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