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