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