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