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