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