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