mime-view.el

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