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