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