mime-view.el

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