;;; mime-view.el --- interactive MIME viewer for GNU Emacs
-;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
+;; Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc.
;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
;; Created: 1994/07/13
;; Renamed: 1997/02/19 from tm-view.el
;; Keywords: MIME, multimedia, mail, news
-;; This file is part of SEMI (Sophisticated Emacs MIME Interfaces).
+;; 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
;;; Code:
-(require 'std11)
+(require 'emu)
(require 'mime)
(require 'semi-def)
(require 'calist)
;;; @ version
;;;
-(defconst mime-view-version-string
- `,(concat (car mime-user-interface-version) " MIME-View "
+(defconst mime-view-version
+ (eval-when-compile
+ (concat (mime-product-name mime-user-interface-product) " MIME-View "
(mapconcat #'number-to-string
- (cddr mime-user-interface-version) ".")
- " (" (cadr mime-user-interface-version) ")"))
+ (mime-product-version mime-user-interface-product) ".")
+ " (" (mime-product-code-name mime-user-interface-product) ")")))
;;; @ variables
(make-variable-buffer-local 'mime-preview-buffer)
-(defvar mime-raw-representation-type nil
- "Representation-type of mime-raw-buffer.
-It must be nil, `binary' or `cooked'.
-If it is nil, `mime-raw-representation-type-alist' is used as default
-value.
-Notice that this variable is usually used as buffer local variable in
-raw-buffer.")
-
-(make-variable-buffer-local 'mime-raw-representation-type)
-
(defvar mime-raw-representation-type-alist
'((mime-show-message-mode . binary)
(mime-temp-message-mode . binary)
"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'.
-This value is overridden by buffer local variable
-`mime-raw-representation-type' if it is not nil.")
-
-
-(defsubst mime-raw-find-entity-from-node-id (entity-node-id
- &optional message-info)
- "Return entity from ENTITY-NODE-ID in mime-raw-buffer.
-If optional argument MESSAGE-INFO is not specified,
-`mime-message-structure' is used."
- (mime-raw-find-entity-from-number (reverse entity-node-id) message-info))
+`binary' or `cooked'.")
-(defun mime-raw-find-entity-from-number (entity-number &optional message-info)
- "Return entity from ENTITY-NUMBER in mime-raw-buffer.
-If optional argument MESSAGE-INFO is not specified,
-`mime-message-structure' is used."
- (or message-info
- (setq message-info mime-message-structure))
- (if (eq entity-number t)
- message-info
- (let ((sn (car entity-number)))
- (if (null sn)
- message-info
- (let ((rc (nth sn (mime-entity-children message-info))))
- (if rc
- (mime-raw-find-entity-from-number (cdr entity-number) rc)
- ))
- ))))
(defun mime-raw-find-entity-from-point (point &optional message-info)
"Return entity from POINT in mime-raw-buffer.
;;; @ entity information
;;;
-(defsubst mime-entity-representation-type (entity)
- (with-current-buffer (mime-entity-buffer entity)
- (or mime-raw-representation-type
- (cdr (or (assq major-mode mime-raw-representation-type-alist)
- (assq t mime-raw-representation-type-alist))))))
-
-(defsubst mime-entity-cooked-p (entity)
- (eq (mime-entity-representation-type entity) 'cooked))
-
-(defsubst mime-entity-parent (entity &optional message-info)
- "Return mother entity of ENTITY.
-If optional argument MESSAGE-INFO is not specified,
-`mime-message-structure' in buffer of ENTITY is used."
- (mime-raw-find-entity-from-node-id
- (cdr (mime-entity-node-id entity))
- (or message-info
- (save-excursion
- (set-buffer (mime-entity-buffer entity))
- mime-message-structure))))
-
(defun mime-entity-situation (entity)
"Return situation of ENTITY."
(append (or (mime-entity-content-type entity)
))
-(defvar mime-view-uuencode-encoding-name-list '("x-uue" "x-uuencode"))
-
-(defun mime-entity-uu-filename (entity)
- (if (member (mime-entity-encoding entity)
- mime-view-uuencode-encoding-name-list)
- (save-excursion
- (set-buffer (mime-entity-buffer entity))
- (goto-char (mime-entity-body-start entity))
- (if (re-search-forward "^begin [0-9]+ "
- (mime-entity-body-end entity) t)
- (if (looking-at ".+$")
- (buffer-substring (match-beginning 0)(match-end 0))
- )))))
-
-(defun mime-entity-filename (entity)
- (or (mime-entity-uu-filename entity)
- (mime-content-disposition-filename
- (mime-entity-content-disposition entity))
- (cdr (let ((param (mime-content-type-parameters
- (mime-entity-content-type entity))))
- (or (assoc "name" param)
- (assoc "x-name" param))
- ))))
-
(defun mime-view-entity-title (entity)
- (or (mime-entity-read-field entity 'Content-Description)
- (mime-entity-read-field entity 'Subject)
+ (or (mime-read-field 'Content-Description entity)
+ (mime-read-field 'Subject entity)
(mime-entity-filename entity)
""))
num subject access-type (cdr server))
(let ((site (cdr (assoc "site" params)))
(dir (cdr (assoc "directory" params)))
+ (url (cdr (assoc "url" params)))
)
- (format "%s %s ([%s] %s:%s)"
- num subject access-type site dir)
+ (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
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-.*")
+ '(".*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")
+(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.")
(ctree-set-calist-strictly
'mime-preview-condition
+ '((type . text)(subtype . x-vcard)
+ (body . visible)
+ (body-presentation-method . mime-display-text/x-vcard)))
+
+(ctree-set-calist-strictly
+ 'mime-preview-condition
'((type . text)(subtype . t)
(body . visible)
(body-presentation-method . mime-display-text/plain)))
;;; @@@ entity presentation
;;;
-(autoload 'mime-display-text/plain "mime-text")
-(autoload 'mime-display-text/enriched "mime-text")
-(autoload 'mime-display-text/richtext "mime-text")
+(defun mime-display-text/plain (entity situation)
+ (save-restriction
+ (narrow-to-region (point-max)(point-max))
+ (mime-insert-text-content entity)
+ (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))
+ )))
+
+(defun mime-display-text/x-vcard (entity situation)
+ (save-restriction
+ (narrow-to-region (point-max)(point-max))
+ (insert (string-as-multibyte (mime-entity-content entity)))
+ (goto-char (point-min))
+ (while (re-search-forward
+ "\\(;\\(encoding=\\)?quoted-printable:\\)\\(\\(=[0-9A-F][0-9A-F]\\|=\r\n\\|[^\r\n]\\)*\\)"
+ nil t)
+ (replace-match
+ (concat
+ (buffer-substring (match-beginning 1) (match-end 1))
+ (string-as-multibyte
+ (mime-decode-string
+ (decode-coding-string
+ (buffer-substring (match-beginning 3) (match-end 3)) 'raw-text-dos)
+ "quoted-printable")))
+ t t))
+ (decode-coding-region (point-min) (point-max) 'undecided)
+ (goto-char (point-max))
+ (if (not (eq (char-after (1- (point))) ?\n))
+ (insert "\n"))
+ (mime-add-url-buttons)
+ (run-hooks 'mime-display-text/x-vcard-hook)
+ ))
(defvar mime-view-announcement-for-message/partial
(if (and (>= emacs-major-version 19) window-system)
MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t. t means default."
:group 'mime-view
:type '(repeat (cons (choice :tag "Media-Type"
- (item :tag "Type/Subtype"
- (cons symbol symbol))
- (item :tag "Type" symbol)
- (item :tag "Default" t))
+ (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)
'mime-acting-condition
'((type . message)(subtype . external-body)
("access-type" . "anon-ftp")
- (method . mime-view-message/external-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
'("From"))
-;;; @ X-Face
-;;;
-
-;; hack from Gnus 5.0.4.
-
-(defvar mime-view-x-face-to-pbm-command
- "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm")
-
-(defvar mime-view-x-face-command
- (concat mime-view-x-face-to-pbm-command
- " | xv -quit -")
- "String to be executed to display an X-Face field.
-The command will be executed in a sub-shell asynchronously.
-The compressed face will be piped to this command.")
-
-(defun mime-view-x-face-function ()
- "Function to display X-Face field. You can redefine to customize."
- ;; 1995/10/12 (c.f. tm-eng:130)
- ;; fixed by Eric Ding <ericding@San-Jose.ate.slb.com>
- (save-restriction
- (narrow-to-region (point-min) (re-search-forward "^$" nil t))
- ;; end
- (goto-char (point-min))
- (if (re-search-forward "^X-Face:[ \t]*" nil t)
- (let ((beg (match-end 0))
- (end (std11-field-end))
- )
- (call-process-region beg end "sh" nil 0 nil
- "-c" mime-view-x-face-command)
- ))))
-
-
;;; @ buffer setup
;;;
(when header-is-visible
(if header-presentation-method
(funcall header-presentation-method entity situation)
- (mime-insert-decoded-header entity
- mime-view-ignored-field-list
- mime-view-visible-field-list
- (if (mime-entity-cooked-p entity)
- nil
- default-mime-charset))
- )
+ (mime-insert-header entity
+ mime-view-ignored-field-list
+ mime-view-visible-field-list))
(goto-char (point-max))
(insert "\n")
(run-hooks 'mime-display-header-hook)
(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)
- (x-face "Show X Face" mime-preview-display-x-face)
)
"Menu for MIME Viewer")
-(cond (running-xemacs
+(cond ((featurep 'xemacs)
(defvar mime-view-xemacs-popup-menu
(cons mime-view-menu-title
(mapcar (function
(define-key mime-view-mode-map
[backspace] (function mime-preview-scroll-down-entity))
(if (functionp default)
- (cond (running-xemacs
+ (cond ((featurep 'xemacs)
(set-keymap-default-binding mime-view-mode-map default)
)
(t
(define-key mime-view-mode-map
mouse-button-2 (function mime-button-dispatcher))
)
- (cond (running-xemacs
+ (cond ((featurep 'xemacs)
(define-key mime-view-mode-map
mouse-button-3 (function mime-view-xemacs-popup-menu))
)
(setq preview-buffer
(concat "*Preview-" (buffer-name raw-buffer) "*")))
(set-buffer raw-buffer)
- (mime-parse-buffer)
(setq mime-preview-buffer preview-buffer)
(let ((inhibit-read-only t))
- (switch-to-buffer preview-buffer)
+ (set-buffer (get-buffer-create preview-buffer))
(widen)
(erase-buffer)
(setq mime-raw-buffer raw-buffer)
(search-forward "\n\n" nil t)
))
(run-hooks 'mime-view-mode-hook)
- ))
- (set-buffer-modified-p nil)
- (setq buffer-read-only t)
- )
+ (set-buffer-modified-p nil)
+ (setq buffer-read-only t)
+ (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-buffer (&optional raw-buffer preview-buffer mother
- default-keymap-or-function)
+ 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)
+ )
(mime-display-message
- (save-excursion
- (if raw-buffer (set-buffer raw-buffer))
- (mime-parse-message)
- )
+ (mime-open-entity representation-type raw-buffer)
preview-buffer mother default-keymap-or-function))
(defun mime-view-mode (&optional mother ctl encoding
and decode current content as `play mode'
"
(interactive)
- (mime-display-message
- (save-excursion
- (if raw-buffer (set-buffer raw-buffer))
- (or mime-view-redisplay
- (mime-parse-message ctl encoding))
- )
- preview-buffer mother default-keymap-or-function))
+ (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-internal
+ mime-message-structure ctl))
+ )
+ (or (mime-entity-encoding mime-message-structure)
+ (mime-entity-set-encoding-internal mime-message-structure encoding))
+ ))
+ (mime-display-message mime-message-structure preview-buffer
+ mother default-keymap-or-function)
+ )
;;; @@ playing
(autoload 'mime-preview-play-current-entity "mime-play"
"Play current entity." t)
-(defun mime-preview-extract-current-entity ()
+(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)
- (mime-preview-play-current-entity "extract")
+ (interactive "P")
+ (mime-preview-play-current-entity ignore-examples "extract")
)
-(defun mime-preview-print-current-entity ()
+(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)
- (mime-preview-play-current-entity "print")
+ (interactive "P")
+ (mime-preview-play-current-entity ignore-examples "print")
)
str
(save-excursion
(set-buffer a-buf)
- (setq
- ci
- (mime-raw-find-entity-from-node-id entity-node-id))
+ (setq ci
+ (mime-find-entity-from-node-id entity-node-id))
(save-restriction
(narrow-to-region
(mime-entity-point-min ci)
))
(setq rest (cdr rest))
))
- (eword-decode-header)
+ (mime-decode-header-in-buffer)
)
(let ((f (cdr (assq mode mime-preview-following-method-alist))))
(if (functionp f)
))))
-;;; @@ X-Face
-;;;
-
-(defun mime-preview-display-x-face ()
- (interactive)
- (save-window-excursion
- (set-buffer mime-raw-buffer)
- (mime-view-x-face-function)
- ))
-
-
;;; @@ moving
;;;
(get-text-property (point) 'mime-view-entity)))
(backward-char)
)
- (let ((r (mime-raw-find-entity-from-node-id
- (cdr (mime-entity-node-id cinfo))
- (get-text-property 1 'mime-view-entity)))
+ (let ((r (mime-entity-parent cinfo))
point)
(catch 'tag
(while (setq point (previous-single-property-change
If there is no previous entity, it calls function registered in
variable `mime-preview-over-to-next-method-alist'."
(interactive)
- (while (null (get-text-property (point) 'mime-view-entity))
+ (while (and (not (eobp))
+ (null (get-text-property (point) 'mime-view-entity)))
(forward-char)
)
(let ((point (next-single-property-change (point) 'mime-view-entity)))
projects / elisp / semi.git / blobdiff