mime-play.el

   1 ;;; mime-play.el --- Playback processing module for mime-view.el
   2
   3 ;; Copyright (C) 1994,1995,1996,1997,1998 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; Created: 1995/9/26 (separated from tm-view.el)
   7 ;;      Renamed: 1997/2/21 from tm-play.el
   8 ;; Keywords: MIME, multimedia, mail, news
   9
  10 ;; This file is part of SEMI (Secretariat of Emacs MIME Interfaces).
  11
  12 ;; This program is free software; you can redistribute it and/or
  13 ;; modify it under the terms of the GNU General Public License as
  14 ;; published by the Free Software Foundation; either version 2, or (at
  15 ;; your option) any later version.
  16
  17 ;; This program is distributed in the hope that it will be useful, but
  18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20 ;; General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; Code:
  28
  29 (require 'mime-view)
  30 (require 'alist)
  31 (require 'filename)
  32
  33 (eval-when-compile
  34   (require 'mime-text)
  35   (condition-case nil
  36       (require 'bbdb)
  37     (error (defvar bbdb-buffer-name nil))
  38     ))
  39
  40 (defvar mime-acting-situation-examples nil)
  41
  42 (defun mime-save-acting-situation-examples ()
  43   (let* ((file mime-acting-situation-examples-file)
  44          (buffer (get-buffer-create " *mime-example*")))
  45     (unwind-protect
  46         (save-excursion
  47           (set-buffer buffer)
  48           (setq buffer-file-name file)
  49           (erase-buffer)
  50           (insert ";;; " (file-name-nondirectory file) "\n")
  51           (insert "\n;; This file is generated automatically by "
  52                   mime-view-version-string "\n\n")
  53           (insert ";;; Code:\n\n")
  54           (pp `(setq mime-acting-situation-examples
  55                      ',mime-acting-situation-examples)
  56               (current-buffer))
  57           (insert "\n;;; "
  58                   (file-name-nondirectory file)
  59                   " ends here.\n")
  60           (save-buffer))
  61       (kill-buffer buffer))))
  62
  63 (add-hook 'kill-emacs-hook 'mime-save-acting-situation-examples)
  64
  65
  66 ;;; @ content decoder
  67 ;;;
  68
  69 (defvar mime-preview-after-decoded-position nil)
  70
  71 (defun mime-preview-play-current-entity (&optional mode)
  72   "Play current entity.
  73 It decodes current entity to call internal or external method.  The
  74 method is selected from variable `mime-acting-condition'.
  75 If MODE is specified, play as it.  Default MODE is \"play\"."
  76   (interactive)
  77   (or mode
  78       (setq mode "play"))
  79   (let ((entity (get-text-property (point) 'mime-view-entity)))
  80     (if entity
  81         (let ((the-buf (current-buffer))
  82               (raw-buffer (mime-entity-buffer entity)))
  83           (setq mime-preview-after-decoded-position (point))
  84           (set-buffer raw-buffer)
  85           (mime-raw-play-entity entity mode)
  86           (when (eq (current-buffer) raw-buffer)
  87             (set-buffer the-buf)
  88             (goto-char mime-preview-after-decoded-position)
  89             )))))
  90
  91 (defun mime-sort-situation (situation)
  92   (sort situation
  93         #'(lambda (a b)
  94             (let ((a-t (car a))
  95                   (b-t (car b))
  96                   (order '((type . 1)
  97                            (subtype . 2)
  98                            (mode . 3)
  99                            (method . 4)
 100                            (major-mode . 5)
 101                            (disposition-type . 6)
 102                            ))
 103                   a-order b-order)
 104               (if (symbolp a-t)
 105                   (let ((ret (assq a-t order)))
 106                     (if ret
 107                         (setq a-order (cdr ret))
 108                       (setq a-order 7)
 109                       ))
 110                 (setq a-order 8)
 111                 )
 112               (if (symbolp b-t)
 113                   (let ((ret (assq b-t order)))
 114                     (if ret
 115                         (setq b-order (cdr ret))
 116                       (setq b-order 7)
 117                       ))
 118                 (setq b-order 8)
 119                 )
 120               (if (= a-order b-order)
 121                   (string< (format "%s" a-t)(format "%s" b-t))
 122                 (< a-order b-order))
 123               )))
 124   )
 125
 126 (defsubst mime-delq-null-situation (situations field)
 127   (let (dest)
 128     (while situations
 129       (let ((situation (car situations)))
 130         (if (assq field situation)
 131             (setq dest (cons situation dest))
 132           ))
 133       (setq situations (cdr situations)))
 134     dest))
 135
 136 (defun mime-raw-play-entity (entity &optional mode situation)
 137   "Play entity specified by ENTITY.
 138 It decodes the entity to call internal or external method.  The method
 139 is selected from variable `mime-acting-condition'.  If MODE is
 140 specified, play as it.  Default MODE is \"play\"."
 141   (let (method ret)
 142     (or situation
 143         (setq situation (mime-entity-situation entity)))
 144     (if mode
 145         (setq situation (cons (cons 'mode mode) situation))
 146       )
 147     (setq ret
 148           (or (ctree-match-calist mime-acting-situation-examples situation)
 149               (ctree-match-calist-partially mime-acting-situation-examples
 150                                             situation)
 151               situation))
 152     (setq ret
 153           (or (mime-delq-null-situation
 154                (ctree-find-calist mime-acting-condition ret
 155                                   mime-view-find-every-acting-situation)
 156                'method)
 157               (mime-delq-null-situation
 158                (ctree-find-calist mime-acting-condition situation
 159                                   mime-view-find-every-acting-situation)
 160                'method)
 161               ))
 162     (cond ((cdr ret)
 163            (setq ret (select-menu-alist
 164                       "Methods"
 165                       (mapcar (function
 166                                (lambda (situation)
 167                                  (cons
 168                                   (format "%s"
 169                                           (cdr (assq 'method situation)))
 170                                   situation)))
 171                               ret)))
 172            (setq ret (mime-sort-situation ret))
 173            (ctree-set-calist-strictly 'mime-acting-situation-examples ret)
 174            )
 175           (t
 176            (setq ret (car ret))
 177            ))
 178     (setq method (cdr (assq 'method ret)))
 179     (cond ((and (symbolp method)
 180                 (fboundp method))
 181            (funcall method entity ret)
 182            )
 183           ((stringp method)
 184            (mime-activate-mailcap-method entity ret)
 185            )
 186           ;; ((and (listp method)(stringp (car method)))
 187           ;;  (mime-activate-external-method entity ret)
 188           ;;  )
 189           (t
 190            (mime-show-echo-buffer "No method are specified for %s\n"
 191                                   (mime-entity-type/subtype entity))
 192            ))
 193     ))
 194
 195
 196 ;;; @ external decoder
 197 ;;;
 198
 199 (defvar mime-mailcap-method-filename-alist nil)
 200
 201 (defun mime-activate-mailcap-method (entity situation)
 202   (save-excursion
 203     (save-restriction
 204       (let ((start (mime-entity-point-min entity))
 205             (end (mime-entity-point-max entity)))
 206         (narrow-to-region start end)
 207         (goto-char start)
 208         (let ((method (cdr (assoc 'method situation)))
 209               (name (mime-entity-safe-filename entity)))
 210           (setq name
 211                 (if name
 212                     (expand-file-name name mime-temp-directory)
 213                   (make-temp-name
 214                    (expand-file-name "EMI" mime-temp-directory))
 215                   ))
 216           (mime-write-decoded-region (mime-entity-body-start entity) end
 217                                      name (cdr (assq 'encoding situation)))
 218           (message "External method is starting...")
 219           (let ((process
 220                  (let ((command
 221                         (mailcap-format-command
 222                          method
 223                          (cons (cons 'filename name) situation))))
 224                    (start-process command mime-echo-buffer-name
 225                                   shell-file-name shell-command-switch command)
 226                    )))
 227             (set-alist 'mime-mailcap-method-filename-alist process name)
 228             (set-process-sentinel process 'mime-mailcap-method-sentinel)
 229             )
 230           )))))
 231
 232 (defun mime-mailcap-method-sentinel (process event)
 233   (let ((file (cdr (assq process mime-mailcap-method-filename-alist))))
 234     (if (file-exists-p file)
 235         (delete-file file)
 236       ))
 237   (remove-alist 'mime-mailcap-method-filename-alist process)
 238   (message (format "%s %s" process event)))
 239
 240 (defvar mime-echo-window-is-shared-with-bbdb t
 241   "*If non-nil, mime-echo window is shared with BBDB window.")
 242
 243 (defvar mime-echo-window-height
 244   (function
 245    (lambda ()
 246      (/ (window-height) 5)
 247      ))
 248   "*Size of mime-echo window.
 249 It allows function or integer.  If it is function,
 250 `mime-show-echo-buffer' calls it to get height of mime-echo window.
 251 Otherwise `mime-show-echo-buffer' uses it as height of mime-echo
 252 window.")
 253
 254 (defun mime-show-echo-buffer (&rest forms)
 255   "Show mime-echo buffer to display MIME-playing information."
 256   (get-buffer-create mime-echo-buffer-name)
 257   (let ((the-win (selected-window))
 258         (win (get-buffer-window mime-echo-buffer-name))
 259         )
 260     (or win
 261         (if (and mime-echo-window-is-shared-with-bbdb
 262                  (boundp 'bbdb-buffer-name)
 263                  (setq win (get-buffer-window bbdb-buffer-name))
 264                  )
 265             (set-window-buffer win mime-echo-buffer-name)
 266           (select-window (get-buffer-window mime-preview-buffer))
 267           (setq win (split-window-vertically
 268                      (- (window-height)
 269                         (if (functionp mime-echo-window-height)
 270                             (funcall mime-echo-window-height)
 271                           mime-echo-window-height)
 272                         )))
 273           (set-window-buffer win mime-echo-buffer-name)
 274           ))
 275     (select-window win)
 276     (goto-char (point-max))
 277     (if forms
 278         (insert (apply (function format) forms))
 279       )
 280     (select-window the-win)
 281     ))
 282
 283
 284 ;;; @ file name
 285 ;;;
 286
 287 (defvar mime-view-file-name-char-regexp "[A-Za-z0-9+_-]")
 288
 289 (defvar mime-view-file-name-regexp-1
 290   (concat mime-view-file-name-char-regexp "+\\."
 291           mime-view-file-name-char-regexp "+"))
 292
 293 (defvar mime-view-file-name-regexp-2
 294   (concat (regexp-* mime-view-file-name-char-regexp)
 295           "\\(\\." mime-view-file-name-char-regexp "+\\)*"))
 296
 297 (defun mime-entity-safe-filename (entity)
 298   (let ((filename
 299          (or (mime-entity-filename entity)
 300              (let ((subj
 301                     (or (mime-entity-read-field entity 'Content-Description)
 302                         (mime-entity-read-field entity 'Subject))))
 303                (if (and subj
 304                         (or (string-match mime-view-file-name-regexp-1 subj)
 305                             (string-match mime-view-file-name-regexp-2 subj)))
 306                    (substring subj (match-beginning 0)(match-end 0))
 307                  )))))
 308     (if filename
 309         (replace-as-filename filename)
 310       )))
 311
 312
 313 ;;; @ file extraction
 314 ;;;
 315
 316 (defun mime-save-content (entity situation)
 317   (let* ((name (mime-entity-safe-filename entity))
 318          (encoding (or (mime-entity-encoding entity) "7bit"))
 319          (filename (if (and name (not (string-equal name "")))
 320                        (expand-file-name name
 321                                          (save-window-excursion
 322                                            (call-interactively
 323                                             (function
 324                                              (lambda (dir)
 325                                                (interactive "DDirectory: ")
 326                                                dir)))))
 327                      (save-window-excursion
 328                        (call-interactively
 329                         (function
 330                          (lambda (file)
 331                            (interactive "FFilename: ")
 332                            (expand-file-name file)))))))
 333          )
 334     (if (file-exists-p filename)
 335         (or (yes-or-no-p (format "File %s exists. Save anyway? " filename))
 336             (error "")))
 337     (mime-write-decoded-region (mime-entity-body-start entity)
 338                                (mime-entity-body-end entity)
 339                                filename encoding)
 340     ))
 341
 342
 343 ;;; @ file detection
 344 ;;;
 345
 346 (defvar mime-file-content-type-alist
 347   '(("JPEG"     image jpeg)
 348     ("GIF"      image gif)
 349     )
 350   "*Alist of \"file\" output patterns vs. corresponding media-types.
 351 Each element looks like (REGEXP TYPE SUBTYPE).
 352 REGEXP is pattern for \"file\" command output.
 353 TYPE is symbol to indicate primary type of media-type.
 354 SUBTYPE is symbol to indicate subtype of media-type.")
 355
 356 (defun mime-detect-content (entity situation)
 357   (let ((beg (mime-entity-point-min entity))
 358         (end (mime-entity-point-max entity)))
 359     (goto-char beg)
 360     (let* ((name (save-restriction
 361                    (narrow-to-region beg end)
 362                    (mime-entity-safe-filename entity)
 363                    ))
 364            (encoding (or (cdr (assq 'encoding situation)) "7bit"))
 365            (filename (if (and name (not (string-equal name "")))
 366                          (expand-file-name name mime-temp-directory)
 367                        (make-temp-name
 368                         (expand-file-name "EMI" mime-temp-directory)))))
 369       (mime-write-decoded-region (mime-entity-body-start entity) end
 370                                  filename encoding)
 371       (let (type subtype)
 372         (with-temp-buffer
 373           (call-process "file" nil t nil filename)
 374           (goto-char (point-min))
 375           (if (search-forward (concat filename ": ") nil t)
 376               (let ((rest mime-file-content-type-alist))
 377                 (while (not (let ((cell (car rest)))
 378                               (if (looking-at (car cell))
 379                                   (setq type (nth 1 cell)
 380                                         subtype (nth 2 cell))
 381                                 )))
 382                   (setq rest (cdr rest))))))
 383         (if type
 384             (mime-raw-play-entity
 385              entity "play"
 386              (put-alist 'type type
 387                         (put-alist 'subtype subtype
 388                                    (mime-entity-situation entity))))
 389           ))
 390       )))
 391
 392
 393 ;;; @ mail/news message
 394 ;;;
 395
 396 (defun mime-preview-quitting-method-for-mime-show-message-mode ()
 397   "Quitting method for mime-view.
 398 It is registered to variable `mime-preview-quitting-method-alist'."
 399   (let ((mother mime-mother-buffer)
 400         (win-conf mime-preview-original-window-configuration)
 401         )
 402     (kill-buffer mime-raw-buffer)
 403     (mime-preview-kill-buffer)
 404     (set-window-configuration win-conf)
 405     (pop-to-buffer mother)
 406     ))
 407
 408 (defun mime-view-message/rfc822 (entity cal)
 409   (let* ((beg (mime-entity-point-min entity))
 410          (end (mime-entity-point-max entity))
 411          (cnum (mime-raw-point-to-entity-number beg))
 412          (new-name (format "%s-%s" (buffer-name) cnum))
 413          (mother mime-preview-buffer)
 414          (representation-type (mime-entity-representation-type entity))
 415          str)
 416     (setq str (buffer-substring beg end))
 417     (switch-to-buffer new-name)
 418     (erase-buffer)
 419     (insert str)
 420     (goto-char (point-min))
 421     (if (re-search-forward "^\n" nil t)
 422         (delete-region (point-min) (match-end 0))
 423       )
 424     (setq major-mode 'mime-show-message-mode)
 425     (setq mime-raw-representation-type representation-type)
 426     (mime-view-mode mother)
 427     ))
 428
 429
 430 ;;; @ message/partial
 431 ;;;
 432
 433 (defun mime-raw-write-region (start end filename)
 434   "Write current region into specified file.
 435 When called from a program, takes three arguments:
 436 START, END and FILENAME.  START and END are buffer positions.
 437 It refer `mime-raw-representation-type' or `major-mode
 438 mime-raw-representation-type-alist'.  If it is `binary', region is
 439 saved as binary.  Otherwise the region is saved by `write-region'."
 440   (let ((presentation-type
 441          (or mime-raw-representation-type
 442              (cdr (or (assq major-mode mime-raw-representation-type-alist)
 443                       (assq t mime-raw-representation-type-alist))))))
 444     (if (eq presentation-type 'binary)
 445         (write-region-as-binary start end filename)
 446       (write-region start end filename)
 447       )))
 448
 449 (defun mime-store-message/partial-piece (entity cal)
 450   (goto-char (mime-entity-point-min entity))
 451   (let* ((root-dir
 452           (expand-file-name
 453            (concat "m-prts-" (user-login-name)) mime-temp-directory))
 454          (id (cdr (assoc "id" cal)))
 455          (number (cdr (assoc "number" cal)))
 456          (total (cdr (assoc "total" cal)))
 457          file
 458          (mother mime-preview-buffer)
 459          )
 460     (or (file-exists-p root-dir)
 461         (make-directory root-dir)
 462         )
 463     (setq id (replace-as-filename id))
 464     (setq root-dir (concat root-dir "/" id))
 465     (or (file-exists-p root-dir)
 466         (make-directory root-dir)
 467         )
 468     (setq file (concat root-dir "/FULL"))
 469     (if (file-exists-p file)
 470         (let ((full-buf (get-buffer-create "FULL"))
 471               (pwin (or (get-buffer-window mother)
 472                         (get-largest-window)))
 473               )
 474           (save-window-excursion
 475             (set-buffer full-buf)
 476             (erase-buffer)
 477             (as-binary-input-file (insert-file-contents file))
 478             (setq major-mode 'mime-show-message-mode)
 479             (mime-view-mode mother)
 480             )
 481           (set-window-buffer pwin
 482                              (save-excursion
 483                                (set-buffer full-buf)
 484                                mime-preview-buffer))
 485           (select-window pwin)
 486           )
 487       (setq file (concat root-dir "/" number))
 488       (mime-raw-write-region (mime-entity-body-start entity)
 489                              (mime-entity-body-end entity) file)
 490       (let ((total-file (concat root-dir "/CT")))
 491         (setq total
 492               (if total
 493                   (progn
 494                     (or (file-exists-p total-file)
 495                         (save-excursion
 496                           (set-buffer
 497                            (get-buffer-create mime-temp-buffer-name))
 498                           (erase-buffer)
 499                           (insert total)
 500                           (write-region (point-min)(point-max) total-file)
 501                           (kill-buffer (current-buffer))
 502                           ))
 503                     (string-to-number total)
 504                     )
 505                 (and (file-exists-p total-file)
 506                      (save-excursion
 507                        (set-buffer (find-file-noselect total-file))
 508                        (prog1
 509                            (and (re-search-forward "[0-9]+" nil t)
 510                                 (string-to-number
 511                                  (buffer-substring (match-beginning 0)
 512                                                    (match-end 0)))
 513                                 )
 514                          (kill-buffer (current-buffer))
 515                          )))
 516                 )))
 517       (if (and total (> total 0))
 518           (catch 'tag
 519             (save-excursion
 520               (set-buffer (get-buffer-create mime-temp-buffer-name))
 521               (let ((full-buf (current-buffer)))
 522                 (erase-buffer)
 523                 (let ((i 1))
 524                   (while (<= i total)
 525                     (setq file (concat root-dir "/" (int-to-string i)))
 526                     (or (file-exists-p file)
 527                         (throw 'tag nil)
 528                         )
 529                     (as-binary-input-file (insert-file-contents file))
 530                     (goto-char (point-max))
 531                     (setq i (1+ i))
 532                     ))
 533                 (as-binary-output-file
 534                  (write-region (point-min)(point-max)
 535                                (expand-file-name "FULL" root-dir)))
 536                 (let ((i 1))
 537                   (while (<= i total)
 538                     (let ((file (format "%s/%d" root-dir i)))
 539                       (and (file-exists-p file)
 540                            (delete-file file)
 541                            ))
 542                     (setq i (1+ i))
 543                     ))
 544                 (let ((file (expand-file-name "CT" root-dir)))
 545                   (and (file-exists-p file)
 546                        (delete-file file)
 547                        ))
 548                 (save-window-excursion
 549                   (setq major-mode 'mime-show-message-mode)
 550                   (mime-view-mode mother)
 551                   )
 552                 (let ((pwin (or (get-buffer-window mother)
 553                                 (get-largest-window)
 554                                 ))
 555                       (pbuf (save-excursion
 556                               (set-buffer full-buf)
 557                               mime-preview-buffer)))
 558                   (set-window-buffer pwin pbuf)
 559                   (select-window pwin)
 560                   )))))
 561       )))
 562
 563
 564 ;;; @ message/external-body
 565 ;;;
 566
 567 (defvar mime-raw-dired-function
 568   (if (and (>= emacs-major-version 19) window-system)
 569       (function dired-other-frame)
 570     (function mime-raw-dired-function-for-one-frame)
 571     ))
 572
 573 (defun mime-raw-dired-function-for-one-frame (dir)
 574   (let ((win (or (get-buffer-window mime-preview-buffer)
 575                  (get-largest-window))))
 576     (select-window win)
 577     (dired dir)
 578     ))
 579
 580 (defun mime-view-message/external-ftp (entity cal)
 581   (let* ((site (cdr (assoc "site" cal)))
 582          (directory (cdr (assoc "directory" cal)))
 583          (name (cdr (assoc "name" cal)))
 584          (pathname (concat "/anonymous@" site ":" directory)))
 585     (message (concat "Accessing " (expand-file-name name pathname) "..."))
 586     (funcall mime-raw-dired-function pathname)
 587     (goto-char (point-min))
 588     (search-forward name)
 589     ))
 590
 591
 592 ;;; @ rot13-47
 593 ;;;
 594
 595 (defun mime-view-caesar (entity situation)
 596   "Internal method for mime-view to display ROT13-47-48 message."
 597   (let* ((new-name (format "%s-%s" (buffer-name)
 598                            (mime-entity-number entity)))
 599          (mother mime-preview-buffer))
 600     (let ((pwin (or (get-buffer-window mother)
 601                     (get-largest-window)))
 602           (buf (get-buffer-create new-name)))
 603       (set-window-buffer pwin buf)
 604       (set-buffer buf)
 605       (select-window pwin)
 606       )
 607     (setq buffer-read-only nil)
 608     (erase-buffer)
 609     (mime-text-insert-decoded-body entity)
 610     (mule-caesar-region (point-min) (point-max))
 611     (set-buffer-modified-p nil)
 612     (set-buffer mother)
 613     (view-buffer new-name)
 614     ))
 615
 616
 617 ;;; @ end
 618 ;;;
 619
 620 (provide 'mime-play)
 621
 622 (let* ((file mime-acting-situation-examples-file)
 623        (buffer (get-buffer-create " *mime-example*")))
 624   (if (file-readable-p file)
 625       (unwind-protect
 626           (save-excursion
 627             (set-buffer buffer)
 628             (erase-buffer)
 629             (insert-file-contents file)
 630             (eval-buffer)
 631             ;; format check
 632             (or (eq (car mime-acting-situation-examples) 'type)
 633                 (setq mime-acting-situation-examples nil))
 634             )
 635         (kill-buffer buffer))))
 636
 637 ;;; mime-play.el ends here