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   (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 (defcustom mime-preview-move-scroll nil
  66   "*Decides whether to scroll when moving to next entity.
  67 When t, scroll the buffer. Non-nil but not t means scroll when
  68 the next entity is within next-screen-context-lines from top or
  69 buttom. Nil means don't scroll at all."
  70   :group 'mime-view
  71   :type '(choice (const :tag "Off" nil)
  72                  (const :tag "On" t)
  73                  (sexp :tag "Situation" 1)))
  74
  75 (defcustom mime-preview-scroll-full-screen nil
  76   "*When non-nil, always scroll full screen.
  77 If nil, point will be moved to the next entity if exists."
  78   :group 'mime-view
  79   :type '(choice (const :tag "On" t)
  80                  (const :tag "Off" nil)))
  81
  82 (defcustom mime-view-force-inline-types '(text multipart)
  83   "*List of MIME types that \"attachment\" should be ignored.
  84 The element can be type or type/subtype. When t, inline everything
  85 if possible."
  86   :group 'mime-view
  87   :type '(choice (const :tag "Nothing" nil)
  88                  (const :tag "All" t)
  89                  (list (repeat symbol))))
  90
  91 (defcustom mime-view-button-place-alist
  92   '((message . around)
  93     (application . before)
  94     (multipart/alternative . around))
  95   "*Alist of MIME type or type/subtype vs. button place.
  96 When around, button will be inserted before and after that part.
  97 When after or before, button will be inserted that place.
  98 If not specified, that type will not have button."
  99   :group 'mime-view
 100   :type '(choice (const :tag "Nothing" nil)
 101                  (list (repeat symbol))))
 102
 103 ;; Rename this.
 104 (defcustom mime-view-type-subtype-score-alist
 105   '(((text . enriched) . 3)
 106     ((text . richtext) . 2)
 107     ((text . plain)    . 1)
 108     (t . 0))
 109   "Alist MEDIA-TYPE vs corresponding score.
 110 MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t.  t means default."
 111   :group 'mime-view
 112   :type '(repeat (cons (choice :tag "Media-Type"
 113                                (cons :tag "Type/Subtype"
 114                                      (symbol :tag "Primary-type")
 115                                      (symbol :tag "Subtype"))
 116                                (symbol :tag "Type")
 117                                (const :tag "Default" t))
 118                        integer)))
 119
 120 ;;; @ in raw-buffer (representation space)
 121 ;;;
 122
 123 (defvar mime-preview-buffer nil
 124   "MIME-preview buffer corresponding with the (raw) buffer.")
 125 (make-variable-buffer-local 'mime-preview-buffer)
 126
 127
 128 (defvar mime-raw-representation-type-alist
 129   '((mime-show-message-mode     . binary)
 130     (mime-temp-message-mode     . binary)
 131     (t                          . cooked)
 132     )
 133   "Alist of major-mode vs. representation-type of mime-raw-buffer.
 134 Each element looks like (SYMBOL . REPRESENTATION-TYPE).  SYMBOL is
 135 major-mode or t.  t means default.  REPRESENTATION-TYPE must be
 136 `binary' or `cooked'.")
 137
 138
 139 ;; (defun mime-raw-find-entity-from-point (point &optional message-info)
 140 ;;   "Return entity from POINT in mime-raw-buffer.
 141 ;; If optional argument MESSAGE-INFO is not specified,
 142 ;; `mime-message-structure' is used."
 143 ;;   (or message-info
 144 ;;       (setq message-info mime-message-structure))
 145 ;;   (if (and (<= (mime-entity-point-min message-info) point)
 146 ;;            (<= point (mime-entity-point-max message-info)))
 147 ;;       (let ((children (mime-entity-children message-info)))
 148 ;;         (catch 'tag
 149 ;;           (while children
 150 ;;             (let ((ret
 151 ;;                    (mime-raw-find-entity-from-point point (car children))))
 152 ;;               (if ret
 153 ;;                   (throw 'tag ret)
 154 ;;                 ))
 155 ;;             (setq children (cdr children)))
 156 ;;           message-info))))
 157 ;; (make-obsolete 'mime-raw-find-entity-from-point "don't use it.")
 158
 159
 160 ;;; @ in preview-buffer (presentation space)
 161 ;;;
 162
 163 (defvar mime-mother-buffer nil
 164   "Mother buffer corresponding with the (MIME-preview) buffer.
 165 If current MIME-preview buffer is generated by other buffer, such as
 166 message/partial, it is called `mother-buffer'.")
 167 (make-variable-buffer-local 'mime-mother-buffer)
 168
 169 ;; (defvar mime-raw-buffer nil
 170 ;;   "Raw buffer corresponding with the (MIME-preview) buffer.")
 171 ;; (make-variable-buffer-local 'mime-raw-buffer)
 172
 173 (defvar mime-preview-original-window-configuration nil
 174   "Window-configuration before mime-view-mode is called.")
 175 (make-variable-buffer-local 'mime-preview-original-window-configuration)
 176
 177 (defun mime-preview-original-major-mode (&optional recursive point)
 178   "Return major-mode of original buffer.
 179 If optional argument RECURSIVE is non-nil and current buffer has
 180 mime-mother-buffer, it returns original major-mode of the
 181 mother-buffer."
 182   (if (and recursive mime-mother-buffer)
 183       (save-excursion
 184         (set-buffer mime-mother-buffer)
 185         (mime-preview-original-major-mode recursive)
 186         )
 187     (cdr (assq 'major-mode
 188                (get-text-property (or point
 189                                       (if (> (point) (buffer-size))
 190                                           (max (1- (point-max)) (point-min))
 191                                         (point)))
 192                                   'mime-view-situation)))))
 193
 194
 195 ;;; @ entity information
 196 ;;;
 197
 198 (defun mime-entity-situation (entity &optional situation)
 199   "Return situation of ENTITY."
 200   (let (rest param name)
 201     ;; Content-Type
 202     (unless (assq 'type situation)
 203       (setq rest (or (mime-entity-content-type entity)
 204                      (make-mime-content-type 'text 'plain))
 205             situation (cons (car rest) situation)
 206             rest (cdr rest))
 207       )
 208     (unless (assq 'subtype situation)
 209       (or rest
 210           (setq rest (or (cdr (mime-entity-content-type entity))
 211                          '((subtype . plain)))))
 212       (setq situation (cons (car rest) situation)
 213             rest (cdr rest))
 214       )
 215     (while rest
 216       (setq param (car rest))
 217       (or (assoc (car param) situation)
 218           (setq situation (cons param situation)))
 219       (setq rest (cdr rest)))
 220
 221     ;; Content-Disposition
 222     (setq rest nil)
 223     (unless (assq 'disposition-type situation)
 224       (setq rest (mime-entity-content-disposition entity))
 225       (if rest
 226           (setq situation (cons (cons 'disposition-type
 227                                       (mime-content-disposition-type rest))
 228                                 situation)
 229                 rest (mime-content-disposition-parameters rest))
 230         ))
 231     (while rest
 232       (setq param (car rest)
 233             name (car param))
 234       (if (cond ((string= name "filename")
 235                  (if (assq 'filename situation)
 236                      nil
 237                    (setq name 'filename)))
 238                 ((string= name "creation-date")
 239                  (if (assq 'creation-date situation)
 240                      nil
 241                    (setq name 'creation-date)))
 242                 ((string= name "modification-date")
 243                  (if (assq 'modification-date situation)
 244                      nil
 245                    (setq name 'modification-date)))
 246                 ((string= name "read-date")
 247                  (if (assq 'read-date situation)
 248                      nil
 249                    (setq name 'read-date)))
 250                 ((string= name "size")
 251                  (if (assq 'size situation)
 252                      nil
 253                    (setq name 'size)))
 254                 (t (setq name (cons 'disposition name))
 255                    (if (assoc name situation)
 256                        nil
 257                      name)))
 258           (setq situation
 259                 (cons (cons name (cdr param))
 260                       situation)))
 261       (setq rest (cdr rest)))
 262
 263     ;; Content-Transfer-Encoding
 264     (or (assq 'encoding situation)
 265         (setq situation
 266               (cons (cons 'encoding (or (mime-entity-encoding entity)
 267                                         "7bit"))
 268                     situation)))
 269
 270     situation))
 271
 272 (defun mime-view-entity-title (entity)
 273   (or (mime-entity-read-field entity 'Content-Description)
 274       (mime-entity-read-field entity 'Subject)
 275       (mime-entity-filename entity)
 276       ""))
 277
 278
 279 ;; (defsubst mime-raw-point-to-entity-node-id (point &optional message-info)
 280 ;;   "Return entity-node-id from POINT in mime-raw-buffer.
 281 ;; If optional argument MESSAGE-INFO is not specified,
 282 ;; `mime-message-structure' is used."
 283 ;;   (mime-entity-node-id (mime-raw-find-entity-from-point point message-info)))
 284
 285 ;; (make-obsolete 'mime-raw-point-to-entity-node-id "don't use it.")
 286
 287 ;; (defsubst mime-raw-point-to-entity-number (point &optional message-info)
 288 ;;   "Return entity-number from POINT in mime-raw-buffer.
 289 ;; If optional argument MESSAGE-INFO is not specified,
 290 ;; `mime-message-structure' is used."
 291 ;;   (mime-entity-number (mime-raw-find-entity-from-point point message-info)))
 292
 293 ;; (make-obsolete 'mime-raw-point-to-entity-number "don't use it.")
 294
 295 ;; (defun mime-raw-flatten-message-info (&optional message-info)
 296 ;;   "Return list of entity in mime-raw-buffer.
 297 ;; If optional argument MESSAGE-INFO is not specified,
 298 ;; `mime-message-structure' is used."
 299 ;;   (or message-info
 300 ;;       (setq message-info mime-message-structure))
 301 ;;   (let ((dest (list message-info))
 302 ;;         (rcl (mime-entity-children message-info)))
 303 ;;     (while rcl
 304 ;;       (setq dest (nconc dest (mime-raw-flatten-message-info (car rcl))))
 305 ;;       (setq rcl (cdr rcl)))
 306 ;;     dest))
 307
 308
 309 ;;; @ presentation of preview
 310 ;;;
 311
 312 ;;; @@ entity-button
 313 ;;;
 314
 315 ;;; @@@ predicate function
 316 ;;;
 317
 318 ;; fix flim
 319 (defun mime-view-entity-type/subtype (entity)
 320   (if (not (mime-entity-media-type entity))
 321       'text/plain
 322     (intern (format "%s/%s"
 323                     (mime-entity-media-type entity)
 324                     (mime-entity-media-subtype entity)))))
 325
 326 (defun mime-view-entity-button-visible-p (entity)
 327   "Return non-nil if header of ENTITY is visible.
 328 You can customize the visibility by changing `mime-view-button-place-alist'."
 329   (or
 330    ;; Check current entity
 331    ;; type/subtype
 332    (memq (cdr (assq (mime-view-entity-type/subtype entity)
 333                     mime-view-button-place-alist))
 334          '(around before))
 335    ;; type
 336    (memq (cdr (assq (mime-entity-media-type entity)
 337                     mime-view-button-place-alist))
 338          '(around before))
 339    (and (mime-entity-parent entity)
 340    (let ((prev-entity
 341          (cadr (memq entity
 342                      (reverse (mime-entity-children
 343                                (mime-entity-parent entity)))))))
 344      ;; When previous entity exists
 345      (and prev-entity
 346           (or
 347            ;; Check previous eneity
 348            ;; type/subtype
 349            (memq (cdr
 350                   (assq
 351                    (mime-view-entity-type/subtype prev-entity)
 352                    mime-view-button-place-alist))
 353                  '(around after))
 354            ;; type
 355            (memq (cdr
 356                   (assq
 357                    (mime-entity-media-type prev-entity)
 358                    mime-view-button-place-alist))
 359                  '(around after))))))))
 360
 361 ;;; @@@ entity button generator
 362 ;;;
 363
 364 (defun mime-view-insert-entity-button (entity &optional body-is-invisible)
 365   "Insert entity-button of ENTITY."
 366   (let ((entity-node-id (mime-entity-node-id entity))
 367         (params (mime-entity-parameters entity))
 368         (subject (mime-view-entity-title entity)))
 369     (mime-insert-button
 370      (concat
 371       (let ((access-type (assoc "access-type" params))
 372             (num (or (cdr (assoc "x-part-number" params))
 373                      (if (consp entity-node-id)
 374                          (mapconcat (function
 375                                      (lambda (num)
 376                                        (format "%s" (1+ num))
 377                                        ))
 378                                     (reverse entity-node-id) ".")
 379                        "0"))
 380                  ))
 381         (cond (access-type
 382                (let ((server (assoc "server" params)))
 383                  (setq access-type (cdr access-type))
 384                  (if server
 385                      (format "%s %s ([%s] %s)"
 386                              num subject access-type (cdr server))
 387                    (let ((site (cdr (assoc "site" params)))
 388                          (dir (cdr (assoc "directory" params)))
 389                          (url (cdr (assoc "url" params)))
 390                          )
 391                      (if url
 392                          (format "%s %s ([%s] %s)"
 393                                  num subject access-type url)
 394                        (format "%s %s ([%s] %s:%s)"
 395                                num subject access-type site dir))
 396                      )))
 397                )
 398               (t
 399                (let ((media-type (mime-entity-media-type entity))
 400                      (media-subtype (mime-entity-media-subtype entity))
 401                      (charset (cdr (assoc "charset" params)))
 402                      (encoding (mime-entity-encoding entity)))
 403                  (concat
 404                   num " " subject
 405                   (let ((rest
 406                          (format " <%s/%s%s%s>"
 407                                  media-type media-subtype
 408                                  (if charset
 409                                      (concat "; " charset)
 410                                    "")
 411                                  (if encoding
 412                                      (concat " (" encoding ")")
 413                                    ""))))
 414                     (if (>= (+ (current-column)(length rest))(window-width))
 415                         "\n\t")
 416                     rest)))
 417                )))
 418       (if body-is-invisible
 419           " ..."
 420         ""))
 421      (function mime-preview-play-current-entity))
 422     ))
 423
 424
 425 ;;; @@ entity-header
 426 ;;;
 427
 428 (defvar mime-header-presentation-method-alist nil
 429   "Alist of major mode vs. corresponding header-presentation-method functions.
 430 Each element looks like (SYMBOL . FUNCTION).
 431 SYMBOL must be major mode in raw-buffer or t.  t means default.
 432 Interface of FUNCTION must be (ENTITY SITUATION).")
 433
 434 (defvar mime-view-ignored-field-list
 435   '(".*Received:" ".*Path:" ".*Id:" "^References:"
 436     "^Replied:" "^Errors-To:"
 437     "^Lines:" "^Sender:" ".*Host:" "^Xref:"
 438     "^Content-Type:" "^Precedence:"
 439     "^Status:" "^X-VM-.*:")
 440   "All fields that match this list will be hidden in MIME preview buffer.
 441 Each elements are regexp of field-name.")
 442
 443 (defvar mime-view-visible-field-list '("^Dnas.*:" "^Message-Id:")
 444   "All fields that match this list will be displayed in MIME preview buffer.
 445 Each elements are regexp of field-name.")
 446
 447
 448 ;;; @@ entity-body
 449 ;;;
 450
 451 ;;; @@@ predicate function
 452 ;;;
 453
 454 (in-calist-package 'mime-view)
 455
 456 (defun mime-calist::field-match-method-as-default-rule (calist
 457                                                         field-type field-value)
 458   (let ((s-field (assq field-type calist)))
 459     (cond ((null s-field)
 460            (cons (cons field-type field-value) calist)
 461            )
 462           (t calist))))
 463
 464 (define-calist-field-match-method
 465   'header #'mime-calist::field-match-method-as-default-rule)
 466
 467 (define-calist-field-match-method
 468   'body #'mime-calist::field-match-method-as-default-rule)
 469
 470
 471 (defvar mime-preview-condition nil
 472   "Condition-tree about how to display entity.")
 473
 474 (ctree-set-calist-strictly
 475  'mime-preview-condition '((type . application)(subtype . t)
 476                            (encoding . nil)
 477                            (body . visible)))
 478 (ctree-set-calist-strictly
 479  'mime-preview-condition '((type . application)(subtype . t)
 480                            (encoding . "7bit")
 481                            (body . visible)))
 482 (ctree-set-calist-strictly
 483  'mime-preview-condition '((type . application)(subtype . t)
 484                            (encoding . "8bit")
 485                            (body . visible)))
 486
 487 (ctree-set-calist-strictly
 488  'mime-preview-condition '((type . application)(subtype . pgp)
 489                            (body . visible)))
 490
 491 (ctree-set-calist-strictly
 492  'mime-preview-condition '((type . application)(subtype . x-latex)
 493                            (body . visible)))
 494
 495 (ctree-set-calist-strictly
 496  'mime-preview-condition '((type . application)(subtype . x-selection)
 497                            (body . visible)))
 498
 499 (ctree-set-calist-strictly
 500  'mime-preview-condition '((type . application)(subtype . x-comment)
 501                            (body . visible)))
 502
 503 (ctree-set-calist-strictly
 504  'mime-preview-condition '((type . message)(subtype . delivery-status)
 505                            (body . visible)))
 506
 507 (ctree-set-calist-strictly
 508  'mime-preview-condition
 509  '((body . visible)
 510    (body-presentation-method . mime-display-text/plain)))
 511
 512 (ctree-set-calist-strictly
 513  'mime-preview-condition
 514  '((type . nil)
 515    (body . visible)
 516    (body-presentation-method . mime-display-text/plain)))
 517
 518 (ctree-set-calist-strictly
 519  'mime-preview-condition
 520  '((type . text)(subtype . enriched)
 521    (body . visible)
 522    (body-presentation-method . mime-display-text/enriched)))
 523
 524 (ctree-set-calist-strictly
 525  'mime-preview-condition
 526  '((type . text)(subtype . richtext)
 527    (body . visible)
 528    (body-presentation-method . mime-display-text/richtext)))
 529
 530 (ctree-set-calist-strictly
 531  'mime-preview-condition
 532  '((type . application)(subtype . x-postpet)
 533    (body . visible)
 534    (body-presentation-method . mime-display-application/x-postpet)))
 535
 536 (ctree-set-calist-strictly
 537  'mime-preview-condition
 538  '((type . text)(subtype . t)
 539    (body . visible)
 540    (body-presentation-method . mime-display-text/plain)))
 541
 542 (ctree-set-calist-strictly
 543  'mime-preview-condition
 544  '((type . text)(subtype . x-rot13-47-48)
 545    (body . visible)
 546    (body-presentation-method . mime-display-text/x-rot13-47-48)))
 547
 548 (ctree-set-calist-strictly
 549  'mime-preview-condition
 550  '((type . multipart)(subtype . alternative)
 551    (body . visible)
 552    (body-presentation-method . mime-display-multipart/alternative)))
 553
 554 (ctree-set-calist-strictly
 555  'mime-preview-condition '((type . message)(subtype . partial)
 556                            (body-presentation-method
 557                             . mime-display-message/partial-button)))
 558
 559 (ctree-set-calist-strictly
 560  'mime-preview-condition '((type . message)(subtype . rfc822)
 561                            (body-presentation-method . nil)
 562                            (childrens-situation (header . visible)
 563                                                 (entity-button . invisible))))
 564
 565 (ctree-set-calist-strictly
 566  'mime-preview-condition '((type . message)(subtype . news)
 567                            (body-presentation-method . nil)
 568                            (childrens-situation (header . visible)
 569                                                 (entity-button . invisible))))
 570
 571
 572 ;;; @@@ entity presentation
 573 ;;;
 574
 575 (defun mime-display-text/plain (entity situation)
 576   (save-restriction
 577     (narrow-to-region (point-max)(point-max))
 578     (mime-insert-text-content entity)
 579     (run-hooks 'mime-text-decode-hook)
 580     (goto-char (point-max))
 581     (if (not (eq (char-after (1- (point))) ?\n))
 582         (insert "\n")
 583       )
 584     (mime-add-url-buttons)
 585     (run-hooks 'mime-display-text/plain-hook)
 586     ))
 587
 588 (defun mime-display-text/richtext (entity situation)
 589   (save-restriction
 590     (narrow-to-region (point-max)(point-max))
 591     (mime-insert-text-content entity)
 592     (run-hooks 'mime-text-decode-hook)
 593     (let ((beg (point-min)))
 594       (remove-text-properties beg (point-max) '(face nil))
 595       (richtext-decode beg (point-max))
 596       )))
 597
 598 (defun mime-display-text/enriched (entity situation)
 599   (save-restriction
 600     (narrow-to-region (point-max)(point-max))
 601     (mime-insert-text-content entity)
 602     (run-hooks 'mime-text-decode-hook)
 603     (let ((beg (point-min)))
 604       (remove-text-properties beg (point-max) '(face nil))
 605       (enriched-decode beg (point-max))
 606       )))
 607
 608 (defun mime-display-text/x-rot13-47-48 (entity situation)
 609   (save-restriction
 610     (narrow-to-region (point-max)(point-max))
 611     (mime-insert-text-content entity)
 612     (goto-char (point-max))
 613     (if (not (eq (char-after (1- (point))) ?\n))
 614         (insert "\n"))
 615     (mule-caesar-region (point-min) (point-max))
 616     (mime-add-url-buttons)))
 617
 618 (put 'unpack 'lisp-indent-function 1)
 619 (defmacro unpack (string &rest body)
 620   `(let* ((*unpack*string* (string-as-unibyte ,string))
 621           (*unpack*index* 0))
 622      ,@body))
 623
 624 (defun unpack-skip (len)
 625   (setq *unpack*index* (+ len *unpack*index*)))
 626
 627 (defun unpack-fixed (len)
 628   (prog1
 629       (substring *unpack*string* *unpack*index* (+ *unpack*index* len))
 630     (unpack-skip len)))
 631
 632 (defun unpack-byte ()
 633   (char-int (aref (unpack-fixed 1) 0)))
 634
 635 (defun unpack-short ()
 636   (let* ((b0 (unpack-byte))
 637          (b1 (unpack-byte)))
 638     (+ (* 256 b0) b1)))
 639
 640 (defun unpack-long ()
 641   (let* ((s0 (unpack-short))
 642          (s1 (unpack-short)))
 643     (+ (* 65536 s0) s1)))
 644
 645 (defun unpack-string ()
 646   (let ((len (unpack-byte)))
 647     (unpack-fixed len)))
 648
 649 (defun unpack-string-sjis ()
 650   (decode-mime-charset-string (unpack-string) 'shift_jis))
 651
 652 (defun postpet-decode (string)
 653   (condition-case nil
 654       (unpack string
 655         (let (res)
 656           (unpack-skip 4)
 657           (set-alist 'res 'carryingcount (unpack-long))
 658           (unpack-skip 8)
 659           (set-alist 'res 'sentyear (unpack-short))
 660           (set-alist 'res 'sentmonth (unpack-short))
 661           (set-alist 'res 'sentday (unpack-short))
 662           (unpack-skip 8)
 663           (set-alist 'res 'petname (unpack-string-sjis))
 664           (set-alist 'res 'owner (unpack-string-sjis))
 665           (set-alist 'res 'pettype (unpack-fixed 4))
 666           (set-alist 'res 'health (unpack-short))
 667           (unpack-skip 2)
 668           (set-alist 'res 'sex (unpack-long))
 669           (unpack-skip 1)
 670           (set-alist 'res 'brain (unpack-byte))
 671           (unpack-skip 39)
 672           (set-alist 'res 'happiness (unpack-byte))
 673           (unpack-skip 14)
 674           (set-alist 'res 'petbirthyear (unpack-short))
 675           (set-alist 'res 'petbirthmonth (unpack-short))
 676           (set-alist 'res 'petbirthday (unpack-short))
 677           (unpack-skip 8)
 678           (set-alist 'res 'from (unpack-string))
 679           (unpack-skip 5)
 680           (unpack-skip 160)
 681           (unpack-skip 4)
 682           (unpack-skip 8)
 683           (unpack-skip 8)
 684           (unpack-skip 26)
 685           (set-alist 'res 'treasure (unpack-short))
 686           (set-alist 'res 'money (unpack-long))
 687           res))
 688     (error nil)))
 689
 690 (defun mime-display-application/x-postpet (entity situation)
 691   (save-restriction
 692     (narrow-to-region (point-max)(point-max))
 693     (let ((pet (postpet-decode (mime-entity-content entity))))
 694       (if pet
 695           (insert "Petname: " (cdr (assq 'petname pet)) "\n"
 696                   "Owner: " (cdr (assq 'owner pet)) "\n"
 697                   "Pettype: " (cdr (assq 'pettype pet)) "\n"
 698                   "From: " (cdr (assq 'from pet)) "\n"
 699                   "CarryingCount: " (int-to-string (cdr (assq 'carryingcount pet))) "\n"
 700                   "SentYear: " (int-to-string (cdr (assq 'sentyear pet))) "\n"
 701                   "SentMonth: " (int-to-string (cdr (assq 'sentmonth pet))) "\n"
 702                   "SentDay: " (int-to-string (cdr (assq 'sentday pet))) "\n"
 703                   "PetbirthYear: " (int-to-string (cdr (assq 'petbirthyear pet))) "\n"
 704                   "PetbirthMonth: " (int-to-string (cdr (assq 'petbirthmonth pet))) "\n"
 705                   "PetbirthDay: " (int-to-string (cdr (assq 'petbirthday pet))) "\n"
 706                   "Health: " (int-to-string (cdr (assq 'health pet))) "\n"
 707                   "Sex: " (int-to-string (cdr (assq 'sex pet))) "\n"
 708                   "Brain: " (int-to-string (cdr (assq 'brain pet))) "\n"
 709                   "Happiness: " (int-to-string (cdr (assq 'happiness pet))) "\n"
 710                   "Treasure: " (int-to-string (cdr (assq 'treasure pet))) "\n"
 711                   "Money: " (int-to-string (cdr (assq 'money pet))) "\n"
 712                   )
 713         (insert "Invalid format\n"))
 714       (run-hooks 'mime-display-application/x-postpet-hook))))
 715
 716
 717 (defvar mime-view-announcement-for-message/partial
 718   (if (and (>= emacs-major-version 19) window-system)
 719       "\
 720 \[[ This is message/partial style split message. ]]
 721 \[[ Please press `v' key in this buffer          ]]
 722 \[[ or click here by mouse button-2.             ]]"
 723     "\
 724 \[[ This is message/partial style split message. ]]
 725 \[[ Please press `v' key in this buffer.         ]]"
 726     ))
 727
 728 (defun mime-display-message/partial-button (&optional entity situation)
 729   (save-restriction
 730     (goto-char (point-max))
 731     (if (not (search-backward "\n\n" nil t))
 732         (insert "\n")
 733       )
 734     (goto-char (point-max))
 735     (narrow-to-region (point-max)(point-max))
 736     (insert mime-view-announcement-for-message/partial)
 737     (mime-add-button (point-min)(point-max)
 738                      #'mime-preview-play-current-entity)
 739     ))
 740
 741 (defun mime-display-multipart/mixed (entity situation)
 742   (let ((children (mime-entity-children entity))
 743         (original-major-mode-cell (assq 'major-mode situation))
 744         (default-situation
 745           (cdr (assq 'childrens-situation situation))))
 746     (if original-major-mode-cell
 747         (setq default-situation
 748               (cons original-major-mode-cell default-situation)))
 749     (while children
 750       (mime-display-entity (car children) nil default-situation)
 751       (setq children (cdr children))
 752       )))
 753
 754 (defun mime-display-multipart/alternative (entity situation)
 755   (let* ((children (mime-entity-children entity))
 756          (original-major-mode-cell (assq 'major-mode situation))
 757          (default-situation
 758            (cdr (assq 'childrens-situation situation)))
 759          (i 0)
 760          (p 0)
 761          (max-score 0)
 762          situations)
 763     (if original-major-mode-cell
 764         (setq default-situation
 765               (cons original-major-mode-cell default-situation)))
 766     (setq situations
 767           (mapcar (function
 768                    (lambda (child)
 769                      (let ((situation
 770                             (or (ctree-match-calist
 771                                  mime-preview-condition
 772                                  (append (mime-entity-situation child)
 773                                          default-situation))
 774                                 default-situation)))
 775                        (if (cdr (assq 'body-presentation-method situation))
 776                            (let ((score
 777                                   (cdr
 778                                    (or (assoc
 779                                         (cons
 780                                          (cdr (assq 'type situation))
 781                                          (cdr (assq 'subtype situation)))
 782                                         mime-view-type-subtype-score-alist)
 783                                        (assq
 784                                         (cdr (assq 'type situation))
 785                                         mime-view-type-subtype-score-alist)
 786                                        (assq
 787                                         t
 788                                         mime-view-type-subtype-score-alist)
 789                                        ))))
 790                              (if (> score max-score)
 791                                  (setq p i
 792                                        max-score score)
 793                                )))
 794                        (setq i (1+ i))
 795                        situation)
 796                      ))
 797                   children))
 798     (setq i 0)
 799     (while children
 800       (let ((child (car children))
 801             (situation (car situations)))
 802         (mime-display-entity child (if (= i p)
 803                                        situation
 804                                      (del-alist 'body-presentation-method
 805                                                 (copy-alist situation))))
 806         )
 807       (setq children (cdr children)
 808             situations (cdr situations)
 809             i (1+ i))
 810       )))
 811
 812 (defun mime-preview-inline ()
 813   "View part as text without code conversion"
 814   (interactive)
 815   (let ((inhibit-read-only t)
 816         (entity (get-text-property (point) 'mime-view-entity))
 817         (situation (get-text-property (point) 'mime-view-situation))
 818         start end)
 819     (when (and entity
 820                (not (get-text-property (point) 'mime-view-entity-header))
 821                (not (memq (mime-entity-media-type entity)
 822                           '(multipart message))))
 823       (setq start (or (and (not (mime-entity-parent entity))
 824                            (1+ (previous-single-property-change
 825                                 (point)
 826                                 'mime-view-entity-header)))
 827                       (and (not (eq (point) (point-min)))
 828                            (not (eq (get-text-property (1- (point))
 829                                                        'mime-view-entity)
 830                                     entity))
 831                            (point))
 832                       (previous-single-property-change (point)
 833                                                    'mime-view-entity)
 834                       (point)))
 835       (delete-region start
 836                      (1-
 837                       (or (next-single-property-change (point)
 838                                                        'mime-view-entity)
 839                           (point-max))))
 840       (setq start (point))
 841       (if (mime-view-entity-button-visible-p entity)
 842           (mime-view-insert-entity-button entity))
 843       (insert (mime-entity-content entity))
 844       (if (and (bolp) (eolp))
 845           (delete-char 1)
 846         (forward-char 1))
 847       (add-text-properties start (point)
 848                            (list 'mime-view-entity entity
 849                                  'mime-view-situation situation))
 850       (goto-char start))))
 851
 852 (defun mime-preview-text (&optional ask-coding)
 853   "View part as text. MIME charset will be guessed automatically.
 854 With prefix, it prompts for coding-system."
 855   (interactive "P")
 856   (let ((inhibit-read-only t)
 857         (entity (get-text-property (point) 'mime-view-entity))
 858         (situation (get-text-property (point) 'mime-view-situation))
 859         (coding (if ask-coding
 860                     (or (read-coding-system "Coding system: ")
 861                         'undecided)
 862                   'undecided)))
 863     (when (and entity
 864                (not (get-text-property (point) 'mime-view-entity-header))
 865                (not (memq (mime-entity-media-type entity)
 866                           '(multipart message))))
 867       (setq start (or (and (not (mime-entity-parent entity))
 868                            (1+ (previous-single-property-change
 869                                 (point)
 870                                 'mime-view-entity-header)))
 871                       (and (not (eq (point) (point-min)))
 872                            (not (eq (get-text-property (1- (point))
 873                                                        'mime-view-entity)
 874                                     entity))
 875                            (point))
 876                       (previous-single-property-change (point)
 877                                                        'mime-view-entity)
 878                       (point)))
 879       (delete-region start
 880                      (1-
 881                       (or (next-single-property-change (point)
 882                                                        'mime-view-entity)
 883                           (point-max))))
 884       (setq start (point))
 885       (if (mime-view-entity-button-visible-p entity)
 886           (mime-view-insert-entity-button entity))
 887       (insert (decode-coding-string (mime-entity-content entity) coding))
 888       (if (and (bolp) (eolp))
 889           (delete-char 1)
 890         (forward-char 1))
 891       (add-text-properties start (point)
 892                            (list 'mime-view-entity entity
 893                                  'mime-view-situation situation))
 894       (goto-char start))))
 895
 896
 897 (defun mime-preview-type ()
 898   "View part as text without code conversion"
 899   (interactive)
 900   (let ((inhibit-read-only t)
 901         (entity (get-text-property (point) 'mime-view-entity))
 902         (situation (get-text-property (point) 'mime-view-situation))
 903         (mime-view-force-inline-types t)
 904         start end)
 905     (when (and entity
 906                (not (get-text-property (point) 'mime-view-entity-header))
 907                (not (memq (mime-entity-media-type entity)
 908                           '(multipart message))))
 909       (setq start (or (and (not (mime-entity-parent entity))
 910                            (1+ (previous-single-property-change
 911                                 (point)
 912                                'mime-view-entity-header)))
 913                       (and (not (eq (point) (point-min)))
 914                            (not (eq (get-text-property (1- (point))
 915                                                        'mime-view-entity)
 916                                     entity))
 917                            (point))
 918                       (previous-single-property-change (point)
 919                                                    'mime-view-entity)
 920                       (point)))
 921       (delete-region start
 922                      (1-
 923                       (or (next-single-property-change (point)
 924                                                        'mime-view-entity)
 925                           (point-max))))
 926       (save-excursion
 927         (save-restriction
 928           (narrow-to-region (point) (point))
 929           (mime-display-entity entity (if (eq (assq 'body situation)
 930                                               'invisible)
 931                                           situation
 932                                         (put-alist 'body 'visible
 933                                                    situation))))
 934         (if (and (bolp) (eolp))
 935               (delete-char 1))))))
 936
 937 (defun mime-preview-buttonize ()
 938   (interactive)
 939   (save-excursion
 940     (goto-char (point-min))
 941     (let ((inhibit-read-only t)
 942           point)
 943       (while (setq point (next-single-property-change
 944                           (point) 'mime-view-entity))
 945         (goto-char point)
 946         (unless (get-text-property (point) 'mime-button-callback)
 947           (mime-view-insert-entity-button
 948            (get-text-property (point) 'mime-view-entity)))))))
 949
 950 (defun mime-preview-unbuttonize ()
 951   (interactive)
 952   (save-excursion
 953     (goto-char (point-min))
 954     (let ((inhibit-read-only t)
 955           point)
 956       (while (setq point (next-single-property-change
 957                           (point) 'mime-view-entity))
 958         (goto-char point)
 959         (if (get-text-property (point) 'mime-button-callback)
 960             (delete-region (point) (save-excursion
 961                                      (goto-char
 962                                       (next-single-property-change
 963                                        (point) 'mime-button-callback)))))))))
 964
 965
 966 ;;; @ acting-condition
 967 ;;;
 968
 969 (defvar mime-acting-condition nil
 970   "Condition-tree about how to process entity.")
 971
 972 (if (file-readable-p mailcap-file)
 973     (let ((entries (mailcap-parse-file)))
 974       (while entries
 975         (let ((entry (car entries))
 976               view print shared)
 977           (while entry
 978             (let* ((field (car entry))
 979                    (field-type (car field)))
 980               (cond ((eq field-type 'view)  (setq view field))
 981                     ((eq field-type 'print) (setq print field))
 982                     ((memq field-type '(compose composetyped edit)))
 983                     (t (setq shared (cons field shared))))
 984               )
 985             (setq entry (cdr entry))
 986             )
 987           (setq shared (nreverse shared))
 988           (ctree-set-calist-with-default
 989            'mime-acting-condition
 990            (append shared (list '(mode . "play")(cons 'method (cdr view)))))
 991           (if print
 992               (ctree-set-calist-with-default
 993                'mime-acting-condition
 994                (append shared
 995                        (list '(mode . "print")(cons 'method (cdr view))))
 996                ))
 997           )
 998         (setq entries (cdr entries))
 999         )))
1000
1001 (ctree-set-calist-strictly
1002  'mime-acting-condition
1003  '((type . application)(subtype . octet-stream)
1004    (mode . "play")
1005    (method . mime-detect-content)
1006    ))
1007
1008 (ctree-set-calist-with-default
1009  'mime-acting-condition
1010  '((mode . "extract")
1011    (method . mime-save-content)))
1012
1013 (ctree-set-calist-strictly
1014  'mime-acting-condition
1015  '((type . text)(subtype . x-rot13-47)(mode . "play")
1016    (method . mime-view-caesar)
1017    ))
1018 (ctree-set-calist-strictly
1019  'mime-acting-condition
1020  '((type . text)(subtype . x-rot13-47-48)(mode . "play")
1021    (method . mime-view-caesar)
1022    ))
1023
1024 (ctree-set-calist-strictly
1025  'mime-acting-condition
1026  '((type . message)(subtype . rfc822)(mode . "play")
1027    (method . mime-view-message/rfc822)
1028    ))
1029 (ctree-set-calist-strictly
1030  'mime-acting-condition
1031  '((type . message)(subtype . partial)(mode . "play")
1032    (method . mime-store-message/partial-piece)
1033    ))
1034
1035 (ctree-set-calist-strictly
1036  'mime-acting-condition
1037  '((type . message)(subtype . external-body)
1038    ("access-type" . "anon-ftp")
1039    (method . mime-view-message/external-anon-ftp)
1040    ))
1041
1042 (ctree-set-calist-strictly
1043  'mime-acting-condition
1044  '((type . message)(subtype . external-body)
1045    ("access-type" . "url")
1046    (method . mime-view-message/external-url)
1047    ))
1048
1049 (ctree-set-calist-strictly
1050  'mime-acting-condition
1051  '((type . application)(subtype . octet-stream)
1052    (method . mime-save-content)
1053    ))
1054
1055
1056 ;;; @ quitting method
1057 ;;;
1058
1059 (defvar mime-preview-quitting-method-alist
1060   '((mime-show-message-mode
1061      . mime-preview-quitting-method-for-mime-show-message-mode))
1062   "Alist of major-mode vs. quitting-method of mime-view.")
1063
1064 (defvar mime-preview-over-to-previous-method-alist nil
1065   "Alist of major-mode vs. over-to-previous-method of mime-view.")
1066
1067 (defvar mime-preview-over-to-next-method-alist nil
1068   "Alist of major-mode vs. over-to-next-method of mime-view.")
1069
1070
1071 ;;; @ following method
1072 ;;;
1073
1074 (defvar mime-preview-following-method-alist nil
1075   "Alist of major-mode vs. following-method of mime-view.")
1076
1077 (defvar mime-view-following-required-fields-list
1078   '("From"))
1079
1080
1081 ;;; @ buffer setup
1082 ;;;
1083
1084 (defun mime-display-entity (entity &optional situation
1085                                    default-situation preview-buffer)
1086   (or preview-buffer
1087       (setq preview-buffer (current-buffer)))
1088   (let (e nb ne nhb nbb)
1089     (mime-goto-header-start-point entity)
1090     (in-calist-package 'mime-view)
1091     (or situation
1092         (setq situation
1093               (or (ctree-match-calist mime-preview-condition
1094                                       (append (mime-entity-situation entity)
1095                                               default-situation))
1096                   default-situation)))
1097     (let ((button-is-invisible
1098            (or (eq (cdr (assq 'entity-button situation)) 'invisible)
1099                (not (mime-view-entity-button-visible-p entity))))
1100            (header-is-visible
1101             (eq (cdr (assq 'header situation)) 'visible))
1102            (header-presentation-method
1103             (or (cdr (assq 'header-presentation-method situation))
1104                 (cdr (assq (cdr (assq 'major-mode situation))
1105                            mime-header-presentation-method-alist))))
1106            (body-is-visible
1107             (eq (cdr (assq 'body situation)) 'visible))
1108            (body-presentation-method
1109             (cdr (assq 'body-presentation-method situation)))
1110            (children (mime-entity-children entity)))
1111       ;; Check if attachment is specified.
1112       ;; if inline is forced or not.
1113       (if (not (or (eq t mime-view-force-inline-types)
1114                    (memq (mime-entity-media-type entity)
1115                          mime-view-force-inline-types)
1116                    (memq (mime-view-entity-type/subtype entity)
1117                          mime-view-force-inline-types)
1118                    ;; whether Content-Disposition header exists.
1119                    (not (and
1120                          (mime-entity-content-disposition entity)
1121                          (eq 'inline
1122                              (mime-content-disposition-type
1123                               (mime-entity-content-disposition entity)))))))
1124           ;; This is attachment
1125           (setq header-is-visible nil
1126                 body-is-visible nil))
1127       (set-buffer preview-buffer)
1128       (setq nb (point))
1129       (save-restriction
1130         (narrow-to-region nb nb)
1131         (or button-is-invisible
1132             (if (mime-view-entity-button-visible-p entity)
1133                 (mime-view-insert-entity-button entity
1134                                                 ;; work around composite type
1135                                                 (not (or children
1136                                                          body-is-visible)))))
1137         (when header-is-visible
1138           (setq nhb (point))
1139           (if header-presentation-method
1140               (funcall header-presentation-method entity situation)
1141             (mime-insert-header entity
1142                                 mime-view-ignored-field-list
1143                                 mime-view-visible-field-list))
1144           (run-hooks 'mime-display-header-hook)
1145           (put-text-property nhb (point-max) 'mime-view-entity-header entity)
1146           (goto-char (point-max))
1147           (insert "\n"))
1148         (setq nbb (point))
1149         (cond (children)
1150               ((and body-is-visible
1151                     (functionp body-presentation-method))
1152                (funcall body-presentation-method entity situation))
1153               (t
1154                (when button-is-invisible
1155                  (goto-char (point-max))
1156                  (mime-view-insert-entity-button entity
1157                                                  ;; work around composite type
1158                                                  (not (or children
1159                                                           body-is-visible))))
1160                (or header-is-visible
1161                    (progn
1162                      (goto-char (point-max))
1163                      (insert "\n")
1164                      ))
1165                ))
1166         (setq ne (point-max)))
1167       (put-text-property nb ne 'mime-view-entity entity)
1168       (put-text-property nb ne 'mime-view-situation situation)
1169       (put-text-property nbb ne 'mime-view-entity-body entity)
1170       (goto-char ne)
1171       (if children
1172           (if (functionp body-presentation-method)
1173               (funcall body-presentation-method entity situation)
1174             (mime-display-multipart/mixed entity situation))))))
1175
1176
1177 ;;; @ MIME viewer mode
1178 ;;;
1179
1180 (defconst mime-view-menu-title "MIME-View")
1181 (defconst mime-view-menu-list
1182   '((up          "Move to upper entity"    mime-preview-move-to-upper)
1183     (previous    "Move to previous entity" mime-preview-move-to-previous)
1184     (next        "Move to next entity"     mime-preview-move-to-next)
1185     (scroll-down "Scroll-down"             mime-preview-scroll-down-entity)
1186     (scroll-up   "Scroll-up"               mime-preview-scroll-up-entity)
1187     (play        "Play current entity"     mime-preview-play-current-entity)
1188     (extract     "Extract current entity"  mime-preview-extract-current-entity)
1189     (print       "Print current entity"    mime-preview-print-current-entity)
1190     (raw "View text without code conversion" mime-preview-inline)
1191     (text "View text with code conversion" mime-preview-text)
1192     (type "View internally as type" mime-preview-type)
1193     )
1194   "Menu for MIME Viewer")
1195
1196 (cond ((featurep 'xemacs)
1197        (defvar mime-view-xemacs-popup-menu
1198          (cons mime-view-menu-title
1199                (mapcar (function
1200                         (lambda (item)
1201                           (vector (nth 1 item)(nth 2 item) t)
1202                           ))
1203                        mime-view-menu-list)))
1204        (defun mime-view-xemacs-popup-menu (event)
1205          "Popup the menu in the MIME Viewer buffer"
1206          (interactive "e")
1207          (select-window (event-window event))
1208          (set-buffer (event-buffer event))
1209          (popup-menu 'mime-view-xemacs-popup-menu))
1210        (defvar mouse-button-2 'button2)
1211        )
1212       (t
1213        (defvar mouse-button-2 [mouse-2])
1214        ))
1215
1216 (defun mime-view-define-keymap (&optional default)
1217   (let ((mime-view-mode-map (if (keymapp default)
1218                                 (copy-keymap default)
1219                               (make-sparse-keymap)
1220                               )))
1221     (define-key mime-view-mode-map
1222       "u"        (function mime-preview-move-to-upper))
1223     (define-key mime-view-mode-map
1224       "p"        (function mime-preview-move-to-previous))
1225     (define-key mime-view-mode-map
1226       "n"        (function mime-preview-move-to-next))
1227     (define-key mime-view-mode-map
1228       "\e\t"     (function mime-preview-move-to-previous))
1229     (define-key mime-view-mode-map
1230       "\t"       (function mime-preview-move-to-next))
1231     (define-key mime-view-mode-map
1232       " "        (function mime-preview-scroll-up-entity))
1233     (define-key mime-view-mode-map
1234       "\M- "     (function mime-preview-scroll-down-entity))
1235     (define-key mime-view-mode-map
1236       "\177"     (function mime-preview-scroll-down-entity))
1237     (define-key mime-view-mode-map
1238       "\C-m"     (function mime-preview-next-line-entity))
1239     (define-key mime-view-mode-map
1240       "\C-\M-m"  (function mime-preview-previous-line-entity))
1241     (define-key mime-view-mode-map
1242       "v"        (function mime-preview-play-current-entity))
1243     (define-key mime-view-mode-map
1244       "e"        (function mime-preview-extract-current-entity))
1245     (define-key mime-view-mode-map
1246       "i"        (function mime-preview-inline))
1247     (define-key mime-view-mode-map
1248       "c"        (function mime-preview-text))
1249     (define-key mime-view-mode-map
1250       "t"        (function mime-preview-type))
1251     (define-key mime-view-mode-map
1252       "b"        (function mime-preview-buttonize))
1253     (define-key mime-view-mode-map
1254       "B"        (function mime-preview-unbuttonize))
1255     (define-key mime-view-mode-map
1256       "\C-c\C-p" (function mime-preview-print-current-entity))
1257     (define-key mime-view-mode-map
1258       "a"        (function mime-preview-follow-current-entity))
1259     (define-key mime-view-mode-map
1260       "q"        (function mime-preview-quit))
1261     (define-key mime-view-mode-map
1262       "\C-c\C-x" (function mime-preview-kill-buffer))
1263     ;; (define-key mime-view-mode-map
1264     ;;   "<"        (function beginning-of-buffer))
1265     ;; (define-key mime-view-mode-map
1266     ;;   ">"        (function end-of-buffer))
1267     (define-key mime-view-mode-map
1268       "?"        (function describe-mode))
1269     (define-key mime-view-mode-map
1270       [tab] (function mime-preview-move-to-next))
1271     (define-key mime-view-mode-map
1272       [delete] (function mime-preview-scroll-down-entity))
1273     (define-key mime-view-mode-map
1274       [backspace] (function mime-preview-scroll-down-entity))
1275     (if (functionp default)
1276         (cond ((featurep 'xemacs)
1277                (set-keymap-default-binding mime-view-mode-map default)
1278                )
1279               (t
1280                (setq mime-view-mode-map
1281                      (append mime-view-mode-map (list (cons t default))))
1282                )))
1283     (if mouse-button-2
1284         (define-key mime-view-mode-map
1285           mouse-button-2 (function mime-button-dispatcher))
1286       )
1287     (cond ((featurep 'xemacs)
1288            (define-key mime-view-mode-map
1289              mouse-button-3 (function mime-view-xemacs-popup-menu))
1290            )
1291           ((>= emacs-major-version 19)
1292            (define-key mime-view-mode-map [menu-bar mime-view]
1293              (cons mime-view-menu-title
1294                    (make-sparse-keymap mime-view-menu-title)))
1295            (mapcar (function
1296                     (lambda (item)
1297                       (define-key mime-view-mode-map
1298                         (vector 'menu-bar 'mime-view (car item))
1299                         (cons (nth 1 item)(nth 2 item))
1300                         )
1301                       ))
1302                    (reverse mime-view-menu-list)
1303                    )
1304            ))
1305     (use-local-map mime-view-mode-map)
1306     (run-hooks 'mime-view-define-keymap-hook)
1307     ))
1308
1309 (defsubst mime-maybe-hide-echo-buffer ()
1310   "Clear mime-echo buffer and delete window for it."
1311   (let ((buf (get-buffer mime-echo-buffer-name)))
1312     (if buf
1313         (save-excursion
1314           (set-buffer buf)
1315           (erase-buffer)
1316           (let ((win (get-buffer-window buf)))
1317             (if win
1318                 (delete-window win)
1319               ))
1320           (bury-buffer buf)
1321           ))))
1322
1323 (defvar mime-view-redisplay nil)
1324
1325 ;;;###autoload
1326 (defun mime-display-message (message &optional preview-buffer
1327                                      mother default-keymap-or-function
1328                                      original-major-mode)
1329   "View MESSAGE in MIME-View mode.
1330
1331 Optional argument PREVIEW-BUFFER specifies the buffer of the
1332 presentation.  It must be either nil or a name of preview buffer.
1333
1334 Optional argument MOTHER specifies mother-buffer of the preview-buffer.
1335
1336 Optional argument DEFAULT-KEYMAP-OR-FUNCTION is nil, keymap or
1337 function.  If it is a keymap, keymap of MIME-View mode will be added
1338 to it.  If it is a function, it will be bound as default binding of
1339 keymap of MIME-View mode."
1340   (mime-maybe-hide-echo-buffer)
1341   (let ((win-conf (current-window-configuration)))
1342     (or preview-buffer
1343         (setq preview-buffer
1344               (concat "*Preview-" (mime-entity-name message) "*")))
1345     (or original-major-mode
1346         (setq original-major-mode
1347               (with-current-buffer (mime-entity-header-buffer message)
1348                 major-mode)))
1349     (let ((inhibit-read-only t))
1350       (set-buffer (get-buffer-create preview-buffer))
1351       (widen)
1352       (erase-buffer)
1353       (if mother
1354           (setq mime-mother-buffer mother)
1355         )
1356       (setq mime-preview-original-window-configuration win-conf)
1357       (setq major-mode 'mime-view-mode)
1358       (setq mode-name "MIME-View")
1359       (mime-display-entity message nil
1360                            `((entity-button . invisible)
1361                              (header . visible)
1362                              (major-mode . ,original-major-mode))
1363                            preview-buffer)
1364       (mime-view-define-keymap default-keymap-or-function)
1365       (let ((point
1366              (next-single-property-change (point-min) 'mime-view-entity)))
1367         (if point
1368             (goto-char point)
1369           (goto-char (point-min))
1370           (search-forward "\n\n" nil t)
1371           ))
1372       (run-hooks 'mime-view-mode-hook)
1373       (set-buffer-modified-p nil)
1374       (setq buffer-read-only t)
1375       preview-buffer)))
1376
1377 ;;;###autoload
1378 (defun mime-view-buffer (&optional raw-buffer preview-buffer mother
1379                                    default-keymap-or-function
1380                                    representation-type)
1381   "View RAW-BUFFER in MIME-View mode.
1382 Optional argument PREVIEW-BUFFER is either nil or a name of preview
1383 buffer.
1384 Optional argument DEFAULT-KEYMAP-OR-FUNCTION is nil, keymap or
1385 function.  If it is a keymap, keymap of MIME-View mode will be added
1386 to it.  If it is a function, it will be bound as default binding of
1387 keymap of MIME-View mode.
1388 Optional argument REPRESENTATION-TYPE is representation-type of
1389 message.  It must be nil, `binary' or `cooked'.  If it is nil,
1390 `cooked' is used as default."
1391   (interactive)
1392   (or raw-buffer
1393       (setq raw-buffer (current-buffer)))
1394   (or representation-type
1395       (setq representation-type
1396             (save-excursion
1397               (set-buffer raw-buffer)
1398               (cdr (or (assq major-mode mime-raw-representation-type-alist)
1399                        (assq t mime-raw-representation-type-alist)))
1400               )))
1401   (if (eq representation-type 'binary)
1402       (setq representation-type 'buffer)
1403     )
1404   (setq preview-buffer (mime-display-message
1405                         (mime-open-entity representation-type raw-buffer)
1406                         preview-buffer mother default-keymap-or-function))
1407   (or (get-buffer-window preview-buffer)
1408       (let ((r-win (get-buffer-window raw-buffer)))
1409         (if r-win
1410             (set-window-buffer r-win preview-buffer)
1411           (let ((m-win (and mother (get-buffer-window mother))))
1412             (if m-win
1413                 (set-window-buffer m-win preview-buffer)
1414               (switch-to-buffer preview-buffer)
1415               ))))))
1416
1417 (defun mime-view-mode (&optional mother ctl encoding
1418                                  raw-buffer preview-buffer
1419                                  default-keymap-or-function)
1420   "Major mode for viewing MIME message.
1421
1422 Here is a list of the standard keys for mime-view-mode.
1423
1424 key             feature
1425 ---             -------
1426
1427 u               Move to upper content
1428 p or M-TAB      Move to previous content
1429 n or TAB        Move to next content
1430 SPC             Scroll up or move to next content
1431 M-SPC or DEL    Scroll down or move to previous content
1432 RET             Move to next line
1433 M-RET           Move to previous line
1434 v               Decode current content as `play mode'
1435 e               Decode current content as `extract mode'
1436 C-c C-p         Decode current content as `print mode'
1437 a               Followup to current content.
1438 q               Quit
1439 button-2        Move to point under the mouse cursor
1440                 and decode current content as `play mode'
1441 "
1442   (interactive)
1443   (unless mime-view-redisplay
1444     (save-excursion
1445       (if raw-buffer (set-buffer raw-buffer))
1446       (let ((type
1447              (cdr
1448               (or (assq major-mode mime-raw-representation-type-alist)
1449                   (assq t mime-raw-representation-type-alist)))))
1450         (if (eq type 'binary)
1451             (setq type 'buffer)
1452           )
1453         (setq mime-message-structure (mime-open-entity type raw-buffer))
1454         (or (mime-entity-content-type mime-message-structure)
1455             (mime-entity-set-content-type-internal
1456              mime-message-structure ctl))
1457         )
1458       (or (mime-entity-encoding mime-message-structure)
1459           (mime-entity-set-encoding-internal mime-message-structure encoding))
1460       ))
1461   (mime-display-message mime-message-structure preview-buffer
1462                         mother default-keymap-or-function)
1463   )
1464
1465
1466 ;;; @@ playing
1467 ;;;
1468
1469 (autoload 'mime-preview-play-current-entity "mime-play"
1470   "Play current entity." t)
1471
1472 (defun mime-preview-extract-current-entity (&optional ignore-examples)
1473   "Extract current entity into file (maybe).
1474 It decodes current entity to call internal or external method as
1475 \"extract\" mode.  The method is selected from variable
1476 `mime-acting-condition'."
1477   (interactive "P")
1478   (mime-preview-play-current-entity ignore-examples "extract")
1479   )
1480
1481 (defun mime-preview-print-current-entity (&optional ignore-examples)
1482   "Print current entity (maybe).
1483 It decodes current entity to call internal or external method as
1484 \"print\" mode.  The method is selected from variable
1485 `mime-acting-condition'."
1486   (interactive "P")
1487   (mime-preview-play-current-entity ignore-examples "print")
1488   )
1489
1490
1491 ;;; @@ following
1492 ;;;
1493
1494 (defun mime-preview-follow-current-entity ()
1495   "Write follow message to current entity.
1496 It calls following-method selected from variable
1497 `mime-preview-following-method-alist'."
1498   (interactive)
1499   (let (entity)
1500     (while (null (setq entity
1501                        (get-text-property (point) 'mime-view-entity)))
1502       (backward-char)
1503       )
1504     (let* ((p-beg
1505             (previous-single-property-change (point) 'mime-view-entity))
1506            p-end
1507            ph-end
1508            (entity-node-id (mime-entity-node-id entity))
1509            (len (length entity-node-id))
1510            )
1511       (cond ((null p-beg)
1512              (setq p-beg
1513                    (if (eq (next-single-property-change (point-min)
1514                                                         'mime-view-entity)
1515                            (point))
1516                        (point)
1517                      (point-min)))
1518              )
1519             ((eq (next-single-property-change p-beg 'mime-view-entity)
1520                  (point))
1521              (setq p-beg (point))
1522              ))
1523       (setq p-end (next-single-property-change p-beg 'mime-view-entity))
1524       (cond ((null p-end)
1525              (setq p-end (point-max))
1526              )
1527             ((null entity-node-id)
1528              (setq p-end (point-max))
1529              )
1530             (t
1531              (save-excursion
1532                (goto-char p-end)
1533                (catch 'tag
1534                  (let (e)
1535                    (while (setq e
1536                                 (next-single-property-change
1537                                  (point) 'mime-view-entity))
1538                      (goto-char e)
1539                      (let ((rc (mime-entity-node-id
1540                                 (get-text-property (point)
1541                                                    'mime-view-entity))))
1542                        (or (equal entity-node-id
1543                                   (nthcdr (- (length rc) len) rc))
1544                            (throw 'tag nil)
1545                            ))
1546                      (setq p-end e)
1547                      ))
1548                  (setq p-end (point-max))
1549                  ))
1550              ))
1551       (setq ph-end
1552             (previous-single-property-change p-end 'mime-view-entity-header))
1553       (if (or (null ph-end)
1554               (< ph-end p-beg))
1555           (setq ph-end p-beg)
1556         )
1557       (let* ((mode (mime-preview-original-major-mode 'recursive))
1558              (new-name
1559               (format "%s-%s" (buffer-name) (reverse entity-node-id)))
1560              new-buf
1561              (the-buf (current-buffer))
1562              fields)
1563         (save-excursion
1564           (set-buffer (setq new-buf (get-buffer-create new-name)))
1565           (erase-buffer)
1566           (insert-buffer-substring the-buf ph-end p-end)
1567           (when (= ph-end p-beg)
1568             (goto-char (point-min))
1569             (insert ?\n))
1570           (goto-char (point-min))
1571           (let ((current-entity
1572                  (if (and (eq (mime-entity-media-type entity) 'message)
1573                           (eq (mime-entity-media-subtype entity) 'rfc822))
1574                      (mime-entity-children entity)
1575                    entity))
1576                 str)
1577             (while (and current-entity
1578                         (progn
1579                           (setq str
1580                                 (with-current-buffer
1581                                     (mime-entity-header-buffer current-entity)
1582                                   (save-restriction
1583                                     (narrow-to-region
1584                                      (mime-entity-header-start-point
1585                                       current-entity)
1586                                      (mime-entity-header-end-point
1587                                       current-entity))
1588                                     (std11-header-string-except
1589                                      (concat
1590                                       "^"
1591                                       (apply (function regexp-or) fields)
1592                                       ":") ""))))
1593                           (if (and (eq (mime-entity-media-type
1594                                         current-entity) 'message)
1595                                    (eq (mime-entity-media-subtype
1596                                         current-entity) 'rfc822))
1597                               nil
1598                             (if str
1599                                 (insert str)
1600                               )
1601                             t)))
1602               (setq fields (std11-collect-field-names)
1603                     current-entity (mime-entity-parent current-entity))
1604               )
1605             )
1606           (let ((rest mime-view-following-required-fields-list)
1607                 field-name ret)
1608             (while rest
1609               (setq field-name (car rest))
1610               (or (std11-field-body field-name)
1611                   (progn
1612                     (save-excursion
1613                       (set-buffer the-buf)
1614                       (setq ret
1615                             (when mime-mother-buffer
1616                               (set-buffer mime-mother-buffer)
1617                               (mime-entity-fetch-field
1618                                (get-text-property (point)
1619                                                   'mime-view-entity)
1620                                field-name))))
1621                     (if ret
1622                         (insert (concat field-name ": " ret "\n"))
1623                       )))
1624               (setq rest (cdr rest))
1625               ))
1626           (mime-decode-header-in-buffer)
1627           )
1628         (let ((f (cdr (assq mode mime-preview-following-method-alist))))
1629           (if (functionp f)
1630               (funcall f new-buf)
1631             (message
1632              (format
1633               "Sorry, following method for %s is not implemented yet."
1634               mode))
1635             ))
1636         ))))
1637
1638
1639 ;;; @@ moving
1640 ;;;
1641
1642 (defun mime-preview-move-to-upper ()
1643   "Move to upper entity.
1644 If there is no upper entity, call function `mime-preview-quit'."
1645   (interactive)
1646   (let (cinfo)
1647     (while (null (setq cinfo
1648                        (get-text-property (point) 'mime-view-entity)))
1649       (backward-char))
1650     (let ((r (mime-entity-parent cinfo))
1651           point)
1652       (catch 'tag
1653         (while (setq point (previous-single-property-change
1654                             (point) 'mime-view-entity))
1655           (goto-char point)
1656           (when (eq r (get-text-property (point) 'mime-view-entity))
1657             (if (or (eq mime-preview-move-scroll t)
1658                     (and mime-preview-move-scroll
1659                          (>= point
1660                              (save-excursion
1661                                (move-to-window-line -1)
1662                                (forward-line (* -1 next-screen-context-lines))
1663                                (beginning-of-line)
1664                                (point)))))
1665                 (recenter next-screen-context-lines))
1666             (throw 'tag t)))
1667         (mime-preview-quit)))))
1668
1669 (defun mime-preview-move-to-previous ()
1670   "Move to previous entity.
1671 If there is no previous entity, it calls function registered in
1672 variable `mime-preview-over-to-previous-method-alist'."
1673   (interactive)
1674   (while (and (not (bobp))
1675               (null (get-text-property (point) 'mime-view-entity)))
1676     (backward-char)
1677     )
1678   (let ((point (previous-single-property-change (point) 'mime-view-entity)))
1679     (if (and point
1680              (>= point (point-min)))
1681         (if (get-text-property (1- point) 'mime-view-entity)
1682             (progn (goto-char point)
1683                    (if
1684                     (or (eq mime-preview-move-scroll t)
1685                         (and mime-preview-move-scroll
1686                              (<= point
1687                                 (save-excursion
1688                                   (move-to-window-line 0)
1689                                   (forward-line next-screen-context-lines)
1690                                   (end-of-line)
1691                                   (point)))))
1692                         (recenter next-screen-context-lines)))
1693           (goto-char (1- point))
1694           (mime-preview-move-to-previous)
1695           )
1696       (let ((f (assq (mime-preview-original-major-mode)
1697                      mime-preview-over-to-previous-method-alist)))
1698         (if f
1699             (funcall (cdr f)))))))
1700
1701 (defun mime-preview-move-to-next ()
1702   "Move to next entity.
1703 If there is no previous entity, it calls function registered in
1704 variable `mime-preview-over-to-next-method-alist'."
1705   (interactive)
1706   (while (and (not (eobp))
1707               (null (get-text-property (point) 'mime-view-entity)))
1708     (forward-char))
1709   (let ((point (next-single-property-change (point) 'mime-view-entity)))
1710     (if (and point
1711              (<= point (point-max)))
1712         (progn
1713           (goto-char point)
1714           (if (null (get-text-property point 'mime-view-entity))
1715               (mime-preview-move-to-next)
1716             (and
1717              (or (eq mime-preview-move-scroll t)
1718                  (and mime-preview-move-scroll
1719                       (>= point
1720                          (save-excursion
1721                            (move-to-window-line -1)
1722                            (forward-line
1723                             (* -1 next-screen-context-lines))
1724                            (beginning-of-line)
1725                            (point)))))
1726                  (recenter next-screen-context-lines))))
1727       (let ((f (assq (mime-preview-original-major-mode)
1728                      mime-preview-over-to-next-method-alist)))
1729         (if f
1730             (funcall (cdr f)))))))
1731
1732 (defun mime-preview-scroll-up-entity (&optional h)
1733   "Scroll up current entity.
1734 If reached to (point-max), it calls function registered in variable
1735 `mime-preview-over-to-next-method-alist'."
1736   (interactive)
1737   (if (eobp)
1738       (let ((f (assq (mime-preview-original-major-mode)
1739                      mime-preview-over-to-next-method-alist)))
1740         (if f
1741             (funcall (cdr f))))
1742     (let ((point
1743            (or (next-single-property-change (point) 'mime-view-entity)
1744                (point-max)))
1745           (bottom (window-end (selected-window))))
1746       (if (and (not h)
1747                (> bottom point)
1748                (not mime-preview-scroll-full-screen))
1749           (progn (goto-char point)
1750                  (recenter next-screen-context-lines))
1751         (condition-case nil
1752             (scroll-up h)
1753           (end-of-buffer
1754            (goto-char (point-max))))))))
1755
1756 (defun mime-preview-scroll-down-entity (&optional h)
1757   "Scroll down current entity.
1758 If reached to (point-min), it calls function registered in variable
1759 `mime-preview-over-to-previous-method-alist'."
1760   (interactive)
1761   (if (bobp)
1762       (let ((f (assq (mime-preview-original-major-mode)
1763                      mime-preview-over-to-previous-method-alist)))
1764         (if f
1765             (funcall (cdr f))))
1766     (let ((point
1767            (or (previous-single-property-change (point) 'mime-view-entity)
1768                (point-min)))
1769           (top (window-start (selected-window))))
1770       (if (and (not h)
1771                (< top point)
1772                (not mime-preview-scroll-full-screen))
1773           (progn (goto-char point)
1774                  (recenter (* -1 next-screen-context-lines)))
1775         (condition-case nil
1776             (scroll-down h)
1777           (beginning-of-buffer
1778            (goto-char (point-min))))))))
1779
1780 (defun mime-preview-next-line-entity (&optional lines)
1781   "Scroll up one line (or prefix LINES lines).
1782 If LINES is negative, scroll down LINES lines."
1783   (interactive "p")
1784   (mime-preview-scroll-up-entity (or lines 1)))
1785
1786 (defun mime-preview-previous-line-entity (&optional lines)
1787   "Scrroll down one line (or prefix LINES lines).
1788 If LINES is negative, scroll up LINES lines."
1789   (interactive "p")
1790   (mime-preview-scroll-down-entity (or lines 1)))
1791
1792 ;;; @@ quitting
1793 ;;;
1794
1795 (defun mime-preview-quit ()
1796   "Quit from MIME-preview buffer.
1797 It calls function registered in variable
1798 `mime-preview-quitting-method-alist'."
1799   (interactive)
1800   (let ((r (assq (mime-preview-original-major-mode)
1801                  mime-preview-quitting-method-alist)))
1802     (if r
1803         (funcall (cdr r))
1804       )))
1805
1806 (defun mime-preview-kill-buffer ()
1807   (interactive)
1808   (kill-buffer (current-buffer))
1809   )
1810
1811
1812 ;;; @ end
1813 ;;;
1814
1815 (provide 'mime-view)
1816
1817 (run-hooks 'mime-view-load-hook)
1818
1819 ;;; mime-view.el ends here