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