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