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