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