mime-play.el

   1 ;;; mime-play.el --- Playback processing module for mime-view.el
   2
   3 ;; Copyright (C) 1994,95,96,97,98,99,2000 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <tomo@m17n.org>
   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   (condition-case nil
  35       (require 'bbdb)
  36     (error (defvar bbdb-buffer-name nil))))
  37
  38 (defcustom mime-save-directory "~/"
  39   "*Name of the directory where MIME entity will be saved in.
  40 If t, it means current directory."
  41   :group 'mime-view
  42   :type '(choice (const :tag "Current directory" t)
  43                  (directory)))
  44
  45 (defvar mime-play-find-every-situations t
  46   "*Find every available situations if non-nil.")
  47
  48 (defvar mime-play-messages-coding-system nil
  49   "Coding system to be used for external MIME playback method.")
  50
  51
  52 ;;; @ content decoder
  53 ;;;
  54
  55 ;;;###autoload
  56 (defun mime-preview-play-current-entity (&optional ignore-examples mode)
  57   "Play current entity.
  58 It decodes current entity to call internal or external method.  The
  59 method is selected from variable `mime-acting-condition'.
  60 If IGNORE-EXAMPLES (C-u prefix) is specified, this function ignores
  61 `mime-acting-situation-example-list'.
  62 If MODE is specified, play as it.  Default MODE is \"play\"."
  63   (interactive "P")
  64   (let ((entity (get-text-property (point) 'mime-view-entity)))
  65     (if entity
  66         (let ((situation
  67                (get-text-property (point) 'mime-view-situation)))
  68           (or mode
  69               (setq mode "play"))
  70           (setq situation
  71                 (if (assq 'mode situation)
  72                     (put-alist 'mode mode (copy-alist situation))
  73                   (cons (cons 'mode mode)
  74                         situation)))
  75           (if ignore-examples
  76               (setq situation
  77                     (cons (cons 'ignore-examples ignore-examples)
  78                           situation)))
  79           (mime-play-entity entity situation)))))
  80
  81 ;;;###autoload
  82 (defun mime-play-entity (entity &optional situation ignored-method)
  83   "Play entity specified by ENTITY.
  84 It decodes the entity to call internal or external method.  The method
  85 is selected from variable `mime-acting-condition'.  If MODE is
  86 specified, play as it.  Default MODE is \"play\"."
  87   (let* ((entity-situation (mime-entity-situation entity situation))
  88          (ret (mime-unify-situations entity-situation
  89                                      mime-acting-condition
  90                                      mime-acting-situation-example-list
  91                                      'method ignored-method
  92                                      mime-play-find-every-situations))
  93          method menu s)
  94     (setq mime-acting-situation-example-list (cdr ret)
  95           ret (car ret))
  96     (cond ((cdr ret)
  97            (while ret
  98              (or (vassoc (setq method
  99                                (format "%s"
 100                                        (cdr (assq 'method
 101                                                   (setq s (pop ret))))))
 102                          menu)
 103                  (push (vector method s t) menu)))
 104            (setq ret (mime-sort-situation
 105                       (mime-menu-select "Play entity with: "
 106                                         (cons "Methods" menu))))
 107            (add-to-list 'mime-acting-situation-example-list (cons ret 0)))
 108           (t
 109            (setq ret (car ret))))
 110     (setq method (cdr (assq 'method ret)))
 111     (cond ((and (symbolp method)
 112                 (fboundp method))
 113            (funcall method entity ret))
 114           ((stringp method)
 115            (mime-activate-mailcap-method entity ret))
 116           ;; ((and (listp method)(stringp (car method)))
 117           ;;  (mime-activate-external-method entity ret)
 118           ;;  )
 119           (t
 120            (mime-show-echo-buffer "No method is specified for %s\n"
 121                                   (mime-type/subtype-string
 122                                    (cdr (assq 'type entity-situation))
 123                                    (cdr (assq 'subtype entity-situation))))
 124            (when (y-or-n-p "Do you want to save current entity to disk?")
 125              (message "")
 126              (mime-save-content entity entity-situation))))))
 127
 128
 129 ;;; @ external decoder
 130 ;;;
 131
 132 (defvar mime-mailcap-method-filename-alist nil)
 133
 134 (defun mime-activate-mailcap-method (entity situation)
 135   (let ((method (cdr (assoc 'method situation)))
 136         (name (mime-entity-safe-filename entity)))
 137     (setq name
 138           (if (and name (not (string= name "")))
 139               (expand-file-name name temporary-file-directory)
 140             (make-temp-name
 141              (expand-file-name "EMI" temporary-file-directory))))
 142     (if (and (not (featurep 'xemacs))
 143              (>= emacs-major-version 21))
 144         ;; For security reason, assert the 7th argument of
 145         ;; `write-region' to be 'excl to guarantee that the file is
 146         ;; created atomically.  Unfortunately, this feature is not yet
 147         ;; supported in Emacs 20 or XEmacs.
 148         (let ((coding-system-for-write 'binary)
 149               jka-compr-compression-info-list jam-zcat-filename-list)
 150           (write-region (mime-entity-content entity) nil name
 151                         nil nil nil 'excl))
 152       (if (file-exists-p name)
 153           (signal 'file-already-exists
 154                   (list "Failed to create temporary file" name))
 155         (mime-write-entity-content entity name)))
 156     (message "External method is starting...")
 157     (let ((process
 158            (let ((command
 159                   (mime-format-mailcap-command
 160                    method
 161                    (cons (cons 'filename name) situation))))
 162              (binary-to-text-funcall
 163               mime-play-messages-coding-system
 164               #'start-process command mime-echo-buffer-name
 165               shell-file-name shell-command-switch command))))
 166       (set-alist 'mime-mailcap-method-filename-alist process name)
 167       (set-process-sentinel process 'mime-mailcap-method-sentinel))))
 168
 169 (defun mime-mailcap-method-sentinel (process event)
 170   (let ((file (cdr (assq process mime-mailcap-method-filename-alist))))
 171     (if (file-exists-p file)
 172         (delete-file file)))
 173   (remove-alist 'mime-mailcap-method-filename-alist process)
 174   (message (format "%s %s" process event)))
 175
 176 (defvar mime-echo-window-is-shared-with-bbdb
 177   (module-installed-p 'bbdb)
 178   "*If non-nil, mime-echo window is shared with BBDB window.")
 179
 180 (defvar mime-echo-window-height
 181   (function
 182    (lambda ()
 183      (/ (window-height) 5)))
 184   "*Size of mime-echo window.
 185 It allows function or integer.  If it is function,
 186 `mime-show-echo-buffer' calls it to get height of mime-echo window.
 187 Otherwise `mime-show-echo-buffer' uses it as height of mime-echo
 188 window.")
 189
 190 (defun mime-show-echo-buffer (&rest forms)
 191   "Show mime-echo buffer to display MIME-playing information."
 192   (get-buffer-create mime-echo-buffer-name)
 193   (let ((the-win (selected-window))
 194         (win (get-buffer-window mime-echo-buffer-name)))
 195     (unless win
 196       (unless (and mime-echo-window-is-shared-with-bbdb
 197                    (condition-case nil
 198                        (setq win (get-buffer-window bbdb-buffer-name))
 199                      (error nil)))
 200         (select-window (get-buffer-window (or mime-preview-buffer
 201                                               (current-buffer))))
 202         (setq win (split-window-vertically
 203                    (- (window-height)
 204                       (if (functionp mime-echo-window-height)
 205                           (funcall mime-echo-window-height)
 206                         mime-echo-window-height)))))
 207       (set-window-buffer win mime-echo-buffer-name))
 208     (select-window win)
 209     (goto-char (point-max))
 210     (if forms
 211         (let ((buffer-read-only nil))
 212           (insert (apply (function format) forms))))
 213     (select-window the-win)))
 214
 215
 216 ;;; @ file name
 217 ;;;
 218
 219 (defvar mime-view-file-name-char-regexp "[A-Za-z0-9+_-]")
 220
 221 (defvar mime-view-file-name-regexp-1
 222   (concat mime-view-file-name-char-regexp "+\\."
 223           mime-view-file-name-char-regexp "+"))
 224
 225 (defvar mime-view-file-name-regexp-2
 226   (concat (regexp-* mime-view-file-name-char-regexp)
 227           "\\(\\." mime-view-file-name-char-regexp "+\\)*"))
 228
 229 (defun mime-entity-safe-filename (entity)
 230   (let ((filename
 231          (or (mime-entity-filename entity)
 232              (let ((subj
 233                     (or (mime-entity-read-field entity 'Content-Description)
 234                         (mime-entity-read-field entity 'Subject))))
 235                (if (and subj
 236                         (or (string-match mime-view-file-name-regexp-1 subj)
 237                             (string-match mime-view-file-name-regexp-2 subj)))
 238                    (substring subj (match-beginning 0)(match-end 0)))))))
 239     (if filename
 240         (replace-as-filename filename))))
 241
 242
 243 ;;; @ file extraction
 244 ;;;
 245
 246 (defun mime-save-content (entity situation)
 247   (let ((name (or (mime-entity-safe-filename entity)
 248                   (format "%s" (mime-entity-media-type entity))))
 249         (dir (if (eq t mime-save-directory)
 250                  default-directory
 251                mime-save-directory))
 252         filename)
 253     (setq filename (read-file-name
 254                     (concat "File name: (default "
 255                             (file-name-nondirectory name) ") ")
 256                     dir
 257                     (concat (file-name-as-directory dir)
 258                             (file-name-nondirectory name))))
 259     (if (file-directory-p filename)
 260         (setq filename (concat (file-name-as-directory filename)
 261                                (file-name-nondirectory name))))
 262     (if (file-exists-p filename)
 263         (or (yes-or-no-p (format "File %s exists. Save anyway? " filename))
 264             (error "")))
 265     (mime-write-entity-content entity (expand-file-name filename))))
 266
 267
 268 ;;; @ file detection
 269 ;;;
 270
 271 (defvar mime-magic-type-alist
 272   '(("^\377\330\377[\340\356]..JFIF"    image jpeg)
 273     ("^\211PNG"                         image png)
 274     ("^GIF8[79]"                        image gif)
 275     ("^II\\*\000"                       image tiff)
 276     ("^MM\000\\*"                       image tiff)
 277     ("^MThd"                            audio midi)
 278     ("^\000\000\001\263"                video mpeg))
 279   "*Alist of regexp about magic-number vs. corresponding media-types.
 280 Each element looks like (REGEXP TYPE SUBTYPE).
 281 REGEXP is a regular expression to match against the beginning of the
 282 content of entity.
 283 TYPE is symbol to indicate primary type of media-type.
 284 SUBTYPE is symbol to indicate subtype of media-type.")
 285
 286 (defun mime-detect-content (entity situation)
 287   (let (type subtype)
 288     (let ((mdata (mime-entity-content entity))
 289           (rest mime-magic-type-alist))
 290       (while (not (let ((cell (car rest)))
 291                     (if cell
 292                         (if (string-match (car cell) mdata)
 293                             (setq type (nth 1 cell)
 294                                   subtype (nth 2 cell)))
 295                       t)))
 296         (setq rest (cdr rest))))
 297     (setq situation (del-alist 'method (copy-alist situation)))
 298     (mime-play-entity entity
 299                       (if type
 300                           (put-alist 'type type
 301                                      (put-alist 'subtype subtype
 302                                                 situation))
 303                         situation)
 304                       'mime-detect-content)))
 305
 306
 307 ;;; @ mail/news message
 308 ;;;
 309
 310 (defun mime-preview-quitting-method-for-mime-show-message-mode ()
 311   "Quitting method for mime-view.
 312 It is registered to variable `mime-preview-quitting-method-alist'."
 313   (let ((mother mime-mother-buffer)
 314         (win-conf mime-preview-original-window-configuration))
 315     (if (and (boundp 'mime-view-temp-message-buffer)
 316              (buffer-live-p mime-view-temp-message-buffer))
 317         (kill-buffer mime-view-temp-message-buffer))
 318     (mime-preview-kill-buffer)
 319     (set-window-configuration win-conf)
 320     (pop-to-buffer mother)))
 321
 322 (defun mime-view-message/rfc822 (entity situation)
 323   (let* ((new-name
 324           (format "%s-%s" (buffer-name) (mime-entity-number entity)))
 325          (mother (current-buffer))
 326          (children (car (mime-entity-children entity)))
 327          (preview-buffer
 328           (mime-display-message
 329            children new-name mother nil
 330            (cdr (assq 'major-mode
 331                       (get-text-property (point) 'mime-view-situation))))))
 332     (or (get-buffer-window preview-buffer)
 333         (let ((m-win (get-buffer-window mother)))
 334           (if m-win
 335               (set-window-buffer m-win preview-buffer)
 336             (switch-to-buffer preview-buffer))))))
 337
 338
 339 ;;; @ message/partial
 340 ;;;
 341
 342 (defun mime-store-message/partial-piece (entity cal)
 343   (let* ((root-dir
 344           (expand-file-name
 345            (concat "m-prts-" (user-login-name)) temporary-file-directory))
 346          (id (cdr (assoc "id" cal)))
 347          (number (cdr (assoc "number" cal)))
 348          (total (cdr (assoc "total" cal)))
 349          file
 350          (mother (current-buffer)))
 351     (or (file-exists-p root-dir)
 352         (make-directory root-dir))
 353     (setq id (replace-as-filename id))
 354     (setq root-dir (concat root-dir "/" id))
 355     (or (file-exists-p root-dir)
 356         (make-directory root-dir))
 357     (setq file (concat root-dir "/FULL"))
 358     (if (file-exists-p file)
 359         (let ((full-buf (get-buffer-create "FULL"))
 360               (pwin (or (get-buffer-window mother)
 361                         (get-largest-window)))
 362               pbuf)
 363           (save-window-excursion
 364             (set-buffer full-buf)
 365             (erase-buffer)
 366             (binary-insert-encoded-file file)
 367             (setq major-mode 'mime-show-message-mode)
 368             (mime-view-buffer (current-buffer) nil mother)
 369             (setq pbuf (current-buffer))
 370             (make-local-variable 'mime-view-temp-message-buffer)
 371             (setq mime-view-temp-message-buffer full-buf))
 372           (set-window-buffer pwin pbuf)
 373           (select-window pwin))
 374       (setq file (concat root-dir "/" number))
 375       (mime-write-entity-body entity file)
 376       (let ((total-file (concat root-dir "/CT")))
 377         (setq total
 378               (if total
 379                   (progn
 380                     (or (file-exists-p total-file)
 381                         (save-excursion
 382                           (set-buffer
 383                            (get-buffer-create mime-temp-buffer-name))
 384                           (erase-buffer)
 385                           (insert total)
 386                           (write-region (point-min)(point-max) total-file)
 387                           (kill-buffer (current-buffer))))
 388                     (string-to-number total))
 389                 (and (file-exists-p total-file)
 390                      (save-excursion
 391                        (set-buffer (find-file-noselect total-file))
 392                        (prog1
 393                            (and (re-search-forward "[0-9]+" nil t)
 394                                 (string-to-number
 395                                  (buffer-substring (match-beginning 0)
 396                                                    (match-end 0))))
 397                          (kill-buffer (current-buffer))))))))
 398       (if (and total (> total 0)
 399                (>= (length (directory-files root-dir nil "^[0-9]+$" t))
 400                    total))
 401           (catch 'tag
 402             (save-excursion
 403               (set-buffer (get-buffer-create mime-temp-buffer-name))
 404               (let ((full-buf (current-buffer)))
 405                 (erase-buffer)
 406                 (let ((i 1))
 407                   (while (<= i total)
 408                     (setq file (concat root-dir "/" (int-to-string i)))
 409                     (or (file-exists-p file)
 410                         (throw 'tag nil))
 411                     (binary-insert-encoded-file file)
 412                     (goto-char (point-max))
 413                     (setq i (1+ i))))
 414                 (binary-write-decoded-region
 415                  (point-min)(point-max)
 416                  (expand-file-name "FULL" root-dir))
 417                 (let ((i 1))
 418                   (while (<= i total)
 419                     (let ((file (format "%s/%d" root-dir i)))
 420                       (and (file-exists-p file)
 421                            (delete-file file)))
 422                     (setq i (1+ i))))
 423                 (let ((file (expand-file-name "CT" root-dir)))
 424                   (and (file-exists-p file)
 425                        (delete-file file)))
 426                 (let ((buf (current-buffer))
 427                       (pwin (or (get-buffer-window mother)
 428                                 (get-largest-window)))
 429                       (pbuf (mime-display-message
 430                              (mime-open-entity 'buffer (current-buffer))
 431                              nil mother nil 'mime-show-message-mode)))
 432                   (with-current-buffer pbuf
 433                     (make-local-variable 'mime-view-temp-message-buffer)
 434                     (setq mime-view-temp-message-buffer buf))
 435                   (set-window-buffer pwin pbuf)
 436                   (select-window pwin)))))))))
 437
 438
 439 ;;; @ message/external-body
 440 ;;;
 441
 442 (defvar mime-raw-dired-function
 443   (if (and (>= emacs-major-version 19) window-system)
 444       (function dired-other-frame)
 445     (function mime-raw-dired-function-for-one-frame)))
 446
 447 (defun mime-raw-dired-function-for-one-frame (dir)
 448   (let ((win (or (get-buffer-window mime-preview-buffer)
 449                  (get-largest-window))))
 450     (select-window win)
 451     (dired dir)))
 452
 453 (defun mime-view-message/external-anon-ftp (entity cal)
 454   (let* ((site (cdr (assoc "site" cal)))
 455          (directory (cdr (assoc "directory" cal)))
 456          (name (cdr (assoc "name" cal)))
 457          (pathname (concat "/anonymous@" site ":" directory)))
 458     (message (concat "Accessing " (expand-file-name name pathname) "..."))
 459     (funcall mime-raw-dired-function pathname)
 460     (goto-char (point-min))
 461     (search-forward name)))
 462
 463 (defvar mime-raw-browse-url-function mime-browse-url-function)
 464
 465 (defun mime-view-message/external-url (entity cal)
 466   (let ((url (cdr (assoc "url" cal))))
 467     (message (concat "Accessing " url "..."))
 468     (funcall mime-raw-browse-url-function url)))
 469
 470
 471 ;;; @ rot13-47
 472 ;;;
 473
 474 (defun mime-view-caesar (entity situation)
 475   "Internal method for mime-view to display ROT13-47-48 message."
 476   (let ((buf (get-buffer-create
 477               (format "%s-%s" (buffer-name) (mime-entity-number entity)))))
 478     (with-current-buffer buf
 479       (setq buffer-read-only nil)
 480       (erase-buffer)
 481       (mime-insert-text-content entity)
 482       (mule-caesar-region (point-min) (point-max))
 483       (set-buffer-modified-p nil))
 484     (let ((win (get-buffer-window (current-buffer))))
 485       (or (eq (selected-window) win)
 486           (select-window (or win (get-largest-window)))))
 487     (view-buffer buf)
 488     (goto-char (point-min))))
 489
 490
 491 ;;; @ end
 492 ;;;
 493
 494 (provide 'mime-play)
 495
 496 ;;; mime-play.el ends here