mime-play.el

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