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