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.94 $
  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.94 1997-06-24 16:15:47 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     (goto-char (point-max))
 586     (narrow-to-region (point-max)(point-max))
 587     (insert mime-view-announcement-for-message/partial)
 588     (mime-add-button (point-min)(point-max)
 589                      (function mime-view-play-current-entity))
 590     ))
 591
 592 (defun mime-article/get-uu-filename (param &optional encoding)
 593   (if (member (or encoding
 594                   (cdr (assq 'encoding param))
 595                   )
 596               mime-view-uuencode-encoding-name-list)
 597       (save-excursion
 598         (or (if (re-search-forward "^begin [0-9]+ " nil t)
 599                 (if (looking-at ".+$")
 600                     (buffer-substring (match-beginning 0)(match-end 0))
 601                   ))
 602             ""))
 603     ))
 604
 605 (defun mime-article/get-subject (param &optional encoding)
 606   (or (std11-find-field-body '("Content-Description" "Subject"))
 607       (let (ret)
 608         (if (or (and (setq ret (mime/Content-Disposition))
 609                      (setq ret (assoc "filename" (cdr ret)))
 610                      )
 611                 (setq ret (assoc "name" param))
 612                 (setq ret (assoc "x-name" param))
 613                 )
 614             (std11-strip-quoted-string (cdr ret))
 615           ))
 616       (mime-article/get-uu-filename param encoding)
 617       ""))
 618
 619
 620 ;;; @ content information
 621 ;;;
 622
 623 (defun mime-article/point-content-number (p &optional cinfo)
 624   (or cinfo
 625       (setq cinfo mime::article/content-info)
 626       )
 627   (let ((b (mime::content-info/point-min cinfo))
 628         (e (mime::content-info/point-max cinfo))
 629         (c (mime::content-info/children cinfo))
 630         )
 631     (if (and (<= b p)(<= p e))
 632         (or (let (co ret (sn 0))
 633               (catch 'tag
 634                 (while c
 635                   (setq co (car c))
 636                   (setq ret (mime-article/point-content-number p co))
 637                   (cond ((eq ret t) (throw 'tag (list sn)))
 638                         (ret (throw 'tag (cons sn ret)))
 639                         )
 640                   (setq c (cdr c))
 641                   (setq sn (1+ sn))
 642                   )))
 643             t))))
 644
 645 (defun mime-article/rcnum-to-cinfo (rcnum &optional cinfo)
 646   (or cinfo
 647       (setq cinfo mime::article/content-info)
 648       )
 649   (find-if (function
 650             (lambda (ci)
 651               (equal (mime::content-info/rcnum ci) rcnum)
 652               ))
 653            (mime/flatten-content-info cinfo)
 654            ))
 655
 656 (defun mime-article/cnum-to-cinfo (cn &optional cinfo)
 657   (or cinfo
 658       (setq cinfo mime::article/content-info)
 659       )
 660   (if (eq cn t)
 661       cinfo
 662     (let ((sn (car cn)))
 663       (if (null sn)
 664           cinfo
 665         (let ((rc (nth sn (mime::content-info/children cinfo))))
 666           (if rc
 667               (mime-article/cnum-to-cinfo (cdr cn) rc)
 668             ))
 669         ))))
 670
 671 (defun mime/flatten-content-info (&optional cinfo)
 672   (or cinfo
 673       (setq cinfo mime::article/content-info)
 674       )
 675   (let ((dest (list cinfo))
 676         (rcl (mime::content-info/children cinfo))
 677         )
 678     (while rcl
 679       (setq dest (nconc dest (mime/flatten-content-info (car rcl))))
 680       (setq rcl (cdr rcl))
 681       )
 682     dest))
 683
 684
 685 ;;; @ MIME viewer mode
 686 ;;;
 687
 688 (defconst mime-view-menu-title "MIME-View")
 689 (defconst mime-view-menu-list
 690   '((up          "Move to upper content"      mime-view-move-to-upper)
 691     (previous    "Move to previous content"   mime-view-move-to-previous)
 692     (next        "Move to next content"       mime-view-move-to-next)
 693     (scroll-down "Scroll to previous content" mime-view-scroll-down-entity)
 694     (scroll-up   "Scroll to next content"     mime-view-scroll-up-entity)
 695     (play        "Play Content"               mime-view-play-current-entity)
 696     (extract     "Extract Content"            mime-view-extract-current-entity)
 697     (print       "Print"                      mime-view-print-current-entity)
 698     (x-face      "Show X Face"                mime-view-display-x-face)
 699     )
 700   "Menu for MIME Viewer")
 701
 702 (cond (running-xemacs
 703        (defvar mime-view-xemacs-popup-menu
 704          (cons mime-view-menu-title
 705                (mapcar (function
 706                         (lambda (item)
 707                           (vector (nth 1 item)(nth 2 item) t)
 708                           ))
 709                        mime-view-menu-list)))
 710        (defun mime-view-xemacs-popup-menu (event)
 711          "Popup the menu in the MIME Viewer buffer"
 712          (interactive "e")
 713          (select-window (event-window event))
 714          (set-buffer (event-buffer event))
 715          (popup-menu 'mime-view-xemacs-popup-menu))
 716        (defvar mouse-button-2 'button2)
 717        )
 718       (t
 719        (defvar mouse-button-2 [mouse-2])
 720        ))
 721
 722 (defun mime-view-define-keymap (&optional default)
 723   (let ((mime-view-mode-map (if (keymapp default)
 724                                 (copy-keymap default)
 725                               (make-sparse-keymap)
 726                               )))
 727     (define-key mime-view-mode-map
 728       "u"        (function mime-view-move-to-upper))
 729     (define-key mime-view-mode-map
 730       "p"        (function mime-view-move-to-previous))
 731     (define-key mime-view-mode-map
 732       "n"        (function mime-view-move-to-next))
 733     (define-key mime-view-mode-map
 734       "\e\t"     (function mime-view-move-to-previous))
 735     (define-key mime-view-mode-map
 736       "\t"       (function mime-view-move-to-next))
 737     (define-key mime-view-mode-map
 738       " "        (function mime-view-scroll-up-entity))
 739     (define-key mime-view-mode-map
 740       "\M- "     (function mime-view-scroll-down-entity))
 741     (define-key mime-view-mode-map
 742       "\177"     (function mime-view-scroll-down-entity))
 743     (define-key mime-view-mode-map
 744       "\C-m"     (function mime-view-next-line-content))
 745     (define-key mime-view-mode-map
 746       "\C-\M-m"  (function mime-view-previous-line-content))
 747     (define-key mime-view-mode-map
 748       "v"        (function mime-view-play-current-entity))
 749     (define-key mime-view-mode-map
 750       "e"        (function mime-view-extract-current-entity))
 751     (define-key mime-view-mode-map
 752       "\C-c\C-p" (function mime-view-print-current-entity))
 753     (define-key mime-view-mode-map
 754       "a"        (function mime-view-follow-current-entity))
 755     (define-key mime-view-mode-map
 756       "q"        (function mime-view-quit))
 757     (define-key mime-view-mode-map
 758       "h"        (function mime-view-show-summary))
 759     (define-key mime-view-mode-map
 760       "\C-c\C-x" (function mime-view-kill-buffer))
 761     ;; (define-key mime-view-mode-map
 762     ;;   "<"        (function beginning-of-buffer))
 763     ;; (define-key mime-view-mode-map
 764     ;;   ">"        (function end-of-buffer))
 765     (define-key mime-view-mode-map
 766       "?"        (function describe-mode))
 767     (define-key mime-view-mode-map
 768       [tab] (function mime-view-move-to-next))
 769     (define-key mime-view-mode-map
 770       [delete] (function mime-view-scroll-down-entity))
 771     (define-key mime-view-mode-map
 772       [backspace] (function mime-view-scroll-down-entity))
 773     (if (functionp default)
 774         (cond (running-xemacs
 775                (set-keymap-default-binding mime-view-mode-map default)
 776                )
 777               (t
 778                (setq mime-view-mode-map
 779                      (append mime-view-mode-map (list (cons t default))))
 780                )))
 781     (if mouse-button-2
 782         (define-key mime-view-mode-map
 783           mouse-button-2 (function mime-button-dispatcher))
 784       )
 785     (cond (running-xemacs
 786            (define-key mime-view-mode-map
 787              mouse-button-3 (function mime-view-xemacs-popup-menu))
 788            )
 789           ((>= emacs-major-version 19)
 790            (define-key mime-view-mode-map [menu-bar mime-view]
 791              (cons mime-view-menu-title
 792                    (make-sparse-keymap mime-view-menu-title)))
 793            (mapcar (function
 794                     (lambda (item)
 795                       (define-key mime-view-mode-map
 796                         (vector 'menu-bar 'mime-view (car item))
 797                         (cons (nth 1 item)(nth 2 item))
 798                         )
 799                       ))
 800                    (reverse mime-view-menu-list)
 801                    )
 802            ))
 803     (use-local-map mime-view-mode-map)
 804     (run-hooks 'mime-view-define-keymap-hook)
 805     ))
 806
 807 (defsubst mime-hide-echo-buffer ()
 808   "Hide mime-echo buffer."
 809   (let ((win (get-buffer-window mime-echo-buffer-name)))
 810     (if win
 811         (delete-window win)
 812       )))
 813
 814 (defun mime-view-mode (&optional mother ctl encoding ibuf obuf
 815                                  default-keymap-or-function)
 816   "Major mode for viewing MIME message.
 817
 818 Here is a list of the standard keys for mime-view-mode.
 819
 820 key             feature
 821 ---             -------
 822
 823 u               Move to upper content
 824 p or M-TAB      Move to previous content
 825 n or TAB        Move to next content
 826 SPC             Scroll up or move to next content
 827 M-SPC or DEL    Scroll down or move to previous content
 828 RET             Move to next line
 829 M-RET           Move to previous line
 830 v               Decode current content as `play mode'
 831 e               Decode current content as `extract mode'
 832 C-c C-p         Decode current content as `print mode'
 833 a               Followup to current content.
 834 x               Display X-Face
 835 q               Quit
 836 button-2        Move to point under the mouse cursor
 837                 and decode current content as `play mode'
 838 "
 839   (interactive)
 840   (let ((buf (get-buffer mime-echo-buffer-name)))
 841     (if buf
 842         (save-excursion
 843           (set-buffer buf)
 844           (erase-buffer)
 845           (mime-hide-echo-buffer)
 846           )))
 847   (let ((ret (mime-view-setup-buffers ctl encoding ibuf obuf))
 848         (win-conf (current-window-configuration))
 849         )
 850     (prog1
 851         (switch-to-buffer ret)
 852       (setq mime::preview/original-window-configuration win-conf)
 853       (if mother
 854           (progn
 855             (setq mime-mother-buffer mother)
 856             ))
 857       (mime-view-define-keymap default-keymap-or-function)
 858       (let ((point (next-single-property-change (point-min) 'mime-view-cinfo)))
 859         (if point
 860             (goto-char point)
 861           (goto-char (point-min))
 862           (search-forward "\n\n" nil t)
 863           ))
 864       (run-hooks 'mime-view-mode-hook)
 865       )))
 866
 867
 868 ;;; @@ playing
 869 ;;;
 870
 871 (autoload 'mime-view-play-current-entity "mime-play" "Play current entity." t)
 872
 873 (defun mime-view-extract-current-entity ()
 874   "Extract current entity into file (maybe).
 875 It decodes current entity to call internal or external method as
 876 \"extract\" mode.  The method is selected from variable
 877 `mime-acting-condition'."
 878   (interactive)
 879   (mime-view-play-current-entity "extract")
 880   )
 881
 882 (defun mime-view-print-current-entity ()
 883   "Print current entity (maybe).
 884 It decodes current entity to call internal or external method as
 885 \"print\" mode.  The method is selected from variable
 886 `mime-acting-condition'."
 887   (interactive)
 888   (mime-view-play-current-entity "print")
 889   )
 890
 891
 892 ;;; @@ following
 893 ;;;
 894
 895 (defun mime-view-get-original-major-mode ()
 896   "Return major-mode of original buffer.
 897 If a current buffer has mime-mother-buffer, return original major-mode
 898 of the mother-buffer."
 899   (if mime-mother-buffer
 900       (save-excursion
 901         (set-buffer mime-mother-buffer)
 902         (mime-view-get-original-major-mode)
 903         )
 904     mime-view-original-major-mode))
 905
 906 (defun mime-view-follow-current-entity ()
 907   "Write follow message to current entity.
 908 It calls following-method selected from variable
 909 `mime-view-following-method-alist'."
 910   (interactive)
 911   (let ((root-cinfo (get-text-property (point-min) 'mime-view-cinfo))
 912         cinfo)
 913     (while (null (setq cinfo (get-text-property (point) 'mime-view-cinfo)))
 914       (backward-char)
 915       )
 916     (let* ((p-beg (previous-single-property-change (point) 'mime-view-cinfo))
 917            p-end
 918            (rcnum (mime::content-info/rcnum cinfo))
 919            (len (length rcnum))
 920            )
 921       (cond ((null p-beg)
 922              (setq p-beg
 923                    (if (eq (next-single-property-change (point-min)
 924                                                         'mime-view-cinfo)
 925                            (point))
 926                        (point)
 927                      (point-min)))
 928              )
 929             ((eq (next-single-property-change p-beg 'mime-view-cinfo)
 930                  (point))
 931              (setq p-beg (point))
 932              ))
 933       (setq p-end (next-single-property-change p-beg 'mime-view-cinfo))
 934       (cond ((null p-end)
 935              (setq p-end (point-max))
 936              )
 937             ((null rcnum)
 938              (setq p-end (point-max))
 939              )
 940             (t
 941              (save-excursion
 942                (goto-char p-end)
 943                (catch 'tag
 944                  (let (e)
 945                    (while (setq e
 946                                 (next-single-property-change
 947                                  (point) 'mime-view-cinfo))
 948                      (goto-char e)
 949                      (let ((rc (mime::content-info/rcnum
 950                                 (get-text-property (point)
 951                                                    'mime-view-cinfo))))
 952                        (or (equal rcnum (nthcdr (- (length rc) len) rc))
 953                            (throw 'tag nil)
 954                            ))
 955                      (setq p-end e)
 956                      ))
 957                  (setq p-end (point-max))
 958                  ))
 959              ))
 960       (let* ((mode (mime-view-get-original-major-mode))
 961              (new-name (format "%s-%s" (buffer-name) (reverse rcnum)))
 962              new-buf
 963              (the-buf (current-buffer))
 964              (a-buf mime-raw-buffer)
 965              fields)
 966         (save-excursion
 967           (set-buffer (setq new-buf (get-buffer-create new-name)))
 968           (erase-buffer)
 969           (insert-buffer-substring the-buf p-beg p-end)
 970           (goto-char (point-min))
 971           (if (mime-view-header-visible-p rcnum root-cinfo)
 972               (delete-region (goto-char (point-min))
 973                              (if (re-search-forward "^$" nil t)
 974                                  (match-end 0)
 975                                (point-min)))
 976             )
 977           (goto-char (point-min))
 978           (insert "\n")
 979           (goto-char (point-min))
 980           (let ((rcnum (mime::content-info/rcnum cinfo)) ci str)
 981             (while (progn
 982                      (setq str
 983                            (save-excursion
 984                              (set-buffer a-buf)
 985                              (setq ci (mime-article/rcnum-to-cinfo rcnum))
 986                              (save-restriction
 987                                (narrow-to-region
 988                                 (mime::content-info/point-min ci)
 989                                 (mime::content-info/point-max ci)
 990                                 )
 991                                (std11-header-string-except
 992                                 (concat "^"
 993                                         (apply (function regexp-or) fields)
 994                                         ":") ""))))
 995                      (if (string= (mime::content-info/type ci)
 996                                   "message/rfc822")
 997                          nil
 998                        (if str
 999                            (insert str)
1000                          )
1001                        rcnum))
1002               (setq fields (std11-collect-field-names)
1003                     rcnum (cdr rcnum))
1004               )
1005             )
1006           (let ((rest mime-view-following-required-fields-list))
1007             (while rest
1008               (let ((field-name (car rest)))
1009                 (or (std11-field-body field-name)
1010                     (insert
1011                      (format
1012                       (concat field-name
1013                               ": "
1014                               (save-excursion
1015                                 (set-buffer the-buf)
1016                                 (set-buffer mime-mother-buffer)
1017                                 (set-buffer mime-raw-buffer)
1018                                 (std11-field-body field-name)
1019                                 )
1020                               "\n")))
1021                     ))
1022               (setq rest (cdr rest))
1023               ))
1024           (eword-decode-header)
1025           )
1026         (let ((f (cdr (assq mode mime-view-following-method-alist))))
1027           (if (functionp f)
1028               (funcall f new-buf)
1029             (message
1030              (format
1031               "Sorry, following method for %s is not implemented yet."
1032               mode))
1033             ))
1034         ))))
1035
1036
1037 ;;; @@ X-Face
1038 ;;;
1039
1040 (defun mime-view-display-x-face ()
1041   (interactive)
1042   (save-window-excursion
1043     (set-buffer mime-raw-buffer)
1044     (mime-view-x-face-function)
1045     ))
1046
1047
1048 ;;; @@ moving
1049 ;;;
1050
1051 (defun mime-view-move-to-upper ()
1052   "Move to upper entity.
1053 If there is no upper entity, call function `mime-view-quit'."
1054   (interactive)
1055   (let (cinfo)
1056     (while (null (setq cinfo (get-text-property (point) 'mime-view-cinfo)))
1057       (backward-char)
1058       )
1059     (let ((r (mime-article/rcnum-to-cinfo
1060               (cdr (mime::content-info/rcnum cinfo))
1061               (get-text-property 1 'mime-view-cinfo)))
1062           point)
1063       (catch 'tag
1064         (while (setq point (previous-single-property-change
1065                             (point) 'mime-view-cinfo))
1066           (goto-char point)
1067           (if (eq r (get-text-property (point) 'mime-view-cinfo))
1068               (throw 'tag t)
1069             )
1070           )
1071         (mime-view-quit)
1072         ))))
1073
1074 (defun mime-view-move-to-previous ()
1075   "Move to previous entity.
1076 If there is no previous entity, it calls function registered in
1077 variable `mime-view-over-to-previous-method-alist'."
1078   (interactive)
1079   (while (null (get-text-property (point) 'mime-view-cinfo))
1080     (backward-char)
1081     )
1082   (let ((point (previous-single-property-change (point) 'mime-view-cinfo)))
1083     (if point
1084         (goto-char point)
1085       (let ((f (assq mime-view-original-major-mode
1086                      mime-view-over-to-previous-method-alist)))
1087         (if f
1088             (funcall (cdr f))
1089           ))
1090       )))
1091
1092 (defun mime-view-move-to-next ()
1093   "Move to next entity.
1094 If there is no previous entity, it calls function registered in
1095 variable `mime-view-over-to-next-method-alist'."
1096   (interactive)
1097   (let ((point (next-single-property-change (point) 'mime-view-cinfo)))
1098     (if point
1099         (goto-char point)
1100       (let ((f (assq mime-view-original-major-mode
1101                      mime-view-over-to-next-method-alist)))
1102         (if f
1103             (funcall (cdr f))
1104           ))
1105       )))
1106
1107 (defun mime-view-scroll-up-entity (&optional h)
1108   "Scroll up current entity.
1109 If reached to (point-max), it calls function registered in variable
1110 `mime-view-over-to-next-method-alist'."
1111   (interactive)
1112   (or h
1113       (setq h (1- (window-height)))
1114       )
1115   (if (= (point) (point-max))
1116       (let ((f (assq mime-view-original-major-mode
1117                      mime-view-over-to-next-method-alist)))
1118         (if f
1119             (funcall (cdr f))
1120           ))
1121     (let ((point
1122            (or (next-single-property-change (point) 'mime-view-cinfo)
1123                (point-max))))
1124       (forward-line h)
1125       (if (> (point) point)
1126           (goto-char point)
1127         )
1128       )))
1129
1130 (defun mime-view-scroll-down-entity (&optional h)
1131   "Scroll down current entity.
1132 If reached to (point-min), it calls function registered in variable
1133 `mime-view-over-to-previous-method-alist'."
1134   (interactive)
1135   (or h
1136       (setq h (1- (window-height)))
1137       )
1138   (if (= (point) (point-min))
1139       (let ((f (assq mime-view-original-major-mode
1140                      mime-view-over-to-previous-method-alist)))
1141         (if f
1142             (funcall (cdr f))
1143           ))
1144     (let (point)
1145       (save-excursion
1146         (catch 'tag
1147           (while (> (point) 1)
1148             (if (setq point
1149                       (previous-single-property-change (point)
1150                                                        'mime-view-cinfo))
1151                 (throw 'tag t)
1152               )
1153             (backward-char)
1154             )
1155           (setq point (point-min))
1156           ))
1157       (forward-line (- h))
1158       (if (< (point) point)
1159           (goto-char point)
1160         ))))
1161
1162 (defun mime-view-next-line-content ()
1163   (interactive)
1164   (mime-view-scroll-up-entity 1)
1165   )
1166
1167 (defun mime-view-previous-line-content ()
1168   (interactive)
1169   (mime-view-scroll-down-entity 1)
1170   )
1171
1172
1173 ;;; @@ quitting
1174 ;;;
1175
1176 (defun mime-view-quit ()
1177   "Quit from MIME-View buffer.
1178 It calls function registered in variable
1179 `mime-view-quitting-method-alist'."
1180   (interactive)
1181   (let ((r (assq mime-view-original-major-mode
1182                  mime-view-quitting-method-alist)))
1183     (if r
1184         (funcall (cdr r))
1185       )))
1186
1187 (defun mime-view-show-summary ()
1188   "Show summary.
1189 It calls function registered in variable
1190 `mime-view-show-summary-method'."
1191   (interactive)
1192   (let ((r (assq mime-view-original-major-mode
1193                  mime-view-show-summary-method)))
1194     (if r
1195         (funcall (cdr r))
1196       )))
1197
1198 (defun mime-view-kill-buffer ()
1199   (interactive)
1200   (kill-buffer (current-buffer))
1201   )
1202
1203
1204 ;;; @ end
1205 ;;;
1206
1207 (provide 'mime-view)
1208
1209 (run-hooks 'mime-view-load-hook)
1210
1211 ;;; mime-view.el ends here