mime-view.el

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