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