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 (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 (and (boundp 'mime-view-temp-message-buffer)
 318              (buffer-live-p mime-view-temp-message-buffer))
 319         (kill-buffer mime-view-temp-message-buffer))
 320     (mime-preview-kill-buffer)
 321     (set-window-configuration win-conf)
 322     (pop-to-buffer mother)))
 323
 324 (defun mime-view-message/rfc822 (entity situation)
 325   (let* ((new-name
 326           (format "%s-%s" (buffer-name) (mime-entity-number entity)))
 327          (mother (current-buffer))
 328          (children (car (mime-entity-children entity)))
 329          (preview-buffer
 330           (mime-display-message
 331            children new-name mother nil
 332            (cdr (assq 'major-mode
 333                       (get-text-property (point) 'mime-view-situation))))))
 334     (or (get-buffer-window preview-buffer)
 335         (let ((m-win (get-buffer-window mother)))
 336           (if m-win
 337               (set-window-buffer m-win preview-buffer)
 338             (switch-to-buffer preview-buffer))))))
 339
 340
 341 ;;; @ message/partial
 342 ;;;
 343
 344 (defun mime-require-safe-directory (dir)
 345   "Create a directory DIR safely.
 346 The permission of the created directory becomes `700' (for the owner only).
 347 If the directory already exists and is writable by other users, an error
 348 occurs."
 349   (let ((attr (file-attributes dir))
 350         (orig-modes (default-file-modes)))
 351     (if (and attr (eq (car attr) t)) ; directory already exists.
 352         (unless (or (memq system-type '(windows-nt ms-dos OS/2 emx))
 353                     (and (eq (nth 2 attr) (user-real-uid))
 354                          (eq (file-modes dir) 448)))
 355           (error "Invalid owner or permission for %s" dir))
 356       (unwind-protect
 357           (progn
 358             (set-default-file-modes 448)
 359             (make-directory dir))
 360         (set-default-file-modes orig-modes)))))
 361
 362 (defun mime-store-message/partial-piece (entity cal)
 363   (let ((root-dir
 364          (expand-file-name
 365           (concat "m-prts-" (user-login-name)) temporary-file-directory))
 366         (id (cdr (assoc "id" cal)))
 367         (number (cdr (assoc "number" cal)))
 368         (total (cdr (assoc "total" cal)))
 369         file
 370         (mother (current-buffer))
 371         (orig-modes (default-file-modes)))
 372     (mime-require-safe-directory root-dir)
 373     (or (file-exists-p root-dir)
 374         (unwind-protect
 375             (progn
 376               (set-default-file-modes 448)
 377               (make-directory root-dir))
 378           (set-default-file-modes orig-modes)))
 379     (setq id (replace-as-filename id))
 380     (setq root-dir (concat root-dir "/" id))
 381
 382     (or (file-exists-p root-dir)
 383         (unwind-protect
 384             (progn
 385               (set-default-file-modes 448)
 386               (make-directory root-dir))
 387           (set-default-file-modes orig-modes)))
 388
 389     (setq file (concat root-dir "/FULL"))
 390     (if (file-exists-p file)
 391         (let ((full-buf (get-buffer-create "FULL"))
 392               (pwin (or (get-buffer-window mother)
 393                         (get-largest-window)))
 394               pbuf)
 395           (save-window-excursion
 396             (set-buffer full-buf)
 397             (erase-buffer)
 398             (binary-insert-encoded-file file)
 399             (setq major-mode 'mime-show-message-mode)
 400             (mime-view-buffer (current-buffer) nil mother)
 401             (setq pbuf (current-buffer))
 402             (make-local-variable 'mime-view-temp-message-buffer)
 403             (setq mime-view-temp-message-buffer full-buf))
 404           (set-window-buffer pwin pbuf)
 405           (select-window pwin))
 406       (setq file (concat root-dir "/" number))
 407       (mime-write-entity-body entity file)
 408       (let ((total-file (concat root-dir "/CT")))
 409         (setq total
 410               (if total
 411                   (progn
 412                     (or (file-exists-p total-file)
 413                         (save-excursion
 414                           (set-buffer
 415                            (get-buffer-create mime-temp-buffer-name))
 416                           (erase-buffer)
 417                           (insert total)
 418                           (write-region (point-min)(point-max) total-file)
 419                           (kill-buffer (current-buffer))))
 420                     (string-to-number total))
 421                 (and (file-exists-p total-file)
 422                      (save-excursion
 423                        (set-buffer (find-file-noselect total-file))
 424                        (prog1
 425                            (and (re-search-forward "[0-9]+" nil t)
 426                                 (string-to-number
 427                                  (buffer-substring (match-beginning 0)
 428                                                    (match-end 0))))
 429                          (kill-buffer (current-buffer))))))))
 430       (if (and total (> total 0)
 431                (>= (length (directory-files root-dir nil "^[0-9]+$" t))
 432                    total))
 433           (catch 'tag
 434             (save-excursion
 435               (set-buffer (get-buffer-create mime-temp-buffer-name))
 436               (let ((full-buf (current-buffer)))
 437                 (erase-buffer)
 438                 (let ((i 1))
 439                   (while (<= i total)
 440                     (setq file (concat root-dir "/" (int-to-string i)))
 441                     (or (file-exists-p file)
 442                         (throw 'tag nil))
 443                     (binary-insert-encoded-file file)
 444                     (goto-char (point-max))
 445                     (setq i (1+ i))))
 446                 (binary-write-decoded-region
 447                  (point-min)(point-max)
 448                  (expand-file-name "FULL" root-dir))
 449                 (let ((i 1))
 450                   (while (<= i total)
 451                     (let ((file (format "%s/%d" root-dir i)))
 452                       (and (file-exists-p file)
 453                            (delete-file file)))
 454                     (setq i (1+ i))))
 455                 (let ((file (expand-file-name "CT" root-dir)))
 456                   (and (file-exists-p file)
 457                        (delete-file file)))
 458                 (let ((buf (current-buffer))
 459                       (pwin (or (get-buffer-window mother)
 460                                 (get-largest-window)))
 461                       (pbuf (mime-display-message
 462                              (mime-open-entity 'buffer (current-buffer))
 463                              nil mother nil 'mime-show-message-mode)))
 464                   (with-current-buffer pbuf
 465                     (make-local-variable 'mime-view-temp-message-buffer)
 466                     (setq mime-view-temp-message-buffer buf))
 467                   (set-window-buffer pwin pbuf)
 468                   (select-window pwin)))))))))
 469
 470
 471 ;;; @ message/external-body
 472 ;;;
 473
 474 (defvar mime-raw-dired-function
 475   (if (and (>= emacs-major-version 19) window-system)
 476       (function dired-other-frame)
 477     (function mime-raw-dired-function-for-one-frame)))
 478
 479 (defun mime-raw-dired-function-for-one-frame (dir)
 480   (let ((win (or (get-buffer-window mime-preview-buffer)
 481                  (get-largest-window))))
 482     (select-window win)
 483     (dired dir)))
 484
 485 (defun mime-view-message/external-anon-ftp (entity cal)
 486   (let* ((site (cdr (assoc "site" cal)))
 487          (directory (cdr (assoc "directory" cal)))
 488          (name (cdr (assoc "name" cal)))
 489          (pathname (concat "/anonymous@" site ":" directory)))
 490     (message "%s" (concat "Accessing " (expand-file-name name pathname) "..."))
 491     (funcall mime-raw-dired-function pathname)
 492     (goto-char (point-min))
 493     (search-forward name)))
 494
 495 (defvar mime-raw-browse-url-function mime-browse-url-function)
 496
 497 (defun mime-view-message/external-url (entity cal)
 498   (let ((url (cdr (assoc "url" cal))))
 499     (message "%s" (concat "Accessing " url "..."))
 500     (funcall mime-raw-browse-url-function url)))
 501
 502
 503 ;;; @ rot13-47
 504 ;;;
 505
 506 (defun mime-view-caesar (entity situation)
 507   "Internal method for mime-view to display ROT13-47-48 message."
 508   (let ((buf (get-buffer-create
 509               (format "%s-%s" (buffer-name) (mime-entity-number entity)))))
 510     (with-current-buffer buf
 511       (setq buffer-read-only nil)
 512       (erase-buffer)
 513       (mime-insert-text-content entity)
 514       (mule-caesar-region (point-min) (point-max))
 515       (set-buffer-modified-p nil))
 516     (let ((win (get-buffer-window (current-buffer))))
 517       (or (eq (selected-window) win)
 518           (select-window (or win (get-largest-window)))))
 519     (view-buffer buf)
 520     (goto-char (point-min))))
 521
 522
 523 ;;; @ end
 524 ;;;
 525
 526 (provide 'mime-play)
 527
 528 ;;; mime-play.el ends here