mime-view.el

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