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