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