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   (or mode
  78       (setq mode "play"))
  79   (let ((entity (get-text-property (point) 'mime-view-entity)))
  80     (if entity
  81         (let ((the-buf (current-buffer))
  82               (raw-buffer (mime-entity-buffer entity)))
  83           (setq mime-preview-after-decoded-position (point))
  84           (set-buffer raw-buffer)
  85           (mime-raw-play-entity entity mode)
  86           (when (eq (current-buffer) raw-buffer)
  87             (set-buffer the-buf)
  88             (goto-char mime-preview-after-decoded-position)
  89             )))))
  90
  91 (defun mime-sort-situation (situation)
  92   (sort situation
  93         #'(lambda (a b)
  94             (let ((a-t (car a))
  95                   (b-t (car b))
  96                   (order '((type . 1)
  97                            (subtype . 2)
  98                            (mode . 3)
  99                            (major-mode . 4)))
 100                   a-order b-order)
 101               (if (symbolp a-t)
 102                   (let ((ret (assq a-t order)))
 103                     (if ret
 104                         (setq a-order (cdr ret))
 105                       (setq a-order 5)
 106                       ))
 107                 (setq a-order 6)
 108                 )
 109               (if (symbolp b-t)
 110                   (let ((ret (assq b-t order)))
 111                     (if ret
 112                         (setq b-order (cdr ret))
 113                       (setq b-order 5)
 114                       ))
 115                 (setq b-order 6)
 116                 )
 117               (if (= a-order b-order)
 118                   (string< (format "%s" a-t)(format "%s" b-t))
 119                 (< a-order b-order))
 120               )))
 121   )
 122
 123 (defsubst mime-delq-null-situation (situations field)
 124   (let (dest)
 125     (while situations
 126       (let ((situation (car situations)))
 127         (if (assq field situation)
 128             (setq dest (cons situation dest))
 129           ))
 130       (setq situations (cdr situations)))
 131     dest))
 132
 133 (defun mime-raw-play-entity (entity &optional mode)
 134   "Play entity specified by ENTITY.
 135 It decodes the entity to call internal or external method.  The method
 136 is selected from variable `mime-acting-condition'.  If MODE is
 137 specified, play as it.  Default MODE is \"play\"."
 138   (let ((beg (mime-entity-point-min entity))
 139         (end (mime-entity-point-max entity)))
 140     (let (method cal ret)
 141       (setq cal (mime-entity-situation entity))
 142       (if mode
 143           (setq cal (cons (cons 'mode mode) cal))
 144         )
 145       (setq ret
 146             (or (ctree-match-calist mime-acting-situation-examples cal)
 147                 (ctree-match-calist-partially mime-acting-situation-examples
 148                                               cal)
 149                 cal))
 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 cal
 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 beg end 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 (expand-file-name (mime-raw-get-filename situation)
 208                                       mime-temp-directory)))
 209           (mime-write-decoded-region (if (re-search-forward "^$" end t)
 210                                          (1+ (match-end 0))
 211                                        (point-min))
 212                                      end name
 213                                      (cdr (assq 'encoding situation)))
 214           (message "External method is starting...")
 215           (let ((process
 216                  (let ((command
 217                         (mailcap-format-command
 218                          method
 219                          (cons (cons 'filename name) situation))))
 220                    (start-process command mime-echo-buffer-name
 221                                   shell-file-name shell-command-switch command)
 222                    )))
 223             (set-alist 'mime-mailcap-method-filename-alist process name)
 224             (set-process-sentinel process 'mime-mailcap-method-sentinel)
 225             )
 226           )))))
 227
 228 (defun mime-mailcap-method-sentinel (process event)
 229   (let ((file (cdr (assq process mime-mailcap-method-filename-alist))))
 230     (if (file-exists-p file)
 231         (delete-file file)
 232       ))
 233   (remove-alist 'mime-mailcap-method-filename-alist process)
 234   (message (format "%s %s" process event)))
 235
 236 (defun mime-activate-external-method (beg end cal)
 237   (save-excursion
 238     (save-restriction
 239       (narrow-to-region beg end)
 240       (goto-char beg)
 241       (let ((method (cdr (assoc 'method cal)))
 242             (name (mime-raw-get-filename cal))
 243             )
 244         (if method
 245             (let ((file (make-temp-name
 246                          (expand-file-name "TM" mime-temp-directory)))
 247                   b args)
 248               (if (nth 1 method)
 249                   (setq b beg)
 250                 (setq b
 251                       (if (re-search-forward "^$" nil t)
 252                           (1+ (match-end 0))
 253                         (point-min)
 254                         ))
 255                 )
 256               (goto-char b)
 257               (write-region b end file)
 258               (message "External method is starting...")
 259               (setq cal (put-alist
 260                          'name (replace-as-filename name) cal))
 261               (setq cal (put-alist 'file file cal))
 262               (setq args (nconc
 263                           (list (car method)
 264                                 mime-echo-buffer-name (car method)
 265                                 )
 266                           (mime-make-external-method-args
 267                            cal (cdr (cdr method)))
 268                           ))
 269               (apply (function start-process) args)
 270               (mime-show-echo-buffer)
 271               ))
 272         ))))
 273
 274 (defun mime-make-external-method-args (cal format)
 275   (mapcar (function
 276            (lambda (arg)
 277              (if (stringp arg)
 278                  arg
 279                (let* ((item (eval arg))
 280                       (ret (cdr (assoc item cal)))
 281                       )
 282                  (if ret
 283                      ret
 284                    (if (eq item 'encoding)
 285                        "7bit"
 286                      ""))
 287                  ))
 288              ))
 289           format))
 290
 291 (defvar mime-echo-window-is-shared-with-bbdb t
 292   "*If non-nil, mime-echo window is shared with BBDB window.")
 293
 294 (defvar mime-echo-window-height
 295   (function
 296    (lambda ()
 297      (/ (window-height) 5)
 298      ))
 299   "*Size of mime-echo window.
 300 It allows function or integer.  If it is function,
 301 `mime-show-echo-buffer' calls it to get height of mime-echo window.
 302 Otherwise `mime-show-echo-buffer' uses it as height of mime-echo
 303 window.")
 304
 305 (defun mime-show-echo-buffer (&rest forms)
 306   "Show mime-echo buffer to display MIME-playing information."
 307   (get-buffer-create mime-echo-buffer-name)
 308   (let ((the-win (selected-window))
 309         (win (get-buffer-window mime-echo-buffer-name))
 310         )
 311     (or win
 312         (if (and mime-echo-window-is-shared-with-bbdb
 313                  (boundp 'bbdb-buffer-name)
 314                  (setq win (get-buffer-window bbdb-buffer-name))
 315                  )
 316             (set-window-buffer win mime-echo-buffer-name)
 317           (select-window (get-buffer-window mime-preview-buffer))
 318           (setq win (split-window-vertically
 319                      (- (window-height)
 320                         (if (functionp mime-echo-window-height)
 321                             (funcall mime-echo-window-height)
 322                           mime-echo-window-height)
 323                         )))
 324           (set-window-buffer win mime-echo-buffer-name)
 325           ))
 326     (select-window win)
 327     (goto-char (point-max))
 328     (if forms
 329         (insert (apply (function format) forms))
 330       )
 331     (select-window the-win)
 332     ))
 333
 334
 335 ;;; @ file name
 336 ;;;
 337
 338 (defvar mime-view-file-name-char-regexp "[A-Za-z0-9+_-]")
 339
 340 (defvar mime-view-file-name-regexp-1
 341   (concat mime-view-file-name-char-regexp "+\\."
 342           mime-view-file-name-char-regexp "+"))
 343
 344 (defvar mime-view-file-name-regexp-2
 345   (concat (regexp-* mime-view-file-name-char-regexp)
 346           "\\(\\." mime-view-file-name-char-regexp "+\\)*"))
 347
 348 (defun mime-raw-get-original-filename (param)
 349   (or (if (member (cdr (assq 'encoding param))
 350                   mime-view-uuencode-encoding-name-list)
 351           (mime-raw-get-uu-filename))
 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 (entity cal)
 383   (let ((beg (mime-entity-point-min entity))
 384         (end (mime-entity-point-max entity)))
 385     (goto-char beg)
 386     (let* ((name (save-restriction
 387                    (narrow-to-region beg end)
 388                    (mime-raw-get-filename cal)
 389                    ))
 390            (encoding (or (cdr (assq 'encoding cal)) "7bit"))
 391            (filename (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 (entity cal)
 430   (let* ((beg (mime-entity-point-min entity))
 431          (end (mime-entity-point-max entity))
 432          (cnum (mime-raw-point-to-entity-number beg))
 433          (new-name (format "%s-%s" (buffer-name) cnum))
 434          (mother mime-preview-buffer)
 435          (representation-type
 436           (cdr (or (assq major-mode mime-raw-representation-type-alist)
 437                    (assq t mime-raw-representation-type-alist))))
 438          str)
 439     (setq str (buffer-substring beg end))
 440     (switch-to-buffer new-name)
 441     (erase-buffer)
 442     (insert str)
 443     (goto-char (point-min))
 444     (if (re-search-forward "^\n" nil t)
 445         (delete-region (point-min) (match-end 0))
 446       )
 447     (setq major-mode 'mime-show-message-mode)
 448     (setq mime-raw-representation-type representation-type)
 449     (mime-view-mode mother)
 450     ))
 451
 452
 453 ;;; @ message/partial
 454 ;;;
 455
 456 (defun mime-raw-write-region (start end filename)
 457   "Write current region into specified file.
 458 When called from a program, takes three arguments:
 459 START, END and FILENAME.  START and END are buffer positions.
 460 It refer `mime-raw-representation-type' or `major-mode
 461 mime-raw-representation-type-alist'.  If it is `binary', region is
 462 saved as binary.  Otherwise the region is saved by `write-region'."
 463   (let ((presentation-type
 464          (or mime-raw-representation-type
 465              (cdr (or (assq major-mode mime-raw-representation-type-alist)
 466                       (assq t mime-raw-representation-type-alist))))))
 467     (if (eq presentation-type 'binary)
 468         (write-region-as-binary start end filename)
 469       (write-region start end filename)
 470       )))
 471
 472 (defun mime-method-to-store-message/partial (entity cal)
 473   (goto-char (mime-entity-point-min entity))
 474   (let* ((root-dir
 475           (expand-file-name
 476            (concat "m-prts-" (user-login-name)) mime-temp-directory))
 477          (id (cdr (assoc "id" cal)))
 478          (number (cdr (assoc "number" cal)))
 479          (total (cdr (assoc "total" cal)))
 480          file
 481          (mother mime-preview-buffer)
 482          )
 483     (or (file-exists-p root-dir)
 484         (make-directory root-dir)
 485         )
 486     (setq id (replace-as-filename id))
 487     (setq root-dir (concat root-dir "/" id))
 488     (or (file-exists-p root-dir)
 489         (make-directory root-dir)
 490         )
 491     (setq file (concat root-dir "/FULL"))
 492     (if (file-exists-p file)
 493         (let ((full-buf (get-buffer-create "FULL"))
 494               (pwin (or (get-buffer-window mother)
 495                         (get-largest-window)))
 496               )
 497           (save-window-excursion
 498             (set-buffer full-buf)
 499             (erase-buffer)
 500             (as-binary-input-file (insert-file-contents file))
 501             (setq major-mode 'mime-show-message-mode)
 502             (mime-view-mode mother)
 503             )
 504           (set-window-buffer pwin
 505                              (save-excursion
 506                                (set-buffer full-buf)
 507                                mime-preview-buffer))
 508           (select-window pwin)
 509           )
 510       (re-search-forward "^$")
 511       (goto-char (1+ (match-end 0)))
 512       (setq file (concat root-dir "/" number))
 513       (mime-raw-write-region (point) (mime-entity-point-max entity) file)
 514       (let ((total-file (concat root-dir "/CT")))
 515         (setq total
 516               (if total
 517                   (progn
 518                     (or (file-exists-p total-file)
 519                         (save-excursion
 520                           (set-buffer
 521                            (get-buffer-create mime-temp-buffer-name))
 522                           (erase-buffer)
 523                           (insert total)
 524                           (write-region (point-min)(point-max) total-file)
 525                           (kill-buffer (current-buffer))
 526                           ))
 527                     (string-to-number total)
 528                     )
 529                 (and (file-exists-p total-file)
 530                      (save-excursion
 531                        (set-buffer (find-file-noselect total-file))
 532                        (prog1
 533                            (and (re-search-forward "[0-9]+" nil t)
 534                                 (string-to-number
 535                                  (buffer-substring (match-beginning 0)
 536                                                    (match-end 0)))
 537                                 )
 538                          (kill-buffer (current-buffer))
 539                          )))
 540                 )))
 541       (if (and total (> total 0))
 542           (catch 'tag
 543             (save-excursion
 544               (set-buffer (get-buffer-create mime-temp-buffer-name))
 545               (let ((full-buf (current-buffer)))
 546                 (erase-buffer)
 547                 (let ((i 1))
 548                   (while (<= i total)
 549                     (setq file (concat root-dir "/" (int-to-string i)))
 550                     (or (file-exists-p file)
 551                         (throw 'tag nil)
 552                         )
 553                     (as-binary-input-file (insert-file-contents file))
 554                     (goto-char (point-max))
 555                     (setq i (1+ i))
 556                     ))
 557                 (as-binary-output-file
 558                  (write-region (point-min)(point-max)
 559                                (expand-file-name "FULL" root-dir)))
 560                 (let ((i 1))
 561                   (while (<= i total)
 562                     (let ((file (format "%s/%d" root-dir i)))
 563                       (and (file-exists-p file)
 564                            (delete-file file)
 565                            ))
 566                     (setq i (1+ i))
 567                     ))
 568                 (let ((file (expand-file-name "CT" root-dir)))
 569                   (and (file-exists-p file)
 570                        (delete-file file)
 571                        ))
 572                 (save-window-excursion
 573                   (setq major-mode 'mime-show-message-mode)
 574                   (mime-view-mode mother)
 575                   )
 576                 (let ((pwin (or (get-buffer-window mother)
 577                                 (get-largest-window)
 578                                 ))
 579                       (pbuf (save-excursion
 580                               (set-buffer full-buf)
 581                               mime-preview-buffer)))
 582                   (set-window-buffer pwin pbuf)
 583                   (select-window pwin)
 584                   )))))
 585       )))
 586
 587
 588 ;;; @ message/external-body
 589 ;;;
 590
 591 (defvar mime-raw-dired-function
 592   (if (and (>= emacs-major-version 19) window-system)
 593       (function dired-other-frame)
 594     (function mime-raw-dired-function-for-one-frame)
 595     ))
 596
 597 (defun mime-raw-dired-function-for-one-frame (dir)
 598   (let ((win (or (get-buffer-window mime-preview-buffer)
 599                  (get-largest-window))))
 600     (select-window win)
 601     (dired dir)
 602     ))
 603
 604 (defun mime-method-to-display-message/external-ftp (entity cal)
 605   (let* ((site (cdr (assoc "site" cal)))
 606          (directory (cdr (assoc "directory" cal)))
 607          (name (cdr (assoc "name" cal)))
 608          (pathname (concat "/anonymous@" site ":" directory)))
 609     (message (concat "Accessing " (expand-file-name name pathname) "..."))
 610     (funcall mime-raw-dired-function pathname)
 611     (goto-char (point-min))
 612     (search-forward name)
 613     ))
 614
 615
 616 ;;; @ rot13-47
 617 ;;;
 618
 619 (defun mime-method-to-display-caesar (entity situation)
 620   "Internal method for mime-view to display ROT13-47-48 message."
 621   (let* ((new-name (format "%s-%s" (buffer-name)
 622                            (mime-entity-number entity)))
 623          (mother mime-preview-buffer))
 624     (let ((pwin (or (get-buffer-window mother)
 625                     (get-largest-window)))
 626           (buf (get-buffer-create new-name)))
 627       (set-window-buffer pwin buf)
 628       (set-buffer buf)
 629       (select-window pwin)
 630       )
 631     (setq buffer-read-only nil)
 632     (erase-buffer)
 633     (mime-text-insert-decoded-body entity)
 634     (mule-caesar-region (point-min) (point-max))
 635     (set-buffer-modified-p nil)
 636     (set-buffer mother)
 637     (view-buffer new-name)
 638     ))
 639
 640
 641 ;;; @ end
 642 ;;;
 643
 644 (provide 'mime-play)
 645
 646 (let* ((file mime-acting-situation-examples-file)
 647        (buffer (get-buffer-create " *mime-example*")))
 648   (if (file-readable-p file)
 649       (unwind-protect
 650           (save-excursion
 651             (set-buffer buffer)
 652             (erase-buffer)
 653             (insert-file-contents file)
 654             (eval-buffer)
 655             ;; format check
 656             (or (eq (car mime-acting-situation-examples) 'type)
 657                 (setq mime-acting-situation-examples nil))
 658             )
 659         (kill-buffer buffer))))
 660
 661 ;;; mime-play.el ends here