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