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