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