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