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