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 (list "play"))
  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 mode)
  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 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-decoded-region (mime-entity-body-start entity) end
 215                                      name (cdr (assq 'encoding situation)))
 216           (message "External method is starting...")
 217           (let ((process
 218                  (let ((command
 219                         (mailcap-format-command
 220                          method
 221                          (cons (cons 'filename name) situation))))
 222                    (start-process command mime-echo-buffer-name
 223                                   shell-file-name shell-command-switch command)
 224                    )))
 225             (set-alist 'mime-mailcap-method-filename-alist process name)
 226             (set-process-sentinel process 'mime-mailcap-method-sentinel)
 227             )
 228           )))))
 229
 230 (defun mime-mailcap-method-sentinel (process event)
 231   (let ((file (cdr (assq process mime-mailcap-method-filename-alist))))
 232     (if (file-exists-p file)
 233         (delete-file file)
 234       ))
 235   (remove-alist 'mime-mailcap-method-filename-alist process)
 236   (message (format "%s %s" process event)))
 237
 238 (defvar mime-echo-window-is-shared-with-bbdb t
 239   "*If non-nil, mime-echo window is shared with BBDB window.")
 240
 241 (defvar mime-echo-window-height
 242   (function
 243    (lambda ()
 244      (/ (window-height) 5)
 245      ))
 246   "*Size of mime-echo window.
 247 It allows function or integer.  If it is function,
 248 `mime-show-echo-buffer' calls it to get height of mime-echo window.
 249 Otherwise `mime-show-echo-buffer' uses it as height of mime-echo
 250 window.")
 251
 252 (defun mime-show-echo-buffer (&rest forms)
 253   "Show mime-echo buffer to display MIME-playing information."
 254   (get-buffer-create mime-echo-buffer-name)
 255   (let ((the-win (selected-window))
 256         (win (get-buffer-window mime-echo-buffer-name))
 257         )
 258     (or win
 259         (if (and mime-echo-window-is-shared-with-bbdb
 260                  (boundp 'bbdb-buffer-name)
 261                  (setq win (get-buffer-window bbdb-buffer-name))
 262                  )
 263             (set-window-buffer win mime-echo-buffer-name)
 264           (select-window (get-buffer-window mime-preview-buffer))
 265           (setq win (split-window-vertically
 266                      (- (window-height)
 267                         (if (functionp mime-echo-window-height)
 268                             (funcall mime-echo-window-height)
 269                           mime-echo-window-height)
 270                         )))
 271           (set-window-buffer win mime-echo-buffer-name)
 272           ))
 273     (select-window win)
 274     (goto-char (point-max))
 275     (if forms
 276         (insert (apply (function format) forms))
 277       )
 278     (select-window the-win)
 279     ))
 280
 281
 282 ;;; @ file name
 283 ;;;
 284
 285 (defvar mime-view-file-name-char-regexp "[A-Za-z0-9+_-]")
 286
 287 (defvar mime-view-file-name-regexp-1
 288   (concat mime-view-file-name-char-regexp "+\\."
 289           mime-view-file-name-char-regexp "+"))
 290
 291 (defvar mime-view-file-name-regexp-2
 292   (concat (regexp-* mime-view-file-name-char-regexp)
 293           "\\(\\." mime-view-file-name-char-regexp "+\\)*"))
 294
 295 (defun mime-entity-safe-filename (entity)
 296   (let ((filename
 297          (or (mime-entity-filename entity)
 298              (let ((subj
 299                     (or (mime-read-field 'Content-Description entity)
 300                         (mime-read-field 'Subject entity))))
 301                (if (and subj
 302                         (or (string-match mime-view-file-name-regexp-1 subj)
 303                             (string-match mime-view-file-name-regexp-2 subj)))
 304                    (substring subj (match-beginning 0)(match-end 0))
 305                  )))))
 306     (if filename
 307         (replace-as-filename filename)
 308       )))
 309
 310
 311 ;;; @ file extraction
 312 ;;;
 313
 314 (defun mime-save-content (entity situation)
 315   (let* ((name (mime-entity-safe-filename entity))
 316          (encoding (or (mime-entity-encoding entity) "7bit"))
 317          (filename (if (and name (not (string-equal name "")))
 318                        (expand-file-name name
 319                                          (save-window-excursion
 320                                            (call-interactively
 321                                             (function
 322                                              (lambda (dir)
 323                                                (interactive "DDirectory: ")
 324                                                dir)))))
 325                      (save-window-excursion
 326                        (call-interactively
 327                         (function
 328                          (lambda (file)
 329                            (interactive "FFilename: ")
 330                            (expand-file-name file)))))))
 331          )
 332     (if (file-exists-p filename)
 333         (or (yes-or-no-p (format "File %s exists. Save anyway? " filename))
 334             (error "")))
 335     (mime-write-decoded-region (mime-entity-body-start entity)
 336                                (mime-entity-body-end entity)
 337                                filename encoding)
 338     ))
 339
 340
 341 ;;; @ file detection
 342 ;;;
 343
 344 (defvar mime-file-content-type-alist
 345   '(("JPEG"     image jpeg)
 346     ("GIF"      image gif)
 347     )
 348   "*Alist of \"file\" output patterns vs. corresponding media-types.
 349 Each element looks like (REGEXP TYPE SUBTYPE).
 350 REGEXP is pattern for \"file\" command output.
 351 TYPE is symbol to indicate primary type of media-type.
 352 SUBTYPE is symbol to indicate subtype of media-type.")
 353
 354 (defun mime-detect-content (entity situation)
 355   (let ((beg (mime-entity-point-min entity))
 356         (end (mime-entity-point-max entity)))
 357     (goto-char beg)
 358     (let* ((name (save-restriction
 359                    (narrow-to-region beg end)
 360                    (mime-entity-safe-filename entity)
 361                    ))
 362            (encoding (or (cdr (assq 'encoding situation)) "7bit"))
 363            (filename (if (and name (not (string-equal name "")))
 364                          (expand-file-name name mime-temp-directory)
 365                        (make-temp-name
 366                         (expand-file-name "EMI" mime-temp-directory)))))
 367       (mime-write-decoded-region (mime-entity-body-start entity) end
 368                                  filename encoding)
 369       (let (type subtype)
 370         (with-temp-buffer
 371           (call-process "file" nil t nil filename)
 372           (goto-char (point-min))
 373           (if (search-forward (concat filename ": ") nil t)
 374               (let ((rest mime-file-content-type-alist))
 375                 (while (not (let ((cell (car rest)))
 376                               (if (looking-at (car cell))
 377                                   (setq type (nth 1 cell)
 378                                         subtype (nth 2 cell))
 379                                 )))
 380                   (setq rest (cdr rest))))))
 381         (if type
 382             (mime-raw-play-entity
 383              entity "play"
 384              (put-alist 'type type
 385                         (put-alist 'subtype subtype
 386                                    (mime-entity-situation entity))))
 387           ))
 388       )))
 389
 390
 391 ;;; @ mail/news message
 392 ;;;
 393
 394 (defun mime-preview-quitting-method-for-mime-show-message-mode ()
 395   "Quitting method for mime-view.
 396 It is registered to variable `mime-preview-quitting-method-alist'."
 397   (let ((mother mime-mother-buffer)
 398         (win-conf mime-preview-original-window-configuration)
 399         )
 400     (kill-buffer mime-raw-buffer)
 401     (mime-preview-kill-buffer)
 402     (set-window-configuration win-conf)
 403     (pop-to-buffer mother)
 404     ))
 405
 406 (defun mime-view-message/rfc822 (entity cal)
 407   (let* ((beg (mime-entity-point-min entity))
 408          (end (mime-entity-point-max entity))
 409          (cnum (mime-raw-point-to-entity-number beg))
 410          (new-name (format "%s-%s" (buffer-name) cnum))
 411          (mother mime-preview-buffer)
 412          (representation-type (mime-entity-representation-type entity))
 413          str)
 414     (setq str (buffer-substring beg end))
 415     (switch-to-buffer new-name)
 416     (erase-buffer)
 417     (insert str)
 418     (goto-char (point-min))
 419     (if (re-search-forward "^\n" nil t)
 420         (delete-region (point-min) (match-end 0))
 421       )
 422     (setq major-mode 'mime-show-message-mode)
 423     (setq mime-raw-representation-type representation-type)
 424     (mime-view-mode mother)
 425     ))
 426
 427
 428 ;;; @ message/partial
 429 ;;;
 430
 431 (defun mime-raw-write-region (start end filename)
 432   "Write current region into specified file.
 433 When called from a program, takes three arguments:
 434 START, END and FILENAME.  START and END are buffer positions.
 435 It refer `mime-raw-representation-type' or `major-mode
 436 mime-raw-representation-type-alist'.  If it is `binary', region is
 437 saved as binary.  Otherwise the region is saved by `write-region'."
 438   (let ((presentation-type
 439          (or mime-raw-representation-type
 440              (cdr (or (assq major-mode mime-raw-representation-type-alist)
 441                       (assq t mime-raw-representation-type-alist))))))
 442     (if (eq presentation-type 'binary)
 443         (write-region-as-binary start end filename)
 444       (write-region start end filename)
 445       )))
 446
 447 (defun mime-store-message/partial-piece (entity cal)
 448   (goto-char (mime-entity-point-min entity))
 449   (let* ((root-dir
 450           (expand-file-name
 451            (concat "m-prts-" (user-login-name)) mime-temp-directory))
 452          (id (cdr (assoc "id" cal)))
 453          (number (cdr (assoc "number" cal)))
 454          (total (cdr (assoc "total" cal)))
 455          file
 456          (mother mime-preview-buffer)
 457          )
 458     (or (file-exists-p root-dir)
 459         (make-directory root-dir)
 460         )
 461     (setq id (replace-as-filename id))
 462     (setq root-dir (concat root-dir "/" id))
 463     (or (file-exists-p root-dir)
 464         (make-directory root-dir)
 465         )
 466     (setq file (concat root-dir "/FULL"))
 467     (if (file-exists-p file)
 468         (let ((full-buf (get-buffer-create "FULL"))
 469               (pwin (or (get-buffer-window mother)
 470                         (get-largest-window)))
 471               )
 472           (save-window-excursion
 473             (set-buffer full-buf)
 474             (erase-buffer)
 475             (as-binary-input-file (insert-file-contents file))
 476             (setq major-mode 'mime-show-message-mode)
 477             (mime-view-mode mother)
 478             )
 479           (set-window-buffer pwin
 480                              (save-excursion
 481                                (set-buffer full-buf)
 482                                mime-preview-buffer))
 483           (select-window pwin)
 484           )
 485       (setq file (concat root-dir "/" number))
 486       (mime-raw-write-region (mime-entity-body-start entity)
 487                              (mime-entity-body-end entity) file)
 488       (let ((total-file (concat root-dir "/CT")))
 489         (setq total
 490               (if total
 491                   (progn
 492                     (or (file-exists-p total-file)
 493                         (save-excursion
 494                           (set-buffer
 495                            (get-buffer-create mime-temp-buffer-name))
 496                           (erase-buffer)
 497                           (insert total)
 498                           (write-region (point-min)(point-max) total-file)
 499                           (kill-buffer (current-buffer))
 500                           ))
 501                     (string-to-number total)
 502                     )
 503                 (and (file-exists-p total-file)
 504                      (save-excursion
 505                        (set-buffer (find-file-noselect total-file))
 506                        (prog1
 507                            (and (re-search-forward "[0-9]+" nil t)
 508                                 (string-to-number
 509                                  (buffer-substring (match-beginning 0)
 510                                                    (match-end 0)))
 511                                 )
 512                          (kill-buffer (current-buffer))
 513                          )))
 514                 )))
 515       (if (and total (> total 0))
 516           (catch 'tag
 517             (save-excursion
 518               (set-buffer (get-buffer-create mime-temp-buffer-name))
 519               (let ((full-buf (current-buffer)))
 520                 (erase-buffer)
 521                 (let ((i 1))
 522                   (while (<= i total)
 523                     (setq file (concat root-dir "/" (int-to-string i)))
 524                     (or (file-exists-p file)
 525                         (throw 'tag nil)
 526                         )
 527                     (as-binary-input-file (insert-file-contents file))
 528                     (goto-char (point-max))
 529                     (setq i (1+ i))
 530                     ))
 531                 (as-binary-output-file
 532                  (write-region (point-min)(point-max)
 533                                (expand-file-name "FULL" root-dir)))
 534                 (let ((i 1))
 535                   (while (<= i total)
 536                     (let ((file (format "%s/%d" root-dir i)))
 537                       (and (file-exists-p file)
 538                            (delete-file file)
 539                            ))
 540                     (setq i (1+ i))
 541                     ))
 542                 (let ((file (expand-file-name "CT" root-dir)))
 543                   (and (file-exists-p file)
 544                        (delete-file file)
 545                        ))
 546                 (save-window-excursion
 547                   (setq major-mode 'mime-show-message-mode)
 548                   (mime-view-mode mother)
 549                   )
 550                 (let ((pwin (or (get-buffer-window mother)
 551                                 (get-largest-window)
 552                                 ))
 553                       (pbuf (save-excursion
 554                               (set-buffer full-buf)
 555                               mime-preview-buffer)))
 556                   (set-window-buffer pwin pbuf)
 557                   (select-window pwin)
 558                   )))))
 559       )))
 560
 561
 562 ;;; @ message/external-body
 563 ;;;
 564
 565 (defvar mime-raw-dired-function
 566   (if (and (>= emacs-major-version 19) window-system)
 567       (function dired-other-frame)
 568     (function mime-raw-dired-function-for-one-frame)
 569     ))
 570
 571 (defun mime-raw-dired-function-for-one-frame (dir)
 572   (let ((win (or (get-buffer-window mime-preview-buffer)
 573                  (get-largest-window))))
 574     (select-window win)
 575     (dired dir)
 576     ))
 577
 578 (defun mime-view-message/external-anon-ftp (entity cal)
 579   (let* ((site (cdr (assoc "site" cal)))
 580          (directory (cdr (assoc "directory" cal)))
 581          (name (cdr (assoc "name" cal)))
 582          (pathname (concat "/anonymous@" site ":" directory)))
 583     (message (concat "Accessing " (expand-file-name name pathname) " ..."))
 584     (funcall mime-raw-dired-function pathname)
 585     (goto-char (point-min))
 586     (search-forward name)
 587     ))
 588
 589 (defvar mime-raw-browse-url-function (function mime-browse-url))
 590
 591 (defun mime-view-message/external-url (entity cal)
 592   (let ((url (cdr (assoc "url" cal))))
 593     (message (concat "Accessing " url " ..."))
 594     (funcall mime-raw-browse-url-function url)))
 595
 596
 597 ;;; @ rot13-47
 598 ;;;
 599
 600 (defun mime-view-caesar (entity situation)
 601   "Internal method for mime-view to display ROT13-47-48 message."
 602   (let* ((new-name (format "%s-%s" (buffer-name)
 603                            (mime-entity-number entity)))
 604          (mother mime-preview-buffer))
 605     (let ((pwin (or (get-buffer-window mother)
 606                     (get-largest-window)))
 607           (buf (get-buffer-create new-name)))
 608       (set-window-buffer pwin buf)
 609       (set-buffer buf)
 610       (select-window pwin)
 611       )
 612     (setq buffer-read-only nil)
 613     (erase-buffer)
 614     (mime-text-insert-decoded-body entity)
 615     (mule-caesar-region (point-min) (point-max))
 616     (set-buffer-modified-p nil)
 617     (set-buffer mother)
 618     (view-buffer new-name)
 619     ))
 620
 621
 622 ;;; @ end
 623 ;;;
 624
 625 (provide 'mime-play)
 626
 627 (let* ((file mime-acting-situation-examples-file)
 628        (buffer (get-buffer-create " *mime-example*")))
 629   (if (file-readable-p file)
 630       (unwind-protect
 631           (save-excursion
 632             (set-buffer buffer)
 633             (erase-buffer)
 634             (insert-file-contents file)
 635             (eval-buffer)
 636             ;; format check
 637             (or (eq (car mime-acting-situation-examples) 'type)
 638                 (setq mime-acting-situation-examples nil))
 639             )
 640         (kill-buffer buffer))))
 641
 642 ;;; mime-play.el ends here