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