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