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