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