mime-view.el

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