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