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       (if (file-exists-p file)
 170           (delete-file file)))
 171     (remove-alist 'mime-mailcap-method-filename-alist process))
 172   (message (format "%s %s" process event)))
 173
 174 (defun mime-mailcap-delete-played-files ()
 175   (dolist (elem mime-mailcap-method-filename-alist)
 176     (when (file-exists-p (cdr elem))
 177       (delete-file (cdr elem)))))
 178
 179 (add-hook 'kill-emacs-hook 'mime-mailcap-delete-played-files)
 180
 181 (defvar mime-echo-window-is-shared-with-bbdb
 182   (module-installed-p 'bbdb)
 183   "*If non-nil, mime-echo window is shared with BBDB window.")
 184
 185 (defvar mime-echo-window-height
 186   (function
 187    (lambda ()
 188      (/ (window-height) 5)
 189      ))
 190   "*Size of mime-echo window.
 191 It allows function or integer.  If it is function,
 192 `mime-show-echo-buffer' calls it to get height of mime-echo window.
 193 Otherwise `mime-show-echo-buffer' uses it as height of mime-echo
 194 window.")
 195
 196 (defun mime-show-echo-buffer (&rest forms)
 197   "Show mime-echo buffer to display MIME-playing information."
 198   (get-buffer-create mime-echo-buffer-name)
 199   (let ((the-win (selected-window))
 200         (win (get-buffer-window mime-echo-buffer-name)))
 201     (unless win
 202       (unless (and mime-echo-window-is-shared-with-bbdb
 203                    (condition-case nil
 204                        (setq win (get-buffer-window bbdb-buffer-name))
 205                      (error nil)))
 206         (select-window (get-buffer-window (or mime-preview-buffer
 207                                               (current-buffer))))
 208         (setq win (split-window-vertically
 209                    (- (window-height)
 210                       (if (functionp mime-echo-window-height)
 211                           (funcall mime-echo-window-height)
 212                         mime-echo-window-height)
 213                       )))
 214         )
 215       (set-window-buffer win mime-echo-buffer-name)
 216       )
 217     (select-window win)
 218     (goto-char (point-max))
 219     (if forms
 220         (let ((buffer-read-only nil))
 221           (insert (apply (function format) forms))
 222           ))
 223     (select-window the-win)
 224     ))
 225
 226
 227 ;;; @ file name
 228 ;;;
 229
 230 (defvar mime-view-file-name-char-regexp "[A-Za-z0-9+_-]")
 231
 232 (defvar mime-view-file-name-regexp-1
 233   (concat mime-view-file-name-char-regexp "+\\."
 234           mime-view-file-name-char-regexp "+"))
 235
 236 (defvar mime-view-file-name-regexp-2
 237   (concat (regexp-* mime-view-file-name-char-regexp)
 238           "\\(\\." mime-view-file-name-char-regexp "+\\)*"))
 239
 240 (defun mime-entity-safe-filename (entity)
 241   (let ((filename
 242          (or (mime-entity-filename entity)
 243              (let ((subj
 244                     (or (mime-entity-read-field entity 'Content-Description)
 245                         (mime-entity-read-field entity 'Subject))))
 246                (if (and subj
 247                         (or (string-match mime-view-file-name-regexp-1 subj)
 248                             (string-match mime-view-file-name-regexp-2 subj)))
 249                    (substring subj (match-beginning 0)(match-end 0))
 250                  )))))
 251     (if filename
 252         (replace-as-filename filename)
 253       )))
 254
 255
 256 ;;; @ file extraction
 257 ;;;
 258
 259 (defun mime-save-content (entity situation)
 260   (let ((name (or (mime-entity-safe-filename entity)
 261                   (format "%s" (mime-entity-media-type entity))))
 262         (dir (if (eq t mime-save-directory)
 263                  default-directory
 264                mime-save-directory))
 265         filename)
 266     (setq filename (read-file-name
 267                     (concat "File name: (default "
 268                             (file-name-nondirectory name) ") ")
 269                     dir
 270                     (concat (file-name-as-directory dir)
 271                             (file-name-nondirectory name))))
 272     (if (file-directory-p filename)
 273         (setq filename (concat (file-name-as-directory filename)
 274                                (file-name-nondirectory name))))
 275     (if (file-exists-p filename)
 276         (or (yes-or-no-p (format "File %s exists. Save anyway? " filename))
 277             (error "")))
 278     (mime-write-entity-content entity (expand-file-name filename))
 279     ))
 280
 281
 282 ;;; @ file detection
 283 ;;;
 284
 285 (defvar mime-magic-type-alist
 286   '(("^\377\330\377[\340\356]..JFIF"    image jpeg)
 287     ("^\211PNG"                         image png)
 288     ("^GIF8[79]"                        image gif)
 289     ("^II\\*\000"                       image tiff)
 290     ("^MM\000\\*"                       image tiff)
 291     ("^MThd"                            audio midi)
 292     ("^\000\000\001\263"                video mpeg)
 293     )
 294   "*Alist of regexp about magic-number vs. corresponding media-types.
 295 Each element looks like (REGEXP TYPE SUBTYPE).
 296 REGEXP is a regular expression to match against the beginning of the
 297 content of entity.
 298 TYPE is symbol to indicate primary type of media-type.
 299 SUBTYPE is symbol to indicate subtype of media-type.")
 300
 301 (defun mime-detect-content (entity situation)
 302   (let (type subtype)
 303     (let ((mdata (mime-entity-content entity))
 304           (rest mime-magic-type-alist))
 305       (while (not (let ((cell (car rest)))
 306                     (if cell
 307                         (if (string-match (car cell) mdata)
 308                             (setq type (nth 1 cell)
 309                                   subtype (nth 2 cell))
 310                           )
 311                       t)))
 312         (setq rest (cdr rest))))
 313     (setq situation (del-alist 'method (copy-alist situation)))
 314     (mime-play-entity entity
 315                       (if type
 316                           (put-alist 'type type
 317                                      (put-alist 'subtype subtype
 318                                                 situation))
 319                         situation)
 320                       'mime-detect-content)))
 321
 322
 323 ;;; @ mail/news message
 324 ;;;
 325
 326 (defun mime-preview-quitting-method-for-mime-show-message-mode ()
 327   "Quitting method for mime-view.
 328 It is registered to variable `mime-preview-quitting-method-alist'."
 329   (let ((mother mime-mother-buffer)
 330         (win-conf mime-preview-original-window-configuration))
 331     (if (and (boundp 'mime-view-temp-message-buffer)
 332              (buffer-live-p mime-view-temp-message-buffer))
 333         (kill-buffer mime-view-temp-message-buffer))
 334     (mime-preview-kill-buffer)
 335     (set-window-configuration win-conf)
 336     (pop-to-buffer mother)))
 337
 338 (defun mime-view-message/rfc822 (entity situation)
 339   (let* ((new-name
 340           (format "%s-%s" (buffer-name) (mime-entity-number entity)))
 341          (mother (current-buffer))
 342          (children (car (mime-entity-children entity)))
 343          (preview-buffer
 344           (mime-display-message
 345            children new-name mother nil
 346            (cdr (assq 'major-mode
 347                       (get-text-property (point) 'mime-view-situation))))))
 348     (or (get-buffer-window preview-buffer)
 349         (let ((m-win (get-buffer-window mother)))
 350           (if m-win
 351               (set-window-buffer m-win preview-buffer)
 352             (switch-to-buffer preview-buffer)
 353             )))))
 354
 355
 356 ;;; @ message/partial
 357 ;;;
 358
 359 (defun mime-require-safe-directory (dir)
 360   "Create a directory DIR safely.
 361 The permission of the created directory becomes `700' (for the owner only).
 362 If the directory already exists and is writable by other users, an error
 363 occurs."
 364   (let ((attr (file-attributes dir))
 365         (orig-modes (default-file-modes)))
 366     (if (and attr (eq (car attr) t)) ; directory already exists.
 367         (unless (or (memq system-type '(windows-nt ms-dos OS/2 emx))
 368                     (and (eq (nth 2 attr) (user-real-uid))
 369                          (eq (file-modes dir) 448)))
 370           (error "Invalid owner or permission for %s" dir))
 371       (unwind-protect
 372           (progn
 373             (set-default-file-modes 448)
 374             (make-directory dir))
 375         (set-default-file-modes orig-modes)))))
 376
 377 (defun mime-store-message/partial-piece (entity cal)
 378   (let* ((root-dir
 379           (expand-file-name
 380            (concat "m-prts-" (user-login-name)) temporary-file-directory))
 381          (id (cdr (assoc "id" cal)))
 382          (number (cdr (assoc "number" cal)))
 383          (total (cdr (assoc "total" cal)))
 384          file
 385          (mother (current-buffer))
 386          (orig-modes (default-file-modes)))
 387     (mime-require-safe-directory root-dir)
 388     (or (file-exists-p root-dir)
 389         (unwind-protect
 390             (progn
 391               (set-default-file-modes 448)
 392               (make-directory root-dir))
 393           (set-default-file-modes orig-modes)))
 394     (setq id (replace-as-filename id))
 395     (setq root-dir (concat root-dir "/" id))
 396
 397     (or (file-exists-p root-dir)
 398         (unwind-protect
 399             (progn
 400               (set-default-file-modes 448)
 401               (make-directory root-dir))
 402           (set-default-file-modes orig-modes)))
 403
 404     (setq file (concat root-dir "/FULL"))
 405     (if (file-exists-p file)
 406         (let ((full-buf (get-buffer-create "FULL"))
 407               (pwin (or (get-buffer-window mother)
 408                         (get-largest-window)))
 409               pbuf)
 410           (save-window-excursion
 411             (set-buffer full-buf)
 412             (erase-buffer)
 413             (binary-insert-encoded-file file)
 414             (setq major-mode 'mime-show-message-mode)
 415             (mime-view-buffer (current-buffer) nil mother)
 416             (setq pbuf (current-buffer))
 417             (make-local-variable 'mime-view-temp-message-buffer)
 418             (setq mime-view-temp-message-buffer full-buf))
 419           (set-window-buffer pwin pbuf)
 420           (select-window pwin))
 421       (setq file (concat root-dir "/" number))
 422       (mime-write-entity-body entity file)
 423       (let ((total-file (concat root-dir "/CT")))
 424         (setq total
 425               (if total
 426                   (progn
 427                     (or (file-exists-p total-file)
 428                         (save-excursion
 429                           (set-buffer
 430                            (get-buffer-create mime-temp-buffer-name))
 431                           (erase-buffer)
 432                           (insert total)
 433                           (write-region (point-min)(point-max) total-file)
 434                           (kill-buffer (current-buffer))
 435                           ))
 436                     (string-to-number total)
 437                     )
 438                 (and (file-exists-p total-file)
 439                      (save-excursion
 440                        (set-buffer (find-file-noselect total-file))
 441                        (prog1
 442                            (and (re-search-forward "[0-9]+" nil t)
 443                                 (string-to-number
 444                                  (buffer-substring (match-beginning 0)
 445                                                    (match-end 0)))
 446                                 )
 447                          (kill-buffer (current-buffer))
 448                          )))
 449                 )))
 450       (if (and total (> total 0)
 451                (>= (length (directory-files root-dir nil "^[0-9]+$" t))
 452                    total))
 453           (catch 'tag
 454             (save-excursion
 455               (set-buffer (get-buffer-create mime-temp-buffer-name))
 456               (let ((full-buf (current-buffer)))
 457                 (erase-buffer)
 458                 (let ((i 1))
 459                   (while (<= i total)
 460                     (setq file (concat root-dir "/" (int-to-string i)))
 461                     (or (file-exists-p file)
 462                         (throw 'tag nil)
 463                         )
 464                     (binary-insert-encoded-file file)
 465                     (goto-char (point-max))
 466                     (setq i (1+ i))))
 467                 (binary-write-decoded-region
 468                  (point-min)(point-max)
 469                  (expand-file-name "FULL" root-dir))
 470                 (let ((i 1))
 471                   (while (<= i total)
 472                     (let ((file (format "%s/%d" root-dir i)))
 473                       (and (file-exists-p file)
 474                            (delete-file file)))
 475                     (setq i (1+ i))))
 476                 (let ((file (expand-file-name "CT" root-dir)))
 477                   (and (file-exists-p file)
 478                        (delete-file file)))
 479                 (let ((buf (current-buffer))
 480                       (pwin (or (get-buffer-window mother)
 481                                 (get-largest-window)))
 482                       (pbuf (mime-display-message
 483                              (mime-open-entity 'buffer (current-buffer))
 484                              nil mother nil 'mime-show-message-mode)))
 485                   (with-current-buffer pbuf
 486                     (make-local-variable 'mime-view-temp-message-buffer)
 487                     (setq mime-view-temp-message-buffer buf))
 488                   (set-window-buffer pwin pbuf)
 489                   (select-window pwin)
 490                   )))))
 491       )))
 492
 493
 494 ;;; @ message/external-body
 495 ;;;
 496
 497 (defvar mime-raw-dired-function
 498   (if (and (>= emacs-major-version 19) window-system)
 499       (function dired-other-frame)
 500     (function mime-raw-dired-function-for-one-frame)
 501     ))
 502
 503 (defun mime-raw-dired-function-for-one-frame (dir)
 504   (let ((win (or (get-buffer-window mime-preview-buffer)
 505                  (get-largest-window))))
 506     (select-window win)
 507     (dired dir)
 508     ))
 509
 510 (defun mime-view-message/external-anon-ftp (entity cal)
 511   (let* ((site (cdr (assoc "site" cal)))
 512          (directory (cdr (assoc "directory" cal)))
 513          (name (cdr (assoc "name" cal)))
 514          (pathname (concat "/anonymous@" site ":" directory)))
 515     (message "%s" (concat "Accessing " (expand-file-name name pathname) "..."))
 516     (funcall mime-raw-dired-function pathname)
 517     (goto-char (point-min))
 518     (search-forward name)
 519     ))
 520
 521 (defvar mime-raw-browse-url-function mime-browse-url-function)
 522
 523 (defun mime-view-message/external-url (entity cal)
 524   (let ((url (cdr (assoc "url" cal))))
 525     (message "%s" (concat "Accessing " url "..."))
 526     (funcall mime-raw-browse-url-function url)))
 527
 528
 529 ;;; @ rot13-47
 530 ;;;
 531
 532 (defun mime-view-caesar (entity situation)
 533   "Internal method for mime-view to display ROT13-47-48 message."
 534   (let ((buf (get-buffer-create
 535               (format "%s-%s" (buffer-name) (mime-entity-number entity)))))
 536     (with-current-buffer buf
 537       (setq buffer-read-only nil)
 538       (erase-buffer)
 539       (mime-insert-text-content entity)
 540       (mule-caesar-region (point-min) (point-max))
 541       (set-buffer-modified-p nil)
 542       )
 543     (let ((win (get-buffer-window (current-buffer))))
 544       (or (eq (selected-window) win)
 545           (select-window (or win (get-largest-window)))
 546           ))
 547     (view-buffer buf)
 548     (goto-char (point-min))
 549     ))
 550
 551
 552 ;;; @ end
 553 ;;;
 554
 555 (provide 'mime-play)
 556
 557 ;;; mime-play.el ends here