mime-view.el

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