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