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.118 $
  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.118 1997-11-24 11:52:06 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-raw-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-raw-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-raw-content-info (mime-parse-message ctl encoding))
 453       )
 454   (let* ((cinfo mime-raw-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-raw-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-raw-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-raw-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-maybe-hide-echo-buffer ()
 824   "Clear mime-echo buffer and delete window for it."
 825   (let ((buf (get-buffer mime-echo-buffer-name)))
 826     (if buf
 827         (save-excursion
 828           (set-buffer buf)
 829           (erase-buffer)
 830           (let ((win (get-buffer-window buf)))
 831             (if win
 832                 (delete-window win)
 833               ))
 834           (bury-buffer buf)
 835           ))))
 836
 837 (defun mime-view-mode (&optional mother ctl encoding ibuf obuf
 838                                  default-keymap-or-function)
 839   "Major mode for viewing MIME message.
 840
 841 Here is a list of the standard keys for mime-view-mode.
 842
 843 key             feature
 844 ---             -------
 845
 846 u               Move to upper content
 847 p or M-TAB      Move to previous content
 848 n or TAB        Move to next content
 849 SPC             Scroll up or move to next content
 850 M-SPC or DEL    Scroll down or move to previous content
 851 RET             Move to next line
 852 M-RET           Move to previous line
 853 v               Decode current content as `play mode'
 854 e               Decode current content as `extract mode'
 855 C-c C-p         Decode current content as `print mode'
 856 a               Followup to current content.
 857 x               Display X-Face
 858 q               Quit
 859 button-2        Move to point under the mouse cursor
 860                 and decode current content as `play mode'
 861 "
 862   (interactive)
 863   (mime-maybe-hide-echo-buffer)
 864   (let ((ret (mime-view-setup-buffers ctl encoding ibuf obuf))
 865         (win-conf (current-window-configuration))
 866         )
 867     (prog1
 868         (switch-to-buffer ret)
 869       (setq mime::preview/original-window-configuration win-conf)
 870       (if mother
 871           (progn
 872             (setq mime-mother-buffer mother)
 873             ))
 874       (mime-view-define-keymap default-keymap-or-function)
 875       (let ((point (next-single-property-change (point-min) 'mime-view-cinfo)))
 876         (if point
 877             (goto-char point)
 878           (goto-char (point-min))
 879           (search-forward "\n\n" nil t)
 880           ))
 881       (run-hooks 'mime-view-mode-hook)
 882       )))
 883
 884
 885 ;;; @@ playing
 886 ;;;
 887
 888 (autoload 'mime-view-play-current-entity "mime-play" "Play current entity." t)
 889
 890 (defun mime-view-extract-current-entity ()
 891   "Extract current entity into file (maybe).
 892 It decodes current entity to call internal or external method as
 893 \"extract\" mode.  The method is selected from variable
 894 `mime-acting-condition'."
 895   (interactive)
 896   (mime-view-play-current-entity "extract")
 897   )
 898
 899 (defun mime-view-print-current-entity ()
 900   "Print current entity (maybe).
 901 It decodes current entity to call internal or external method as
 902 \"print\" mode.  The method is selected from variable
 903 `mime-acting-condition'."
 904   (interactive)
 905   (mime-view-play-current-entity "print")
 906   )
 907
 908
 909 ;;; @@ following
 910 ;;;
 911
 912 (defun mime-view-get-original-major-mode ()
 913   "Return major-mode of original buffer.
 914 If a current buffer has mime-mother-buffer, return original major-mode
 915 of the mother-buffer."
 916   (if mime-mother-buffer
 917       (save-excursion
 918         (set-buffer mime-mother-buffer)
 919         (mime-view-get-original-major-mode)
 920         )
 921     mime-view-original-major-mode))
 922
 923 (defun mime-view-follow-current-entity ()
 924   "Write follow message to current entity.
 925 It calls following-method selected from variable
 926 `mime-view-following-method-alist'."
 927   (interactive)
 928   (let ((root-cinfo (get-text-property (point-min) 'mime-view-cinfo))
 929         cinfo)
 930     (while (null (setq cinfo (get-text-property (point) 'mime-view-cinfo)))
 931       (backward-char)
 932       )
 933     (let* ((p-beg (previous-single-property-change (point) 'mime-view-cinfo))
 934            p-end
 935            (rcnum (mime-entity-info-rnum cinfo))
 936            (len (length rcnum))
 937            )
 938       (cond ((null p-beg)
 939              (setq p-beg
 940                    (if (eq (next-single-property-change (point-min)
 941                                                         'mime-view-cinfo)
 942                            (point))
 943                        (point)
 944                      (point-min)))
 945              )
 946             ((eq (next-single-property-change p-beg 'mime-view-cinfo)
 947                  (point))
 948              (setq p-beg (point))
 949              ))
 950       (setq p-end (next-single-property-change p-beg 'mime-view-cinfo))
 951       (cond ((null p-end)
 952              (setq p-end (point-max))
 953              )
 954             ((null rcnum)
 955              (setq p-end (point-max))
 956              )
 957             (t
 958              (save-excursion
 959                (goto-char p-end)
 960                (catch 'tag
 961                  (let (e)
 962                    (while (setq e
 963                                 (next-single-property-change
 964                                  (point) 'mime-view-cinfo))
 965                      (goto-char e)
 966                      (let ((rc (mime-entity-info-rnum
 967                                 (get-text-property (point)
 968                                                    'mime-view-cinfo))))
 969                        (or (equal rcnum (nthcdr (- (length rc) len) rc))
 970                            (throw 'tag nil)
 971                            ))
 972                      (setq p-end e)
 973                      ))
 974                  (setq p-end (point-max))
 975                  ))
 976              ))
 977       (let* ((mode (mime-view-get-original-major-mode))
 978              (new-name (format "%s-%s" (buffer-name) (reverse rcnum)))
 979              new-buf
 980              (the-buf (current-buffer))
 981              (a-buf mime-raw-buffer)
 982              fields)
 983         (save-excursion
 984           (set-buffer (setq new-buf (get-buffer-create new-name)))
 985           (erase-buffer)
 986           (insert-buffer-substring the-buf p-beg p-end)
 987           (goto-char (point-min))
 988           (if (mime-view-header-visible-p rcnum root-cinfo)
 989               (delete-region (goto-char (point-min))
 990                              (if (re-search-forward "^$" nil t)
 991                                  (match-end 0)
 992                                (point-min)))
 993             )
 994           (goto-char (point-min))
 995           (insert "\n")
 996           (goto-char (point-min))
 997           (let ((rcnum (mime-entity-info-rnum cinfo)) ci str)
 998             (while (progn
 999                      (setq str
1000                            (save-excursion
1001                              (set-buffer a-buf)
1002                              (setq ci (mime-article/rcnum-to-cinfo rcnum))
1003                              (save-restriction
1004                                (narrow-to-region
1005                                 (mime-entity-info-point-min ci)
1006                                 (mime-entity-info-point-max ci)
1007                                 )
1008                                (std11-header-string-except
1009                                 (concat "^"
1010                                         (apply (function regexp-or) fields)
1011                                         ":") ""))))
1012                      (if (and
1013                           (eq (mime-entity-info-media-type ci) 'message)
1014                           (eq (mime-entity-info-media-subtype ci) 'rfc822))
1015                          nil
1016                        (if str
1017                            (insert str)
1018                          )
1019                        rcnum))
1020               (setq fields (std11-collect-field-names)
1021                     rcnum (cdr rcnum))
1022               )
1023             )
1024           (let ((rest mime-view-following-required-fields-list))
1025             (while rest
1026               (let ((field-name (car rest)))
1027                 (or (std11-field-body field-name)
1028                     (insert
1029                      (format
1030                       (concat field-name
1031                               ": "
1032                               (save-excursion
1033                                 (set-buffer the-buf)
1034                                 (set-buffer mime-mother-buffer)
1035                                 (set-buffer mime-raw-buffer)
1036                                 (std11-field-body field-name)
1037                                 )
1038                               "\n")))
1039                     ))
1040               (setq rest (cdr rest))
1041               ))
1042           (eword-decode-header)
1043           )
1044         (let ((f (cdr (assq mode mime-view-following-method-alist))))
1045           (if (functionp f)
1046               (funcall f new-buf)
1047             (message
1048              (format
1049               "Sorry, following method for %s is not implemented yet."
1050               mode))
1051             ))
1052         ))))
1053
1054
1055 ;;; @@ X-Face
1056 ;;;
1057
1058 (defun mime-view-display-x-face ()
1059   (interactive)
1060   (save-window-excursion
1061     (set-buffer mime-raw-buffer)
1062     (mime-view-x-face-function)
1063     ))
1064
1065
1066 ;;; @@ moving
1067 ;;;
1068
1069 (defun mime-view-move-to-upper ()
1070   "Move to upper entity.
1071 If there is no upper entity, call function `mime-view-quit'."
1072   (interactive)
1073   (let (cinfo)
1074     (while (null (setq cinfo (get-text-property (point) 'mime-view-cinfo)))
1075       (backward-char)
1076       )
1077     (let ((r (mime-article/rcnum-to-cinfo
1078               (cdr (mime-entity-info-rnum cinfo))
1079               (get-text-property 1 'mime-view-cinfo)))
1080           point)
1081       (catch 'tag
1082         (while (setq point (previous-single-property-change
1083                             (point) 'mime-view-cinfo))
1084           (goto-char point)
1085           (if (eq r (get-text-property (point) 'mime-view-cinfo))
1086               (throw 'tag t)
1087             )
1088           )
1089         (mime-view-quit)
1090         ))))
1091
1092 (defun mime-view-move-to-previous ()
1093   "Move to previous entity.
1094 If there is no previous entity, it calls function registered in
1095 variable `mime-view-over-to-previous-method-alist'."
1096   (interactive)
1097   (while (null (get-text-property (point) 'mime-view-cinfo))
1098     (backward-char)
1099     )
1100   (let ((point (previous-single-property-change (point) 'mime-view-cinfo)))
1101     (if point
1102         (goto-char point)
1103       (let ((f (assq mime-view-original-major-mode
1104                      mime-view-over-to-previous-method-alist)))
1105         (if f
1106             (funcall (cdr f))
1107           ))
1108       )))
1109
1110 (defun mime-view-move-to-next ()
1111   "Move to next entity.
1112 If there is no previous entity, it calls function registered in
1113 variable `mime-view-over-to-next-method-alist'."
1114   (interactive)
1115   (let ((point (next-single-property-change (point) 'mime-view-cinfo)))
1116     (if point
1117         (goto-char point)
1118       (let ((f (assq mime-view-original-major-mode
1119                      mime-view-over-to-next-method-alist)))
1120         (if f
1121             (funcall (cdr f))
1122           ))
1123       )))
1124
1125 (defun mime-view-scroll-up-entity (&optional h)
1126   "Scroll up current entity.
1127 If reached to (point-max), it calls function registered in variable
1128 `mime-view-over-to-next-method-alist'."
1129   (interactive)
1130   (or h
1131       (setq h (1- (window-height)))
1132       )
1133   (if (= (point) (point-max))
1134       (let ((f (assq mime-view-original-major-mode
1135                      mime-view-over-to-next-method-alist)))
1136         (if f
1137             (funcall (cdr f))
1138           ))
1139     (let ((point
1140            (or (next-single-property-change (point) 'mime-view-cinfo)
1141                (point-max))))
1142       (forward-line h)
1143       (if (> (point) point)
1144           (goto-char point)
1145         )
1146       )))
1147
1148 (defun mime-view-scroll-down-entity (&optional h)
1149   "Scroll down current entity.
1150 If reached to (point-min), it calls function registered in variable
1151 `mime-view-over-to-previous-method-alist'."
1152   (interactive)
1153   (or h
1154       (setq h (1- (window-height)))
1155       )
1156   (if (= (point) (point-min))
1157       (let ((f (assq mime-view-original-major-mode
1158                      mime-view-over-to-previous-method-alist)))
1159         (if f
1160             (funcall (cdr f))
1161           ))
1162     (let (point)
1163       (save-excursion
1164         (catch 'tag
1165           (while (> (point) 1)
1166             (if (setq point
1167                       (previous-single-property-change (point)
1168                                                        'mime-view-cinfo))
1169                 (throw 'tag t)
1170               )
1171             (backward-char)
1172             )
1173           (setq point (point-min))
1174           ))
1175       (forward-line (- h))
1176       (if (< (point) point)
1177           (goto-char point)
1178         ))))
1179
1180 (defun mime-view-next-line-content ()
1181   (interactive)
1182   (mime-view-scroll-up-entity 1)
1183   )
1184
1185 (defun mime-view-previous-line-content ()
1186   (interactive)
1187   (mime-view-scroll-down-entity 1)
1188   )
1189
1190
1191 ;;; @@ quitting
1192 ;;;
1193
1194 (defun mime-view-quit ()
1195   "Quit from MIME-View buffer.
1196 It calls function registered in variable
1197 `mime-view-quitting-method-alist'."
1198   (interactive)
1199   (let ((r (assq mime-view-original-major-mode
1200                  mime-view-quitting-method-alist)))
1201     (if r
1202         (funcall (cdr r))
1203       )))
1204
1205 (defun mime-view-show-summary ()
1206   "Show summary.
1207 It calls function registered in variable
1208 `mime-view-show-summary-method'."
1209   (interactive)
1210   (let ((r (assq mime-view-original-major-mode
1211                  mime-view-show-summary-method)))
1212     (if r
1213         (funcall (cdr r))
1214       )))
1215
1216 (defun mime-view-kill-buffer ()
1217   (interactive)
1218   (kill-buffer (current-buffer))
1219   )
1220
1221
1222 ;;; @ end
1223 ;;;
1224
1225 (provide 'mime-view)
1226
1227 (run-hooks 'mime-view-load-hook)
1228
1229 ;;; mime-view.el ends here