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