mime-view.el

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