X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=mime-view.el;h=51938b7f90c8ed4f48a0c5ff5dc7ec18d43eb9b6;hb=3a152807002ffad73a6700816229e7bd9301efda;hp=280436532daf09cfd858e2c4c1092573bc5cfe24;hpb=cc0a722ec13e11cd7aa00db6929cb2505d1c9556;p=elisp%2Fsemi.git diff --git a/mime-view.el b/mime-view.el index 2804365..51938b7 100644 --- a/mime-view.el +++ b/mime-view.el @@ -1,6 +1,6 @@ ;;; 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 ;; Created: 1994/07/13 @@ -8,7 +8,7 @@ ;; 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 @@ -27,6 +27,7 @@ ;;; Code: +(require 'emu) (require 'mime) (require 'semi-def) (require 'calist) @@ -38,11 +39,10 @@ ;;; (defconst mime-view-version - (eval-when-compile - (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) ")"))) + (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 @@ -139,37 +139,87 @@ mother-buffer." ;;; @ entity information ;;; -(defun mime-entity-situation (entity) +(defun mime-entity-situation (entity &optional situation) "Return situation of ENTITY." - (append (or (mime-entity-content-type entity) - (make-mime-content-type 'text 'plain)) - (let ((d (mime-entity-content-disposition entity))) - (cons (cons 'disposition-type - (mime-content-disposition-type d)) - (mapcar (function - (lambda (param) - (let ((name (car param))) - (cons (cond ((string= name "filename") - 'filename) - ((string= name "creation-date") - 'creation-date) - ((string= name "modification-date") - 'modification-date) - ((string= name "read-date") - 'read-date) - ((string= name "size") - 'size) - (t (cons 'disposition (car param)))) - (cdr param))))) - (mime-content-disposition-parameters d)) - )) - (list (cons 'encoding (mime-entity-encoding entity)) - (cons 'major-mode - (save-excursion - (set-buffer (mime-entity-buffer entity)) - major-mode))) - )) + (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))) + ;; major-mode + (or (assq 'major-mode situation) + (setq situation + (cons (cons 'major-mode + (with-current-buffer (mime-entity-buffer entity) + major-mode)) + situation))) + + situation)) (defun mime-view-entity-title (entity) (or (mime-read-field 'Content-Description entity) @@ -256,9 +306,13 @@ Please redefine this function if you want to change default setting." 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 @@ -681,7 +735,7 @@ MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t. t means default." (setq preview-buffer (current-buffer))) (let* ((raw-buffer (mime-entity-buffer entity)) (start (mime-entity-point-min entity)) - e nb ne) + e nb ne nhb nbb) (set-buffer raw-buffer) (goto-char start) (or situation @@ -708,15 +762,18 @@ MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t. t means default." (mime-view-insert-entity-button entity) )) (when header-is-visible + (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)) (goto-char (point-max)) - (insert "\n") (run-hooks 'mime-display-header-hook) + (put-text-property nhb (point-max) 'mime-view-entity-header entity) + (insert "\n") ) + (setq nbb (point)) (cond (children) ((functionp body-presentation-method) (funcall body-presentation-method entity situation) @@ -735,6 +792,7 @@ MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t. t means default." (setq ne (point-max)) (widen) (put-text-property nb ne 'mime-view-entity entity) + (put-text-property nbb ne 'mime-view-entity-body entity) (goto-char ne) (if children (if (functionp body-presentation-method) @@ -879,8 +937,20 @@ MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t. t means default." (defvar mime-view-redisplay nil) +;;;###autoload (defun mime-display-message (message &optional preview-buffer mother default-keymap-or-function) + "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." (mime-maybe-hide-echo-buffer) (let ((win-conf (current-window-configuration)) (raw-buffer (mime-entity-buffer message))) @@ -926,6 +996,7 @@ MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t. t means default." ))))) ))) +;;;###autoload (defun mime-view-buffer (&optional raw-buffer preview-buffer mother default-keymap-or-function representation-type) @@ -938,7 +1009,7 @@ 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, -`binary' is used as default." +`cooked' is used as default." (interactive) (or raw-buffer (setq raw-buffer (current-buffer))) @@ -1046,6 +1117,7 @@ It calls following-method selected from variable (let* ((p-beg (previous-single-property-change (point) 'mime-view-entity)) p-end + ph-end (entity-node-id (mime-entity-node-id entity)) (len (length entity-node-id)) ) @@ -1089,6 +1161,12 @@ It calls following-method selected from variable (setq p-end (point-max)) )) )) + (setq ph-end + (previous-single-property-change p-end 'mime-view-entity-header)) + (if (or (null ph-end) + (< ph-end p-beg)) + (setq ph-end p-beg) + ) (let* ((mode (mime-preview-original-major-mode 'recursive)) (new-name (format "%s-%s" (buffer-name) (reverse entity-node-id))) @@ -1099,7 +1177,10 @@ It calls following-method selected from variable (save-excursion (set-buffer (setq new-buf (get-buffer-create new-name))) (erase-buffer) - (insert-buffer-substring the-buf p-beg p-end) + (insert-buffer-substring the-buf ph-end p-end) + (when (= ph-end p-beg) + (goto-char (point-min)) + (insert ?\n)) (goto-char (point-min)) (let ((entity-node-id (mime-entity-node-id entity)) ci str) (while (progn @@ -1118,9 +1199,8 @@ It calls following-method selected from variable (concat "^" (apply (function regexp-or) fields) ":") "")))) - (if (and - (eq (mime-entity-media-type ci) 'message) - (eq (mime-entity-media-subtype ci) 'rfc822)) + (if (and (eq (mime-entity-media-type ci) 'message) + (eq (mime-entity-media-subtype ci) 'rfc822)) nil (if str (insert str) @@ -1148,7 +1228,7 @@ It calls following-method selected from variable )) (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) @@ -1213,7 +1293,8 @@ variable `mime-preview-over-to-previous-method-alist'." 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)))