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