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