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