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