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