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