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