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