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