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