mime-view.el

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