1895 lines
57 KiB
EmacsLisp
1895 lines
57 KiB
EmacsLisp
;;; mime-view.el --- interactive MIME viewer for GNU Emacs
|
|
|
|
;; Copyright (C) 1995,96,97,98,99,2000 Free Software Foundation, Inc.
|
|
|
|
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
|
|
;; Created: 1994/07/13
|
|
;; Renamed: 1994/08/31 from tm-body.el
|
|
;; Renamed: 1997/02/19 from tm-view.el
|
|
;; Keywords: MIME, multimedia, mail, news
|
|
|
|
;; This file is part of SEMI (Sample of Elastic MIME Interfaces).
|
|
|
|
;; This program is free software; you can redistribute it and/or
|
|
;; modify it under the terms of the GNU General Public License as
|
|
;; published by the Free Software Foundation; either version 2, or (at
|
|
;; your option) any later version.
|
|
|
|
;; This program is distributed in the hope that it will be useful, but
|
|
;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
;; General Public License for more details.
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with GNU Emacs; see the file COPYING. If not, write to the
|
|
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
;; Boston, MA 02111-1307, USA.
|
|
|
|
;;; Code:
|
|
|
|
(require 'mime)
|
|
(require 'semi-def)
|
|
(require 'calist)
|
|
(require 'alist)
|
|
(require 'mime-conf)
|
|
|
|
(eval-when-compile (require 'static))
|
|
|
|
|
|
;;; @ version
|
|
;;;
|
|
|
|
(defconst mime-view-version
|
|
(concat (mime-product-name mime-user-interface-product) " MIME-View "
|
|
(mapconcat #'number-to-string
|
|
(mime-product-version mime-user-interface-product) ".")
|
|
" (" (mime-product-code-name mime-user-interface-product) ")"))
|
|
|
|
|
|
;;; @ variables
|
|
;;;
|
|
|
|
(defgroup mime-view nil
|
|
"MIME view mode"
|
|
:group 'mime)
|
|
|
|
(defcustom mime-situation-examples-file "~/.mime-example"
|
|
"*File name of situation-examples demonstrated by user."
|
|
:group 'mime-view
|
|
:type 'file)
|
|
|
|
(defcustom mime-preview-move-scroll nil
|
|
"*Decides whether to scroll when moving to next entity.
|
|
When t, scroll the buffer. Non-nil but not t means scroll when
|
|
the next entity is within next-screen-context-lines from top or
|
|
buttom. Nil means don't scroll at all."
|
|
:group 'mime-view
|
|
:type '(choice (const :tag "Off" nil)
|
|
(const :tag "On" t)
|
|
(sexp :tag "Situation" 1)))
|
|
|
|
(defcustom mime-view-mailcap-files
|
|
(let ((files '("/etc/mailcap" "/usr/etc/mailcap" "~/.mailcap")))
|
|
(or (member mime-mailcap-file files)
|
|
(setq files (cons mime-mailcap-file files)))
|
|
files)
|
|
"List of mailcap files."
|
|
:group 'mime-view
|
|
:type '(repeat file))
|
|
|
|
|
|
;;; @ in raw-buffer (representation space)
|
|
;;;
|
|
|
|
(defvar mime-preview-buffer nil
|
|
"MIME-preview buffer corresponding with the (raw) buffer.")
|
|
(make-variable-buffer-local 'mime-preview-buffer)
|
|
|
|
|
|
(defvar mime-raw-representation-type-alist
|
|
'((mime-show-message-mode . binary)
|
|
(mime-temp-message-mode . binary)
|
|
(t . cooked)
|
|
)
|
|
"Alist of major-mode vs. representation-type of mime-raw-buffer.
|
|
Each element looks like (SYMBOL . REPRESENTATION-TYPE). SYMBOL is
|
|
major-mode or t. t means default. REPRESENTATION-TYPE must be
|
|
`binary' or `cooked'.")
|
|
|
|
|
|
;;; @ in preview-buffer (presentation space)
|
|
;;;
|
|
|
|
(defvar mime-mother-buffer nil
|
|
"Mother buffer corresponding with the (MIME-preview) buffer.
|
|
If current MIME-preview buffer is generated by other buffer, such as
|
|
message/partial, it is called `mother-buffer'.")
|
|
(make-variable-buffer-local 'mime-mother-buffer)
|
|
|
|
;; (defvar mime-raw-buffer nil
|
|
;; "Raw buffer corresponding with the (MIME-preview) buffer.")
|
|
;; (make-variable-buffer-local 'mime-raw-buffer)
|
|
|
|
(defvar mime-preview-original-window-configuration nil
|
|
"Window-configuration before mime-view-mode is called.")
|
|
(make-variable-buffer-local 'mime-preview-original-window-configuration)
|
|
|
|
(defun mime-preview-original-major-mode (&optional recursive point)
|
|
"Return major-mode of original buffer.
|
|
If optional argument RECURSIVE is non-nil and current buffer has
|
|
mime-mother-buffer, it returns original major-mode of the
|
|
mother-buffer."
|
|
(if (and recursive mime-mother-buffer)
|
|
(save-excursion
|
|
(set-buffer mime-mother-buffer)
|
|
(mime-preview-original-major-mode recursive)
|
|
)
|
|
(cdr (assq 'major-mode
|
|
(get-text-property (or point
|
|
(if (> (point) (buffer-size))
|
|
(max (1- (point-max)) (point-min))
|
|
(point)))
|
|
'mime-view-situation)))))
|
|
|
|
|
|
;;; @ entity information
|
|
;;;
|
|
|
|
(defun mime-entity-situation (entity &optional situation)
|
|
"Return situation of ENTITY."
|
|
(let (rest param name)
|
|
;; Content-Type
|
|
(unless (assq 'type situation)
|
|
(setq rest (or (mime-entity-content-type entity)
|
|
(make-mime-content-type 'text 'plain))
|
|
situation (cons (car rest) situation)
|
|
rest (cdr rest))
|
|
)
|
|
(unless (assq 'subtype situation)
|
|
(or rest
|
|
(setq rest (or (cdr (mime-entity-content-type entity))
|
|
'((subtype . plain)))))
|
|
(setq situation (cons (car rest) situation)
|
|
rest (cdr rest))
|
|
)
|
|
(while rest
|
|
(setq param (car rest))
|
|
(or (assoc (car param) situation)
|
|
(setq situation (cons param situation)))
|
|
(setq rest (cdr rest)))
|
|
|
|
;; Content-Disposition
|
|
(setq rest nil)
|
|
(unless (assq 'disposition-type situation)
|
|
(setq rest (mime-entity-content-disposition entity))
|
|
(if rest
|
|
(setq situation (cons (cons 'disposition-type
|
|
(mime-content-disposition-type rest))
|
|
situation)
|
|
rest (mime-content-disposition-parameters rest))
|
|
))
|
|
(while rest
|
|
(setq param (car rest)
|
|
name (car param))
|
|
(if (cond ((string= name "filename")
|
|
(if (assq 'filename situation)
|
|
nil
|
|
(setq name 'filename)))
|
|
((string= name "creation-date")
|
|
(if (assq 'creation-date situation)
|
|
nil
|
|
(setq name 'creation-date)))
|
|
((string= name "modification-date")
|
|
(if (assq 'modification-date situation)
|
|
nil
|
|
(setq name 'modification-date)))
|
|
((string= name "read-date")
|
|
(if (assq 'read-date situation)
|
|
nil
|
|
(setq name 'read-date)))
|
|
((string= name "size")
|
|
(if (assq 'size situation)
|
|
nil
|
|
(setq name 'size)))
|
|
(t (setq name (cons 'disposition name))
|
|
(if (assoc name situation)
|
|
nil
|
|
name)))
|
|
(setq situation
|
|
(cons (cons name (cdr param))
|
|
situation)))
|
|
(setq rest (cdr rest)))
|
|
|
|
;; Content-Transfer-Encoding
|
|
(or (assq 'encoding situation)
|
|
(setq situation
|
|
(cons (cons 'encoding (or (mime-entity-encoding entity)
|
|
"7bit"))
|
|
situation)))
|
|
|
|
situation))
|
|
|
|
(defsubst mime-delq-null-situation (situations field
|
|
&rest ignored-values)
|
|
(let (dest)
|
|
(while situations
|
|
(let* ((situation (car situations))
|
|
(cell (assq field situation)))
|
|
(if cell
|
|
(or (memq (cdr cell) ignored-values)
|
|
(setq dest (cons situation dest))
|
|
)))
|
|
(setq situations (cdr situations)))
|
|
dest))
|
|
|
|
(defun mime-compare-situation-with-example (situation example)
|
|
(let ((example (copy-alist example))
|
|
(match 0))
|
|
(while situation
|
|
(let* ((cell (car situation))
|
|
(key (car cell))
|
|
(ecell (assoc key example)))
|
|
(when ecell
|
|
(if (equal cell ecell)
|
|
(setq match (1+ match))
|
|
(setq example (delq ecell example))
|
|
))
|
|
)
|
|
(setq situation (cdr situation))
|
|
)
|
|
(cons match example)
|
|
))
|
|
|
|
(defun mime-sort-situation (situation)
|
|
(sort situation
|
|
#'(lambda (a b)
|
|
(let ((a-t (car a))
|
|
(b-t (car b))
|
|
(order '((type . 1)
|
|
(subtype . 2)
|
|
(mode . 3)
|
|
(method . 4)
|
|
(major-mode . 5)
|
|
(disposition-type . 6)
|
|
))
|
|
a-order b-order)
|
|
(if (symbolp a-t)
|
|
(let ((ret (assq a-t order)))
|
|
(if ret
|
|
(setq a-order (cdr ret))
|
|
(setq a-order 7)
|
|
))
|
|
(setq a-order 8)
|
|
)
|
|
(if (symbolp b-t)
|
|
(let ((ret (assq b-t order)))
|
|
(if ret
|
|
(setq b-order (cdr ret))
|
|
(setq b-order 7)
|
|
))
|
|
(setq b-order 8)
|
|
)
|
|
(if (= a-order b-order)
|
|
(string< (format "%s" a-t)(format "%s" b-t))
|
|
(< a-order b-order))
|
|
)))
|
|
)
|
|
|
|
(defun mime-unify-situations (entity-situation
|
|
condition situation-examples
|
|
&optional required-name ignored-value
|
|
every-situations)
|
|
(let (ret)
|
|
(in-calist-package 'mime-view)
|
|
(setq ret
|
|
(ctree-find-calist condition entity-situation
|
|
every-situations))
|
|
(if required-name
|
|
(setq ret (mime-delq-null-situation ret required-name
|
|
ignored-value t)))
|
|
(or (assq 'ignore-examples entity-situation)
|
|
(if (cdr ret)
|
|
(let ((rest ret)
|
|
(max-score 0)
|
|
(max-escore 0)
|
|
max-examples
|
|
max-situations)
|
|
(while rest
|
|
(let ((situation (car rest))
|
|
(examples situation-examples))
|
|
(while examples
|
|
(let* ((ret
|
|
(mime-compare-situation-with-example
|
|
situation (caar examples)))
|
|
(ret-score (car ret)))
|
|
(cond ((> ret-score max-score)
|
|
(setq max-score ret-score
|
|
max-escore (cdar examples)
|
|
max-examples (list (cdr ret))
|
|
max-situations (list situation))
|
|
)
|
|
((= ret-score max-score)
|
|
(cond ((> (cdar examples) max-escore)
|
|
(setq max-escore (cdar examples)
|
|
max-examples (list (cdr ret))
|
|
max-situations (list situation))
|
|
)
|
|
((= (cdar examples) max-escore)
|
|
(setq max-examples
|
|
(cons (cdr ret) max-examples))
|
|
(or (member situation max-situations)
|
|
(setq max-situations
|
|
(cons situation max-situations)))
|
|
)))))
|
|
(setq examples (cdr examples))))
|
|
(setq rest (cdr rest)))
|
|
(when max-situations
|
|
(setq ret max-situations)
|
|
(while max-examples
|
|
(let* ((example (car max-examples))
|
|
(cell
|
|
(assoc example situation-examples)))
|
|
(if cell
|
|
(setcdr cell (1+ (cdr cell)))
|
|
(setq situation-examples
|
|
(cons (cons example 0)
|
|
situation-examples))
|
|
))
|
|
(setq max-examples (cdr max-examples))
|
|
)))))
|
|
(cons ret situation-examples)
|
|
;; ret: list of situations
|
|
;; situation-examples: new examples (notoce that contents of
|
|
;; argument `situation-examples' has bees modified)
|
|
))
|
|
|
|
(defun mime-view-entity-title (entity)
|
|
(or (mime-entity-read-field entity 'Content-Description)
|
|
(mime-entity-read-field entity 'Subject)
|
|
(mime-entity-filename entity)
|
|
""))
|
|
|
|
(defvar mime-preview-situation-example-list nil)
|
|
(defvar mime-preview-situation-example-list-max-size 16)
|
|
;; (defvar mime-preview-situation-example-condition nil)
|
|
|
|
(defun mime-find-entity-preview-situation (entity
|
|
&optional default-situation)
|
|
(or (let ((ret
|
|
(mime-unify-situations
|
|
(append (mime-entity-situation entity)
|
|
default-situation)
|
|
mime-preview-condition
|
|
mime-preview-situation-example-list)))
|
|
(setq mime-preview-situation-example-list
|
|
(cdr ret))
|
|
(caar ret))
|
|
default-situation))
|
|
|
|
|
|
(defvar mime-acting-situation-example-list nil)
|
|
(defvar mime-acting-situation-example-list-max-size 16)
|
|
(defvar mime-situation-examples-file-coding-system nil)
|
|
|
|
(defun mime-view-read-situation-examples-file (&optional file)
|
|
(or file
|
|
(setq file mime-situation-examples-file))
|
|
(if (and file
|
|
(file-readable-p file))
|
|
(with-temp-buffer
|
|
(insert-file-contents file)
|
|
(setq mime-situation-examples-file-coding-system
|
|
(static-cond
|
|
((boundp 'buffer-file-coding-system)
|
|
(symbol-value 'buffer-file-coding-system))
|
|
((boundp 'file-coding-system)
|
|
(symbol-value 'file-coding-system))
|
|
(t nil))
|
|
;; (and (boundp 'buffer-file-coding-system)
|
|
;; buffer-file-coding-system)
|
|
)
|
|
(condition-case error
|
|
(eval-buffer)
|
|
(error (message "%s is broken: %s" file (cdr error))))
|
|
;; format check
|
|
(condition-case nil
|
|
(let ((i 0))
|
|
(while (and (> (length mime-preview-situation-example-list)
|
|
mime-preview-situation-example-list-max-size)
|
|
(< i 16))
|
|
(setq mime-preview-situation-example-list
|
|
(mime-reduce-situation-examples
|
|
mime-preview-situation-example-list))
|
|
(setq i (1+ i))))
|
|
(error (setq mime-preview-situation-example-list nil)))
|
|
;; (let ((rest mime-preview-situation-example-list))
|
|
;; (while rest
|
|
;; (ctree-set-calist-strictly 'mime-preview-condition
|
|
;; (caar rest))
|
|
;; (setq rest (cdr rest))))
|
|
(condition-case nil
|
|
(let ((i 0))
|
|
(while (and (> (length mime-acting-situation-example-list)
|
|
mime-acting-situation-example-list-max-size)
|
|
(< i 16))
|
|
(setq mime-acting-situation-example-list
|
|
(mime-reduce-situation-examples
|
|
mime-acting-situation-example-list))
|
|
(setq i (1+ i))))
|
|
(error (setq mime-acting-situation-example-list nil))))))
|
|
|
|
(defun mime-save-situation-examples ()
|
|
(if (or mime-preview-situation-example-list
|
|
mime-acting-situation-example-list)
|
|
(let ((file mime-situation-examples-file)
|
|
print-length print-level)
|
|
(with-temp-buffer
|
|
(insert ";;; " (file-name-nondirectory file) "\n")
|
|
(insert "\n;; This file is generated automatically by "
|
|
mime-view-version "\n\n")
|
|
(insert ";;; Code:\n\n")
|
|
(if mime-preview-situation-example-list
|
|
(pp `(setq mime-preview-situation-example-list
|
|
',mime-preview-situation-example-list)
|
|
(current-buffer)))
|
|
(if mime-acting-situation-example-list
|
|
(pp `(setq mime-acting-situation-example-list
|
|
',mime-acting-situation-example-list)
|
|
(current-buffer)))
|
|
(insert "\n;;; "
|
|
(file-name-nondirectory file)
|
|
" ends here.\n")
|
|
(static-cond
|
|
((boundp 'buffer-file-coding-system)
|
|
(setq buffer-file-coding-system
|
|
mime-situation-examples-file-coding-system))
|
|
((boundp 'file-coding-system)
|
|
(setq file-coding-system
|
|
mime-situation-examples-file-coding-system)))
|
|
;; (setq buffer-file-coding-system
|
|
;; mime-situation-examples-file-coding-system)
|
|
(setq buffer-file-name file)
|
|
(save-buffer)))))
|
|
|
|
(add-hook 'kill-emacs-hook 'mime-save-situation-examples)
|
|
|
|
(defun mime-reduce-situation-examples (situation-examples)
|
|
(let ((len (length situation-examples))
|
|
i ir ic j jr jc ret
|
|
dest d-i d-j
|
|
(max-sim 0) sim
|
|
min-det-ret det-ret
|
|
min-det-org det-org
|
|
min-freq freq)
|
|
(setq i 0
|
|
ir situation-examples)
|
|
(while (< i len)
|
|
(setq ic (car ir)
|
|
j 0
|
|
jr situation-examples)
|
|
(while (< j len)
|
|
(unless (= i j)
|
|
(setq jc (car jr))
|
|
(setq ret (mime-compare-situation-with-example (car ic)(car jc))
|
|
sim (car ret)
|
|
det-ret (+ (length (car ic))(length (car jc)))
|
|
det-org (length (cdr ret))
|
|
freq (+ (cdr ic)(cdr jc)))
|
|
(cond ((< max-sim sim)
|
|
(setq max-sim sim
|
|
min-det-ret det-ret
|
|
min-det-org det-org
|
|
min-freq freq
|
|
d-i i
|
|
d-j j
|
|
dest (cons (cdr ret) freq))
|
|
)
|
|
((= max-sim sim)
|
|
(cond ((> min-det-ret det-ret)
|
|
(setq min-det-ret det-ret
|
|
min-det-org det-org
|
|
min-freq freq
|
|
d-i i
|
|
d-j j
|
|
dest (cons (cdr ret) freq))
|
|
)
|
|
((= min-det-ret det-ret)
|
|
(cond ((> min-det-org det-org)
|
|
(setq min-det-org det-org
|
|
min-freq freq
|
|
d-i i
|
|
d-j j
|
|
dest (cons (cdr ret) freq))
|
|
)
|
|
((= min-det-org det-org)
|
|
(cond ((> min-freq freq)
|
|
(setq min-freq freq
|
|
d-i i
|
|
d-j j
|
|
dest (cons (cdr ret) freq))
|
|
))
|
|
))
|
|
))
|
|
))
|
|
)
|
|
(setq jr (cdr jr)
|
|
j (1+ j)))
|
|
(setq ir (cdr ir)
|
|
i (1+ i)))
|
|
(if (> d-i d-j)
|
|
(setq i d-i
|
|
d-i d-j
|
|
d-j i))
|
|
(setq jr (nthcdr (1- d-j) situation-examples))
|
|
(setcdr jr (cddr jr))
|
|
(if (= d-i 0)
|
|
(setq situation-examples
|
|
(cdr situation-examples))
|
|
(setq ir (nthcdr (1- d-i) situation-examples))
|
|
(setcdr ir (cddr ir))
|
|
)
|
|
(if (setq ir (assoc (car dest) situation-examples))
|
|
(progn
|
|
(setcdr ir (+ (cdr ir)(cdr dest)))
|
|
situation-examples)
|
|
(cons dest situation-examples)
|
|
;; situation-examples may be modified.
|
|
)))
|
|
|
|
|
|
;;; @ presentation of preview
|
|
;;;
|
|
|
|
;;; @@ entity-button
|
|
;;;
|
|
|
|
;;; @@@ predicate function
|
|
;;;
|
|
|
|
;; (defun mime-view-entity-button-visible-p (entity)
|
|
;; "Return non-nil if header of ENTITY is visible.
|
|
;; Please redefine this function if you want to change default setting."
|
|
;; (let ((media-type (mime-entity-media-type entity))
|
|
;; (media-subtype (mime-entity-media-subtype entity)))
|
|
;; (or (not (eq media-type 'application))
|
|
;; (and (not (eq media-subtype 'x-selection))
|
|
;; (or (not (eq media-subtype 'octet-stream))
|
|
;; (let ((mother-entity (mime-entity-parent entity)))
|
|
;; (or (not (eq (mime-entity-media-type mother-entity)
|
|
;; 'multipart))
|
|
;; (not (eq (mime-entity-media-subtype mother-entity)
|
|
;; 'encrypted)))
|
|
;; )
|
|
;; )))))
|
|
|
|
;;; @@@ entity button generator
|
|
;;;
|
|
|
|
(defun mime-view-insert-entity-button (entity)
|
|
"Insert entity-button of ENTITY."
|
|
(let ((entity-node-id (mime-entity-node-id entity))
|
|
(params (mime-entity-parameters entity))
|
|
(subject (mime-view-entity-title entity)))
|
|
(mime-insert-button
|
|
(let ((access-type (assoc "access-type" params))
|
|
(num (or (cdr (assoc "x-part-number" params))
|
|
(if (consp entity-node-id)
|
|
(mapconcat (function
|
|
(lambda (num)
|
|
(format "%s" (1+ num))
|
|
))
|
|
(reverse entity-node-id) ".")
|
|
"0"))
|
|
))
|
|
(cond (access-type
|
|
(let ((server (assoc "server" params)))
|
|
(setq access-type (cdr access-type))
|
|
(if server
|
|
(format "%s %s ([%s] %s)"
|
|
num subject access-type (cdr server))
|
|
(let ((site (cdr (assoc "site" params)))
|
|
(dir (cdr (assoc "directory" params)))
|
|
(url (cdr (assoc "url" params)))
|
|
)
|
|
(if url
|
|
(format "%s %s ([%s] %s)"
|
|
num subject access-type url)
|
|
(format "%s %s ([%s] %s:%s)"
|
|
num subject access-type site dir))
|
|
)))
|
|
)
|
|
(t
|
|
(let ((media-type (mime-entity-media-type entity))
|
|
(media-subtype (mime-entity-media-subtype entity))
|
|
(charset (cdr (assoc "charset" params)))
|
|
(encoding (mime-entity-encoding entity)))
|
|
(concat
|
|
num " " subject
|
|
(let ((rest
|
|
(format " <%s/%s%s%s>"
|
|
media-type media-subtype
|
|
(if charset
|
|
(concat "; " charset)
|
|
"")
|
|
(if encoding
|
|
(concat " (" encoding ")")
|
|
""))))
|
|
(if (>= (+ (current-column)(length rest))(window-width))
|
|
"\n\t")
|
|
rest)))
|
|
)))
|
|
(function mime-preview-play-current-entity))
|
|
))
|
|
|
|
|
|
;;; @@ entity-header
|
|
;;;
|
|
|
|
(defvar mime-header-presentation-method-alist nil
|
|
"Alist of major mode vs. corresponding header-presentation-method functions.
|
|
Each element looks like (SYMBOL . FUNCTION).
|
|
SYMBOL must be major mode in raw-buffer or t. t means default.
|
|
Interface of FUNCTION must be (ENTITY SITUATION).")
|
|
|
|
(defvar mime-view-ignored-field-list
|
|
'(".*Received:" ".*Path:" ".*Id:" "^References:"
|
|
"^Replied:" "^Errors-To:"
|
|
"^Lines:" "^Sender:" ".*Host:" "^Xref:"
|
|
"^Content-Type:" "^Precedence:"
|
|
"^Status:" "^X-VM-.*:")
|
|
"All fields that match this list will be hidden in MIME preview buffer.
|
|
Each elements are regexp of field-name.")
|
|
|
|
(defvar mime-view-visible-field-list '("^Dnas.*:" "^Message-Id:")
|
|
"All fields that match this list will be displayed in MIME preview buffer.
|
|
Each elements are regexp of field-name.")
|
|
|
|
|
|
;;; @@ entity-body
|
|
;;;
|
|
|
|
;;; @@@ predicate function
|
|
;;;
|
|
|
|
(in-calist-package 'mime-view)
|
|
|
|
(defun mime-calist::field-match-method-as-default-rule (calist
|
|
field-type field-value)
|
|
(let ((s-field (assq field-type calist)))
|
|
(cond ((null s-field)
|
|
(cons (cons field-type field-value) calist)
|
|
)
|
|
(t calist))))
|
|
|
|
(define-calist-field-match-method
|
|
'header #'mime-calist::field-match-method-as-default-rule)
|
|
|
|
(define-calist-field-match-method
|
|
'body #'mime-calist::field-match-method-as-default-rule)
|
|
|
|
|
|
(defvar mime-preview-condition nil
|
|
"Condition-tree about how to display entity.")
|
|
|
|
(ctree-set-calist-strictly
|
|
'mime-preview-condition '((type . application)(subtype . octet-stream)
|
|
(encoding . nil)
|
|
(body . visible)))
|
|
(ctree-set-calist-strictly
|
|
'mime-preview-condition '((type . application)(subtype . octet-stream)
|
|
(encoding . "7bit")
|
|
(body . visible)))
|
|
(ctree-set-calist-strictly
|
|
'mime-preview-condition '((type . application)(subtype . octet-stream)
|
|
(encoding . "8bit")
|
|
(body . visible)))
|
|
|
|
(ctree-set-calist-strictly
|
|
'mime-preview-condition '((type . application)(subtype . pgp)
|
|
(body . visible)))
|
|
|
|
(ctree-set-calist-strictly
|
|
'mime-preview-condition '((type . application)(subtype . x-latex)
|
|
(body . visible)))
|
|
|
|
(ctree-set-calist-strictly
|
|
'mime-preview-condition '((type . application)(subtype . x-selection)
|
|
(body . visible)))
|
|
|
|
(ctree-set-calist-strictly
|
|
'mime-preview-condition '((type . application)(subtype . x-comment)
|
|
(body . visible)))
|
|
|
|
(ctree-set-calist-strictly
|
|
'mime-preview-condition '((type . message)(subtype . delivery-status)
|
|
(body . visible)))
|
|
|
|
(ctree-set-calist-strictly
|
|
'mime-preview-condition
|
|
'((body . visible)
|
|
(body-presentation-method . mime-display-text/plain)))
|
|
|
|
(ctree-set-calist-strictly
|
|
'mime-preview-condition
|
|
'((type . nil)
|
|
(body . visible)
|
|
(body-presentation-method . mime-display-text/plain)))
|
|
|
|
(ctree-set-calist-strictly
|
|
'mime-preview-condition
|
|
'((type . text)(subtype . enriched)
|
|
(body . visible)
|
|
(body-presentation-method . mime-display-text/enriched)))
|
|
|
|
(ctree-set-calist-strictly
|
|
'mime-preview-condition
|
|
'((type . text)(subtype . richtext)
|
|
(body . visible)
|
|
(body-presentation-method . mime-display-text/richtext)))
|
|
|
|
(autoload 'mime-display-application/x-postpet "postpet")
|
|
|
|
(ctree-set-calist-strictly
|
|
'mime-preview-condition
|
|
'((type . application)(subtype . x-postpet)
|
|
(body . visible)
|
|
(body-presentation-method . mime-display-application/x-postpet)))
|
|
|
|
(ctree-set-calist-strictly
|
|
'mime-preview-condition
|
|
'((type . text)(subtype . t)
|
|
(body . visible)
|
|
(body-presentation-method . mime-display-text/plain)))
|
|
|
|
(ctree-set-calist-strictly
|
|
'mime-preview-condition
|
|
'((type . multipart)(subtype . alternative)
|
|
(body . visible)
|
|
(body-presentation-method . mime-display-multipart/alternative)))
|
|
|
|
(ctree-set-calist-strictly
|
|
'mime-preview-condition
|
|
'((type . multipart)(subtype . related)
|
|
(body . visible)
|
|
(body-presentation-method . mime-display-multipart/related)))
|
|
|
|
(ctree-set-calist-strictly
|
|
'mime-preview-condition
|
|
'((type . multipart)(subtype . t)
|
|
(body . visible)
|
|
(body-presentation-method . mime-display-multipart/mixed)))
|
|
|
|
(ctree-set-calist-strictly
|
|
'mime-preview-condition
|
|
'((type . message)(subtype . partial)
|
|
(body . visible)
|
|
(body-presentation-method . mime-display-message/partial-button)))
|
|
|
|
(ctree-set-calist-strictly
|
|
'mime-preview-condition
|
|
'((type . message)(subtype . rfc822)
|
|
(body . visible)
|
|
(body-presentation-method . mime-display-multipart/mixed)
|
|
(childrens-situation (header . visible)
|
|
(entity-button . invisible))))
|
|
|
|
(ctree-set-calist-strictly
|
|
'mime-preview-condition
|
|
'((type . message)(subtype . news)
|
|
(body . visible)
|
|
(body-presentation-method . mime-display-multipart/mixed)
|
|
(childrens-situation (header . visible)
|
|
(entity-button . invisible))))
|
|
|
|
|
|
;;; @@@ entity presentation
|
|
;;;
|
|
|
|
(defun mime-display-text/plain (entity situation)
|
|
(save-restriction
|
|
(narrow-to-region (point-max)(point-max))
|
|
(condition-case nil
|
|
(mime-insert-text-content entity)
|
|
(error (progn
|
|
(message "Can't decode current entity.")
|
|
(sit-for 1))))
|
|
(run-hooks 'mime-text-decode-hook)
|
|
(goto-char (point-max))
|
|
(if (not (eq (char-after (1- (point))) ?\n))
|
|
(insert "\n")
|
|
)
|
|
(mime-add-url-buttons)
|
|
(run-hooks 'mime-display-text/plain-hook)
|
|
))
|
|
|
|
(defun mime-display-text/richtext (entity situation)
|
|
(save-restriction
|
|
(narrow-to-region (point-max)(point-max))
|
|
(mime-insert-text-content entity)
|
|
(run-hooks 'mime-text-decode-hook)
|
|
(let ((beg (point-min)))
|
|
(remove-text-properties beg (point-max) '(face nil))
|
|
(richtext-decode beg (point-max))
|
|
)))
|
|
|
|
(defun mime-display-text/enriched (entity situation)
|
|
(save-restriction
|
|
(narrow-to-region (point-max)(point-max))
|
|
(mime-insert-text-content entity)
|
|
(run-hooks 'mime-text-decode-hook)
|
|
(let ((beg (point-min)))
|
|
(remove-text-properties beg (point-max) '(face nil))
|
|
(enriched-decode beg (point-max))
|
|
)))
|
|
|
|
|
|
(defvar mime-view-announcement-for-message/partial
|
|
(if (and (>= emacs-major-version 19) window-system)
|
|
"\
|
|
\[[ This is message/partial style split message. ]]
|
|
\[[ Please press `v' key in this buffer ]]
|
|
\[[ or click here by mouse button-2. ]]"
|
|
"\
|
|
\[[ This is message/partial style split message. ]]
|
|
\[[ Please press `v' key in this buffer. ]]"
|
|
))
|
|
|
|
(defun mime-display-message/partial-button (&optional entity situation)
|
|
(save-restriction
|
|
(goto-char (point-max))
|
|
(if (not (search-backward "\n\n" nil t))
|
|
(insert "\n")
|
|
)
|
|
(goto-char (point-max))
|
|
(narrow-to-region (point-max)(point-max))
|
|
(insert mime-view-announcement-for-message/partial)
|
|
(mime-add-button (point-min)(point-max)
|
|
#'mime-preview-play-current-entity)
|
|
))
|
|
|
|
(defun mime-display-multipart/mixed (entity situation)
|
|
(let ((children (mime-entity-children entity))
|
|
(original-major-mode-cell (assq 'major-mode situation))
|
|
(default-situation
|
|
(cdr (assq 'childrens-situation situation))))
|
|
(if original-major-mode-cell
|
|
(setq default-situation
|
|
(cons original-major-mode-cell default-situation)))
|
|
(while children
|
|
(mime-display-entity (car children) nil default-situation)
|
|
(setq children (cdr children))
|
|
)))
|
|
|
|
(defcustom mime-view-type-subtype-score-alist
|
|
'(((text . enriched) . 3)
|
|
((text . richtext) . 2)
|
|
((text . plain) . 1)
|
|
(t . 0))
|
|
"Alist MEDIA-TYPE vs corresponding score.
|
|
MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t. t means default."
|
|
:group 'mime-view
|
|
:type '(repeat (cons (choice :tag "Media-Type"
|
|
(cons :tag "Type/Subtype"
|
|
(symbol :tag "Primary-type")
|
|
(symbol :tag "Subtype"))
|
|
(symbol :tag "Type")
|
|
(const :tag "Default" t))
|
|
integer)))
|
|
|
|
(defun mime-display-multipart/alternative (entity situation)
|
|
(let* ((children (mime-entity-children entity))
|
|
(original-major-mode-cell (assq 'major-mode situation))
|
|
(default-situation
|
|
(cdr (assq 'childrens-situation situation)))
|
|
(i 0)
|
|
(p 0)
|
|
(max-score 0)
|
|
situations)
|
|
(if original-major-mode-cell
|
|
(setq default-situation
|
|
(cons original-major-mode-cell default-situation)))
|
|
(setq situations
|
|
(mapcar (function
|
|
(lambda (child)
|
|
(let ((situation
|
|
(mime-find-entity-preview-situation
|
|
child default-situation)))
|
|
(if (cdr (assq 'body-presentation-method situation))
|
|
(let ((score
|
|
(cdr
|
|
(or (assoc
|
|
(cons
|
|
(cdr (assq 'type situation))
|
|
(cdr (assq 'subtype situation)))
|
|
mime-view-type-subtype-score-alist)
|
|
(assq
|
|
(cdr (assq 'type situation))
|
|
mime-view-type-subtype-score-alist)
|
|
(assq
|
|
t
|
|
mime-view-type-subtype-score-alist)
|
|
))))
|
|
(if (> score max-score)
|
|
(setq p i
|
|
max-score score)
|
|
)))
|
|
(setq i (1+ i))
|
|
situation)
|
|
))
|
|
children))
|
|
(setq i 0)
|
|
(while children
|
|
(let ((child (car children))
|
|
(situation (car situations)))
|
|
(mime-display-entity child (if (= i p)
|
|
situation
|
|
(put-alist 'body 'invisible
|
|
(copy-alist situation)))))
|
|
(setq children (cdr children)
|
|
situations (cdr situations)
|
|
i (1+ i)))))
|
|
|
|
(defun mime-display-multipart/related (entity situation)
|
|
(let* ((param-start (mime-parse-msg-id
|
|
(std11-lexical-analyze
|
|
(cdr (assoc "start"
|
|
(mime-content-type-parameters
|
|
(mime-entity-content-type entity)))))))
|
|
(start (or (and param-start (mime-find-entity-from-content-id
|
|
param-start
|
|
entity))
|
|
(car (mime-entity-children entity))))
|
|
(original-major-mode-cell (assq 'major-mode situation))
|
|
(default-situation (cdr (assq 'childrens-situation situation))))
|
|
(if original-major-mode-cell
|
|
(setq default-situation
|
|
(cons original-major-mode-cell default-situation)))
|
|
(mime-display-entity start nil default-situation)))
|
|
|
|
;;; @ acting-condition
|
|
;;;
|
|
|
|
(defvar mime-acting-condition nil
|
|
"Condition-tree about how to process entity.")
|
|
|
|
(defun mime-view-read-mailcap-files (&optional files)
|
|
(or files
|
|
(setq files mime-view-mailcap-files))
|
|
(let (entries file)
|
|
(while files
|
|
(setq file (car files))
|
|
(if (file-readable-p file)
|
|
(setq entries (append entries (mime-parse-mailcap-file file))))
|
|
(setq files (cdr files)))
|
|
(while entries
|
|
(let ((entry (car entries))
|
|
view print shared)
|
|
(while entry
|
|
(let* ((field (car entry))
|
|
(field-type (car field)))
|
|
(cond ((eq field-type 'view) (setq view field))
|
|
((eq field-type 'print) (setq print field))
|
|
((memq field-type '(compose composetyped edit)))
|
|
(t (setq shared (cons field shared))))
|
|
)
|
|
(setq entry (cdr entry)))
|
|
(setq shared (nreverse shared))
|
|
(ctree-set-calist-with-default
|
|
'mime-acting-condition
|
|
(append shared (list '(mode . "play")(cons 'method (cdr view)))))
|
|
(if print
|
|
(ctree-set-calist-with-default
|
|
'mime-acting-condition
|
|
(append shared
|
|
(list '(mode . "print")(cons 'method (cdr view)))))))
|
|
(setq entries (cdr entries)))))
|
|
|
|
(mime-view-read-mailcap-files)
|
|
|
|
(ctree-set-calist-strictly
|
|
'mime-acting-condition
|
|
'((type . application)(subtype . octet-stream)
|
|
(mode . "play")
|
|
(method . mime-detect-content)
|
|
))
|
|
|
|
(ctree-set-calist-with-default
|
|
'mime-acting-condition
|
|
'((mode . "extract")
|
|
(method . mime-save-content)))
|
|
|
|
(ctree-set-calist-strictly
|
|
'mime-acting-condition
|
|
'((type . text)(subtype . x-rot13-47)(mode . "play")
|
|
(method . mime-view-caesar)
|
|
))
|
|
(ctree-set-calist-strictly
|
|
'mime-acting-condition
|
|
'((type . text)(subtype . x-rot13-47-48)(mode . "play")
|
|
(method . mime-view-caesar)
|
|
))
|
|
|
|
(ctree-set-calist-strictly
|
|
'mime-acting-condition
|
|
'((type . message)(subtype . rfc822)(mode . "play")
|
|
(method . mime-view-message/rfc822)
|
|
))
|
|
(ctree-set-calist-strictly
|
|
'mime-acting-condition
|
|
'((type . message)(subtype . partial)(mode . "play")
|
|
(method . mime-store-message/partial-piece)
|
|
))
|
|
|
|
(ctree-set-calist-strictly
|
|
'mime-acting-condition
|
|
'((type . message)(subtype . external-body)
|
|
("access-type" . "anon-ftp")
|
|
(method . mime-view-message/external-anon-ftp)
|
|
))
|
|
|
|
(ctree-set-calist-strictly
|
|
'mime-acting-condition
|
|
'((type . message)(subtype . external-body)
|
|
("access-type" . "url")
|
|
(method . mime-view-message/external-url)
|
|
))
|
|
|
|
(ctree-set-calist-strictly
|
|
'mime-acting-condition
|
|
'((type . application)(subtype . octet-stream)
|
|
(method . mime-save-content)
|
|
))
|
|
|
|
|
|
;;; @ quitting method
|
|
;;;
|
|
|
|
(defvar mime-preview-quitting-method-alist
|
|
'((mime-show-message-mode
|
|
. mime-preview-quitting-method-for-mime-show-message-mode))
|
|
"Alist of major-mode vs. quitting-method of mime-view.")
|
|
|
|
(defvar mime-preview-over-to-previous-method-alist nil
|
|
"Alist of major-mode vs. over-to-previous-method of mime-view.")
|
|
|
|
(defvar mime-preview-over-to-next-method-alist nil
|
|
"Alist of major-mode vs. over-to-next-method of mime-view.")
|
|
|
|
|
|
;;; @ following method
|
|
;;;
|
|
|
|
(defvar mime-preview-following-method-alist nil
|
|
"Alist of major-mode vs. following-method of mime-view.")
|
|
|
|
(defvar mime-view-following-required-fields-list
|
|
'("From"))
|
|
|
|
|
|
;;; @ buffer setup
|
|
;;;
|
|
|
|
(defun mime-display-entity (entity &optional situation
|
|
default-situation preview-buffer)
|
|
(or preview-buffer
|
|
(setq preview-buffer (current-buffer)))
|
|
(let* (e nb ne nhb nbb)
|
|
(in-calist-package 'mime-view)
|
|
(or situation
|
|
(setq situation
|
|
(mime-find-entity-preview-situation entity default-situation)))
|
|
(let ((button-is-invisible
|
|
(eq (cdr (or (assq '*entity-button situation)
|
|
(assq 'entity-button situation)))
|
|
'invisible))
|
|
(header-is-visible
|
|
(eq (cdr (or (assq '*header situation)
|
|
(assq 'header situation)))
|
|
'visible))
|
|
(body-is-visible
|
|
(eq (cdr (or (assq '*body situation)
|
|
(assq 'body situation)))
|
|
'visible))
|
|
(children (mime-entity-children entity)))
|
|
(set-buffer preview-buffer)
|
|
(setq nb (point))
|
|
(narrow-to-region nb nb)
|
|
(or button-is-invisible
|
|
;; (if (mime-view-entity-button-visible-p entity)
|
|
(mime-view-insert-entity-button entity)
|
|
;; )
|
|
)
|
|
(if header-is-visible
|
|
(let ((header-presentation-method
|
|
(or (cdr (assq 'header-presentation-method situation))
|
|
(cdr (assq (cdr (assq 'major-mode situation))
|
|
mime-header-presentation-method-alist)))))
|
|
(setq nhb (point))
|
|
(if header-presentation-method
|
|
(funcall header-presentation-method entity situation)
|
|
(mime-insert-header entity
|
|
mime-view-ignored-field-list
|
|
mime-view-visible-field-list))
|
|
(run-hooks 'mime-display-header-hook)
|
|
(put-text-property nhb (point-max) 'mime-view-entity-header entity)
|
|
(goto-char (point-max))
|
|
(insert "\n")))
|
|
(setq nbb (point))
|
|
(unless children
|
|
(if body-is-visible
|
|
(let ((body-presentation-method
|
|
(cdr (assq 'body-presentation-method situation))))
|
|
(if (functionp body-presentation-method)
|
|
(funcall body-presentation-method entity situation)
|
|
(mime-display-text/plain entity situation)))
|
|
(when button-is-invisible
|
|
(goto-char (point-max))
|
|
(mime-view-insert-entity-button entity)
|
|
)
|
|
(unless header-is-visible
|
|
(goto-char (point-max))
|
|
(insert "\n"))
|
|
))
|
|
(setq ne (point-max))
|
|
(widen)
|
|
(put-text-property nb ne 'mime-view-entity entity)
|
|
(put-text-property nb ne 'mime-view-situation situation)
|
|
(put-text-property nbb ne 'mime-view-entity-body entity)
|
|
(goto-char ne)
|
|
(if (and children body-is-visible)
|
|
(let ((body-presentation-method
|
|
(cdr (assq 'body-presentation-method situation))))
|
|
(if (functionp body-presentation-method)
|
|
(funcall body-presentation-method entity situation)
|
|
(mime-display-multipart/mixed entity situation))))
|
|
)))
|
|
|
|
|
|
;;; @ MIME viewer mode
|
|
;;;
|
|
|
|
(defconst mime-view-menu-title "MIME-View")
|
|
(defconst mime-view-menu-list
|
|
'((up "Move to upper entity" mime-preview-move-to-upper)
|
|
(previous "Move to previous entity" mime-preview-move-to-previous)
|
|
(next "Move to next entity" mime-preview-move-to-next)
|
|
(scroll-down "Scroll-down" mime-preview-scroll-down-entity)
|
|
(scroll-up "Scroll-up" mime-preview-scroll-up-entity)
|
|
(play "Play current entity" mime-preview-play-current-entity)
|
|
(extract "Extract current entity" mime-preview-extract-current-entity)
|
|
(print "Print current entity" mime-preview-print-current-entity)
|
|
)
|
|
"Menu for MIME Viewer")
|
|
|
|
(cond ((featurep 'xemacs)
|
|
(defvar mime-view-xemacs-popup-menu
|
|
(cons mime-view-menu-title
|
|
(mapcar (function
|
|
(lambda (item)
|
|
(vector (nth 1 item)(nth 2 item) t)
|
|
))
|
|
mime-view-menu-list)))
|
|
(defun mime-view-xemacs-popup-menu (event)
|
|
"Popup the menu in the MIME Viewer buffer"
|
|
(interactive "e")
|
|
(select-window (event-window event))
|
|
(set-buffer (event-buffer event))
|
|
(popup-menu 'mime-view-xemacs-popup-menu))
|
|
(defvar mouse-button-2 'button2)
|
|
(defvar mouse-button-3 'button3)
|
|
)
|
|
(t
|
|
(defvar mime-view-popup-menu
|
|
(let ((menu (make-sparse-keymap mime-view-menu-title)))
|
|
(nconc menu
|
|
(mapcar (function
|
|
(lambda (item)
|
|
(list (intern (nth 1 item)) 'menu-item
|
|
(nth 1 item)(nth 2 item))
|
|
))
|
|
mime-view-menu-list))))
|
|
(defun mime-view-popup-menu (event)
|
|
"Popup the menu in the MIME Viewer buffer"
|
|
(interactive "@e")
|
|
(let ((menu mime-view-popup-menu) events func)
|
|
(setq events (x-popup-menu t menu))
|
|
(and events
|
|
(setq func (lookup-key menu (apply #'vector events)))
|
|
(commandp func)
|
|
(funcall func))))
|
|
(defvar mouse-button-2 [mouse-2])
|
|
(defvar mouse-button-3 [mouse-3])
|
|
))
|
|
|
|
(defun mime-view-define-keymap (&optional default)
|
|
(let ((mime-view-mode-map (if (keymapp default)
|
|
(copy-keymap default)
|
|
(make-sparse-keymap))))
|
|
(define-key mime-view-mode-map
|
|
"u" (function mime-preview-move-to-upper))
|
|
(define-key mime-view-mode-map
|
|
"p" (function mime-preview-move-to-previous))
|
|
(define-key mime-view-mode-map
|
|
"n" (function mime-preview-move-to-next))
|
|
(define-key mime-view-mode-map
|
|
"\e\t" (function mime-preview-move-to-previous))
|
|
(define-key mime-view-mode-map
|
|
"\t" (function mime-preview-move-to-next))
|
|
(define-key mime-view-mode-map
|
|
" " (function mime-preview-scroll-up-entity))
|
|
(define-key mime-view-mode-map
|
|
"\M- " (function mime-preview-scroll-down-entity))
|
|
(define-key mime-view-mode-map
|
|
"\177" (function mime-preview-scroll-down-entity))
|
|
(define-key mime-view-mode-map
|
|
"\C-m" (function mime-preview-next-line-entity))
|
|
(define-key mime-view-mode-map
|
|
"\C-\M-m" (function mime-preview-previous-line-entity))
|
|
(define-key mime-view-mode-map
|
|
"v" (function mime-preview-play-current-entity))
|
|
(define-key mime-view-mode-map
|
|
"e" (function mime-preview-extract-current-entity))
|
|
(define-key mime-view-mode-map
|
|
"\C-c\C-p" (function mime-preview-print-current-entity))
|
|
|
|
(define-key mime-view-mode-map
|
|
"\C-c\C-t\C-f" (function mime-preview-toggle-header))
|
|
(define-key mime-view-mode-map
|
|
"\C-c\C-th" (function mime-preview-toggle-header))
|
|
(define-key mime-view-mode-map
|
|
"\C-c\C-t\C-c" (function mime-preview-toggle-content))
|
|
|
|
(define-key mime-view-mode-map
|
|
"\C-c\C-v\C-f" (function mime-preview-show-header))
|
|
(define-key mime-view-mode-map
|
|
"\C-c\C-vh" (function mime-preview-show-header))
|
|
(define-key mime-view-mode-map
|
|
"\C-c\C-v\C-c" (function mime-preview-show-content))
|
|
|
|
(define-key mime-view-mode-map
|
|
"\C-c\C-d\C-f" (function mime-preview-hide-header))
|
|
(define-key mime-view-mode-map
|
|
"\C-c\C-dh" (function mime-preview-hide-header))
|
|
(define-key mime-view-mode-map
|
|
"\C-c\C-d\C-c" (function mime-preview-hide-content))
|
|
|
|
(define-key mime-view-mode-map
|
|
"a" (function mime-preview-follow-current-entity))
|
|
(define-key mime-view-mode-map
|
|
"q" (function mime-preview-quit))
|
|
(define-key mime-view-mode-map
|
|
"\C-c\C-x" (function mime-preview-kill-buffer))
|
|
;; (define-key mime-view-mode-map
|
|
;; "<" (function beginning-of-buffer))
|
|
;; (define-key mime-view-mode-map
|
|
;; ">" (function end-of-buffer))
|
|
(define-key mime-view-mode-map
|
|
"?" (function describe-mode))
|
|
(define-key mime-view-mode-map
|
|
[tab] (function mime-preview-move-to-next))
|
|
(define-key mime-view-mode-map
|
|
[delete] (function mime-preview-scroll-down-entity))
|
|
(define-key mime-view-mode-map
|
|
[backspace] (function mime-preview-scroll-down-entity))
|
|
(if (functionp default)
|
|
(cond ((featurep 'xemacs)
|
|
(set-keymap-default-binding mime-view-mode-map default)
|
|
)
|
|
(t
|
|
(setq mime-view-mode-map
|
|
(append mime-view-mode-map (list (cons t default))))
|
|
)))
|
|
(if mouse-button-2
|
|
(define-key mime-view-mode-map
|
|
mouse-button-2 (function mime-button-dispatcher))
|
|
)
|
|
(cond ((featurep 'xemacs)
|
|
(define-key mime-view-mode-map
|
|
mouse-button-3 (function mime-view-xemacs-popup-menu))
|
|
)
|
|
((>= emacs-major-version 19)
|
|
(define-key mime-view-mode-map
|
|
mouse-button-3 (function mime-view-popup-menu))
|
|
(define-key mime-view-mode-map [menu-bar mime-view]
|
|
(cons mime-view-menu-title
|
|
(make-sparse-keymap mime-view-menu-title)))
|
|
(mapcar (function
|
|
(lambda (item)
|
|
(define-key mime-view-mode-map
|
|
(vector 'menu-bar 'mime-view (car item))
|
|
(cons (nth 1 item)(nth 2 item)))
|
|
))
|
|
(reverse mime-view-menu-list))
|
|
))
|
|
;; (run-hooks 'mime-view-define-keymap-hook)
|
|
mime-view-mode-map))
|
|
|
|
(defvar mime-view-mode-default-map (mime-view-define-keymap))
|
|
|
|
|
|
(defsubst mime-maybe-hide-echo-buffer ()
|
|
"Clear mime-echo buffer and delete window for it."
|
|
(let ((buf (get-buffer mime-echo-buffer-name)))
|
|
(if buf
|
|
(save-excursion
|
|
(set-buffer buf)
|
|
(erase-buffer)
|
|
(let ((win (get-buffer-window buf)))
|
|
(if win
|
|
(delete-window win)
|
|
))
|
|
(bury-buffer buf)
|
|
))))
|
|
|
|
(defvar mime-view-redisplay nil)
|
|
|
|
;;;###autoload
|
|
(defun mime-display-message (message &optional preview-buffer
|
|
mother default-keymap-or-function
|
|
original-major-mode keymap)
|
|
"View MESSAGE in MIME-View mode.
|
|
|
|
Optional argument PREVIEW-BUFFER specifies the buffer of the
|
|
presentation. It must be either nil or a name of preview buffer.
|
|
|
|
Optional argument MOTHER specifies mother-buffer of the preview-buffer.
|
|
|
|
Optional argument DEFAULT-KEYMAP-OR-FUNCTION is nil, keymap or
|
|
function. If it is a keymap, keymap of MIME-View mode will be added
|
|
to it. If it is a function, it will be bound as default binding of
|
|
keymap of MIME-View mode.
|
|
|
|
Optional argument ORIGINAL-MAJOR-MODE is major-mode of representation
|
|
buffer of MESSAGE. If it is nil, current `major-mode' is used.
|
|
|
|
Optional argument KEYMAP is keymap of MIME-View mode. If it is
|
|
non-nil, DEFAULT-KEYMAP-OR-FUNCTION is ignored. If it is nil,
|
|
`mime-view-mode-default-map' is used."
|
|
(mime-maybe-hide-echo-buffer)
|
|
(let ((win-conf (current-window-configuration)))
|
|
(or preview-buffer
|
|
(setq preview-buffer
|
|
(concat "*Preview-" (mime-entity-name message) "*")))
|
|
(or original-major-mode
|
|
(setq original-major-mode major-mode))
|
|
(let ((inhibit-read-only t))
|
|
(set-buffer (get-buffer-create preview-buffer))
|
|
(widen)
|
|
(erase-buffer)
|
|
(if mother
|
|
(setq mime-mother-buffer mother))
|
|
(setq mime-preview-original-window-configuration win-conf)
|
|
(setq major-mode 'mime-view-mode)
|
|
(setq mode-name "MIME-View")
|
|
(mime-display-entity message nil
|
|
`((entity-button . invisible)
|
|
(header . visible)
|
|
(major-mode . ,original-major-mode))
|
|
preview-buffer)
|
|
(use-local-map
|
|
(or keymap
|
|
(if default-keymap-or-function
|
|
(mime-view-define-keymap default-keymap-or-function)
|
|
mime-view-mode-default-map)))
|
|
(let ((point
|
|
(next-single-property-change (point-min) 'mime-view-entity)))
|
|
(if point
|
|
(goto-char point)
|
|
(goto-char (point-min))
|
|
(search-forward "\n\n" nil t)))
|
|
(run-hooks 'mime-view-mode-hook)
|
|
(set-buffer-modified-p nil)
|
|
(setq buffer-read-only t)
|
|
preview-buffer)))
|
|
|
|
;;;###autoload
|
|
(defun mime-view-buffer (&optional raw-buffer preview-buffer mother
|
|
default-keymap-or-function
|
|
representation-type)
|
|
"View RAW-BUFFER in MIME-View mode.
|
|
Optional argument PREVIEW-BUFFER is either nil or a name of preview
|
|
buffer.
|
|
Optional argument DEFAULT-KEYMAP-OR-FUNCTION is nil, keymap or
|
|
function. If it is a keymap, keymap of MIME-View mode will be added
|
|
to it. If it is a function, it will be bound as default binding of
|
|
keymap of MIME-View mode.
|
|
Optional argument REPRESENTATION-TYPE is representation-type of
|
|
message. It must be nil, `binary' or `cooked'. If it is nil,
|
|
`cooked' is used as default."
|
|
(interactive)
|
|
(or raw-buffer
|
|
(setq raw-buffer (current-buffer)))
|
|
(or representation-type
|
|
(setq representation-type
|
|
(save-excursion
|
|
(set-buffer raw-buffer)
|
|
(cdr (or (assq major-mode mime-raw-representation-type-alist)
|
|
(assq t mime-raw-representation-type-alist)))
|
|
)))
|
|
(if (eq representation-type 'binary)
|
|
(setq representation-type 'buffer)
|
|
)
|
|
(setq preview-buffer (mime-display-message
|
|
(mime-open-entity representation-type raw-buffer)
|
|
preview-buffer mother default-keymap-or-function))
|
|
(or (get-buffer-window preview-buffer)
|
|
(let ((r-win (get-buffer-window raw-buffer)))
|
|
(if r-win
|
|
(set-window-buffer r-win preview-buffer)
|
|
(let ((m-win (and mother (get-buffer-window mother))))
|
|
(if m-win
|
|
(set-window-buffer m-win preview-buffer)
|
|
(switch-to-buffer preview-buffer)
|
|
))))))
|
|
|
|
(defun mime-view-mode (&optional mother ctl encoding
|
|
raw-buffer preview-buffer
|
|
default-keymap-or-function)
|
|
"Major mode for viewing MIME message.
|
|
|
|
Here is a list of the standard keys for mime-view-mode.
|
|
|
|
key feature
|
|
--- -------
|
|
|
|
u Move to upper content
|
|
p or M-TAB Move to previous content
|
|
n or TAB Move to next content
|
|
SPC Scroll up or move to next content
|
|
M-SPC or DEL Scroll down or move to previous content
|
|
RET Move to next line
|
|
M-RET Move to previous line
|
|
v Decode current content as `play mode'
|
|
e Decode current content as `extract mode'
|
|
C-c C-p Decode current content as `print mode'
|
|
a Followup to current content.
|
|
q Quit
|
|
button-2 Move to point under the mouse cursor
|
|
and decode current content as `play mode'
|
|
"
|
|
(interactive)
|
|
(unless mime-view-redisplay
|
|
(save-excursion
|
|
(if raw-buffer (set-buffer raw-buffer))
|
|
(let ((type
|
|
(cdr
|
|
(or (assq major-mode mime-raw-representation-type-alist)
|
|
(assq t mime-raw-representation-type-alist)))))
|
|
(if (eq type 'binary)
|
|
(setq type 'buffer)
|
|
)
|
|
(setq mime-message-structure (mime-open-entity type raw-buffer))
|
|
(or (mime-entity-content-type mime-message-structure)
|
|
(mime-entity-set-content-type mime-message-structure ctl))
|
|
)
|
|
(or (mime-entity-encoding mime-message-structure)
|
|
(mime-entity-set-encoding mime-message-structure encoding))
|
|
))
|
|
(mime-display-message mime-message-structure preview-buffer
|
|
mother default-keymap-or-function)
|
|
)
|
|
|
|
|
|
;;; @@ utility
|
|
;;;
|
|
|
|
(defun mime-preview-find-boundary-info (&optional with-children)
|
|
"Return boundary information of current part.
|
|
If WITH-CHILDREN, refer boundary surrounding current part and its branches."
|
|
(let (entity
|
|
p-beg p-end
|
|
entity-node-id len)
|
|
(while (null (setq entity
|
|
(get-text-property (point) 'mime-view-entity)))
|
|
(backward-char))
|
|
(setq p-beg (previous-single-property-change (point) 'mime-view-entity))
|
|
(setq entity-node-id (mime-entity-node-id entity))
|
|
(setq len (length entity-node-id))
|
|
(cond ((null p-beg)
|
|
(setq p-beg
|
|
(if (eq (next-single-property-change (point-min)
|
|
'mime-view-entity)
|
|
(point))
|
|
(point)
|
|
(point-min)))
|
|
)
|
|
((eq (next-single-property-change p-beg 'mime-view-entity)
|
|
(point))
|
|
(setq p-beg (point))
|
|
))
|
|
(setq p-end (next-single-property-change p-beg 'mime-view-entity))
|
|
(cond ((null p-end)
|
|
(setq p-end (point-max))
|
|
)
|
|
((null entity-node-id)
|
|
(setq p-end (point-max))
|
|
)
|
|
(with-children
|
|
(save-excursion
|
|
(catch 'tag
|
|
(let (e i)
|
|
(while (setq e
|
|
(next-single-property-change
|
|
(point) 'mime-view-entity))
|
|
(goto-char e)
|
|
(let ((rc (mime-entity-node-id
|
|
(get-text-property (point)
|
|
'mime-view-entity))))
|
|
(or (and (>= (setq i (- (length rc) len)) 0)
|
|
(equal entity-node-id (nthcdr i rc)))
|
|
(throw 'tag nil)))
|
|
(setq p-end (or (next-single-property-change
|
|
(point) 'mime-view-entity)
|
|
(point-max)))))
|
|
(setq p-end (point-max))))
|
|
))
|
|
(vector p-beg p-end entity)))
|
|
|
|
|
|
;;; @@ playing
|
|
;;;
|
|
|
|
(autoload 'mime-preview-play-current-entity "mime-play"
|
|
"Play current entity." t)
|
|
|
|
(defun mime-preview-extract-current-entity (&optional ignore-examples)
|
|
"Extract current entity into file (maybe).
|
|
It decodes current entity to call internal or external method as
|
|
\"extract\" mode. The method is selected from variable
|
|
`mime-acting-condition'."
|
|
(interactive "P")
|
|
(mime-preview-play-current-entity ignore-examples "extract")
|
|
)
|
|
|
|
(defun mime-preview-print-current-entity (&optional ignore-examples)
|
|
"Print current entity (maybe).
|
|
It decodes current entity to call internal or external method as
|
|
\"print\" mode. The method is selected from variable
|
|
`mime-acting-condition'."
|
|
(interactive "P")
|
|
(mime-preview-play-current-entity ignore-examples "print")
|
|
)
|
|
|
|
|
|
;;; @@ following
|
|
;;;
|
|
|
|
(defun mime-preview-follow-current-entity ()
|
|
"Write follow message to current entity.
|
|
It calls following-method selected from variable
|
|
`mime-preview-following-method-alist'."
|
|
(interactive)
|
|
(let ((entity (mime-preview-find-boundary-info t))
|
|
p-beg p-end
|
|
pb-beg)
|
|
(setq p-beg (aref entity 0)
|
|
p-end (aref entity 1)
|
|
entity (aref entity 2))
|
|
(if (get-text-property p-beg 'mime-view-entity-body)
|
|
(setq pb-beg p-beg)
|
|
(setq pb-beg
|
|
(next-single-property-change
|
|
p-beg 'mime-view-entity-body nil
|
|
(or (next-single-property-change p-beg 'mime-view-entity)
|
|
p-end))))
|
|
(let* ((mode (mime-preview-original-major-mode 'recursive))
|
|
(entity-node-id (mime-entity-node-id entity))
|
|
(new-name
|
|
(format "%s-%s" (buffer-name) (reverse entity-node-id)))
|
|
new-buf
|
|
(the-buf (current-buffer))
|
|
fields)
|
|
(save-excursion
|
|
(set-buffer (setq new-buf (get-buffer-create new-name)))
|
|
(erase-buffer)
|
|
(insert ?\n)
|
|
(insert-buffer-substring the-buf pb-beg p-end)
|
|
(goto-char (point-min))
|
|
(let ((current-entity
|
|
(if (and (eq (mime-entity-media-type entity) 'message)
|
|
(eq (mime-entity-media-subtype entity) 'rfc822))
|
|
(car (mime-entity-children entity))
|
|
entity)))
|
|
(while (and current-entity
|
|
(if (and (eq (mime-entity-media-type
|
|
current-entity) 'message)
|
|
(eq (mime-entity-media-subtype
|
|
current-entity) 'rfc822))
|
|
nil
|
|
(mime-insert-header current-entity fields)
|
|
t))
|
|
(setq fields (std11-collect-field-names)
|
|
current-entity (mime-entity-parent current-entity))
|
|
))
|
|
(let ((rest mime-view-following-required-fields-list)
|
|
field-name ret)
|
|
(while rest
|
|
(setq field-name (car rest))
|
|
(or (std11-field-body field-name)
|
|
(progn
|
|
(save-excursion
|
|
(set-buffer the-buf)
|
|
(let ((entity (when mime-mother-buffer
|
|
(set-buffer mime-mother-buffer)
|
|
(get-text-property (point)
|
|
'mime-view-entity))))
|
|
(while (and entity
|
|
(null (setq ret (mime-entity-fetch-field
|
|
entity field-name))))
|
|
(setq entity (mime-entity-parent entity)))))
|
|
(if ret
|
|
(insert (concat field-name ": " ret "\n"))
|
|
)))
|
|
(setq rest (cdr rest))
|
|
))
|
|
)
|
|
(let ((f (cdr (assq mode mime-preview-following-method-alist))))
|
|
(if (functionp f)
|
|
(funcall f new-buf)
|
|
(message
|
|
"Sorry, following method for %s is not implemented yet."
|
|
mode)
|
|
))
|
|
)))
|
|
|
|
|
|
;;; @@ moving
|
|
;;;
|
|
|
|
(defun mime-preview-move-to-upper ()
|
|
"Move to upper entity.
|
|
If there is no upper entity, call function `mime-preview-quit'."
|
|
(interactive)
|
|
(let (cinfo)
|
|
(while (null (setq cinfo
|
|
(get-text-property (point) 'mime-view-entity)))
|
|
(backward-char)
|
|
)
|
|
(let ((r (mime-entity-parent cinfo))
|
|
point)
|
|
(catch 'tag
|
|
(while (setq point (previous-single-property-change
|
|
(point) 'mime-view-entity))
|
|
(goto-char point)
|
|
(when (eq r (get-text-property (point) 'mime-view-entity))
|
|
(if (or (eq mime-preview-move-scroll t)
|
|
(and mime-preview-move-scroll
|
|
(>= point
|
|
(save-excursion
|
|
(move-to-window-line -1)
|
|
(forward-line (* -1 next-screen-context-lines))
|
|
(beginning-of-line)
|
|
(point)))))
|
|
(recenter next-screen-context-lines))
|
|
(throw 'tag t)
|
|
)
|
|
)
|
|
(mime-preview-quit)
|
|
))))
|
|
|
|
(defun mime-preview-move-to-previous ()
|
|
"Move to previous entity.
|
|
If there is no previous entity, it calls function registered in
|
|
variable `mime-preview-over-to-previous-method-alist'."
|
|
(interactive)
|
|
(while (and (not (bobp))
|
|
(null (get-text-property (point) 'mime-view-entity)))
|
|
(backward-char)
|
|
)
|
|
(let ((point (previous-single-property-change (point) 'mime-view-entity)))
|
|
(if (and point
|
|
(>= point (point-min)))
|
|
(if (get-text-property (1- point) 'mime-view-entity)
|
|
(progn (goto-char point)
|
|
(if
|
|
(or (eq mime-preview-move-scroll t)
|
|
(and mime-preview-move-scroll
|
|
(<= point
|
|
(save-excursion
|
|
(move-to-window-line 0)
|
|
(forward-line next-screen-context-lines)
|
|
(end-of-line)
|
|
(point)))))
|
|
(recenter (* -1 next-screen-context-lines))))
|
|
(goto-char (1- point))
|
|
(mime-preview-move-to-previous)
|
|
)
|
|
(let ((f (assq (mime-preview-original-major-mode)
|
|
mime-preview-over-to-previous-method-alist)))
|
|
(if f
|
|
(funcall (cdr f))
|
|
))
|
|
)))
|
|
|
|
(defun mime-preview-move-to-next ()
|
|
"Move to next entity.
|
|
If there is no previous entity, it calls function registered in
|
|
variable `mime-preview-over-to-next-method-alist'."
|
|
(interactive)
|
|
(while (and (not (eobp))
|
|
(null (get-text-property (point) 'mime-view-entity)))
|
|
(forward-char)
|
|
)
|
|
(let ((point (next-single-property-change (point) 'mime-view-entity)))
|
|
(if (and point
|
|
(<= point (point-max)))
|
|
(progn
|
|
(goto-char point)
|
|
(if (null (get-text-property point 'mime-view-entity))
|
|
(mime-preview-move-to-next)
|
|
(and
|
|
(or (eq mime-preview-move-scroll t)
|
|
(and mime-preview-move-scroll
|
|
(>= point
|
|
(save-excursion
|
|
(move-to-window-line -1)
|
|
(forward-line
|
|
(* -1 next-screen-context-lines))
|
|
(beginning-of-line)
|
|
(point)))))
|
|
(recenter next-screen-context-lines))
|
|
))
|
|
(let ((f (assq (mime-preview-original-major-mode)
|
|
mime-preview-over-to-next-method-alist)))
|
|
(if f
|
|
(funcall (cdr f))
|
|
))
|
|
)))
|
|
|
|
(defun mime-preview-scroll-up-entity (&optional h)
|
|
"Scroll up current entity.
|
|
If reached to (point-max), it calls function registered in variable
|
|
`mime-preview-over-to-next-method-alist'."
|
|
(interactive)
|
|
(if (eobp)
|
|
(let ((f (assq (mime-preview-original-major-mode)
|
|
mime-preview-over-to-next-method-alist)))
|
|
(if f
|
|
(funcall (cdr f))
|
|
))
|
|
(let ((point
|
|
(or (next-single-property-change (point) 'mime-view-entity)
|
|
(point-max)))
|
|
(bottom (window-end (selected-window))))
|
|
(if (and (not h)
|
|
(> bottom point))
|
|
(progn (goto-char point)
|
|
(recenter next-screen-context-lines))
|
|
(condition-case nil
|
|
(scroll-up h)
|
|
(end-of-buffer
|
|
(goto-char (point-max)))))
|
|
)))
|
|
|
|
(defun mime-preview-scroll-down-entity (&optional h)
|
|
"Scroll down current entity.
|
|
If reached to (point-min), it calls function registered in variable
|
|
`mime-preview-over-to-previous-method-alist'."
|
|
(interactive)
|
|
(if (bobp)
|
|
(let ((f (assq (mime-preview-original-major-mode)
|
|
mime-preview-over-to-previous-method-alist)))
|
|
(if f
|
|
(funcall (cdr f))
|
|
))
|
|
(let ((point
|
|
(or (previous-single-property-change (point) 'mime-view-entity)
|
|
(point-min)))
|
|
(top (window-start (selected-window))))
|
|
(if (and (not h)
|
|
(< top point))
|
|
(progn (goto-char point)
|
|
(recenter (* -1 next-screen-context-lines)))
|
|
(condition-case nil
|
|
(scroll-down h)
|
|
(beginning-of-buffer
|
|
(goto-char (point-min)))))
|
|
)))
|
|
|
|
(defun mime-preview-next-line-entity (&optional lines)
|
|
"Scroll up one line (or prefix LINES lines).
|
|
If LINES is negative, scroll down LINES lines."
|
|
(interactive "p")
|
|
(mime-preview-scroll-up-entity (or lines 1))
|
|
)
|
|
|
|
(defun mime-preview-previous-line-entity (&optional lines)
|
|
"Scrroll down one line (or prefix LINES lines).
|
|
If LINES is negative, scroll up LINES lines."
|
|
(interactive "p")
|
|
(mime-preview-scroll-down-entity (or lines 1))
|
|
)
|
|
|
|
|
|
;;; @@ display
|
|
;;;
|
|
|
|
(defun mime-preview-toggle-display (type &optional display)
|
|
(let ((situation (mime-preview-find-boundary-info t))
|
|
(sym (intern (concat "*" (symbol-name type))))
|
|
entity p-beg p-end)
|
|
(setq p-beg (aref situation 0)
|
|
p-end (aref situation 1)
|
|
entity (aref situation 2)
|
|
situation (get-text-property p-beg 'mime-view-situation))
|
|
(cond ((eq display 'invisible)
|
|
(setq display nil))
|
|
(display)
|
|
(t
|
|
(setq display
|
|
(eq (cdr (or (assq sym situation)
|
|
(assq type situation)))
|
|
'invisible))))
|
|
(setq situation (put-alist sym (if display
|
|
'visible
|
|
'invisible)
|
|
situation))
|
|
(save-excursion
|
|
(let ((inhibit-read-only t))
|
|
(delete-region p-beg p-end)
|
|
(mime-display-entity entity situation)))
|
|
(let ((ret (assoc situation mime-preview-situation-example-list)))
|
|
(if ret
|
|
(setcdr ret (1+ (cdr ret)))
|
|
(add-to-list 'mime-preview-situation-example-list
|
|
(cons situation 0))))))
|
|
|
|
(defun mime-preview-toggle-header (&optional force-visible)
|
|
(interactive "P")
|
|
(mime-preview-toggle-display 'header force-visible))
|
|
|
|
(defun mime-preview-toggle-content (&optional force-visible)
|
|
(interactive "P")
|
|
(mime-preview-toggle-display 'body force-visible))
|
|
|
|
(defun mime-preview-show-header ()
|
|
(interactive)
|
|
(mime-preview-toggle-display 'header 'visible))
|
|
|
|
(defun mime-preview-show-content ()
|
|
(interactive)
|
|
(mime-preview-toggle-display 'body 'visible))
|
|
|
|
(defun mime-preview-hide-header ()
|
|
(interactive)
|
|
(mime-preview-toggle-display 'header 'invisible))
|
|
|
|
(defun mime-preview-hide-content ()
|
|
(interactive)
|
|
(mime-preview-toggle-display 'body 'invisible))
|
|
|
|
|
|
;;; @@ quitting
|
|
;;;
|
|
|
|
(defun mime-preview-quit ()
|
|
"Quit from MIME-preview buffer.
|
|
It calls function registered in variable
|
|
`mime-preview-quitting-method-alist'."
|
|
(interactive)
|
|
(let ((r (assq (mime-preview-original-major-mode)
|
|
mime-preview-quitting-method-alist)))
|
|
(if r
|
|
(funcall (cdr r))
|
|
)))
|
|
|
|
(defun mime-preview-kill-buffer ()
|
|
(interactive)
|
|
(kill-buffer (current-buffer))
|
|
)
|
|
|
|
|
|
;;; @ end
|
|
;;;
|
|
|
|
(provide 'mime-view)
|
|
|
|
(eval-when-compile
|
|
(setq mime-situation-examples-file nil)
|
|
;; to avoid to read situation-examples-file at compile time.
|
|
)
|
|
|
|
(mime-view-read-situation-examples-file)
|
|
|
|
;;; mime-view.el ends here
|