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