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