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