mime-view.el

   1 ;;; mime-view.el --- interactive MIME viewer for GNU Emacs
   2
   3 ;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; Created: 1994/7/13
   7 ;;      Renamed: 1994/8/31 from tm-body.el
   8 ;;      Renamed: 1997/02/19 from tm-view.el
   9 ;; Version: $Revision: 0.34 $
  10 ;; Keywords: MIME, multimedia, mail, news
  11
  12 ;; This file is part of SEMI (SEMI is Emacs MIME Interfaces).
  13
  14 ;; This program is free software; you can redistribute it and/or
  15 ;; modify it under the terms of the GNU General Public License as
  16 ;; published by the Free Software Foundation; either version 2, or (at
  17 ;; your option) any later version.
  18
  19 ;; This program is distributed in the hope that it will be useful, but
  20 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  22 ;; General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  26 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  27 ;; Boston, MA 02111-1307, USA.
  28
  29 ;;; Code:
  30
  31 (require 'cl)
  32 (require 'std11)
  33 (require 'mel)
  34 (require 'eword-decode)
  35 (require 'mime-parse)
  36 (require 'mime-text)
  37
  38
  39 ;;; @ version
  40 ;;;
  41
  42 (defconst mime-view-RCS-ID
  43   "$Id: mime-view.el,v 0.34 1997-03-17 11:57:29 morioka Exp $")
  44
  45 (defconst mime-view-version (get-version-string mime-view-RCS-ID))
  46
  47
  48 ;;; @ variables
  49 ;;;
  50
  51 (defvar mime/content-decoding-condition
  52   '(((type . "text/plain")
  53      (method "tm-plain" nil 'file 'type 'encoding 'mode 'name)
  54      (mode "play" "print")
  55      )
  56     ((type . "text/html")
  57      (method "tm-html" nil 'file 'type 'encoding 'mode 'name)
  58      (mode . "play")
  59      )
  60     ((type . "text/x-rot13-47")
  61      (method . mime-article/decode-caesar)
  62      (mode . "play")
  63      )
  64     ((type . "audio/basic")
  65      (method "tm-au"    nil 'file 'type 'encoding 'mode 'name)
  66      (mode . "play")
  67      )
  68
  69     ((type . "image/jpeg")
  70      (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
  71      (mode "play" "print")
  72      )
  73     ((type . "image/gif")
  74      (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
  75      (mode "play" "print")
  76      )
  77     ((type . "image/tiff")
  78      (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
  79      (mode "play" "print")
  80      )
  81     ((type . "image/x-tiff")
  82      (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
  83      (mode "play" "print")
  84      )
  85     ((type . "image/x-xbm")
  86      (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
  87      (mode "play" "print")
  88      )
  89     ((type . "image/x-pic")
  90      (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
  91      (mode "play" "print")
  92      )
  93     ((type . "image/x-mag")
  94      (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
  95      (mode "play" "print")
  96      )
  97
  98     ((type . "video/mpeg")
  99      (method "tm-mpeg"  nil 'file 'type 'encoding 'mode 'name)
 100      (mode . "play")
 101      )
 102
 103     ((type . "application/postscript")
 104      (method "tm-ps" nil 'file 'type 'encoding 'mode 'name)
 105      (mode "play" "print")
 106      )
 107     ((type . "application/octet-stream")
 108      (method "tm-file"  nil 'file 'type 'encoding 'mode 'name)
 109      (mode "play" "print")
 110      )
 111
 112     ;;((type . "message/external-body")
 113     ;; (method "xterm" nil
 114     ;;         "-e" "showexternal"
 115     ;;         'file '"access-type" '"name" '"site" '"directory"))
 116     ((type . "message/rfc822")
 117      (method . mime-article/view-message/rfc822)
 118      (mode . "play")
 119      )
 120     ((type . "message/partial")
 121      (method . mime-article/decode-message/partial)
 122      (mode . "play")
 123      )
 124     ((type . "message/external-body")
 125      ("access-type" . "anon-ftp")
 126      (method . mime-article/decode-message/external-ftp)
 127      )
 128
 129     ((method "metamail" t "-m" "tm" "-x" "-d" "-z" "-e" 'file)
 130      (mode . "play")
 131      )
 132     ((method "tm-file"  nil 'file 'type 'encoding 'mode 'name)
 133      (mode . "extract")
 134      )
 135     ))
 136
 137 (defvar mime-view-childrens-header-showing-Content-Type-list
 138   '("message/rfc822" "message/news"))
 139
 140 (defvar mime-view-visible-media-type-list
 141   '("text/plain" nil "text/richtext" "text/enriched"
 142     "text/rfc822-headers"
 143     "text/x-latex" "application/x-latex"
 144     "message/delivery-status"
 145     "application/pgp" "text/x-pgp"
 146     "application/octet-stream"
 147     "application/x-selection" "application/x-comment")
 148   "*List of media-types to be able to display in MIME-View buffer.
 149 Each elements are string of TYPE/SUBTYPE, e.g. \"text/plain\".")
 150
 151 (defvar mime-view-content-button-ignored-ctype-list
 152   '("application/x-selection"))
 153
 154 (defvar mime-view-content-button-visible-ctype-list
 155   '("application/pgp"))
 156
 157 (defvar mime-view-uuencode-encoding-name-list '("x-uue" "x-uuencode"))
 158
 159 (defvar mime-view-ignored-field-list
 160   '(".*Received" ".*Path" ".*Id" "References"
 161     "Replied" "Errors-To"
 162     "Lines" "Sender" ".*Host" "Xref"
 163     "Content-Type" "Precedence"
 164     "Status" "X-VM-.*")
 165   "All fields that match this list will be hidden in MIME preview buffer.
 166 Each elements are regexp of field-name. [mime-view.el]")
 167
 168 (defvar mime-view-ignored-field-regexp
 169   (concat "^"
 170           (apply (function regexp-or) mime-view-ignored-field-list)
 171           ":"))
 172
 173 (defvar mime-view-visible-field-list
 174   '("Dnas.*" "Message-Id")
 175   "All fields that match this list will be displayed in MIME preview buffer.
 176 Each elements are regexp of field-name. [mime-view.el]")
 177
 178 (defvar mime-view-visible-field-regexp
 179   (concat "^"
 180           (apply (function regexp-or) mime-view-visible-field-list)
 181           ":"))
 182
 183 (defvar mime-view-redisplay nil)
 184
 185 (defvar mime-view-announcement-for-message/partial
 186   (if (and (>= emacs-major-version 19) window-system)
 187       "\
 188 \[[ This is message/partial style split message. ]]
 189 \[[ Please press `v' key in this buffer          ]]
 190 \[[ or click here by mouse button-2.             ]]"
 191     "\
 192 \[[ This is message/partial style split message. ]]
 193 \[[ Please press `v' key in this buffer.         ]]"
 194     ))
 195
 196
 197 ;;; @@ predicate functions
 198 ;;;
 199
 200 (defun mime-view-header-visible-p (rcnum cinfo &optional ctype)
 201   (or (null rcnum)
 202       (progn
 203         (setq ctype
 204               (mime::content-info/type
 205                (mime-article/rcnum-to-cinfo (cdr rcnum) cinfo)
 206                ))
 207         (member ctype mime-view-childrens-header-showing-Content-Type-list)
 208         )))
 209
 210 (defun mime-view-body-visible-p (rcnum cinfo &optional ctype)
 211   (let (ccinfo)
 212     (or ctype
 213         (setq ctype
 214               (mime::content-info/type
 215                (setq ccinfo (mime-article/rcnum-to-cinfo rcnum cinfo))
 216                ))
 217         )
 218     (and (member ctype mime-view-visible-media-type-list)
 219          (if (string-equal ctype "application/octet-stream")
 220              (progn
 221                (or ccinfo
 222                    (setq ccinfo (mime-article/rcnum-to-cinfo rcnum cinfo))
 223                    )
 224                (member (mime::content-info/encoding ccinfo)
 225                        '(nil "7bit" "8bit"))
 226                )
 227            t))
 228     ))
 229
 230
 231 ;;; @@ content button
 232 ;;;
 233
 234 (defun mime-preview/insert-content-button
 235   (rcnum cinfo ctype params subj encoding)
 236   (save-restriction
 237     (narrow-to-region (point)(point))
 238     (let ((access-type (assoc "access-type" params))
 239           (charset (assoc "charset" params))
 240           (num (or (cdr (assoc "x-part-number" params))
 241                    (if (consp rcnum)
 242                        (mapconcat (function
 243                                    (lambda (num)
 244                                      (format "%s" (1+ num))
 245                                      ))
 246                                   (reverse rcnum) ".")
 247                      "0"))
 248                ))
 249       (cond (access-type
 250              (let ((server (assoc "server" params)))
 251                (setq access-type (cdr access-type))
 252                (if server
 253                    (insert (format "[%s %s ([%s] %s)]\n" num subj
 254                                    access-type (cdr server)))
 255                  (let ((site (cdr (assoc "site" params)))
 256                        (dir (cdr (assoc "directory" params)))
 257                        )
 258                    (insert (format "[%s %s ([%s] %s:%s)]\n" num subj
 259                                    access-type site dir))
 260                    )))
 261              )
 262             (t
 263              (insert (concat "[" num " " subj))
 264              (let ((rest
 265                     (if (setq charset (cdr charset))
 266                         (if encoding
 267                             (format " <%s; %s (%s)>]\n"
 268                                     ctype charset encoding)
 269                           (format " <%s; %s>]\n" ctype charset)
 270                           )
 271                       (format " <%s>]\n" ctype)
 272                       )))
 273                (if (>= (+ (current-column)(length rest))(window-width))
 274                    (setq rest (concat "\n\t" rest))
 275                  )
 276                (insert rest)
 277                ))))
 278     (mime-add-button (point-min)(1- (point-max))
 279                      (function mime-play-entity))
 280     ))
 281
 282 (defun mime-preview/default-content-button-function
 283   (rcnum cinfo ctype params subj encoding)
 284   (if (and (consp rcnum)
 285            (not (member
 286                  ctype
 287                  mime-view-content-button-ignored-ctype-list)))
 288       (mime-preview/insert-content-button
 289        rcnum cinfo ctype params subj encoding)
 290     ))
 291
 292 (defvar mime-preview/content-button-function
 293   (function mime-preview/default-content-button-function))
 294
 295
 296 ;;; @@ content header filter
 297 ;;;
 298
 299 (defun mime-preview/cut-header ()
 300   (goto-char (point-min))
 301   (while (and
 302           (re-search-forward mime-view-ignored-field-regexp nil t)
 303           (let* ((beg (match-beginning 0))
 304                  (end (match-end 0))
 305                  (name (buffer-substring beg end))
 306                  )
 307             (if (not (string-match mime-view-visible-field-regexp name))
 308                 (delete-region
 309                  beg
 310                  (save-excursion
 311                    (and
 312                     (re-search-forward "^\\([^ \t]\\|$\\)" nil t)
 313                     (match-beginning 0)
 314                     )))
 315               )
 316             t)))
 317   )
 318
 319 (defun mime-view-default-content-header-filter ()
 320   (mime-preview/cut-header)
 321   (eword-decode-header)
 322   )
 323
 324 (defvar mime-view-content-header-filter-alist nil)
 325
 326
 327 ;;; @@ content filter
 328 ;;;
 329
 330 (defvar mime-view-content-filter-alist
 331   '(("text/enriched" . mime-preview/filter-for-text/enriched)
 332     ("text/richtext" . mime-preview/filter-for-text/richtext)
 333     (t . mime-preview/filter-for-text/plain)
 334     ))
 335
 336
 337 ;;; @@ content separator
 338 ;;;
 339
 340 (defun mime-preview/default-content-separator (rcnum cinfo ctype params subj)
 341   (if (and (not (mime-view-header-visible-p rcnum cinfo ctype))
 342            (not (mime-view-body-visible-p rcnum cinfo ctype))
 343            )
 344       (progn
 345         (goto-char (point-max))
 346         (insert "\n")
 347         )))
 348
 349
 350 ;;; @@ buffer local variables
 351 ;;;
 352
 353 ;;; @@@ in raw buffer
 354 ;;;
 355
 356 (make-variable-buffer-local 'mime::article/content-info)
 357
 358 (defvar mime::article/preview-buffer nil)
 359 (make-variable-buffer-local 'mime::article/preview-buffer)
 360
 361
 362 ;;; @@@ in view buffer
 363 ;;;
 364
 365 (make-variable-buffer-local 'mime::preview/mother-buffer)
 366 (make-variable-buffer-local 'mime::preview/content-list)
 367
 368 (defvar mime::preview/article-buffer nil)
 369 (make-variable-buffer-local 'mime::preview/article-buffer)
 370
 371 (make-variable-buffer-local 'mime::preview/original-major-mode)
 372 (make-variable-buffer-local 'mime::preview/original-window-configuration)
 373
 374
 375 ;;; @@ quitting method
 376 ;;;
 377
 378 (defvar mime-view-quitting-method-alist
 379   '((mime/show-message-mode
 380      . mime-view-quitting-method-for-mime/show-message-mode)))
 381
 382 (defvar mime-view-over-to-previous-method-alist nil)
 383 (defvar mime-view-over-to-next-method-alist nil)
 384
 385 (defvar mime-view-show-summary-method nil)
 386
 387
 388 ;;; @@ following method
 389 ;;;
 390
 391 (defvar mime-view-following-method-alist nil)
 392
 393 (defvar mime-view-following-required-fields-list
 394   '("From"))
 395
 396
 397 ;;; @@ X-Face
 398 ;;;
 399
 400 ;; hack from Gnus 5.0.4.
 401
 402 (defvar mime-view-x-face-to-pbm-command
 403   "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm")
 404
 405 (defvar mime-view-x-face-command
 406   (concat mime-view-x-face-to-pbm-command
 407           " | xv -quit -")
 408   "String to be executed to display an X-Face field.
 409 The command will be executed in a sub-shell asynchronously.
 410 The compressed face will be piped to this command.")
 411
 412 (defun mime-view-x-face-function ()
 413   "Function to display X-Face field. You can redefine to customize."
 414   ;; 1995/10/12 (c.f. tm-eng:130)
 415   ;;    fixed by Eric Ding <ericding@San-Jose.ate.slb.com>
 416   (save-restriction
 417     (narrow-to-region (point-min) (re-search-forward "^$" nil t))
 418     ;; end
 419     (goto-char (point-min))
 420     (if (re-search-forward "^X-Face:[ \t]*" nil t)
 421         (let ((beg (match-end 0))
 422               (end (std11-field-end))
 423               )
 424           (call-process-region beg end "sh" nil 0 nil
 425                                "-c" mime-view-x-face-command)
 426           ))))
 427
 428
 429 ;;; @@ utility
 430 ;;;
 431
 432 (defun mime-preview/get-original-major-mode ()
 433   (if mime::preview/mother-buffer
 434       (save-excursion
 435         (set-buffer mime::preview/mother-buffer)
 436         (mime-preview/get-original-major-mode)
 437         )
 438     mime::preview/original-major-mode))
 439
 440
 441 ;;; @ data structures
 442 ;;;
 443
 444 ;;; @@ preview-content-info
 445 ;;;
 446
 447 (define-structure mime::preview-content-info
 448   point-min point-max buffer content-info)
 449
 450
 451 ;;; @ buffer setup
 452 ;;;
 453
 454 (defun mime-view-setup-buffer (&optional ctl encoding ibuf obuf)
 455   (if ibuf
 456       (progn
 457         (get-buffer ibuf)
 458         (set-buffer ibuf)
 459         ))
 460   (or mime-view-redisplay
 461       (setq mime::article/content-info (mime-parse-message ctl encoding))
 462       )
 463   (let ((ret (mime-view-make-preview-buffer obuf)))
 464     (setq mime::article/preview-buffer (car ret))
 465     ret))
 466
 467 (defun mime-view-make-preview-buffer (&optional obuf)
 468   (let* ((cinfo mime::article/content-info)
 469          (pcl (mime/flatten-content-info cinfo))
 470          (dest (make-list (length pcl) nil))
 471          (the-buf (current-buffer))
 472          (mode major-mode)
 473          )
 474     (or obuf
 475         (setq obuf (concat "*Preview-" (buffer-name the-buf) "*")))
 476     (set-buffer (get-buffer-create obuf))
 477     (setq buffer-read-only nil)
 478     (widen)
 479     (erase-buffer)
 480     (setq mime::preview/article-buffer the-buf)
 481     (setq mime::preview/original-major-mode mode)
 482     (setq major-mode 'mime-view-mode)
 483     (setq mode-name "MIME-View")
 484     (let ((drest dest))
 485       (while pcl
 486         (setcar drest
 487                 (mime-preview/display-content (car pcl) cinfo the-buf obuf))
 488         (setq pcl (cdr pcl)
 489               drest (cdr drest))
 490         ))
 491     (set-buffer-modified-p nil)
 492     (setq buffer-read-only t)
 493     (set-buffer the-buf)
 494     (list obuf dest)
 495     ))
 496
 497 (defun mime-preview/display-content (content cinfo ibuf obuf)
 498   (let* ((beg (mime::content-info/point-min content))
 499          (end (mime::content-info/point-max content))
 500          (ctype (mime::content-info/type content))
 501          (params (mime::content-info/parameters content))
 502          (encoding (mime::content-info/encoding content))
 503          (rcnum (mime::content-info/rcnum content))
 504          he e nb ne subj)
 505     (set-buffer ibuf)
 506     (goto-char beg)
 507     (setq he (if (re-search-forward "^$" nil t)
 508                  (1+ (match-end 0))
 509                end))
 510     (if (> he end)
 511         (setq he end)
 512       )
 513     (save-restriction
 514       (narrow-to-region beg end)
 515       (setq subj
 516             (eword-decode-string
 517              (mime-article/get-subject params encoding)))
 518       )
 519     (set-buffer obuf)
 520     (setq nb (point))
 521     (narrow-to-region nb nb)
 522     (funcall mime-preview/content-button-function
 523              rcnum cinfo ctype params subj encoding)
 524     (if (mime-view-header-visible-p rcnum cinfo ctype)
 525         (mime-preview/display-header beg he)
 526       )
 527     (if (and (null rcnum)
 528              (member
 529               ctype mime-view-content-button-visible-ctype-list))
 530         (save-excursion
 531           (goto-char (point-max))
 532           (mime-preview/insert-content-button
 533            rcnum cinfo ctype params subj encoding)
 534           ))
 535     (cond ((mime-view-body-visible-p rcnum cinfo ctype)
 536            (mime-preview/display-body he end
 537                                       rcnum cinfo ctype params subj encoding)
 538            )
 539           ((equal ctype "message/partial")
 540            (mime-preview/display-message/partial)
 541            )
 542           ((and (null rcnum)
 543                 (null (mime::content-info/children cinfo))
 544                 )
 545            (goto-char (point-max))
 546            (mime-preview/insert-content-button
 547             rcnum cinfo ctype params subj encoding)
 548            ))
 549     (mime-preview/default-content-separator rcnum cinfo ctype params subj)
 550     (prog1
 551         (progn
 552           (setq ne (point-max))
 553           (widen)
 554           (mime::preview-content-info/create nb (1- ne) ibuf content)
 555           )
 556       (goto-char ne)
 557       )))
 558
 559 (defun mime-preview/display-header (beg end)
 560   (save-restriction
 561     (narrow-to-region (point)(point))
 562     (insert-buffer-substring mime::preview/article-buffer beg end)
 563     (let ((f (cdr (assq mime::preview/original-major-mode
 564                         mime-view-content-header-filter-alist))))
 565       (if (functionp f)
 566           (funcall f)
 567         (mime-view-default-content-header-filter)
 568         ))
 569     (run-hooks 'mime-view-content-header-filter-hook)
 570     ))
 571
 572 (defun mime-preview/display-body (beg end
 573                                       rcnum cinfo ctype params subj encoding)
 574   (save-restriction
 575     (narrow-to-region (point-max)(point-max))
 576     (insert-buffer-substring mime::preview/article-buffer beg end)
 577     (let ((f (cdr (or (assoc ctype mime-view-content-filter-alist)
 578                       (assq t mime-view-content-filter-alist)))))
 579       (and (functionp f)
 580            (funcall f ctype params encoding)
 581            )
 582       )))
 583
 584 (defun mime-preview/display-message/partial ()
 585   (save-restriction
 586     (goto-char (point-max))
 587     (if (not (search-backward "\n\n" nil t))
 588         (insert "\n")
 589       )
 590     (let ((be (point-max)))
 591       (narrow-to-region be be)
 592       (insert mime-view-announcement-for-message/partial)
 593       (mime-add-button (point-min)(point-max)
 594                        (function mime-play-entity))
 595       )))
 596
 597 (defun mime-article/get-uu-filename (param &optional encoding)
 598   (if (member (or encoding
 599                   (cdr (assq 'encoding param))
 600                   )
 601               mime-view-uuencode-encoding-name-list)
 602       (save-excursion
 603         (or (if (re-search-forward "^begin [0-9]+ " nil t)
 604                 (if (looking-at ".+$")
 605                     (buffer-substring (match-beginning 0)(match-end 0))
 606                   ))
 607             ""))
 608     ))
 609
 610 (defun mime-article/get-subject (param &optional encoding)
 611   (or (std11-find-field-body '("Content-Description" "Subject"))
 612       (let (ret)
 613         (if (or (and (setq ret (mime/Content-Disposition))
 614                      (setq ret (assoc "filename" (cdr ret)))
 615                      )
 616                 (setq ret (assoc "name" param))
 617                 (setq ret (assoc "x-name" param))
 618                 )
 619             (std11-strip-quoted-string (cdr ret))
 620           ))
 621       (mime-article/get-uu-filename param encoding)
 622       ""))
 623
 624
 625 ;;; @ content information
 626 ;;;
 627
 628 (defun mime-article/point-content-number (p &optional cinfo)
 629   (or cinfo
 630       (setq cinfo mime::article/content-info)
 631       )
 632   (let ((b (mime::content-info/point-min cinfo))
 633         (e (mime::content-info/point-max cinfo))
 634         (c (mime::content-info/children cinfo))
 635         )
 636     (if (and (<= b p)(<= p e))
 637         (or (let (co ret (sn 0))
 638               (catch 'tag
 639                 (while c
 640                   (setq co (car c))
 641                   (setq ret (mime-article/point-content-number p co))
 642                   (cond ((eq ret t) (throw 'tag (list sn)))
 643                         (ret (throw 'tag (cons sn ret)))
 644                         )
 645                   (setq c (cdr c))
 646                   (setq sn (1+ sn))
 647                   )))
 648             t))))
 649
 650 (defun mime-article/rcnum-to-cinfo (rcnum &optional cinfo)
 651   (or cinfo
 652       (setq cinfo mime::article/content-info)
 653       )
 654   (find-if (function
 655             (lambda (ci)
 656               (equal (mime::content-info/rcnum ci) rcnum)
 657               ))
 658            (mime/flatten-content-info cinfo)
 659            ))
 660
 661 (defun mime-article/cnum-to-cinfo (cn &optional cinfo)
 662   (or cinfo
 663       (setq cinfo mime::article/content-info)
 664       )
 665   (if (eq cn t)
 666       cinfo
 667     (let ((sn (car cn)))
 668       (if (null sn)
 669           cinfo
 670         (let ((rc (nth sn (mime::content-info/children cinfo))))
 671           (if rc
 672               (mime-article/cnum-to-cinfo (cdr cn) rc)
 673             ))
 674         ))))
 675
 676 (defun mime/flatten-content-info (&optional cinfo)
 677   (or cinfo
 678       (setq cinfo mime::article/content-info)
 679       )
 680   (let ((dest (list cinfo))
 681         (rcl (mime::content-info/children cinfo))
 682         )
 683     (while rcl
 684       (setq dest (nconc dest (mime/flatten-content-info (car rcl))))
 685       (setq rcl (cdr rcl))
 686       )
 687     dest))
 688
 689 (defun mime-preview/point-pcinfo (p &optional pcl)
 690   (or pcl
 691       (setq pcl mime::preview/content-list)
 692       )
 693   (catch 'tag
 694     (let ((r pcl) cell)
 695       (while r
 696         (setq cell (car r))
 697         (if (and (<= (mime::preview-content-info/point-min cell) p)
 698                  (<= p (mime::preview-content-info/point-max cell))
 699                  )
 700             (throw 'tag cell)
 701           )
 702         (setq r (cdr r))
 703         ))
 704     (car (last pcl))
 705     ))
 706
 707
 708 ;;; @ MIME viewer mode
 709 ;;;
 710
 711 (defconst mime-view-menu-title "MIME-View")
 712 (defconst mime-view-menu-list
 713   '((up          "Move to upper content"      mime-view-up-content)
 714     (previous    "Move to previous content"   mime-view-previous-content)
 715     (next        "Move to next content"       mime-view-next-content)
 716     (scroll-down "Scroll to previous content" mime-view-scroll-down-content)
 717     (scroll-up   "Scroll to next content"     mime-view-scroll-up-content)
 718     (play        "Play Content"               mime-play-entity)
 719     (extract     "Extract Content"            mime-extract-entity)
 720     (print       "Print"                      mime-print-entity)
 721     (x-face      "Show X Face"                mime-view-display-x-face)
 722     )
 723   "Menu for MIME Viewer")
 724
 725 (cond (running-xemacs
 726        (defvar mime-view-xemacs-popup-menu
 727          (cons mime-view-menu-title
 728                (mapcar (function
 729                         (lambda (item)
 730                           (vector (nth 1 item)(nth 2 item) t)
 731                           ))
 732                        mime-view-menu-list)))
 733        (defun mime-view-xemacs-popup-menu (event)
 734          "Popup the menu in the MIME Viewer buffer"
 735          (interactive "e")
 736          (select-window (event-window event))
 737          (set-buffer (event-buffer event))
 738          (popup-menu 'mime-view-xemacs-popup-menu))
 739        (defvar mouse-button-2 'button2)
 740        )
 741       (t
 742        (defvar mouse-button-2 [mouse-2])
 743        ))
 744
 745 (defun mime-view-define-keymap (&optional default)
 746   (let ((mime-view-mode-map (if (keymapp default)
 747                                 (copy-keymap default)
 748                               (make-sparse-keymap)
 749                               )))
 750     (define-key mime-view-mode-map
 751       "u"        (function mime-view-up-content))
 752     (define-key mime-view-mode-map
 753       "p"        (function mime-view-previous-content))
 754     (define-key mime-view-mode-map
 755       "n"        (function mime-view-next-content))
 756     (define-key mime-view-mode-map
 757       "\e\t"     (function mime-view-previous-content))
 758     (define-key mime-view-mode-map
 759       "\t"       (function mime-view-next-content))
 760     (define-key mime-view-mode-map
 761       " "        (function mime-view-scroll-up-content))
 762     (define-key mime-view-mode-map
 763       "\M- "     (function mime-view-scroll-down-content))
 764     (define-key mime-view-mode-map
 765       "\177"     (function mime-view-scroll-down-content))
 766     (define-key mime-view-mode-map
 767       "\C-m"     (function mime-view-next-line-content))
 768     (define-key mime-view-mode-map
 769       "\C-\M-m"  (function mime-view-previous-line-content))
 770     (define-key mime-view-mode-map
 771       "v"        (function mime-play-entity))
 772     (define-key mime-view-mode-map
 773       "e"        (function mime-extract-entity))
 774     (define-key mime-view-mode-map
 775       "\C-c\C-p" (function mime-print-entity))
 776     (define-key mime-view-mode-map
 777       "a"        (function mime-view-follow-content))
 778     (define-key mime-view-mode-map
 779       "q"        (function mime-view-quit))
 780     (define-key mime-view-mode-map
 781       "h"        (function mime-view-show-summary))
 782     (define-key mime-view-mode-map
 783       "\C-c\C-x" (function mime-view-kill-buffer))
 784     (define-key mime-view-mode-map
 785       "<"        (function beginning-of-buffer))
 786     (define-key mime-view-mode-map
 787       ">"        (function end-of-buffer))
 788     (define-key mime-view-mode-map
 789       "?"        (function describe-mode))
 790     (if (functionp default)
 791         (setq mime-view-mode-map
 792               (append mime-view-mode-map (list (cons t default)))
 793               ))
 794     (if mouse-button-2
 795         (define-key mime-view-mode-map
 796           mouse-button-2 (function mime-button-dispatcher))
 797       )
 798     (cond (running-xemacs
 799            (define-key mime-view-mode-map
 800              mouse-button-3 (function mime-view-xemacs-popup-menu))
 801            )
 802           ((>= emacs-major-version 19)
 803            (define-key mime-view-mode-map [menu-bar mime-view]
 804              (cons mime-view-menu-title
 805                    (make-sparse-keymap mime-view-menu-title)))
 806            (mapcar (function
 807                     (lambda (item)
 808                       (define-key mime-view-mode-map
 809                         (vector 'menu-bar 'mime-view (car item))
 810                         (cons (nth 1 item)(nth 2 item))
 811                         )
 812                       ))
 813                    (reverse mime-view-menu-list)
 814                    )
 815            ))
 816     (use-local-map mime-view-mode-map)
 817     (run-hooks 'mime-view-define-keymap-hook)
 818     ))
 819
 820 (defun mime-view-mode (&optional mother ctl encoding ibuf obuf
 821                                  default-keymap-or-function)
 822   "Major mode for viewing MIME message.
 823
 824 Here is a list of the standard keys for mime-view-mode.
 825
 826 key             feature
 827 ---             -------
 828
 829 u               Move to upper content
 830 p or M-TAB      Move to previous content
 831 n or TAB        Move to next content
 832 SPC             Scroll up or move to next content
 833 M-SPC or DEL    Scroll down or move to previous content
 834 RET             Move to next line
 835 M-RET           Move to previous line
 836 v               Decode current content as `play mode'
 837 e               Decode current content as `extract mode'
 838 C-c C-p         Decode current content as `print mode'
 839 a               Followup to current content.
 840 x               Display X-Face
 841 q               Quit
 842 button-2        Move to point under the mouse cursor
 843                 and decode current content as `play mode'
 844 "
 845   (interactive)
 846   (let ((buf (get-buffer mime/output-buffer-name)))
 847     (if buf
 848         (save-excursion
 849           (set-buffer buf)
 850           (erase-buffer)
 851           )))
 852   (let ((ret (mime-view-setup-buffer ctl encoding ibuf obuf))
 853         (win-conf (current-window-configuration))
 854         )
 855     (prog1
 856         (switch-to-buffer (car ret))
 857       (setq mime::preview/original-window-configuration win-conf)
 858       (if mother
 859           (progn
 860             (setq mime::preview/mother-buffer mother)
 861             ))
 862       (mime-view-define-keymap default-keymap-or-function)
 863       (setq mime::preview/content-list (nth 1 ret))
 864       (goto-char
 865        (let ((ce (mime::preview-content-info/point-max
 866                   (car mime::preview/content-list)
 867                   ))
 868              e)
 869          (goto-char (point-min))
 870          (search-forward "\n\n" nil t)
 871          (setq e (match-end 0))
 872          (if (<= e ce)
 873              e
 874            ce)))
 875       (run-hooks 'mime-view-mode-hook)
 876       )))
 877
 878 (defun mime-preview/point-content-number (point)
 879   (save-window-excursion
 880     (let ((pc (mime-preview/point-pcinfo (point)))
 881           cinfo)
 882       (switch-to-buffer (mime::preview-content-info/buffer pc))
 883       (setq cinfo (mime::preview-content-info/content-info pc))
 884       (mime-article/point-content-number (mime::content-info/point-min cinfo))
 885       )))
 886
 887 (defun mime-preview/cinfo-to-pcinfo (cinfo)
 888   (let ((rpcl mime::preview/content-list) cell)
 889     (catch 'tag
 890       (while rpcl
 891         (setq cell (car rpcl))
 892         (if (eq cinfo (mime::preview-content-info/content-info cell))
 893             (throw 'tag cell)
 894           )
 895         (setq rpcl (cdr rpcl))
 896         ))))
 897
 898 (autoload 'mime-play-entity "mime-play" "Play current entity." t)
 899
 900 (defun mime-extract-entity ()
 901   "Extract current entity into file (maybe).
 902 It decodes current entity to call internal or external method as
 903 \"extract\" mode.  The method is selected from variable
 904 `mime/content-decoding-condition'."
 905   (interactive)
 906   (mime-play-entity "extract")
 907   )
 908
 909 (defun mime-print-entity ()
 910   "Print current entity (maybe).
 911 It decodes current entity to call internal or external method as
 912 \"print\" mode.  The method is selected from variable
 913 `mime/content-decoding-condition'."
 914   (interactive)
 915   (mime-play-entity "print")
 916   )
 917
 918 (defun mime-view-follow-content ()
 919   (interactive)
 920   (let ((root-cinfo
 921          (mime::preview-content-info/content-info
 922           (car mime::preview/content-list)))
 923         pc p-beg p-end cinfo rcnum)
 924     (let ((rest mime::preview/content-list)
 925           b e cell len rc)
 926       (if (catch 'tag
 927             (while (setq cell (car rest))
 928               (setq b (mime::preview-content-info/point-min cell)
 929                     e (mime::preview-content-info/point-max cell))
 930               (setq rest (cdr rest))
 931               (if (and (<= b (point))(<= (point) e))
 932                   (throw 'tag cell)
 933                 )
 934               ))
 935           (progn
 936             (setq pc cell
 937                   cinfo (mime::preview-content-info/content-info pc)
 938                   rcnum (mime::content-info/rcnum cinfo))
 939             (setq len (length rcnum))
 940             (setq p-beg (mime::preview-content-info/point-min pc)
 941                   p-end (mime::preview-content-info/point-max pc))
 942             (while (and (setq cell (car rest))
 943                         (progn
 944                           (setq rc
 945                                 (mime::content-info/rcnum
 946                                  (mime::preview-content-info/content-info
 947                                   cell)))
 948                           (equal rcnum
 949                                  (nthcdr (- (length rc) len) rc))
 950                           ))
 951               (setq p-end (mime::preview-content-info/point-max cell))
 952               (setq rest (cdr rest))
 953               ))))
 954     (if pc
 955         (let* ((mode (mime-preview/get-original-major-mode))
 956                (new-name (format "%s-%s" (buffer-name) (reverse rcnum)))
 957                new-buf
 958                (the-buf (current-buffer))
 959                (a-buf mime::preview/article-buffer)
 960                fields)
 961           (save-excursion
 962             (set-buffer (setq new-buf (get-buffer-create new-name)))
 963             (erase-buffer)
 964             (insert-buffer-substring the-buf p-beg p-end)
 965             (goto-char (point-min))
 966             (if (mime-view-header-visible-p rcnum root-cinfo)
 967                 (delete-region (goto-char (point-min))
 968                                (if (re-search-forward "^$" nil t)
 969                                    (match-end 0)
 970                                  (point-min)))
 971               )
 972             (goto-char (point-min))
 973             (insert "\n")
 974             (goto-char (point-min))
 975             (let ((rcnum (mime::content-info/rcnum cinfo)) ci str)
 976               (while (progn
 977                        (setq str
 978                              (save-excursion
 979                                (set-buffer a-buf)
 980                                (setq ci (mime-article/rcnum-to-cinfo rcnum))
 981                                (save-restriction
 982                                  (narrow-to-region
 983                                   (mime::content-info/point-min ci)
 984                                   (mime::content-info/point-max ci)
 985                                   )
 986                                  (std11-header-string-except
 987                                   (concat "^"
 988                                           (apply (function regexp-or) fields)
 989                                           ":") ""))))
 990                        (if (string= (mime::content-info/type ci)
 991                                     "message/rfc822")
 992                            nil
 993                          (if str
 994                              (insert str)
 995                            )
 996                          rcnum))
 997                 (setq fields (std11-collect-field-names)
 998                       rcnum (cdr rcnum))
 999                 )
1000               )
1001             (let ((rest mime-view-following-required-fields-list))
1002               (while rest
1003                 (let ((field-name (car rest)))
1004                   (or (std11-field-body field-name)
1005                       (insert
1006                        (format
1007                         (concat field-name
1008                                 ": "
1009                                 (save-excursion
1010                                   (set-buffer the-buf)
1011                                   (set-buffer mime::preview/mother-buffer)
1012                                   (set-buffer mime::preview/article-buffer)
1013                                   (std11-field-body field-name)
1014                                   )
1015                                 "\n")))
1016                       ))
1017                 (setq rest (cdr rest))
1018                 ))
1019             (eword-decode-header)
1020             )
1021           (let ((f (cdr (assq mode mime-view-following-method-alist))))
1022             (if (functionp f)
1023                 (funcall f new-buf)
1024               (message
1025                (format
1026                 "Sorry, following method for %s is not implemented yet."
1027                 mode))
1028               ))
1029           ))))
1030
1031 (defun mime-view-display-x-face ()
1032   (interactive)
1033   (save-window-excursion
1034     (set-buffer mime::preview/article-buffer)
1035     (mime-view-x-face-function)
1036     ))
1037
1038 (defun mime-view-up-content ()
1039   (interactive)
1040   (let* ((pc (mime-preview/point-pcinfo (point)))
1041          (cinfo (mime::preview-content-info/content-info pc))
1042          (rcnum (mime::content-info/rcnum cinfo))
1043          )
1044     (if rcnum
1045         (let ((r (save-excursion
1046                    (set-buffer (mime::preview-content-info/buffer pc))
1047                    (mime-article/rcnum-to-cinfo (cdr rcnum))
1048                    ))
1049               (rpcl mime::preview/content-list)
1050               cell)
1051           (while (and
1052                   (setq cell (car rpcl))
1053                   (not (eq r (mime::preview-content-info/content-info cell)))
1054                   )
1055             (setq rpcl (cdr rpcl))
1056             )
1057           (goto-char (mime::preview-content-info/point-min cell))
1058           )
1059       (mime-view-quit)
1060       )))
1061
1062 (defun mime-view-previous-content ()
1063   (interactive)
1064   (let* ((pcl mime::preview/content-list)
1065          (p (point))
1066          (i (- (length pcl) 1))
1067          beg)
1068     (catch 'tag
1069       (while (> i 0)
1070         (setq beg (mime::preview-content-info/point-min (nth i pcl)))
1071         (if (> p beg)
1072             (throw 'tag (goto-char beg))
1073           )
1074         (setq i (- i 1))
1075         )
1076       (let ((f (assq mime::preview/original-major-mode
1077                      mime-view-over-to-previous-method-alist)))
1078         (if f
1079             (funcall (cdr f))
1080           ))
1081       )
1082     ))
1083
1084 (defun mime-view-next-content ()
1085   (interactive)
1086   (let ((pcl mime::preview/content-list)
1087         (p (point))
1088         beg)
1089     (catch 'tag
1090       (while pcl
1091         (setq beg (mime::preview-content-info/point-min (car pcl)))
1092         (if (< p beg)
1093             (throw 'tag (goto-char beg))
1094           )
1095         (setq pcl (cdr pcl))
1096         )
1097       (let ((f (assq mime::preview/original-major-mode
1098                      mime-view-over-to-next-method-alist)))
1099         (if f
1100             (funcall (cdr f))
1101           ))
1102       )
1103     ))
1104
1105 (defun mime-view-scroll-up-content (&optional h)
1106   (interactive)
1107   (or h
1108       (setq h (- (window-height) 1))
1109       )
1110   (if (= (point) (point-max))
1111       (let ((f (assq mime::preview/original-major-mode
1112                      mime-view-over-to-next-method-alist)))
1113         (if f
1114             (funcall (cdr f))
1115           ))
1116     (let ((pcl mime::preview/content-list)
1117           (p (point))
1118           np beg)
1119       (setq np
1120             (or (catch 'tag
1121                   (while pcl
1122                     (setq beg (mime::preview-content-info/point-min (car pcl)))
1123                     (if (< p beg)
1124                         (throw 'tag beg)
1125                       )
1126                     (setq pcl (cdr pcl))
1127                     ))
1128                 (point-max)))
1129       (forward-line h)
1130       (if (> (point) np)
1131           (goto-char np)
1132         )
1133       ;;(show-subtree)
1134       ))
1135   )
1136
1137 (defun mime-view-scroll-down-content (&optional h)
1138   (interactive)
1139   (or h
1140       (setq h (- (window-height) 1))
1141       )
1142   (if (= (point) (point-min))
1143       (let ((f (assq mime::preview/original-major-mode
1144                      mime-view-over-to-previous-method-alist)))
1145         (if f
1146             (funcall (cdr f))
1147           ))
1148     (let ((pcl mime::preview/content-list)
1149           (p (point))
1150           pp beg)
1151       (setq pp
1152             (or (let ((i (- (length pcl) 1)))
1153                   (catch 'tag
1154                     (while (> i 0)
1155                       (setq beg (mime::preview-content-info/point-min
1156                                  (nth i pcl)))
1157                       (if (> p beg)
1158                           (throw 'tag beg)
1159                         )
1160                       (setq i (- i 1))
1161                       )))
1162                 (point-min)))
1163       (forward-line (- h))
1164       (if (< (point) pp)
1165           (goto-char pp)
1166         )))
1167   )
1168
1169 (defun mime-view-next-line-content ()
1170   (interactive)
1171   (mime-view-scroll-up-content 1)
1172   )
1173
1174 (defun mime-view-previous-line-content ()
1175   (interactive)
1176   (mime-view-scroll-down-content 1)
1177   )
1178
1179 (defun mime-view-quit ()
1180   (interactive)
1181   (let ((r (save-excursion
1182              (set-buffer (mime::preview-content-info/buffer
1183                           (mime-preview/point-pcinfo (point))))
1184              (assq major-mode mime-view-quitting-method-alist)
1185              )))
1186     (if r
1187         (funcall (cdr r))
1188       )))
1189
1190 (defun mime-view-show-summary ()
1191   (interactive)
1192   (let ((r (save-excursion
1193              (set-buffer
1194               (mime::preview-content-info/buffer
1195                (mime-preview/point-pcinfo (point)))
1196               )
1197              (assq major-mode mime-view-show-summary-method)
1198              )))
1199     (if r
1200         (funcall (cdr r))
1201       )))
1202
1203 (defun mime-view-kill-buffer ()
1204   (interactive)
1205   (kill-buffer (current-buffer))
1206   )
1207
1208
1209 ;;; @ end
1210 ;;;
1211
1212 (provide 'mime-view)
1213
1214 (run-hooks 'mime-view-load-hook)
1215
1216 ;;; mime-view.el ends here