mime-view.el

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