mime-play.el

   1 ;;; mime-play.el --- Playback processing module for mime-view.el
   2
   3 ;; Copyright (C) 1994,1995,1996,1997,1998 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   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   (require 'mime-text)
  35   (condition-case nil
  36       (require 'bbdb)
  37     (error (defvar bbdb-buffer-name nil)))
  38   )
  39
  40 (defvar mime-acting-situation-examples nil)
  41
  42 (defun mime-save-acting-situation-examples ()
  43   (let* ((file mime-acting-situation-examples-file)
  44          (buffer (get-buffer-create " *mime-example*")))
  45     (unwind-protect
  46         (save-excursion
  47           (set-buffer buffer)
  48           (setq buffer-file-name file)
  49           (erase-buffer)
  50           (insert ";;; " (file-name-nondirectory file) "\n")
  51           (insert "\n;; This file is generated automatically by "
  52                   mime-view-version-string "\n\n")
  53           (insert ";;; Code:\n\n")
  54           (pp `(setq mime-acting-situation-examples
  55                      ',mime-acting-situation-examples)
  56               (current-buffer))
  57           (insert "\n;;; "
  58                   (file-name-nondirectory file)
  59                   " ends here.\n")
  60           (save-buffer))
  61       (kill-buffer buffer))))
  62
  63 (add-hook 'kill-emacs-hook 'mime-save-acting-situation-examples)
  64
  65
  66 ;;; @ content decoder
  67 ;;;
  68
  69 (defvar mime-preview-after-decoded-position nil)
  70
  71 (defun mime-preview-play-current-entity (&optional mode)
  72   "Play current entity.
  73 It decodes current entity to call internal or external method.  The
  74 method is selected from variable `mime-acting-condition'.
  75 If MODE is specified, play as it.  Default MODE is \"play\"."
  76   (interactive)
  77   (let ((entity (get-text-property (point) 'mime-view-entity)))
  78     (if entity
  79         (let ((the-buf (current-buffer))
  80               (raw-buffer (mime-entity-buffer entity)))
  81           (setq mime-preview-after-decoded-position (point))
  82           (set-buffer raw-buffer)
  83           (mime-raw-play-entity entity (or mode "play"))
  84           (when (eq (current-buffer) raw-buffer)
  85             (set-buffer the-buf)
  86             (goto-char mime-preview-after-decoded-position)
  87             )))))
  88
  89 (defun mime-sort-situation (situation)
  90   (sort situation
  91         #'(lambda (a b)
  92             (let ((a-t (car a))
  93                   (b-t (car b))
  94                   (order '((type . 1)
  95                            (subtype . 2)
  96                            (mode . 3)
  97                            (method . 4)
  98                            (major-mode . 5)
  99                            (disposition-type . 6)
 100                            ))
 101                   a-order b-order)
 102               (if (symbolp a-t)
 103                   (let ((ret (assq a-t order)))
 104                     (if ret
 105                         (setq a-order (cdr ret))
 106                       (setq a-order 7)
 107                       ))
 108                 (setq a-order 8)
 109                 )
 110               (if (symbolp b-t)
 111                   (let ((ret (assq b-t order)))
 112                     (if ret
 113                         (setq b-order (cdr ret))
 114                       (setq b-order 7)
 115                       ))
 116                 (setq b-order 8)
 117                 )
 118               (if (= a-order b-order)
 119                   (string< (format "%s" a-t)(format "%s" b-t))
 120                 (< a-order b-order))
 121               )))
 122   )
 123
 124 (defsubst mime-delq-null-situation (situations field)
 125   (let (dest)
 126     (while situations
 127       (let ((situation (car situations)))
 128         (if (assq field situation)
 129             (setq dest (cons situation dest))
 130           ))
 131       (setq situations (cdr situations)))
 132     dest))
 133
 134 (defun mime-raw-play-entity (entity &optional mode situation)
 135   "Play entity specified by ENTITY.
 136 It decodes the entity to call internal or external method.  The method
 137 is selected from variable `mime-acting-condition'.  If MODE is
 138 specified, play as it.  Default MODE is \"play\"."
 139   (let (method ret)
 140     (or situation
 141         (setq situation (mime-entity-situation entity)))
 142     (if mode
 143         (setq situation (cons (cons 'mode mode) situation))
 144       )
 145     (setq ret
 146           (or (ctree-match-calist mime-acting-situation-examples situation)
 147               (ctree-match-calist-partially mime-acting-situation-examples
 148                                             situation)
 149               situation))
 150     (setq ret
 151           (or (mime-delq-null-situation
 152                (ctree-find-calist mime-acting-condition ret
 153                                   mime-view-find-every-acting-situation)
 154                'method)
 155               (mime-delq-null-situation
 156                (ctree-find-calist mime-acting-condition situation
 157                                   mime-view-find-every-acting-situation)
 158                'method)
 159               ))
 160     (cond ((cdr ret)
 161            (setq ret (select-menu-alist
 162                       "Methods"
 163                       (mapcar (function
 164                                (lambda (situation)
 165                                  (cons
 166                                   (format "%s"
 167                                           (cdr (assq 'method situation)))
 168                                   situation)))
 169                               ret)))
 170            (setq ret (mime-sort-situation ret))
 171            (ctree-set-calist-strictly 'mime-acting-situation-examples ret)
 172            )
 173           (t
 174            (setq ret (car ret))
 175            ))
 176     (setq method (cdr (assq 'method ret)))
 177     (cond ((and (symbolp method)
 178                 (fboundp method))
 179            (funcall method entity ret)
 180            )
 181           ((stringp method)
 182            (mime-activate-mailcap-method entity ret)
 183            )
 184           ;; ((and (listp method)(stringp (car method)))
 185           ;;  (mime-activate-external-method entity ret)
 186           ;;  )
 187           (t
 188            (mime-show-echo-buffer "No method are specified for %s\n"
 189                                   (mime-entity-type/subtype entity))
 190            ))
 191     ))
 192
 193
 194 ;;; @ external decoder
 195 ;;;
 196
 197 (defvar mime-mailcap-method-filename-alist nil)
 198
 199 (defun mime-activate-mailcap-method (entity situation)
 200   (save-excursion
 201     (save-restriction
 202       (let ((start (mime-entity-point-min entity))
 203             (end (mime-entity-point-max entity)))
 204         (narrow-to-region start end)
 205         (goto-char start)
 206         (let ((method (cdr (assoc 'method situation)))
 207               (name (mime-entity-safe-filename entity)))
 208           (setq name
 209                 (if (and name (not (string= name "")))
 210                     (expand-file-name name mime-temp-directory)
 211                   (make-temp-name
 212                    (expand-file-name "EMI" mime-temp-directory))
 213                   ))
 214           (mime-write-entity-content entity name)
 215           (message "External method is starting...")
 216           (let ((process
 217                  (let ((command
 218                         (mailcap-format-command
 219                          method
 220                          (cons (cons 'filename name) situation))))
 221                    (start-process command mime-echo-buffer-name
 222                                   shell-file-name shell-command-switch command)
 223                    )))
 224             (set-alist 'mime-mailcap-method-filename-alist process name)
 225             (set-process-sentinel process 'mime-mailcap-method-sentinel)
 226             )
 227           )))))
 228
 229 (defun mime-mailcap-method-sentinel (process event)
 230   (let ((file (cdr (assq process mime-mailcap-method-filename-alist))))
 231     (if (file-exists-p file)
 232         (delete-file file)
 233       ))
 234   (remove-alist 'mime-mailcap-method-filename-alist process)
 235   (message (format "%s %s" process event)))
 236
 237 (defvar mime-echo-window-is-shared-with-bbdb t
 238   "*If non-nil, mime-echo window is shared with BBDB window.")
 239
 240 (defvar mime-echo-window-height
 241   (function
 242    (lambda ()
 243      (/ (window-height) 5)
 244      ))
 245   "*Size of mime-echo window.
 246 It allows function or integer.  If it is function,
 247 `mime-show-echo-buffer' calls it to get height of mime-echo window.
 248 Otherwise `mime-show-echo-buffer' uses it as height of mime-echo
 249 window.")
 250
 251 (defun mime-show-echo-buffer (&rest forms)
 252   "Show mime-echo buffer to display MIME-playing information."
 253   (get-buffer-create mime-echo-buffer-name)
 254   (let ((the-win (selected-window))
 255         (win (get-buffer-window mime-echo-buffer-name))
 256         )
 257     (or win
 258         (if (and mime-echo-window-is-shared-with-bbdb
 259                  (boundp 'bbdb-buffer-name)
 260                  (setq win (get-buffer-window bbdb-buffer-name))
 261                  )
 262             (set-window-buffer win mime-echo-buffer-name)
 263           (select-window (get-buffer-window mime-preview-buffer))
 264           (setq win (split-window-vertically
 265                      (- (window-height)
 266                         (if (functionp mime-echo-window-height)
 267                             (funcall mime-echo-window-height)
 268                           mime-echo-window-height)
 269                         )))
 270           (set-window-buffer win mime-echo-buffer-name)
 271           ))
 272     (select-window win)
 273     (goto-char (point-max))
 274     (if forms
 275         (insert (apply (function format) forms))
 276       )
 277     (select-window the-win)
 278     ))
 279
 280
 281 ;;; @ file name
 282 ;;;
 283
 284 (defvar mime-view-file-name-char-regexp "[A-Za-z0-9+_-]")
 285
 286 (defvar mime-view-file-name-regexp-1
 287   (concat mime-view-file-name-char-regexp "+\\."
 288           mime-view-file-name-char-regexp "+"))
 289
 290 (defvar mime-view-file-name-regexp-2
 291   (concat (regexp-* mime-view-file-name-char-regexp)
 292           "\\(\\." mime-view-file-name-char-regexp "+\\)*"))
 293
 294 (defun mime-entity-safe-filename (entity)
 295   (let ((filename
 296          (or (mime-entity-filename entity)
 297              (let ((subj
 298                     (or (mime-read-field 'Content-Description entity)
 299                         (mime-read-field 'Subject entity))))
 300                (if (and subj
 301                         (or (string-match mime-view-file-name-regexp-1 subj)
 302                             (string-match mime-view-file-name-regexp-2 subj)))
 303                    (substring subj (match-beginning 0)(match-end 0))
 304                  )))))
 305     (if filename
 306         (replace-as-filename filename)
 307       )))
 308
 309
 310 ;;; @ file extraction
 311 ;;;
 312
 313 (defun mime-save-content (entity situation)
 314   (let* ((name (mime-entity-safe-filename entity))
 315          (filename (if (and name (not (string-equal name "")))
 316                        (expand-file-name name
 317                                          (save-window-excursion
 318                                            (call-interactively
 319                                             (function
 320                                              (lambda (dir)
 321                                                (interactive "DDirectory: ")
 322                                                dir)))))
 323                      (save-window-excursion
 324                        (call-interactively
 325                         (function
 326                          (lambda (file)
 327                            (interactive "FFilename: ")
 328                            (expand-file-name file)))))))
 329          )
 330     (if (file-exists-p filename)
 331         (or (yes-or-no-p (format "File %s exists. Save anyway? " filename))
 332             (error "")))
 333     (mime-write-entity-content entity filename)
 334     ))
 335
 336
 337 ;;; @ file detection
 338 ;;;
 339
 340 (defvar mime-file-content-type-alist
 341   '(("JPEG"             image jpeg)
 342     ("GIF"              image gif)
 343     ("Standard MIDI"    audio midi)
 344     )
 345   "*Alist of \"file\" output patterns vs. corresponding media-types.
 346 Each element looks like (REGEXP TYPE SUBTYPE).
 347 REGEXP is pattern for \"file\" command output.
 348 TYPE is symbol to indicate primary type of media-type.
 349 SUBTYPE is symbol to indicate subtype of media-type.")
 350
 351 (defun mime-detect-content (entity situation)
 352   (let ((beg (mime-entity-point-min entity))
 353         (end (mime-entity-point-max entity)))
 354     (goto-char beg)
 355     (let* ((name (save-restriction
 356                    (narrow-to-region beg end)
 357                    (mime-entity-safe-filename entity)
 358                    ))
 359            (encoding (or (cdr (assq 'encoding situation)) "7bit"))
 360            (filename (if (and name (not (string-equal name "")))
 361                          (expand-file-name name mime-temp-directory)
 362                        (make-temp-name
 363                         (expand-file-name "EMI" mime-temp-directory)))))
 364       (mime-write-decoded-region (mime-entity-body-start entity) end
 365                                  filename encoding)
 366       (let (type subtype)
 367         (with-temp-buffer
 368           (call-process "file" nil t nil filename)
 369           (goto-char (point-min))
 370           (if (search-forward (concat filename ": ") nil t)
 371               (let ((rest mime-file-content-type-alist))
 372                 (while (not (let ((cell (car rest)))
 373                               (if cell
 374                                   (if (looking-at (car cell))
 375                                       (setq type (nth 1 cell)
 376                                             subtype (nth 2 cell))
 377                                     )
 378                                 t)))
 379                   (setq rest (cdr rest))))))
 380         (if type
 381             (mime-raw-play-entity
 382              entity "play"
 383              (put-alist 'type type
 384                         (put-alist 'subtype subtype
 385                                    (mime-entity-situation entity))))
 386           ))
 387       )))
 388
 389
 390 ;;; @ mail/news message
 391 ;;;
 392
 393 (defun mime-preview-quitting-method-for-mime-show-message-mode ()
 394   "Quitting method for mime-view.
 395 It is registered to variable `mime-preview-quitting-method-alist'."
 396   (let ((mother mime-mother-buffer)
 397         (win-conf mime-preview-original-window-configuration)
 398         )
 399     (kill-buffer mime-raw-buffer)
 400     (mime-preview-kill-buffer)
 401     (set-window-configuration win-conf)
 402     (pop-to-buffer mother)
 403     ))
 404
 405 (defun mime-view-message/rfc822 (entity situation)
 406   (let* ((new-name
 407           (format "%s-%s" (buffer-name) (mime-entity-number entity)))
 408          (mother mime-preview-buffer)
 409          (children (car (mime-entity-children entity))))
 410     (set-buffer (get-buffer-create new-name))
 411     (erase-buffer)
 412     (insert-buffer-substring (mime-entity-buffer children)
 413                              (mime-entity-point-min children)
 414                              (mime-entity-point-max children))
 415     (setq mime-message-structure children)
 416     (setq major-mode 'mime-show-message-mode)
 417     (mime-view-buffer (current-buffer) nil mother
 418                       nil (if (mime-entity-cooked-p entity) 'cooked))
 419     ))
 420
 421
 422 ;;; @ message/partial
 423 ;;;
 424
 425 (defun mime-store-message/partial-piece (entity cal)
 426   (goto-char (mime-entity-point-min entity))
 427   (let* ((root-dir
 428           (expand-file-name
 429            (concat "m-prts-" (user-login-name)) mime-temp-directory))
 430          (id (cdr (assoc "id" cal)))
 431          (number (cdr (assoc "number" cal)))
 432          (total (cdr (assoc "total" cal)))
 433          file
 434          (mother mime-preview-buffer)
 435          )
 436     (or (file-exists-p root-dir)
 437         (make-directory root-dir)
 438         )
 439     (setq id (replace-as-filename id))
 440     (setq root-dir (concat root-dir "/" id))
 441     (or (file-exists-p root-dir)
 442         (make-directory root-dir)
 443         )
 444     (setq file (concat root-dir "/FULL"))
 445     (if (file-exists-p file)
 446         (let ((full-buf (get-buffer-create "FULL"))
 447               (pwin (or (get-buffer-window mother)
 448                         (get-largest-window)))
 449               )
 450           (save-window-excursion
 451             (set-buffer full-buf)
 452             (erase-buffer)
 453             (as-binary-input-file (insert-file-contents file))
 454             (setq major-mode 'mime-show-message-mode)
 455             (mime-view-mode mother)
 456             )
 457           (set-window-buffer pwin
 458                              (save-excursion
 459                                (set-buffer full-buf)
 460                                mime-preview-buffer))
 461           (select-window pwin)
 462           )
 463       (setq file (concat root-dir "/" number))
 464       (mime-write-entity-body entity file)
 465       (let ((total-file (concat root-dir "/CT")))
 466         (setq total
 467               (if total
 468                   (progn
 469                     (or (file-exists-p total-file)
 470                         (save-excursion
 471                           (set-buffer
 472                            (get-buffer-create mime-temp-buffer-name))
 473                           (erase-buffer)
 474                           (insert total)
 475                           (write-region (point-min)(point-max) total-file)
 476                           (kill-buffer (current-buffer))
 477                           ))
 478                     (string-to-number total)
 479                     )
 480                 (and (file-exists-p total-file)
 481                      (save-excursion
 482                        (set-buffer (find-file-noselect total-file))
 483                        (prog1
 484                            (and (re-search-forward "[0-9]+" nil t)
 485                                 (string-to-number
 486                                  (buffer-substring (match-beginning 0)
 487                                                    (match-end 0)))
 488                                 )
 489                          (kill-buffer (current-buffer))
 490                          )))
 491                 )))
 492       (if (and total (> total 0))
 493           (catch 'tag
 494             (save-excursion
 495               (set-buffer (get-buffer-create mime-temp-buffer-name))
 496               (let ((full-buf (current-buffer)))
 497                 (erase-buffer)
 498                 (let ((i 1))
 499                   (while (<= i total)
 500                     (setq file (concat root-dir "/" (int-to-string i)))
 501                     (or (file-exists-p file)
 502                         (throw 'tag nil)
 503                         )
 504                     (as-binary-input-file (insert-file-contents file))
 505                     (goto-char (point-max))
 506                     (setq i (1+ i))
 507                     ))
 508                 (as-binary-output-file
 509                  (write-region (point-min)(point-max)
 510                                (expand-file-name "FULL" root-dir)))
 511                 (let ((i 1))
 512                   (while (<= i total)
 513                     (let ((file (format "%s/%d" root-dir i)))
 514                       (and (file-exists-p file)
 515                            (delete-file file)
 516                            ))
 517                     (setq i (1+ i))
 518                     ))
 519                 (let ((file (expand-file-name "CT" root-dir)))
 520                   (and (file-exists-p file)
 521                        (delete-file file)
 522                        ))
 523                 (save-window-excursion
 524                   (setq major-mode 'mime-show-message-mode)
 525                   (mime-view-mode mother)
 526                   )
 527                 (let ((pwin (or (get-buffer-window mother)
 528                                 (get-largest-window)
 529                                 ))
 530                       (pbuf (save-excursion
 531                               (set-buffer full-buf)
 532                               mime-preview-buffer)))
 533                   (set-window-buffer pwin pbuf)
 534                   (select-window pwin)
 535                   )))))
 536       )))
 537
 538
 539 ;;; @ message/external-body
 540 ;;;
 541
 542 (defvar mime-raw-dired-function
 543   (if (and (>= emacs-major-version 19) window-system)
 544       (function dired-other-frame)
 545     (function mime-raw-dired-function-for-one-frame)
 546     ))
 547
 548 (defun mime-raw-dired-function-for-one-frame (dir)
 549   (let ((win (or (get-buffer-window mime-preview-buffer)
 550                  (get-largest-window))))
 551     (select-window win)
 552     (dired dir)
 553     ))
 554
 555 (defun mime-view-message/external-anon-ftp (entity cal)
 556   (let* ((site (cdr (assoc "site" cal)))
 557          (directory (cdr (assoc "directory" cal)))
 558          (name (cdr (assoc "name" cal)))
 559          (pathname (concat "/anonymous@" site ":" directory)))
 560     (message (concat "Accessing " (expand-file-name name pathname) " ..."))
 561     (funcall mime-raw-dired-function pathname)
 562     (goto-char (point-min))
 563     (search-forward name)
 564     ))
 565
 566 (defvar mime-raw-browse-url-function (function mime-browse-url))
 567
 568 (defun mime-view-message/external-url (entity cal)
 569   (let ((url (cdr (assoc "url" cal))))
 570     (message (concat "Accessing " url " ..."))
 571     (funcall mime-raw-browse-url-function url)))
 572
 573
 574 ;;; @ rot13-47
 575 ;;;
 576
 577 (defun mime-view-caesar (entity situation)
 578   "Internal method for mime-view to display ROT13-47-48 message."
 579   (let* ((new-name (format "%s-%s" (buffer-name)
 580                            (mime-entity-number entity)))
 581          (mother mime-preview-buffer))
 582     (let ((pwin (or (get-buffer-window mother)
 583                     (get-largest-window)))
 584           (buf (get-buffer-create new-name)))
 585       (set-window-buffer pwin buf)
 586       (set-buffer buf)
 587       (select-window pwin)
 588       )
 589     (setq buffer-read-only nil)
 590     (erase-buffer)
 591     (mime-text-insert-decoded-body entity)
 592     (mule-caesar-region (point-min) (point-max))
 593     (set-buffer-modified-p nil)
 594     (set-buffer mother)
 595     (view-buffer new-name)
 596     ))
 597
 598
 599 ;;; @ end
 600 ;;;
 601
 602 (provide 'mime-play)
 603
 604 (let* ((file mime-acting-situation-examples-file)
 605        (buffer (get-buffer-create " *mime-example*")))
 606   (if (file-readable-p file)
 607       (unwind-protect
 608           (save-excursion
 609             (set-buffer buffer)
 610             (erase-buffer)
 611             (insert-file-contents file)
 612             (eval-buffer)
 613             ;; format check
 614             (or (eq (car mime-acting-situation-examples) 'type)
 615                 (setq mime-acting-situation-examples nil))
 616             )
 617         (kill-buffer buffer))))
 618
 619 ;;; mime-play.el ends here