;;; Code:
-(require 'emu)
(require 'mime)
(require 'semi-def)
(require 'calist)
(require 'alist)
-(require 'mailcap)
+(require 'mime-conf)
+
+(eval-when-compile (require 'static))
;;; @ version
(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-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)
(insert "\n;;; "
(file-name-nondirectory file)
" ends here.\n")
- (static-cond
+ (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)))))
(ctree-set-calist-strictly
'mime-preview-condition
+ '((type . application)(subtype . emacs-lisp)(disposition-type . inline)
+ (body . visible)
+ (body-presentation-method . mime-display-application/emacs-lisp)))
+
+(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 . 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)))
(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. ]]"))
+ "This is message/partial style split message.")
(defun mime-display-message/partial-button (&optional entity situation)
(save-restriction
(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)))
+ (mime-insert-button mime-view-announcement-for-message/partial
+ #'mime-preview-play-current-entity)))
(defun mime-display-multipart/mixed (entity situation)
(let ((children (mime-entity-children entity))
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)))
+
+;;; stolen (and renamed) from mm-view.el.
+(defun mime-display-inline-fontify (entity mode)
+ ;; XEmacs @#$@ version of font-lock refuses to fully turn itself
+ ;; on for buffers whose name begins with " ". That's why we use
+ ;; save-current-buffer/get-buffer-create rather than
+ ;; with-temp-buffer.
+ (let ((buffer (get-buffer-create "*fontification*")))
+ (save-current-buffer
+ (set-buffer buffer)
+ (buffer-disable-undo)
+ (erase-buffer)
+ (mime-insert-entity-content entity)
+ (funcall mode)
+ (let ((font-lock-verbose nil))
+ ;; I find font-lock a bit too verbose.
+ (font-lock-fontify-buffer))
+ ;; By default, XEmacs font-lock uses non-duplicable text
+ ;; properties. This code forces all the text properties
+ ;; to be copied along with the text.
+ (static-when (fboundp 'extent-list)
+ (map-extents (lambda (ext ignored)
+ (set-extent-property ext 'duplicable t)
+ nil)
+ nil nil nil nil nil 'text-prop)))
+ (insert-buffer-substring buffer)))
+
+(defun mime-display-application/emacs-lisp (entity situation)
+ (save-restriction
+ (narrow-to-region (point-max)(point-max))
+ (mime-display-inline-fontify entity 'emacs-lisp-mode)
+ (run-hooks 'mime-text-decode-hook 'mime-display-text/plain-hook)))
+
;;; @ acting-condition
;;;
(defvar mime-acting-condition nil
"Condition-tree about how to process entity.")
-(if (file-readable-p mailcap-file)
- (let ((entries (mailcap-parse-file)))
- (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)))))
+(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
;;; @ 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))
+(defconst mime-view-popup-menu-list
+ '("MIME-View"
+ ["Move to upper entity" mime-preview-move-to-upper]
+ ["Move to previous entity" mime-preview-move-to-previous]
+ ["Move to next entity" mime-preview-move-to-next]
+ ["Scroll-down" mime-preview-scroll-down-entity]
+ ["Scroll-up" mime-preview-scroll-up-entity]
+ ["Play current entity" mime-preview-play-current-entity]
+ ["Extract current entity" mime-preview-extract-current-entity]
+ ["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))
- (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])))
-
-;;; The current local map is taken precendence over `widget-keymap', because GNU Emacs'
-;;; widget implementation doesn't set `local-map' property. So we need to specify derivation.
+(defun mime-view-popup-menu (event)
+ "Popup the menu in the MIME Viewer buffer"
+ (interactive "@e")
+ (mime-popup-menu-popup mime-view-popup-menu-list event))
+
+;;; The current local map is taken precendence over `widget-keymap',
+;;; because GNU Emacs' widget implementation doesn't set `local-map' property.
+;;; So we need to specify derivation.
(defvar widget-keymap)
(defun mime-view-maybe-inherit-widget-keymap ()
(when (boundp 'widget-keymap)
(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)))))))
- (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))))
- (use-local-map mime-view-mode-map)
- (run-hooks 'mime-view-define-keymap-hook)))
+ (if (featurep 'xemacs)
+ (set-keymap-default-binding mime-view-mode-map default)
+ (setq mime-view-mode-map
+ (append mime-view-mode-map (list (cons t default))))))
+ (define-key mime-view-mode-map
+ [down-mouse-3] (function mime-view-popup-menu))
+ ;; (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."
;;;###autoload
(defun mime-display-message (message &optional preview-buffer
mother default-keymap-or-function
- original-major-mode)
+ original-major-mode keymap)
"View MESSAGE in MIME-View mode.
Optional argument PREVIEW-BUFFER specifies the buffer of the
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."
+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
(header . visible)
(major-mode . ,original-major-mode))
preview-buffer)
- (mime-view-define-keymap default-keymap-or-function)
+ (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
(provide 'mime-view)
-(let ((file mime-situation-examples-file))
- (if (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)))
- (eval-buffer)
- ;; 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))))))
+(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
projects / elisp / semi.git / blobdiff