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.114 $
  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 'std11)
  32 (require 'mel)
  33 (require 'eword-decode)
  34 (require 'mime-parse)
  35 (require 'mime-text)
  36
  37
  38 ;;; @ version
  39 ;;;
  40
  41 (defconst mime-view-RCS-ID
  42   "$Id: mime-view.el,v 0.114 1997-09-25 13:03:50 morioka Exp $")
  43
  44 (defconst mime-view-version
  45   `,(get-version-string mime-view-RCS-ID))
  46
  47 (defconst mime-view-version-name
  48   `,(concat "SEMI MIME-View " mime-view-version
  49             " (" semi-version-name ")"))
  50
  51
  52 ;;; @ variables
  53 ;;;
  54
  55 (defvar mime-acting-condition
  56   '(((type . "text/plain")
  57      (method "tm-plain" nil 'file 'type 'encoding 'mode 'name)
  58      (mode "play" "print")
  59      )
  60     ((type . "text/html")
  61      (method "tm-html" nil 'file 'type 'encoding 'mode 'name)
  62      (mode . "play")
  63      )
  64     ((type . "text/x-rot13-47")
  65      (method . mime-display-caesar)
  66      (mode . "play")
  67      )
  68     ((type . "text/x-rot13-47-48")
  69      (method . mime-display-caesar)
  70      (mode . "play")
  71      )
  72     ((type . "audio/basic")
  73      (method "tm-au"    nil 'file 'type 'encoding 'mode 'name)
  74      (mode . "play")
  75      )
  76
  77     ((type . "image/jpeg")
  78      (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
  79      (mode "play" "print")
  80      )
  81     ((type . "image/gif")
  82      (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
  83      (mode "play" "print")
  84      )
  85     ((type . "image/png")
  86      (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
  87      (mode "play" "print")
  88      )
  89     ((type . "image/tiff")
  90      (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
  91      (mode "play" "print")
  92      )
  93     ((type . "image/x-tiff")
  94      (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
  95      (mode "play" "print")
  96      )
  97     ((type . "image/x-xbm")
  98      (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
  99      (mode "play" "print")
 100      )
 101     ((type . "image/x-pic")
 102      (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
 103      (mode "play" "print")
 104      )
 105     ((type . "image/x-mag")
 106      (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
 107      (mode "play" "print")
 108      )
 109
 110     ((type . "video/mpeg")
 111      (method "tm-mpeg"  nil 'file 'type 'encoding 'mode 'name)
 112      (mode . "play")
 113      )
 114
 115     ((type . "application/postscript")
 116      (method "tm-ps" nil 'file 'type 'encoding 'mode 'name)
 117      (mode "play" "print")
 118      )
 119     ((type . "application/octet-stream")
 120      (method "tm-file"  nil 'file 'type 'encoding 'mode 'name)
 121      (mode "play" "print")
 122      )
 123
 124     ;;((type . "message/external-body")
 125     ;; (method "xterm" nil
 126     ;;         "-e" "showexternal"
 127     ;;         'file '"access-type" '"name" '"site" '"directory"))
 128     ((type . "message/external-body")
 129      ("access-type" . "anon-ftp")
 130      (method . mime-display-message/external-ftp)
 131      )
 132     ((type . "message/rfc822")
 133      (method . mime-display-message/rfc822)
 134      (mode . "play")
 135      )
 136     ((type . "message/partial")
 137      (method . mime-display-message/partial)
 138      (mode . "play")
 139      )
 140
 141     ((method "metamail" t "-m" "tm" "-x" "-d" "-z" "-e" 'file)
 142      (mode . "play")
 143      )
 144     ((method "tm-file"  nil 'file 'type 'encoding 'mode 'name)
 145      (mode . "extract")
 146      )
 147     ))
 148
 149 (defvar mime-view-childrens-header-showing-Content-Type-list
 150   '("message/rfc822" "message/news"))
 151
 152 (defvar mime-view-visible-media-type-list
 153   '("text/plain" nil "text/richtext" "text/enriched"
 154     "text/rfc822-headers"
 155     "text/x-latex" "application/x-latex"
 156     "message/delivery-status"
 157     "application/pgp" "text/x-pgp"
 158     "application/octet-stream"
 159     "application/x-selection" "application/x-comment")
 160   "*List of media-types to be able to display in MIME-View buffer.
 161 Each elements are string of TYPE/SUBTYPE, e.g. \"text/plain\".")
 162
 163 (defvar mime-view-content-button-visible-ctype-list
 164   '("application/pgp"))
 165
 166 (defvar mime-view-uuencode-encoding-name-list '("x-uue" "x-uuencode"))
 167
 168 (defvar mime-view-ignored-field-list
 169   '(".*Received" ".*Path" ".*Id" "References"
 170     "Replied" "Errors-To"
 171     "Lines" "Sender" ".*Host" "Xref"
 172     "Content-Type" "Precedence"
 173     "Status" "X-VM-.*")
 174   "All fields that match this list will be hidden in MIME preview buffer.
 175 Each elements are regexp of field-name. [mime-view.el]")
 176
 177 (defvar mime-view-ignored-field-regexp
 178   (concat "^"
 179           (apply (function regexp-or) mime-view-ignored-field-list)
 180           ":"))
 181
 182 (defvar mime-view-visible-field-list '("Dnas.*" "Message-Id")
 183   "All fields that match this list will be displayed in MIME preview buffer.
 184 Each elements are regexp of field-name.")
 185
 186 (defvar mime-view-redisplay nil)
 187
 188 (defvar mime-view-announcement-for-message/partial
 189   (if (and (>= emacs-major-version 19) window-system)
 190       "\
 191 \[[ This is message/partial style split message. ]]
 192 \[[ Please press `v' key in this buffer          ]]
 193 \[[ or click here by mouse button-2.             ]]"
 194     "\
 195 \[[ This is message/partial style split message. ]]
 196 \[[ Please press `v' key in this buffer.         ]]"
 197     ))
 198
 199
 200 ;;; @@ entity button
 201 ;;;
 202
 203 (defun mime-view-insert-entity-button (rcnum cinfo
 204                                              media-type media-subtype params
 205                                              subj encoding)
 206   "Insert entity-button."
 207   (mime-insert-button
 208    (let ((access-type (assoc "access-type" params))
 209          (num (or (cdr (assoc "x-part-number" params))
 210                   (if (consp rcnum)
 211                       (mapconcat (function
 212                                   (lambda (num)
 213                                     (format "%s" (1+ num))
 214                                     ))
 215                                  (reverse rcnum) ".")
 216                     "0"))
 217               ))
 218      (cond (access-type
 219             (let ((server (assoc "server" params)))
 220               (setq access-type (cdr access-type))
 221               (if server
 222                   (format "%s %s ([%s] %s)"
 223                           num subj access-type (cdr server))
 224                 (let ((site (cdr (assoc "site" params)))
 225                       (dir (cdr (assoc "directory" params)))
 226                       )
 227                   (format "%s %s ([%s] %s:%s)"
 228                           num subj access-type site dir)
 229                   )))
 230             )
 231            (t
 232             (let ((charset (cdr (assoc "charset" params))))
 233               (concat
 234                num " " subj
 235                (let ((rest
 236                       (format " <%s/%s%s%s>"
 237                               media-type media-subtype
 238                               (if charset
 239                                   (concat "; " charset)
 240                                 "")
 241                               (if encoding
 242                                   (concat " (" encoding ")")
 243                                 ""))))
 244                  (if (>= (+ (current-column)(length rest))(window-width))
 245                      "\n\t")
 246                  rest)))
 247             )))
 248    (function mime-view-play-current-entity))
 249   )
 250
 251 (defun mime-view-entity-button-function (rcnum cinfo
 252                                                media-type media-subtype
 253                                                params subj encoding)
 254   "Insert entity button conditionally.
 255 Please redefine this function if you want to change default setting."
 256   (or (null rcnum)
 257       (and (eq media-type 'application)
 258            (or (eq media-subtype 'x-selection)
 259                (and (eq media-subtype 'octet-stream)
 260                     (let ((entity-info
 261                            (mime-article/rcnum-to-cinfo (cdr rcnum) cinfo)))
 262                       (and (eq (mime-entity-info-media-type entity-info)
 263                                'multipart)
 264                            (eq (mime-entity-info-media-subtype entity-info)
 265                                'encrypted)
 266                            )))))
 267       (mime-view-insert-entity-button
 268        rcnum cinfo media-type media-subtype params subj encoding)
 269       ))
 270
 271
 272 ;;; @@ content header filter
 273 ;;;
 274
 275 (defun mime-view-cut-header ()
 276   (goto-char (point-min))
 277   (while (re-search-forward mime-view-ignored-field-regexp nil t)
 278     (let* ((beg (match-beginning 0))
 279            (end (match-end 0))
 280            (name (buffer-substring beg end))
 281            )
 282       (or (member-if (function
 283                       (lambda (regexp)
 284                         (string-match regexp name)
 285                         )) mime-view-visible-field-list)
 286           (delete-region beg
 287                          (save-excursion
 288                            (if (re-search-forward "^\\([^ \t]\\|$\\)" nil t)
 289                                (match-beginning 0)
 290                              (point-max))))
 291           ))))
 292
 293 (defun mime-view-default-content-header-filter ()
 294   (mime-view-cut-header)
 295   (eword-decode-header)
 296   )
 297
 298 (defvar mime-view-content-header-filter-alist nil)
 299
 300
 301 ;;; @@ content filter
 302 ;;;
 303
 304 (defvar mime-view-content-filter-alist
 305   '(("text/enriched" . mime-view-filter-for-text/enriched)
 306     ("text/richtext" . mime-view-filter-for-text/richtext)
 307     (t . mime-view-filter-for-text/plain)
 308     )
 309   "Alist of media-types vs. corresponding MIME-View filter functions.
 310 Each element looks like (TYPE/SUBTYPE . FUNCTION) or (t . FUNCTION).
 311 TYPE/SUBTYPE is a string of media-type and FUNCTION is a filter
 312 function.  t means default media-type.")
 313
 314
 315 ;;; @@ entity separator
 316 ;;;
 317
 318 (defun mime-view-entity-separator-function (rcnum cinfo
 319                                                   media-type media-subtype
 320                                                   params subj)
 321   "Insert entity separator conditionally.
 322 Please redefine this function if you want to change default setting."
 323   (or (mime-view-header-visible-p rcnum cinfo)
 324       (mime-view-body-visible-p rcnum cinfo media-type media-subtype)
 325       (progn
 326         (goto-char (point-max))
 327         (insert "\n")
 328         )))
 329
 330
 331 ;;; @@ buffer local variables
 332 ;;;
 333
 334 ;;; @@@ in raw buffer
 335 ;;;
 336
 337 (defvar mime::article/content-info
 338   "Information about structure of message.
 339 Please use reference function `mime::content-info/SLOT-NAME' to
 340 reference slot of content-info.  Their argument is only content-info.
 341
 342 Following is a list of slots of the structure:
 343
 344 rcnum           reversed content-number (list)
 345 point-min       beginning point of region in raw-buffer
 346 point-max       end point of region in raw-buffer
 347 type            media-type/subtype (string or nil)
 348 parameters      parameter of Content-Type field (association list)
 349 encoding        Content-Transfer-Encoding (string or nil)
 350 children        entities included in this entity (list of content-infos)
 351
 352 If a entity includes other entities in its body, such as multipart or
 353 message/rfc822, content-infos of other entities are included in
 354 `children', so content-info become a tree.")
 355 (make-variable-buffer-local 'mime::article/content-info)
 356
 357 (defvar mime-view-buffer nil
 358   "MIME View buffer corresponding with the (raw) buffer.")
 359 (make-variable-buffer-local 'mime-view-buffer)
 360
 361
 362 ;;; @@@ in view buffer
 363 ;;;
 364
 365 (defvar mime-mother-buffer nil
 366   "Mother buffer corresponding with the (MIME-View) buffer.
 367 If current MIME-View buffer is generated by other buffer, such as
 368 message/partial, it is called `mother-buffer'.")
 369 (make-variable-buffer-local 'mime-mother-buffer)
 370
 371 (defvar mime-raw-buffer nil
 372   "Raw buffer corresponding with the (MIME-View) buffer.")
 373 (make-variable-buffer-local 'mime-raw-buffer)
 374
 375 (defvar mime-view-original-major-mode nil
 376   "Major-mode in mime-raw-buffer.")
 377 (make-variable-buffer-local 'mime-view-original-major-mode)
 378
 379 (make-variable-buffer-local 'mime::preview/original-window-configuration)
 380
 381
 382 ;;; @@ quitting method
 383 ;;;
 384
 385 (defvar mime-view-quitting-method-alist
 386   '((mime-show-message-mode
 387      . mime-view-quitting-method-for-mime-show-message-mode))
 388   "Alist of major-mode vs. quitting-method of mime-view.")
 389
 390 (defvar mime-view-over-to-previous-method-alist nil)
 391 (defvar mime-view-over-to-next-method-alist nil)
 392
 393 (defvar mime-view-show-summary-method nil
 394   "Alist of major-mode vs. show-summary-method.")
 395
 396
 397 ;;; @@ following method
 398 ;;;
 399
 400 (defvar mime-view-following-method-alist nil
 401   "Alist of major-mode vs. following-method of mime-view.")
 402
 403 (defvar mime-view-following-required-fields-list
 404   '("From"))
 405
 406
 407 ;;; @@ X-Face
 408 ;;;
 409
 410 ;; hack from Gnus 5.0.4.
 411
 412 (defvar mime-view-x-face-to-pbm-command
 413   "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm")
 414
 415 (defvar mime-view-x-face-command
 416   (concat mime-view-x-face-to-pbm-command
 417           " | xv -quit -")
 418   "String to be executed to display an X-Face field.
 419 The command will be executed in a sub-shell asynchronously.
 420 The compressed face will be piped to this command.")
 421
 422 (defun mime-view-x-face-function ()
 423   "Function to display X-Face field. You can redefine to customize."
 424   ;; 1995/10/12 (c.f. tm-eng:130)
 425   ;;    fixed by Eric Ding <ericding@San-Jose.ate.slb.com>
 426   (save-restriction
 427     (narrow-to-region (point-min) (re-search-forward "^$" nil t))
 428     ;; end
 429     (goto-char (point-min))
 430     (if (re-search-forward "^X-Face:[ \t]*" nil t)
 431         (let ((beg (match-end 0))
 432               (end (std11-field-end))
 433               )
 434           (call-process-region beg end "sh" nil 0 nil
 435                                "-c" mime-view-x-face-command)
 436           ))))
 437
 438
 439 ;;; @ buffer setup
 440 ;;;
 441
 442 (defun mime-view-setup-buffers (&optional ctl encoding ibuf obuf)
 443   (if ibuf
 444       (progn
 445         (get-buffer ibuf)
 446         (set-buffer ibuf)
 447         ))
 448   (or mime-view-redisplay
 449       (setq mime::article/content-info (mime-parse-message ctl encoding))
 450       )
 451   (let* ((cinfo mime::article/content-info)
 452          (pcl (mime/flatten-content-info cinfo))
 453          (the-buf (current-buffer))
 454          (mode major-mode)
 455          )
 456     (or obuf
 457         (setq obuf (concat "*Preview-" (buffer-name the-buf) "*")))
 458     (set-buffer (get-buffer-create obuf))
 459     (let ((inhibit-read-only t))
 460       ;;(setq buffer-read-only nil)
 461       (widen)
 462       (erase-buffer)
 463       (setq mime-raw-buffer the-buf)
 464       (setq mime-view-original-major-mode mode)
 465       (setq major-mode 'mime-view-mode)
 466       (setq mode-name "MIME-View")
 467       (while pcl
 468         (mime-view-display-entity (car pcl) cinfo the-buf obuf)
 469         (setq pcl (cdr pcl))
 470         )
 471       (set-buffer-modified-p nil)
 472       )
 473     (setq buffer-read-only t)
 474     (set-buffer the-buf)
 475     )
 476   (setq mime-view-buffer obuf)
 477   )
 478
 479 (defun mime-view-display-entity (content cinfo ibuf obuf)
 480   "Display entity from content-info CONTENT."
 481   (let* ((beg (mime-entity-info-point-min content))
 482          (end (mime-entity-info-point-max content))
 483          (media-type (mime-entity-info-media-type content))
 484          (media-subtype (mime-entity-info-media-subtype content))
 485          (ctype (if media-type
 486                     (if media-subtype
 487                         (format "%s/%s" media-type media-subtype)
 488                       (symbol-name media-type)
 489                       )))
 490          (params (mime-entity-info-parameters content))
 491          (encoding (mime-entity-info-encoding content))
 492          (rcnum (mime-entity-info-rnum content))
 493          he e nb ne subj)
 494     (set-buffer ibuf)
 495     (goto-char beg)
 496     (setq he (if (re-search-forward "^$" nil t)
 497                  (1+ (match-end 0))
 498                end))
 499     (if (> he end)
 500         (setq he end)
 501       )
 502     (save-restriction
 503       (narrow-to-region beg end)
 504       (setq subj
 505             (eword-decode-string
 506              (mime-article/get-subject params encoding)))
 507       )
 508     (set-buffer obuf)
 509     (setq nb (point))
 510     (narrow-to-region nb nb)
 511     (mime-view-entity-button-function
 512      rcnum cinfo media-type media-subtype params subj encoding)
 513     (if (mime-view-header-visible-p rcnum cinfo)
 514         (mime-view-display-header beg he)
 515       )
 516     (if (and (null rcnum)
 517              (member
 518               ctype mime-view-content-button-visible-ctype-list))
 519         (save-excursion
 520           (goto-char (point-max))
 521           (mime-view-insert-entity-button
 522            rcnum cinfo media-type media-subtype params subj encoding)
 523           ))
 524     (cond ((mime-view-body-visible-p rcnum cinfo media-type media-subtype)
 525            (mime-view-display-body he end
 526                                       rcnum cinfo ctype params subj encoding)
 527            )
 528           ((and (eq media-type 'message)(eq media-subtype 'partial))
 529            (mime-view-insert-message/partial-button)
 530            )
 531           ((and (null rcnum)
 532                 (null (mime-entity-info-children cinfo))
 533                 )
 534            (goto-char (point-max))
 535            (mime-view-insert-entity-button
 536             rcnum cinfo media-type media-subtype params subj encoding)
 537            ))
 538     (mime-view-entity-separator-function
 539      rcnum cinfo media-type media-subtype params subj)
 540     (setq ne (point-max))
 541     (widen)
 542     (put-text-property nb ne 'mime-view-raw-buffer ibuf)
 543     (put-text-property nb ne 'mime-view-cinfo content)
 544     (goto-char ne)
 545     ))
 546
 547 (defun mime-view-display-header (beg end)
 548   (save-restriction
 549     (narrow-to-region (point)(point))
 550     (insert-buffer-substring mime-raw-buffer beg end)
 551     (let ((f (cdr (assq mime-view-original-major-mode
 552                         mime-view-content-header-filter-alist))))
 553       (if (functionp f)
 554           (funcall f)
 555         (mime-view-default-content-header-filter)
 556         ))
 557     (run-hooks 'mime-view-content-header-filter-hook)
 558     ))
 559
 560 (defun mime-view-display-body (beg end rcnum cinfo ctype params subj encoding)
 561   (save-restriction
 562     (narrow-to-region (point-max)(point-max))
 563     (insert-buffer-substring mime-raw-buffer beg end)
 564     (let ((f (cdr (or (assoc ctype mime-view-content-filter-alist)
 565                       (assq t mime-view-content-filter-alist)))))
 566       (and (functionp f)
 567            (funcall f ctype params encoding)
 568            )
 569       )))
 570
 571 (defun mime-view-insert-message/partial-button ()
 572   (save-restriction
 573     (goto-char (point-max))
 574     (if (not (search-backward "\n\n" nil t))
 575         (insert "\n")
 576       )
 577     (goto-char (point-max))
 578     (narrow-to-region (point-max)(point-max))
 579     (insert mime-view-announcement-for-message/partial)
 580     (mime-add-button (point-min)(point-max)
 581                      (function mime-view-play-current-entity))
 582     ))
 583
 584 (defun mime-article/get-uu-filename (param &optional encoding)
 585   (if (member (or encoding
 586                   (cdr (assq 'encoding param))
 587                   )
 588               mime-view-uuencode-encoding-name-list)
 589       (save-excursion
 590         (or (if (re-search-forward "^begin [0-9]+ " nil t)
 591                 (if (looking-at ".+$")
 592                     (buffer-substring (match-beginning 0)(match-end 0))
 593                   ))
 594             ""))
 595     ))
 596
 597 (defun mime-article/get-subject (param &optional encoding)
 598   (or (std11-find-field-body '("Content-Description" "Subject"))
 599       (let (ret)
 600         (if (or (and (setq ret (mime/Content-Disposition))
 601                      (setq ret (assoc "filename" (cdr ret)))
 602                      )
 603                 (setq ret (assoc "name" param))
 604                 (setq ret (assoc "x-name" param))
 605                 )
 606             (std11-strip-quoted-string (cdr ret))
 607           ))
 608       (mime-article/get-uu-filename param encoding)
 609       ""))
 610
 611
 612 ;;; @ entity information
 613 ;;;
 614
 615 (defun mime-article/point-content-number (p &optional cinfo)
 616   (or cinfo
 617       (setq cinfo mime::article/content-info)
 618       )
 619   (let ((b (mime-entity-info-point-min cinfo))
 620         (e (mime-entity-info-point-max cinfo))
 621         (c (mime-entity-info-children cinfo))
 622         )
 623     (if (and (<= b p)(<= p e))
 624         (or (let (co ret (sn 0))
 625               (catch 'tag
 626                 (while c
 627                   (setq co (car c))
 628                   (setq ret (mime-article/point-content-number p co))
 629                   (cond ((eq ret t) (throw 'tag (list sn)))
 630                         (ret (throw 'tag (cons sn ret)))
 631                         )
 632                   (setq c (cdr c))
 633                   (setq sn (1+ sn))
 634                   )))
 635             t))))
 636
 637 (defsubst mime-article/rcnum-to-cinfo (rnum &optional cinfo)
 638   (mime-article/cnum-to-cinfo (reverse rnum) cinfo)
 639   )
 640
 641 (defun mime-article/cnum-to-cinfo (cn &optional cinfo)
 642   (or cinfo
 643       (setq cinfo mime::article/content-info)
 644       )
 645   (if (eq cn t)
 646       cinfo
 647     (let ((sn (car cn)))
 648       (if (null sn)
 649           cinfo
 650         (let ((rc (nth sn (mime-entity-info-children cinfo))))
 651           (if rc
 652               (mime-article/cnum-to-cinfo (cdr cn) rc)
 653             ))
 654         ))))
 655
 656 (defun mime/flatten-content-info (&optional cinfo)
 657   (or cinfo
 658       (setq cinfo mime::article/content-info)
 659       )
 660   (let ((dest (list cinfo))
 661         (rcl (mime-entity-info-children cinfo))
 662         )
 663     (while rcl
 664       (setq dest (nconc dest (mime/flatten-content-info (car rcl))))
 665       (setq rcl (cdr rcl))
 666       )
 667     dest))
 668
 669
 670 ;;; @@ predicate functions
 671 ;;;
 672
 673 (defun mime-view-header-visible-p (rcnum cinfo)
 674   "Return non-nil if header of current entity is visible."
 675   (or (null rcnum)
 676       (member (mime-entity-info-type/subtype
 677                (mime-article/rcnum-to-cinfo (cdr rcnum) cinfo))
 678               mime-view-childrens-header-showing-Content-Type-list)
 679       ))
 680
 681 (defun mime-view-body-visible-p (rcnum cinfo media-type media-subtype)
 682   (let ((ctype (if media-type
 683                    (if media-subtype
 684                        (format "%s/%s" media-type media-subtype)
 685                      (symbol-name media-type)
 686                      ))))
 687     (and (member ctype mime-view-visible-media-type-list)
 688          (if (and (eq media-type 'application)
 689                   (eq media-subtype 'octet-stream))
 690              (let ((ccinfo (mime-article/rcnum-to-cinfo rcnum cinfo)))
 691                (member (mime-entity-info-encoding ccinfo)
 692                        '(nil "7bit" "8bit"))
 693                )
 694            t))
 695     ))
 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