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