From: yamaoka Date: Fri, 11 Sep 1998 07:00:42 +0000 (+0000) Subject: Importing pgnus-0.25. X-Git-Tag: pgnus-0_25~1 X-Git-Url: http://git.chise.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=d9a249ab6f6663e7766b40b54fe8456521c18410;p=elisp%2Fgnus.git- Importing pgnus-0.25. --- diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 312755f..f088f06 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,51 @@ +Fri Sep 11 08:09:40 1998 Lars Magne Ingebrigtsen + + * gnus.el: Pterodactyl Gnus v0.25 is released. + +1998-09-11 07:38:14 Lars Magne Ingebrigtsen + + * gnus-art.el (article-remove-trailing-blank-lines): Don't remove + annotations. + + * gnus.el ((featurep 'gnus-xmas)): New + 'gnus-annotation-in-region-p alias. + +1998-09-10 06:20:52 Lars Magne Ingebrigtsen + + * mm-util.el (mm-with-unibyte-buffer): New function. + + * gnus-uu.el (gnus-quote-arg-for-sh-or-csh): Renamed. + + * mm-decode.el (mm-inline-media-tests): New variable. + + * gnus-sum.el (gnus-summary-exit): Destroy handles. + + * gnus-art.el (gnus-article-mime-handles): New variable. + + * drums.el (drums-narrow-to-header): New function. + + * gnus-art.el (article-decode-charset): Use it. + + * drums.el (drums-content-type-get): New function. + + * mm-util.el (mm-content-type-charset): Removed. + + * drums.el (drums-syntax-table): @ is word. + (drums-parse-content-type): New function. + + * parse-time.el (parse-time-rules): Parse "Wed, 29 Apr 98 0:26:01 + EDT" times. + + * gnus-util.el (gnus-date-get-time): Use safe date. + + * gnus-sum.el (gnus-show-mime): Removed. + (gnus-summary-toggle-mime): Removed. + + * gnus-art.el (gnus-strict-mime): Removed. + (gnus-article-prepare): Don't do MIME. + (gnus-decode-encoded-word-method): Removed. + (gnus-show-mime-method): Removed. + Thu Sep 10 04:03:29 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.24 is released. diff --git a/lisp/drums.el b/lisp/drums.el index 0344956..b13ec15 100644 --- a/lisp/drums.el +++ b/lisp/drums.el @@ -29,6 +29,7 @@ ;;; Code: (require 'time-date) +(require 'mm-util) (defvar drums-no-ws-ctl-token "\001-\010\013\014\016-\037\177" "US-ASCII control characters excluding CR, LF and white space.") @@ -50,16 +51,43 @@ (defvar drums-qtext-token (concat drums-no-ws-ctl-token "\041\043-\133\135-\177") "Non-white-space control characaters, plus the rest of ASCII excluding backslash and doublequote.") - +(defvar drums-tspecials "][()<>@,;:\\\"/?=" + "Tspecials.") + (defvar drums-syntax-table (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table))) (modify-syntax-entry ?\\ "/" table) (modify-syntax-entry ?< "(" table) (modify-syntax-entry ?> ")" table) - (modify-syntax-entry ?( "(" table) - (modify-syntax-entry ?) ")" table) + (modify-syntax-entry ?@ "w" table) + (modify-syntax-entry ?/ "w" table) + (modify-syntax-entry ?= " " table) + (modify-syntax-entry ?\; " " table) table)) +(defun drums-token-to-list (token) + "Translate TOKEN into a list of characters." + (let ((i 0) + b e c out range) + (while (< i (length token)) + (setq c (mm-char-int (aref token i))) + (incf i) + (cond + ((eq c (mm-char-int ?-)) + (if b + (setq range t) + (push c out))) + (range + (while (<= b c) + (push (mm-make-char 'ascii b) out) + (incf b)) + (setq range nil)) + ((= i (length token)) + (push (mm-make-char 'ascii c) out)) + (t + (setq b c)))) + (nreverse out))) + (defsubst drums-init (string) (set-syntax-table drums-syntax-table) (insert string) @@ -92,7 +120,7 @@ (cond ((eq c ?\") (forward-sexp 1)) - ((memq c '(? ?\t)) + ((memq c '(? ?\t ?\n)) (delete-char 1)) (t (forward-char 1)))) @@ -186,7 +214,67 @@ (defun drums-parse-date (string) "Return an Emacs time spec from STRING." (apply 'encode-time (parse-time-string string))) - + +(defun drums-content-type-get (ct attribute) + "Return the value of ATTRIBUTE from CT." + (cdr (assq attribute (cdr ct)))) + +(defun drums-parse-content-type (string) + "Parse STRING and return a list." + (with-temp-buffer + (let ((ttoken (drums-token-to-list drums-text-token)) + (stoken (drums-token-to-list drums-tspecials)) + display-name mailbox c display-string parameters + attribute value type subtype) + (drums-init (drums-remove-whitespace (drums-remove-comments string))) + (setq c (following-char)) + (when (and (memq c ttoken) + (not (memq c stoken))) + (setq type (downcase (buffer-substring + (point) (progn (forward-sexp 1) (point))))) + ;; Do the params + (while (not (eobp)) + (setq c (following-char)) + (unless (eq c ?\;) + (error "Invalid header: %s" string)) + (forward-char 1) + (setq c (following-char)) + (if (and (memq c ttoken) + (not (memq c stoken))) + (setq attribute + (intern + (downcase + (buffer-substring + (point) (progn (forward-sexp 1) (point)))))) + (error "Invalid header: %s" string)) + (setq c (following-char)) + (unless (eq c ?=) + (error "Invalid header: %s" string)) + (forward-char 1) + (setq c (following-char)) + (cond + ((eq c ?\") + (setq value + (buffer-substring (1+ (point)) + (progn (forward-sexp 1) (1- (point)))))) + ((and (memq c ttoken) + (not (memq c stoken))) + (setq value (buffer-substring + (point) (progn (forward-sexp 1) (point))))) + (t + (error "Invalid header: %s" string))) + (push (cons attribute value) parameters)) + `(,type ,@(nreverse parameters)))))) + +(defun drums-narrow-to-header () + "Narrow to the header of the current buffer." + (narrow-to-region + (goto-char (point-min)) + (if (search-forward "\n\n" nil 1) + (1- (point)) + (point-max))) + (goto-char (point-min))) + (provide 'drums) ;;; drums.el ends here diff --git a/lisp/earcon.el b/lisp/earcon.el index 4302182..a698479 100644 --- a/lisp/earcon.el +++ b/lisp/earcon.el @@ -74,8 +74,6 @@ (defvar earcon-button-marker-list nil) (make-variable-buffer-local 'earcon-button-marker-list) - - ;;; FIXME!! clone of code from gnus-vis.el FIXME!! (defun earcon-article-push-button (event) "Check text under the mouse pointer for a callback function. @@ -156,7 +154,6 @@ If N is negative, move backward instead." (setq entry nil))) entry)) - (defun earcon-button-push (marker) ;; Push button starting at MARKER. (save-excursion diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index 38b315b..e99e8c4 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -34,6 +34,8 @@ (require 'gnus-int) (require 'browse-url) (require 'mm-bodies) +(require 'drums) +(require 'mm-decode) (defgroup gnus-article nil "Article display." @@ -374,23 +376,6 @@ be used as possible file names." (cons :value ("" "") regexp (repeat string)) (sexp :value nil)))) -(defcustom gnus-strict-mime t - "*If nil, MIME-decode even if there is no Mime-Version header." - :group 'gnus-article-mime - :type 'boolean) - -(defcustom gnus-show-mime-method 'metamail-buffer - "Function to process a MIME message. -The function is called from the article buffer." - :group 'gnus-article-mime - :type 'function) - -(defcustom gnus-decode-encoded-word-method 'gnus-article-de-quoted-unreadable - "*Function to decode MIME encoded words. -The function is called from the article buffer." - :group 'gnus-article-mime - :type 'function) - (defcustom gnus-page-delimiter "^\^L" "*Regexp describing what to use as article page delimiters. The default value is \"^\^L\", which is a form linefeed at the @@ -547,10 +532,18 @@ displayed by the first non-nil matching CONTENT face." (defcustom gnus-article-decode-hook '(article-decode-charset article-decode-rfc1522) - "*Hook run to decode charsets in articles.") + "*Hook run to decode charsets in articles." + :group 'gnus-article-headers + :type 'hook) + +(defcustom gnus-display-mime-function 'gnus-display-mime + "Function to display MIME articles." + :group 'gnus-article-headers + :type 'function) ;;; Internal variables +(defvar gnus-article-mime-handles nil) (defvar article-lapsed-timer nil) (defvar gnus-article-current-summary nil) @@ -894,7 +887,9 @@ characters to translate to." (point) (progn (while (and (not (bobp)) - (looking-at "^[ \t]*$")) + (looking-at "^[ \t]*$") + (not (gnus-annotation-in-region-p + (point) (gnus-point-at-eol)))) (forward-line -1)) (forward-line 1) (point)))))) @@ -968,11 +963,12 @@ If PROMPT (the prefix), prompt for a coding system to use." (let* ((inhibit-point-motion-hooks t) (ct (message-fetch-field "Content-Type" t)) (cte (message-fetch-field "Content-Transfer-Encoding" t)) + (ctl (and ct (drums-parse-content-type ct))) (charset (cond (prompt (mm-read-coding-system "Charset to decode: ")) (ct - (mm-content-type-charset ct)) + (drums-content-type-get ctl 'charset)) (gnus-newsgroup-name (gnus-group-find-parameter gnus-newsgroup-name 'charset)))) @@ -981,7 +977,7 @@ If PROMPT (the prefix), prompt for a coding system to use." (widen) (narrow-to-region (point) (point-max)) (when (or (not ct) - (string-match "text/plain" ct)) + (equal (car ctl) "text/plain")) (mm-decode-body charset (and cte (intern (downcase (gnus-strip-whitespace cte)))))))))) @@ -1118,7 +1114,9 @@ always hide." (goto-char (point-min)) (search-forward "\n\n" nil t) (while (re-search-forward "\n\n\n+" nil t) - (replace-match "\n\n" t t))))) + (unless (gnus-annotation-in-region-p + (match-beginning 0) (match-end 0)) + (replace-match "\n\n" t t)))))) (defun article-strip-leading-space () "Remove all white space from the beginning of the lines in the article." @@ -1937,14 +1935,13 @@ commands: (setq mode-name "Article") (setq major-mode 'gnus-article-mode) (make-local-variable 'minor-mode-alist) - (unless (assq 'gnus-show-mime minor-mode-alist) - (push (list 'gnus-show-mime " MIME") minor-mode-alist)) (use-local-map gnus-article-mode-map) (gnus-update-format-specifications nil 'article-mode) (set (make-local-variable 'page-delimiter) gnus-page-delimiter) (make-local-variable 'gnus-page-broken) (make-local-variable 'gnus-button-marker-list) (make-local-variable 'gnus-article-current-summary) + (make-local-variable 'gnus-article-mime-handles) (gnus-set-default-directory) (buffer-disable-undo (current-buffer)) (setq buffer-read-only t) @@ -2102,14 +2099,8 @@ If ALL-HEADERS is non-nil, no headers are hidden." (let (buffer-read-only) (gnus-run-hooks 'gnus-tmp-internal-hook) (gnus-run-hooks 'gnus-article-prepare-hook) - ;; Decode MIME message. - (when gnus-show-mime - (if (or (not gnus-strict-mime) - (gnus-fetch-field "Mime-Version")) - (let ((coding-system-for-write 'binary) - (coding-system-for-read 'binary)) - (funcall gnus-show-mime-method)) - (funcall gnus-decode-encoded-word-method))) + (when gnus-display-mime-function + (funcall gnus-display-mime-function)) ;; Perform the article display hooks. (gnus-run-hooks 'gnus-article-display-hook)) ;; Do page break. @@ -2125,6 +2116,32 @@ If ALL-HEADERS is non-nil, no headers are hidden." (set-window-point (get-buffer-window (current-buffer)) (point)) t)))))) +(defun gnus-display-mime () + (let ((handles (mm-dissect-buffer)) + handle name type) + (mapcar 'mm-destroy-part gnus-article-mime-handles) + (setq gnus-article-mime-handles nil) + (setq gnus-article-mime-handles (nconc gnus-article-mime-handles handles)) + (when handles + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (delete-region (point) (point-max)) + (while (setq handle (pop handles)) + (setq name (drums-content-type-get (cadr handle) 'name) + type (caadr handle)) + (gnus-article-add-button + (point) + (progn + (insert + (format "[%s%s]" type (if name (concat " (" name ")") ""))) + (point)) + 'mm-display-part handle) + (insert "\n\n\n") + (when (mm-automatic-display-p type) + (forward-line -2) + (mm-display-part handle) + (goto-char (point-max))))))) + (defun gnus-article-wash-status () "Return a string which display status of article washing." (save-excursion @@ -2136,15 +2153,13 @@ If ALL-HEADERS is non-nil, no headers are hidden." (pem (gnus-article-hidden-text-p 'pem)) (signature (gnus-article-hidden-text-p 'signature)) (overstrike (gnus-article-hidden-text-p 'overstrike)) - (emphasis (gnus-article-hidden-text-p 'emphasis)) - (mime gnus-show-mime)) + (emphasis (gnus-article-hidden-text-p 'emphasis))) (format "%c%c%c%c%c%c%c" (if cite ?c ? ) (if (or headers boring) ?h ? ) (if (or pgp pem) ?p ? ) (if signature ?s ? ) (if overstrike ?o ? ) - (if mime ?m ? ) (if emphasis ?e ? ))))) (fset 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers) diff --git a/lisp/gnus-sum.el b/lisp/gnus-sum.el index 929dddb..ebc08c0 100644 --- a/lisp/gnus-sum.el +++ b/lisp/gnus-sum.el @@ -328,13 +328,6 @@ variable." :group 'gnus-article-various :type 'boolean) -(defcustom gnus-show-mime nil - "*If non-nil, do mime processing of articles. -The articles will simply be fed to the function given by -`gnus-show-mime-method'." - :group 'gnus-article-mime - :type 'boolean) - (defcustom gnus-move-split-methods nil "*Variable used to suggest where articles are to be moved to. It uses the same syntax as the `gnus-split-methods' variable." @@ -1188,7 +1181,6 @@ increase the score of each group you read." "\M-g" gnus-summary-rescan-group "w" gnus-summary-stop-page-breaking "\C-c\C-r" gnus-summary-caesar-message - "\M-t" gnus-summary-toggle-mime "f" gnus-summary-followup "F" gnus-summary-followup-with-original "C" gnus-summary-cancel-article @@ -1363,7 +1355,6 @@ increase the score of each group you read." "r" gnus-summary-caesar-message "t" gnus-article-hide-headers "v" gnus-summary-verbose-headers - "m" gnus-summary-toggle-mime "h" gnus-article-treat-html "d" gnus-article-treat-dumbquotes) @@ -1519,7 +1510,6 @@ increase the score of each group you read." ["Add buttons" gnus-article-add-buttons t] ["Add buttons to head" gnus-article-add-buttons-to-head t] ["Stop page breaking" gnus-summary-stop-page-breaking t] - ["Toggle MIME" gnus-summary-toggle-mime t] ["Verbose header" gnus-summary-verbose-headers t] ["Toggle header" gnus-summary-toggle-header t]) ("Output" @@ -5089,6 +5079,9 @@ gnus-exit-group-hook is called with no arguments if that value is non-nil." nil ;Nothing to do. ;; If we have several article buffers, we kill them at exit. (unless gnus-single-article-buffer + (save-excursion + (set-buffer gnus-article-buffer) + (mapcar 'mm-destroy-part gnus-article-mime-handles)) (gnus-kill-buffer gnus-article-buffer) (gnus-kill-buffer gnus-original-article-buffer) (setq gnus-article-current nil)) @@ -6598,7 +6591,7 @@ Optional argument BACKWARD means do search for backward. (gnus-use-trees nil) ;Inhibit updating tree buffer. (sum (current-buffer)) (found nil) - point) + point gnus-display-mime-function) (gnus-save-hidden-threads (gnus-summary-select-article) (set-buffer gnus-article-buffer) @@ -6772,8 +6765,8 @@ article massaging functions being run." gnus-article-display-hook gnus-article-prepare-hook gnus-article-decode-hook + gnus-display-mime-function gnus-break-pages - gnus-show-mime gnus-visual) (gnus-summary-select-article nil 'force))) (gnus-summary-goto-subject gnus-current-article) @@ -6824,15 +6817,6 @@ If ARG is a negative number, hide the unwanted header lines." (interactive) (gnus-article-show-all-headers)) -(defun gnus-summary-toggle-mime (&optional arg) - "Toggle MIME processing. -If ARG is a positive number, turn MIME processing on." - (interactive "P") - (setq gnus-show-mime - (if (null arg) (not gnus-show-mime) - (> (prefix-numeric-value arg) 0))) - (gnus-summary-select-article t 'force)) - (defun gnus-summary-caesar-message (&optional arg) "Caesar rotate the current article by 13. The numerical prefix specifies how many places to rotate each letter diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el index da80c81..0c63370 100644 --- a/lisp/gnus-util.el +++ b/lisp/gnus-util.el @@ -302,7 +302,7 @@ Cache the result as a text property stored in DATE." '(0 0) (or (get-text-property 0 'gnus-time d) ;; or compute the value... - (let ((time (date-to-time d))) + (let ((time (safe-date-to-time d))) ;; and store it back in the string. (put-text-property 0 1 'gnus-time time d) time))))) diff --git a/lisp/gnus-uu.el b/lisp/gnus-uu.el index 19929f3..776de0a 100644 --- a/lisp/gnus-uu.el +++ b/lisp/gnus-uu.el @@ -32,6 +32,7 @@ (require 'gnus-art) (require 'message) (require 'gnus-msg) +(require 'mm-decode) (defgroup gnus-extract nil "Extracting encoded files." @@ -1694,23 +1695,11 @@ didn't work, and overwrite existing files. Otherwise, ask each time." (when (setq buf (get-buffer gnus-uu-output-buffer-name)) (kill-buffer buf)))) -(defun gnus-quote-arg-for-sh-or-csh (arg) - (let ((pos 0) new-pos accum) - ;; *** bug: we don't handle newline characters properly - (while (setq new-pos (string-match "[!`\"$\\& \t{}]" arg pos)) - (push (substring arg pos new-pos) accum) - (push "\\" accum) - (push (list (aref arg new-pos)) accum) - (setq pos (1+ new-pos))) - (if (= pos 0) - arg - (apply 'concat (nconc (nreverse accum) (list (substring arg pos))))))) - ;; Inputs an action and a filename and returns a full command, making sure ;; that the filename will be treated as a single argument when the shell ;; executes the command. (defun gnus-uu-command (action file) - (let ((quoted-file (gnus-quote-arg-for-sh-or-csh file))) + (let ((quoted-file (mm-quote-arg file))) (if (string-match "%s" action) (format action quoted-file) (concat action " " quoted-file)))) diff --git a/lisp/gnus-xmas.el b/lisp/gnus-xmas.el index dc0f34c..5624d4d 100644 --- a/lisp/gnus-xmas.el +++ b/lisp/gnus-xmas.el @@ -476,6 +476,7 @@ call it with the value of the `gnus-data' text property." 'gnus-xmas-mode-line-buffer-identification) (fset 'gnus-key-press-event-p 'key-press-event-p) (fset 'gnus-region-active-p 'region-active-p) + (fset 'gnus-annotation-in-region-p 'gnus-xmas-annotation-in-region-p) (add-hook 'gnus-group-mode-hook 'gnus-xmas-group-menu-add) (add-hook 'gnus-summary-mode-hook 'gnus-xmas-summary-menu-add) @@ -802,6 +803,9 @@ XEmacs compatibility workaround." (when (eq (device-type) 'x) (gnus-splash))) +(defun gnus-xmas-annotation-in-region-p (b e) + (map-extents (lambda (e u) t) nil b e nil nil 'mm t)) + (provide 'gnus-xmas) ;;; gnus-xmas.el ends here diff --git a/lisp/gnus.el b/lisp/gnus.el index 3e19cb7..b3823cd 100644 --- a/lisp/gnus.el +++ b/lisp/gnus.el @@ -250,7 +250,7 @@ is restarted, and sometimes reloaded." :link '(custom-manual "(gnus)Exiting Gnus") :group 'gnus) -(defconst gnus-version-number "0.24" +(defconst gnus-version-number "0.25" "Version number for this version of Gnus.") (defconst gnus-version (format "Pterodactyl Gnus v%s" gnus-version-number) @@ -268,8 +268,6 @@ be set in `.emacs' instead." :group 'gnus-start :type 'boolean) -;;; Kludges to help the transition from the old `custom.el'. - (unless (featurep 'gnus-xmas) (defalias 'gnus-make-overlay 'make-overlay) (defalias 'gnus-delete-overlay 'delete-overlay) @@ -289,7 +287,8 @@ be set in `.emacs' instead." (defalias 'gnus-characterp 'numberp) (defalias 'gnus-deactivate-mark 'deactivate-mark) (defalias 'gnus-window-edges 'window-edges) - (defalias 'gnus-key-press-event-p 'numberp)) + (defalias 'gnus-key-press-event-p 'numberp) + (defalias 'gnus-annotation-in-region-p 'ignore)) ;; We define these group faces here to avoid the display ;; update forced when creating new faces. @@ -1373,7 +1372,6 @@ want." gnus-summary-stop-page-breaking ;; gnus-summary-caesar-message ;; gnus-summary-verbose-headers - gnus-summary-toggle-mime gnus-article-hide gnus-article-hide-headers gnus-article-hide-boring-headers diff --git a/lisp/lpath.el b/lisp/lpath.el index 20ad587..7a95125 100644 --- a/lisp/lpath.el +++ b/lisp/lpath.el @@ -64,7 +64,9 @@ gnus-mule-get-coding-system decode-coding-string mail-aliases-setup mm-copy-tree url-view-url w3-prepare-buffer - mule-write-region-no-coding-system char-int))) + mule-write-region-no-coding-system char-int + annotationp delete-annotation make-image-specifier + make-annotation))) (setq load-path (cons "." load-path)) (require 'custom) diff --git a/lisp/mailcap.el b/lisp/mailcap.el new file mode 100644 index 0000000..d401499 --- /dev/null +++ b/lisp/mailcap.el @@ -0,0 +1,830 @@ +;;; mailcap.el --- Functions for displaying MIME parts +;; Copyright (C) 1998 Free Software Foundation, Inc. + +;; Author: William M. Perry +;; Lars Magne Ingebrigtsen +;; Keywords: news, mail + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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. + +;; GNU Emacs 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. + +;;; Commentary: + +;;; Code: + +(eval-and-compile + (require 'cl)) +(require 'drums) + +(defvar mailcap-parse-args-syntax-table + (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table))) + (modify-syntax-entry ?' "\"" table) + (modify-syntax-entry ?` "\"" table) + (modify-syntax-entry ?{ "(" table) + (modify-syntax-entry ?} ")" table) + table) + "A syntax table for parsing sgml attributes.") + +(defvar mailcap-mime-data + '(("multipart" + (".*" + ("viewer" . mailcap-save-binary-file) + ("type" . "multipart/*"))) + ("application" + ("x-x509-ca-cert" + ("viewer" . ssl-view-site-cert) + ("test" . (fboundp 'ssl-view-site-cert)) + ("type" . "application/x-x509-ca-cert")) + ("x-x509-user-cert" + ("viewer" . ssl-view-user-cert) + ("test" . (fboundp 'ssl-view-user-cert)) + ("type" . "application/x-x509-user-cert")) + ("octet-stream" + ("viewer" . mailcap-save-binary-file) + ("type" ."application/octet-stream")) + ("dvi" + ("viewer" . "open %s") + ("type" . "application/dvi") + ("test" . (eq (mm-device-type) 'ns))) + ("dvi" + ("viewer" . "xdvi %s") + ("test" . (eq (mm-device-type) 'x)) + ("needsx11") + ("type" . "application/dvi")) + ("dvi" + ("viewer" . "dvitty %s") + ("test" . (not (getenv "DISPLAY"))) + ("type" . "application/dvi")) + ("emacs-lisp" + ("viewer" . mailcap-maybe-eval) + ("type" . "application/emacs-lisp")) + ("x-tar" + ("viewer" . mailcap-save-binary-file) + ("type" . "application/x-tar")) + ("x-latex" + ("viewer" . tex-mode) + ("test" . (fboundp 'tex-mode)) + ("type" . "application/x-latex")) + ("x-tex" + ("viewer" . tex-mode) + ("test" . (fboundp 'tex-mode)) + ("type" . "application/x-tex")) + ("latex" + ("viewer" . tex-mode) + ("test" . (fboundp 'tex-mode)) + ("type" . "application/latex")) + ("tex" + ("viewer" . tex-mode) + ("test" . (fboundp 'tex-mode)) + ("type" . "application/tex")) + ("texinfo" + ("viewer" . texinfo-mode) + ("test" . (fboundp 'texinfo-mode)) + ("type" . "application/tex")) + ("zip" + ("viewer" . mailcap-save-binary-file) + ("type" . "application/zip") + ("copiousoutput")) + ("pdf" + ("viewer" . "acroread %s") + ("type" . "application/pdf")) + ("postscript" + ("viewer" . "open %s") + ("type" . "application/postscript") + ("test" . (eq (mm-device-type) 'ns))) + ("postscript" + ("viewer" . "ghostview %s") + ("type" . "application/postscript") + ("test" . (eq (mm-device-type) 'x)) + ("needsx11")) + ("postscript" + ("viewer" . "ps2ascii %s") + ("type" . "application/postscript") + ("test" . (not (getenv "DISPLAY"))) + ("copiousoutput"))) + ("audio" + ("x-mpeg" + ("viewer" . "maplay %s") + ("type" . "audio/x-mpeg")) + (".*" + ("viewer" . mailcap-play-sound-file) + ("test" . (or (featurep 'nas-sound) + (featurep 'native-sound))) + ("type" . "audio/*")) + (".*" + ("viewer" . "showaudio") + ("type" . "audio/*"))) + ("message" + ("rfc-*822" + ("viewer" . vm-mode) + ("test" . (fboundp 'vm-mode)) + ("type" . "message/rfc-822")) + ("rfc-*822" + ("viewer" . w3-mode) + ("test" . (fboundp 'w3-mode)) + ("type" . "message/rfc-822")) + ("rfc-*822" + ("viewer" . view-mode) + ("test" . (fboundp 'view-mode)) + ("type" . "message/rfc-822")) + ("rfc-*822" + ("viewer" . fundamental-mode) + ("type" . "message/rfc-822"))) + ("image" + ("x-xwd" + ("viewer" . "xwud -in %s") + ("type" . "image/x-xwd") + ("compose" . "xwd -frame > %s") + ("test" . (eq (mm-device-type) 'x)) + ("needsx11")) + ("x11-dump" + ("viewer" . "xwud -in %s") + ("type" . "image/x-xwd") + ("compose" . "xwd -frame > %s") + ("test" . (eq (mm-device-type) 'x)) + ("needsx11")) + ("windowdump" + ("viewer" . "xwud -in %s") + ("type" . "image/x-xwd") + ("compose" . "xwd -frame > %s") + ("test" . (eq (mm-device-type) 'x)) + ("needsx11")) + (".*" + ("viewer" . "aopen %s") + ("type" . "image/*") + ("test" . (eq (mm-device-type) 'ns))) + (".*" + ("viewer" . "xv -perfect %s") + ("type" . "image/*") + ("test" . (eq (mm-device-type) 'x)) + ("needsx11"))) + ("text" + ("plain" + ("viewer" . w3-mode) + ("test" . (fboundp 'w3-mode)) + ("type" . "text/plain")) + ("plain" + ("viewer" . view-mode) + ("test" . (fboundp 'view-mode)) + ("type" . "text/plain")) + ("plain" + ("viewer" . fundamental-mode) + ("type" . "text/plain")) + ("enriched" + ("viewer" . enriched-decode-region) + ("test" . (fboundp 'enriched-decode-region)) + ("type" . "text/enriched")) + ("html" + ("viewer" . w3-prepare-buffer) + ("test" . (fboundp 'w3-prepare-buffer)) + ("type" . "text/html"))) + ("video" + ("mpeg" + ("viewer" . "mpeg_play %s") + ("type" . "video/mpeg") + ("test" . (eq (mm-device-type) 'x)) + ("needsx11"))) + ("x-world" + ("x-vrml" + ("viewer" . "webspace -remote %s -URL %u") + ("type" . "x-world/x-vrml") + ("description" + "VRML document"))) + ("archive" + ("tar" + ("viewer" . tar-mode) + ("type" . "archive/tar") + ("test" . (fboundp 'tar-mode))))) + "*The mailcap structure is an assoc list of assoc lists. +1st assoc list is keyed on the major content-type +2nd assoc list is keyed on the minor content-type (which can be a regexp) + +Which looks like: +----------------- + ((\"application\" + (\"postscript\" . )) + (\"text\" + (\"plain\" . ))) + +Where is another assoc list of the various information +related to the mailcap RFC. This is keyed on the lowercase +attribute name (viewer, test, etc). This looks like: + ((\"viewer\" . viewerinfo) + (\"test\" . testinfo) + (\"xxxx\" . \"string\")) + +Where viewerinfo specifies how the content-type is viewed. Can be +a string, in which case it is run through a shell, with +appropriate parameters, or a symbol, in which case the symbol is +funcall'd, with the buffer as an argument. + +testinfo is a list of strings, or nil. If nil, it means the +viewer specified is always valid. If it is a list of strings, +these are used to determine whether a viewer passes the 'test' or +not.") + +(defvar mailcap-download-directory nil + "*Where downloaded files should go by default.") + +(defvar mailcap-temporary-directory (or (getenv "TMPDIR") "/tmp") + "*Where temporary files go.") + +;;; +;;; Utility functions +;;; + +(defun mailcap-generate-unique-filename (&optional fmt) + "Generate a unique filename in mailcap-temporary-directory" + (if (not fmt) + (let ((base (format "mailcap-tmp.%d" (user-real-uid))) + (fname "") + (x 0)) + (setq fname (format "%s%d" base x)) + (while (file-exists-p + (expand-file-name fname mailcap-temporary-directory)) + (setq x (1+ x) + fname (concat base (int-to-string x)))) + (expand-file-name fname mailcap-temporary-directory)) + (let ((base (concat "mm" (int-to-string (user-real-uid)))) + (fname "") + (x 0)) + (setq fname (format fmt (concat base (int-to-string x)))) + (while (file-exists-p + (expand-file-name fname mailcap-temporary-directory)) + (setq x (1+ x) + fname (format fmt (concat base (int-to-string x))))) + (expand-file-name fname mailcap-temporary-directory)))) + +(defun mailcap-save-binary-file () + ;; Ok, this is truly fucked. In XEmacs, if you use the mouse to select + ;; a URL that gets saved via this function, read-file-name will pop up a + ;; dialog box for file selection. For some reason which buffer we are in + ;; gets royally screwed (even with save-excursions and the whole nine + ;; yards). SO, we just keep the old buffer name around and away we go. + (let ((old-buff (current-buffer)) + (file (read-file-name "Filename to save as: " + (or mailcap-download-directory "~/") + (file-name-nondirectory (url-view-url t)) + nil + (file-name-nondirectory (url-view-url t)))) + (require-final-newline nil)) + (set-buffer old-buff) + (mule-write-region-no-coding-system (point-min) (point-max) file) + (kill-buffer (current-buffer)))) + +(defun mailcap-maybe-eval () + "Maybe evaluate a buffer of emacs lisp code" + (if (yes-or-no-p "This is emacs-lisp code, evaluate it? ") + (eval-buffer (current-buffer)) + (emacs-lisp-mode))) + +;;; +;;; The mailcap parser +;;; + +(defun mailcap-replace-regexp (regexp to-string) + ;; Quiet replace-regexp. + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (replace-match to-string t nil))) + +(defvar mailcap-parsed-p nil) + +(defun mailcap-parse-mailcaps (&optional path force) + "Parse out all the mailcaps specified in a unix-style path string PATH. +If FORCE, re-parse even if already parsed." + (when (or (not mailcap-parsed-p) + force) + (cond + (path nil) + ((getenv "MAILCAPS") (setq path (getenv "MAILCAPS"))) + ((memq system-type '(ms-dos ms-windows windows-nt)) + (setq path (mapconcat 'expand-file-name '("~/mail.cap" "~/etc/mail.cap") + ";"))) + (t (setq path (mapconcat 'expand-file-name + '("~/.mailcap" + "/etc/mailcap:/usr/etc/mailcap" + "/usr/local/etc/mailcap") ":")))) + (let ((fnames (reverse + (split-string + path (if (memq system-type + '(ms-dos ms-windows windows-nt)) + ";" + ":")))) + fname) + (while fnames + (setq fname (car fnames)) + (if (and (file-exists-p fname) (file-readable-p fname)) + (mailcap-parse-mailcap (car fnames))) + (setq fnames (cdr fnames)))) + (setq mailcap-parsed-p t))) + +(defun mailcap-parse-mailcap (fname) + ;; Parse out the mailcap file specified by FNAME + (let (major ; The major mime type (image/audio/etc) + minor ; The minor mime type (gif, basic, etc) + save-pos ; Misc saved positions used in parsing + viewer ; How to view this mime type + info ; Misc info about this mime type + ) + (with-temp-buffer + (insert-file-contents fname) + (set-syntax-table mailcap-parse-args-syntax-table) + (mailcap-replace-regexp "#.*" "") ; Remove all comments + (mailcap-replace-regexp "\n+" "\n") ; And blank lines + (mailcap-replace-regexp "\\\\[ \t\n]+" " ") ; And collapse spaces + (mailcap-replace-regexp (concat (regexp-quote "\\") "[ \t]*\n") "") + (goto-char (point-max)) + (skip-chars-backward " \t\n") + (delete-region (point) (point-max)) + (goto-char (point-min)) + (while (not (eobp)) + (skip-chars-forward " \t\n") + (setq save-pos (point) + info nil) + (skip-chars-forward "^/;") + (downcase-region save-pos (point)) + (setq major (buffer-substring save-pos (point))) + (skip-chars-forward "/ \t\n") + (setq save-pos (point)) + (skip-chars-forward "^;") + (downcase-region save-pos (point)) + (setq minor + (cond + ((= ?* (or (char-after save-pos) 0)) ".*") + ((= (point) save-pos) ".*") + (t (buffer-substring save-pos (point))))) + (skip-chars-forward "; \t\n") + ;;; Got the major/minor chunks, now for the viewers/etc + ;;; The first item _must_ be a viewer, according to the + ;;; RFC for mailcap files (#1343) + (skip-chars-forward "; \t\n") + (setq save-pos (point)) + (skip-chars-forward "^;\n") + (if (= (or (char-after save-pos) 0) ?') + (setq viewer (progn + (narrow-to-region (1+ save-pos) (point)) + (goto-char (point-min)) + (prog1 + (read (current-buffer)) + (goto-char (point-max)) + (widen)))) + (setq viewer (buffer-substring save-pos (point)))) + (setq save-pos (point)) + (end-of-line) + (setq info (nconc (list (cons "viewer" viewer) + (cons "type" (concat major "/" + (if (string= minor ".*") + "*" minor)))) + (mailcap-parse-mailcap-extras save-pos (point)))) + (mailcap-mailcap-entry-passes-test info) + (mailcap-add-mailcap-entry major minor info))))) + +(defun mailcap-parse-mailcap-extras (st nd) + ;; Grab all the extra stuff from a mailcap entry + (let ( + name ; From name= + value ; its value + results ; Assoc list of results + name-pos ; Start of XXXX= position + val-pos ; Start of value position + done ; Found end of \'d ;s? + ) + (save-restriction + (narrow-to-region st nd) + (goto-char (point-min)) + (skip-chars-forward " \n\t;") + (while (not (eobp)) + (setq done nil) + (skip-chars-forward " \";\n\t") + (setq name-pos (point)) + (skip-chars-forward "^ \n\t=") + (downcase-region name-pos (point)) + (setq name (buffer-substring name-pos (point))) + (skip-chars-forward " \t\n") + (if (/= (or (char-after (point)) 0) ?=) ; There is no value + (setq value nil) + (skip-chars-forward " \t\n=") + (setq val-pos (point)) + (if (memq (char-after val-pos) '(?\" ?')) + (progn + (setq val-pos (1+ val-pos)) + (condition-case nil + (progn + (forward-sexp 1) + (backward-char 1)) + (error (goto-char (point-max))))) + (while (not done) + (skip-chars-forward "^;") + (if (= (or (char-after (1- (point))) 0) ?\\ ) + (progn + (subst-char-in-region (1- (point)) (point) ?\\ ? ) + (skip-chars-forward ";")) + (setq done t)))) + (setq value (buffer-substring val-pos (point)))) + (setq results (cons (cons name value) results))) + results))) + +(defun mailcap-mailcap-entry-passes-test (info) + ;; Return t iff a mailcap entry passes its test clause or no test + ;; clause is present. + (let (status ; Call-process-regions return value + (test (assoc "test" info)) ; The test clause + ) + (setq status (and test (split-string (cdr test) " "))) + (if (and (assoc "needsx11" info) (not (getenv "DISPLAY"))) + (setq status nil) + (cond + ((and (equal (nth 0 status) "test") + (equal (nth 1 status) "-n") + (or (equal (nth 2 status) "$DISPLAY") + (equal (nth 2 status) "\"$DISPLAY\""))) + (setq status (if (getenv "DISPLAY") t nil))) + ((and (equal (nth 0 status) "test") + (equal (nth 1 status) "-z") + (or (equal (nth 2 status) "$DISPLAY") + (equal (nth 2 status) "\"$DISPLAY\""))) + (setq status (if (getenv "DISPLAY") nil t))) + (test nil) + (t nil))) + (and test (listp test) (setcdr test status)))) + +;;; +;;; The action routines. +;;; + +(defun mailcap-possible-viewers (major minor) + ;; Return a list of possible viewers from MAJOR for minor type MINOR + (let ((exact '()) + (wildcard '())) + (while major + (cond + ((equal (car (car major)) minor) + (setq exact (cons (cdr (car major)) exact))) + ((string-match (car (car major)) minor) + (setq wildcard (cons (cdr (car major)) wildcard)))) + (setq major (cdr major))) + (nconc (nreverse exact) (nreverse wildcard)))) + +(defun mailcap-unescape-mime-test (test type-info) + (let (save-pos save-chr subst) + (cond + ((symbolp test) test) + ((and (listp test) (symbolp (car test))) test) + ((or (stringp test) + (and (listp test) (stringp (car test)) + (setq test (mapconcat 'identity test " ")))) + (with-temp-buffer + (insert test) + (goto-char (point-min)) + (while (not (eobp)) + (skip-chars-forward "^%") + (if (/= (- (point) + (progn (skip-chars-backward "\\\\") + (point))) + 0) ; It is an escaped % + (progn + (delete-char 1) + (skip-chars-forward "%.")) + (setq save-pos (point)) + (skip-chars-forward "%") + (setq save-chr (char-after (point))) + (cond + ((null save-chr) nil) + ((= save-chr ?t) + (delete-region save-pos (progn (forward-char 1) (point))) + (insert (or (cdr (assoc "type" type-info)) "\"\""))) + ((= save-chr ?M) + (delete-region save-pos (progn (forward-char 1) (point))) + (insert "\"\"")) + ((= save-chr ?n) + (delete-region save-pos (progn (forward-char 1) (point))) + (insert "\"\"")) + ((= save-chr ?F) + (delete-region save-pos (progn (forward-char 1) (point))) + (insert "\"\"")) + ((= save-chr ?{) + (forward-char 1) + (skip-chars-forward "^}") + (downcase-region (+ 2 save-pos) (point)) + (setq subst (buffer-substring (+ 2 save-pos) (point))) + (delete-region save-pos (1+ (point))) + (insert (or (cdr (assoc subst type-info)) "\"\""))) + (t nil)))) + (buffer-string))) + (t (error "Bad value to mailcap-unescape-mime-test. %s" test))))) + +(defvar mailcap-viewer-test-cache nil) + +(defun mailcap-viewer-passes-test (viewer-info type-info) + ;; Return non-nil iff the viewer specified by VIEWER-INFO passes its + ;; test clause (if any). + (let* ((test-info (assoc "test" viewer-info)) + (test (cdr test-info)) + (otest test) + (viewer (cdr (assoc "viewer" viewer-info))) + (default-directory (expand-file-name "~/")) + status parsed-test cache result) + (if (setq cache (assoc test mailcap-viewer-test-cache)) + (cadr cache) + (setq + result + (cond + ((not test-info) t) ; No test clause + ((not test) nil) ; Already failed test + ((eq test t) t) ; Already passed test + ((and (symbolp test) ; Lisp function as test + (fboundp test)) + (funcall test type-info)) + ((and (symbolp test) ; Lisp variable as test + (boundp test)) + (symbol-value test)) + ((and (listp test) ; List to be eval'd + (symbolp (car test))) + (eval test)) + (t + (setq test (mailcap-unescape-mime-test test type-info) + test (list shell-file-name nil nil nil + shell-command-switch test) + status (apply 'call-process test)) + (= 0 status)))) + (push (list otest result) mailcap-viewer-test-cache) + result))) + +(defun mailcap-add-mailcap-entry (major minor info) + (let ((old-major (assoc major mailcap-mime-data))) + (if (null old-major) ; New major area + (setq mailcap-mime-data + (cons (cons major (list (cons minor info))) + mailcap-mime-data)) + (let ((cur-minor (assoc minor old-major))) + (cond + ((or (null cur-minor) ; New minor area, or + (assoc "test" info)) ; Has a test, insert at beginning + (setcdr old-major (cons (cons minor info) (cdr old-major)))) + ((and (not (assoc "test" info)) ; No test info, replace completely + (not (assoc "test" cur-minor))) + (setcdr cur-minor info)) + (t + (setcdr old-major (cons (cons minor info) (cdr old-major))))))))) + +;;; +;;; The main whabbo +;;; + +(defun mailcap-viewer-lessp (x y) + ;; Return t iff viewer X is more desirable than viewer Y + (let ((x-wild (string-match "[*?]" (or (cdr-safe (assoc "type" x)) ""))) + (y-wild (string-match "[*?]" (or (cdr-safe (assoc "type" y)) ""))) + (x-lisp (not (stringp (or (cdr-safe (assoc "viewer" x)) "")))) + (y-lisp (not (stringp (or (cdr-safe (assoc "viewer" y)) ""))))) + (cond + ((and x-lisp (not y-lisp)) + t) + ((and (not y-lisp) x-wild (not y-wild)) + t) + ((and (not x-wild) y-wild) + t) + (t nil)))) + +(defun mailcap-mime-info (string &optional request) + "Get the mime viewer command for HEADERLINE, return nil if none found. +Expects a complete content-type header line as its argument. This can +be simple like text/html, or complex like text/plain; charset=blah; foo=bar + +Second argument REQUEST specifies what information to return. If it is +nil or the empty string, the viewer (second field of the mailcap +entry) will be returned. If it is a string, then the mailcap field +corresponding to that string will be returned (print, description, +whatever). If a number, then all the information for this specific +viewer is returned." + (let ( + major ; Major encoding (text, etc) + minor ; Minor encoding (html, etc) + info ; Other info + save-pos ; Misc. position during parse + major-info ; (assoc major mailcap-mime-data) + minor-info ; (assoc minor major-info) + test ; current test proc. + viewers ; Possible viewers + passed ; Viewers that passed the test + viewer ; The one and only viewer + ctl) + (save-excursion + (setq ctl (drums-parse-content-type (or string "text/plain"))) + (setq major (split-string (car ctl) "/")) + (setq minor (cadr major) + major (car major)) + (when (setq major-info (cdr (assoc major mailcap-mime-data))) + (when (setq viewers (mailcap-possible-viewers major-info minor)) + (setq info (mapcar (lambda (a) (cons (symbol-name (car a)) + (cdr a))) + (cdr ctl))) + (while viewers + (if (mailcap-viewer-passes-test (car viewers) info) + (setq passed (cons (car viewers) passed))) + (setq viewers (cdr viewers))) + (setq passed (sort (nreverse passed) 'mailcap-viewer-lessp)) + (setq viewer (car passed)))) + (when (and (stringp (cdr (assoc "viewer" viewer))) + passed) + (setq viewer (car passed))) + (cond + ((and (null viewer) (not (equal major "default"))) + (mailcap-mime-info "default" request)) + ((or (null request) (equal request "")) + (mailcap-unescape-mime-test (cdr (assoc "viewer" viewer)) info)) + ((stringp request) + (if (or (string= request "test") (string= request "viewer")) + (mailcap-unescape-mime-test + (cdr-safe (assoc request viewer)) info))) + (t + ;; MUST make a copy *sigh*, else we modify mailcap-mime-data + (setq viewer (copy-tree viewer)) + (let ((view (assoc "viewer" viewer)) + (test (assoc "test" viewer))) + (if view (setcdr view (mailcap-unescape-mime-test (cdr view) info))) + (if test (setcdr test (mailcap-unescape-mime-test (cdr test) info)))) + viewer))))) + +;;; +;;; Experimental MIME-types parsing +;;; + +(defvar mailcap-mime-extensions + '(("" . "text/plain") + (".abs" . "audio/x-mpeg") + (".aif" . "audio/aiff") + (".aifc" . "audio/aiff") + (".aiff" . "audio/aiff") + (".ano" . "application/x-annotator") + (".au" . "audio/ulaw") + (".avi" . "video/x-msvideo") + (".bcpio" . "application/x-bcpio") + (".bin" . "application/octet-stream") + (".cdf" . "application/x-netcdr") + (".cpio" . "application/x-cpio") + (".csh" . "application/x-csh") + (".dvi" . "application/x-dvi") + (".el" . "application/emacs-lisp") + (".eps" . "application/postscript") + (".etx" . "text/x-setext") + (".exe" . "application/octet-stream") + (".fax" . "image/x-fax") + (".gif" . "image/gif") + (".hdf" . "application/x-hdf") + (".hqx" . "application/mac-binhex40") + (".htm" . "text/html") + (".html" . "text/html") + (".icon" . "image/x-icon") + (".ief" . "image/ief") + (".jpg" . "image/jpeg") + (".macp" . "image/x-macpaint") + (".man" . "application/x-troff-man") + (".me" . "application/x-troff-me") + (".mif" . "application/mif") + (".mov" . "video/quicktime") + (".movie" . "video/x-sgi-movie") + (".mp2" . "audio/x-mpeg") + (".mp3" . "audio/x-mpeg") + (".mp2a" . "audio/x-mpeg2") + (".mpa" . "audio/x-mpeg") + (".mpa2" . "audio/x-mpeg2") + (".mpe" . "video/mpeg") + (".mpeg" . "video/mpeg") + (".mpega" . "audio/x-mpeg") + (".mpegv" . "video/mpeg") + (".mpg" . "video/mpeg") + (".mpv" . "video/mpeg") + (".ms" . "application/x-troff-ms") + (".nc" . "application/x-netcdf") + (".nc" . "application/x-netcdf") + (".oda" . "application/oda") + (".pbm" . "image/x-portable-bitmap") + (".pdf" . "application/pdf") + (".pgm" . "image/portable-graymap") + (".pict" . "image/pict") + (".png" . "image/png") + (".pnm" . "image/x-portable-anymap") + (".ppm" . "image/portable-pixmap") + (".ps" . "application/postscript") + (".qt" . "video/quicktime") + (".ras" . "image/x-raster") + (".rgb" . "image/x-rgb") + (".rtf" . "application/rtf") + (".rtx" . "text/richtext") + (".sh" . "application/x-sh") + (".sit" . "application/x-stuffit") + (".snd" . "audio/basic") + (".src" . "application/x-wais-source") + (".tar" . "archive/tar") + (".tcl" . "application/x-tcl") + (".tcl" . "application/x-tcl") + (".tex" . "application/x-tex") + (".texi" . "application/texinfo") + (".tga" . "image/x-targa") + (".tif" . "image/tiff") + (".tiff" . "image/tiff") + (".tr" . "application/x-troff") + (".troff" . "application/x-troff") + (".tsv" . "text/tab-separated-values") + (".txt" . "text/plain") + (".vbs" . "video/mpeg") + (".vox" . "audio/basic") + (".vrml" . "x-world/x-vrml") + (".wav" . "audio/x-wav") + (".wrl" . "x-world/x-vrml") + (".xbm" . "image/xbm") + (".xpm" . "image/x-pixmap") + (".xwd" . "image/windowdump") + (".zip" . "application/zip") + (".ai" . "application/postscript") + (".jpe" . "image/jpeg") + (".jpeg" . "image/jpeg")) + "*An assoc list of file extensions and the MIME content-types they +correspond to.") + +(defun mailcap-parse-mimetypes (&optional path) + ;; Parse out all the mimetypes specified in a unix-style path string PATH + (cond + (path nil) + ((getenv "MIMETYPES") (setq path (getenv "MIMETYPES"))) + ((memq system-type '(ms-dos ms-windows windows-nt)) + (setq path (mapconcat 'expand-file-name + '("~/mime.typ" "~/etc/mime.typ") ";"))) + (t (setq path (mapconcat 'expand-file-name + '("~/.mime-types" + "/etc/mime-types:/usr/etc/mime-types" + "/usr/local/etc/mime-types" + "/usr/local/www/conf/mime-types") ":")))) + (let ((fnames (reverse + (split-string path + (if (memq system-type + '(ms-dos ms-windows windows-nt)) + ";" ":")))) + fname) + (while fnames + (setq fname (car fnames)) + (if (and (file-exists-p fname) (file-readable-p fname)) + (mailcap-parse-mimetype-file (car fnames))) + (setq fnames (cdr fnames))))) + +(defun mailcap-parse-mimetype-file (fname) + ;; Parse out a mime-types file + (let (type ; The MIME type for this line + extns ; The extensions for this line + save-pos ; Misc. saved buffer positions + ) + (with-temp-buffer + (insert-file-contents fname) + (mailcap-replace-regexp "#.*" "") + (mailcap-replace-regexp "\n+" "\n") + (mailcap-replace-regexp "[ \t]+$" "") + (goto-char (point-max)) + (skip-chars-backward " \t\n") + (delete-region (point) (point-max)) + (goto-char (point-min)) + (while (not (eobp)) + (skip-chars-forward " \t\n") + (setq save-pos (point)) + (skip-chars-forward "^ \t") + (downcase-region save-pos (point)) + (setq type (buffer-substring save-pos (point))) + (while (not (eolp)) + (skip-chars-forward " \t") + (setq save-pos (point)) + (skip-chars-forward "^ \t\n") + (setq extns (cons (buffer-substring save-pos (point)) extns))) + (while extns + (setq mailcap-mime-extensions + (cons + (cons (if (= (string-to-char (car extns)) ?.) + (car extns) + (concat "." (car extns))) type) + mailcap-mime-extensions) + extns (cdr extns))))))) + +(defun mailcap-extension-to-mime (extn) + "Return the MIME content type of the file extensions EXTN." + (if (and (stringp extn) + (not (eq (string-to-char extn) ?.))) + (setq extn (concat "." extn))) + (cdr (assoc (downcase extn) mailcap-mime-extensions))) + +(provide 'mailcap) + +;;; mailcap.el ends here diff --git a/lisp/mm-bodies.el b/lisp/mm-bodies.el index 1b208d2..0e6640b 100644 --- a/lisp/mm-bodies.el +++ b/lisp/mm-bodies.el @@ -89,25 +89,28 @@ If no encoding was done, nil is returned." ;;; Functions for decoding ;;; +(defun mm-decode-content-transfer-encoding (encoding) + (cond + ((eq encoding 'quoted-printable) + (quoted-printable-decode-region (point-min) (point-max))) + ((eq encoding 'base64) + (condition-case () + (base64-decode-region (point-min) (point-max)) + (error nil))) + ((memq encoding '(7bit 8bit binary)) + ) + ((null encoding) + ) + (t + (error "Can't decode encoding %s" encoding)))) + (defun mm-decode-body (charset encoding) "Decode the current article that has been encoded with ENCODING. The characters in CHARSET should then be decoded." (setq charset (or charset rfc2047-default-charset)) (save-excursion (when encoding - (cond - ((eq encoding 'quoted-printable) - (quoted-printable-decode-region (point-min) (point-max))) - ((eq encoding 'base64) - (condition-case () - (base64-decode-region (point-min) (point-max)) - (error nil))) - ((memq encoding '(7bit 8bit binary)) - ) - ((null encoding) - ) - (t - (error "Can't decode encoding %s" encoding)))) + (mm-decode-content-transfer-encoding encoding)) (when (featurep 'mule) (let (mule-charset) (when (and charset diff --git a/lisp/mm-decode.el b/lisp/mm-decode.el index 9d0a44b..48b0496 100644 --- a/lisp/mm-decode.el +++ b/lisp/mm-decode.el @@ -24,6 +24,257 @@ ;;; Code: +(require 'drums) +(require 'mailcap) +(require 'mm-bodies) + +(defvar mm-inline-media-tests + '(("image/jpeg" mm-inline-image (featurep 'jpeg)) + ("image/png" mm-inline-image (featurep 'png)) + ("image/gif" mm-inline-image (featurep 'gif)) + ("image/tiff" mm-inline-image (featurep 'tiff)) + ("image/xbm" mm-inline-image (eq (device-type) 'x)) + ("image/xpm" mm-inline-image (featurep 'xpm)) + ("text/plain" mm-inline-text t) + ("text/html" mm-inline-text (featurep 'w3)) + ) + "Alist of media types/test that say whether the media types can be displayed inline.") + +(defvar mm-user-display-methods + '(("image/.*" . inline) + ("text/.*" . inline))) + +(defvar mm-user-automatic-display + '("text/plain" "image/gif")) + +(defvar mm-tmp-directory "/tmp/" + "Where mm will store its temporary files.") + +;;; Internal variables. + +(defvar mm-dissection-list nil) + +(defun mm-dissect-buffer (&optional no-strict-mime) + "Dissect the current buffer and return a list of MIME handles." + (save-excursion + (let (ct ctl type subtype cte) + (save-restriction + (drums-narrow-to-header) + (when (and (or no-strict-mime + (mail-fetch-field "mime-version")) + (setq ct (mail-fetch-field "content-type"))) + (setq ctl (drums-parse-content-type ct)) + (setq cte (mail-fetch-field "content-transfer-encoding")))) + (when ctl + (setq type (split-string (car ctl) "/")) + (setq subtype (cadr type) + type (pop type)) + (cond + ((equal type "multipart") + (mm-dissect-multipart ctl)) + (t + (mm-dissect-singlepart ctl (and cte (intern cte)) + no-strict-mime))))))) + +(defun mm-dissect-singlepart (ctl cte &optional force) + (when (or force + (not (equal "text/plain" (car ctl)))) + (let ((res (list (list (mm-copy-to-buffer) ctl cte nil)))) + (push (car res) mm-dissection-list) + res))) + +(defun mm-remove-all-parts () + "Remove all MIME handles." + (interactive) + (mapcar 'mm-remove-part mm-dissection-list) + (setq mm-dissection-list nil)) + +(defun mm-dissect-multipart (ctl) + (goto-char (point-min)) + (let ((boundary (concat "\n--" (drums-content-type-get ctl 'boundary))) + start parts end) + (while (search-forward boundary nil t) + (forward-line -1) + (when start + (save-excursion + (save-restriction + (narrow-to-region start (point)) + (setq parts (nconc (mm-dissect-buffer t) parts))))) + (forward-line 2) + (setq start (point))) + (nreverse parts))) + +(defun mm-copy-to-buffer () + "Copy the contents of the current buffer to a fresh buffer." + (save-excursion + (let ((obuf (current-buffer)) + beg) + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (setq beg (point)) + (set-buffer (generate-new-buffer " *mm*")) + (insert-buffer-substring obuf beg) + (current-buffer)))) + +(defun mm-display-part (handle) + "Display the MIME part represented by HANDLE." + (save-excursion + (mailcap-parse-mailcaps) + (if (nth 3 handle) + (mm-remove-part handle) + (let* ((type (caadr handle)) + (method (mailcap-mime-info type)) + (user-method (mm-user-method type))) + (if (eq user-method 'inline) + (progn + (forward-line 1) + (mm-display-inline handle)) + (mm-display-external handle (or user-method method))))))) + +(defun mm-display-external (handle method) + "Display HANDLE using METHOD." + (mm-with-unibyte-buffer + (insert-buffer-substring (car handle)) + (mm-decode-content-transfer-encoding (nth 2 handle)) + (if (functionp method) + (let ((cur (current-buffer))) + (switch-to-buffer (generate-new-buffer "*mm*")) + (insert-buffer-substring cur) + (funcall method) + (setcar (nthcdr 3 handle) (current-buffer))) + (let* ((file (make-temp-name (expand-file-name "emm." mm-tmp-directory))) + process) + (write-region (point-min) (point-max) + file nil 'nomesg nil 'no-conversion) + (setq process + (start-process "*display*" nil shell-file-name + "-c" (format method file))) + (setcar (nthcdr 3 handle) (cons file process)) + (message "Displaying %s..." (format method file)))))) + +(defun mm-remove-part (handle) + "Remove the displayed MIME part represented by HANDLE." + (let ((object (nth 3 handle))) + (cond + ;; Internally displayed part. + ((mm-annotationp object) + (delete-annotation object)) + ((or (functionp object) + (and (listp object) + (eq (car object) 'lambda))) + (funcall object)) + ;; Externally displayed part. + ((consp object) + (condition-case () + (delete-file (car object)) + (error nil)) + (condition-case () + (kill-process (cdr object)) + (error nil))) + ((bufferp object) + (when (buffer-live-p object) + (kill-buffer object)))) + (setcar (nthcdr 3 handle) nil))) + +(defun mm-display-inline (handle) + (let* ((type (caadr handle)) + (function (cadr (assoc type mm-inline-media-tests)))) + (funcall function handle))) + +(defun mm-inlinable-p (type) + "Say whether TYPE can be displayed inline." + (let ((alist mm-inline-media-tests) + test) + (while alist + (when (equal type (caar alist)) + (setq test (caddar alist) + alist nil) + (setq test (eval test))) + (pop alist)) + test)) + +(defun mm-user-method (type) + "Return the user-defined method for TYPE." + (let ((methods mm-user-display-methods) + method result) + (while (setq method (pop methods)) + (when (string-match (car method) type) + (when (or (not (eq (cdr method) 'inline)) + (mm-inlinable-p type)) + (setq result (cdr method) + methods nil)))) + result)) + +(defun mm-automatic-display-p (type) + "Return the user-defined method for TYPE." + (let ((methods mm-user-automatic-display) + method result) + (while (setq method (pop methods)) + (when (string-match method type) + (setq result t + methods nil))) + result)) + +(defun add-mime-display-method (type method) + "Make parts of TYPE be displayed with METHOD. +This overrides entries in the mailcap file." + (push (cons type method) mm-user-display-methods)) + +(defun mm-destroy-part (handle) + "Destroy the data structures connected to HANDLE." + (mm-remove-part handle) + (when (buffer-live-p (car handle)) + (kill-buffer (car handle)))) + +(defun mm-quote-arg (arg) + "Return a version of ARG that is safe to evaluate in a shell." + (let ((pos 0) new-pos accum) + ;; *** bug: we don't handle newline characters properly + (while (setq new-pos (string-match "[!`\"$\\& \t{}]" arg pos)) + (push (substring arg pos new-pos) accum) + (push "\\" accum) + (push (list (aref arg new-pos)) accum) + (setq pos (1+ new-pos))) + (if (= pos 0) + arg + (apply 'concat (nconc (nreverse accum) (list (substring arg pos))))))) + +;;; +;;; Functions for displaying various formats inline +;;; + +(defun mm-inline-image (handle) + (let ((type (cadr (split-string (caadr handle) "/"))) + image) + (mm-with-unibyte-buffer + (insert-buffer-substring (car handle)) + (mm-decode-content-transfer-encoding (nth 2 handle)) + (setq image (make-image-specifier + (vector (intern type) :data (buffer-string))))) + (let ((annot (make-annotation image nil 'text))) + (set-extent-property annot 'mm t) + (set-extent-property annot 'duplicable t) + (setcar (nthcdr 3 handle) annot)))) + +(defun mm-inline-text (handle) + (let ((type (cadr (split-string (caadr handle) "/"))) + text buffer-read-only) + (mm-with-unibyte-buffer + (insert-buffer-substring (car handle)) + (mm-decode-content-transfer-encoding (nth 2 handle)) + (setq text (buffer-string))) + (cond + ((equal type "plain") + (let ((b (point))) + (insert text) + (setcar + (nthcdr 3 handle) + `(lambda () + (let (buffer-read-only) + (delete-region ,(set-marker (make-marker) b) + ,(set-marker (make-marker) (point))))))))))) + + (provide 'mm-decode) ;; mm-decode.el ends here diff --git a/lisp/mm-util.el b/lisp/mm-util.el index d806104..01ef03c 100644 --- a/lisp/mm-util.el +++ b/lisp/mm-util.el @@ -66,42 +66,30 @@ (eval-and-compile - (if (fboundp 'decode-coding-string) - (fset 'mm-decode-coding-string 'decode-coding-string) - (fset 'mm-decode-coding-string (lambda (s a) s))) - - (if (fboundp 'encode-coding-string) - (fset 'mm-encode-coding-string 'encode-coding-string) - (fset 'mm-encode-coding-string (lambda (s a) s))) - - (if (fboundp 'encode-coding-region) - (fset 'mm-encode-coding-region 'encode-coding-region) - (fset 'mm-encode-coding-region 'ignore)) - - (if (fboundp 'decode-coding-region) - (fset 'mm-decode-coding-region 'decode-coding-region) - (fset 'mm-decode-coding-region 'ignore)) - - (if (fboundp 'coding-system-list) - (fset 'mm-coding-system-list 'coding-system-list) - (fset 'mm-coding-system-list 'ignore)) - - (if (fboundp 'char-int) - (fset 'mm-char-int 'char-int) - (fset 'mm-char-int 'identity)) - - (if (fboundp 'coding-system-equal) - (fset 'mm-coding-system-equal 'coding-system-equal) - (fset 'mm-coding-system-equal 'equal)) - - (if (fboundp 'read-coding-system) - (fset 'mm-read-coding-system 'read-coding-system) - (defun mm-read-coding-system (prompt) - "Prompt the user for a coding system." - (completing-read - prompt (mapcar (lambda (s) (list (symbol-name (car s)))) - mm-mime-mule-charset-alist))))) - + (mapcar + (lambda (elem) + (let ((nfunc (intern (format "mm-%s" (car elem))))) + (if (fboundp (car elem)) + (fset nfunc (car elem)) + (fset nfunc (cdr elem))))) + '((decode-coding-string . (lambda (s a) s)) + (encode-coding-string . (lambda (s a) s)) + (encode-coding-region . ignore) + (decode-coding-region . ignore) + (coding-system-list . ignore) + (char-int . identity) + (device-type . ignore) + (coding-system-equal . equal) + (annotationp . ignore) + (make-char + . (lambda (charset int) + (int-to-char int))) + (read-coding-system + . (lambda (prompt) + "Prompt the user for a coding system." + (completing-read + prompt (mapcar (lambda (s) (list (symbol-name (car s)))) + mm-mime-mule-charset-alist))))))) (defvar mm-charset-coding-system-alist (let ((rest @@ -180,12 +168,6 @@ used as the line break code type of the coding system." (insert "Content-Transfer-Encoding: " (downcase (symbol-name encoding)) "\n")) -(defun mm-content-type-charset (header) - "Return the charset parameter from HEADER." - (when (string-match "charset *= *\"? *\\([-0-9a-zA-Z_]+\\)\"? *$" header) - (intern (downcase (match-string 1 header))))) - - (defun mm-mime-charset (charset b e) (if (fboundp 'coding-system-get) (or @@ -201,6 +183,25 @@ used as the line break code type of the coding system." (and (boundp 'enable-multibyte-characters) enable-multibyte-characters)) +(defmacro mm-with-unibyte-buffer (&rest forms) + "Create a temporary buffer, and evaluate FORMS there like `progn'. +See also `with-temp-file' and `with-output-to-string'." + (let ((temp-buffer (make-symbol "temp-buffer")) + (multibyte (make-symbol "multibyte"))) + `(if (not (boundp 'enable-multibyte-characters)) + (with-temp-buffer ,@forms) + (let ((,multibyte (default-value enable-multibyte-characters)) + ,temp-buffer) + (setq-default enable-multibyte-characters nil) + (setq ,temp-buffer + (get-buffer-create (generate-new-buffer-name " *temp*"))) + (unwind-protect + (with-current-buffer ,temp-buffer + ,@forms) + (and (buffer-name ,temp-buffer) + (kill-buffer ,temp-buffer)) + (setq-default enable-multibyte-characters ,multibyte)))))) + (provide 'mm-util) ;;; mm-util.el ends here diff --git a/lisp/parse-time.el b/lisp/parse-time.el index d9514f6..4ade7b2 100644 --- a/lisp/parse-time.el +++ b/lisp/parse-time.el @@ -162,6 +162,11 @@ (= (length elt) 4) (= (aref elt 1) ?:))) [0 1] [2 4] ,#'(lambda () 0)) + ((2 1 0) + ,#'(lambda () (and (stringp elt) + (= (length elt) 7) + (= (aref elt 1) ?:))) + [0 1] [2 4] [5 7]) ((5) (70 99) ,#'(lambda () (+ 1900 elt)))) "(slots predicate extractor...)") diff --git a/texi/gnus.texi b/texi/gnus.texi index 0459425..ea0121e 100644 --- a/texi/gnus.texi +++ b/texi/gnus.texi @@ -1,7 +1,7 @@ \input texinfo @c -*-texinfo-*- @setfilename gnus -@settitle Pterodactyl Gnus 0.24 Manual +@settitle Pterodactyl Gnus 0.25 Manual @synindex fn cp @synindex vr cp @synindex pg cp @@ -318,7 +318,7 @@ into another language, under the above conditions for modified versions. @tex @titlepage -@title Pterodactyl Gnus 0.24 Manual +@title Pterodactyl Gnus 0.25 Manual @author by Lars Magne Ingebrigtsen @page @@ -354,7 +354,7 @@ can be gotten by any nefarious means you can think of---@sc{nntp}, local spool or your mbox file. All at the same time, if you want to push your luck. -This manual corresponds to Pterodactyl Gnus 0.24. +This manual corresponds to Pterodactyl Gnus 0.25. @end ifinfo diff --git a/texi/message.texi b/texi/message.texi index 3c1f10e..8a0d0fb 100644 --- a/texi/message.texi +++ b/texi/message.texi @@ -1,7 +1,7 @@ \input texinfo @c -*-texinfo-*- @setfilename message -@settitle Pterodactyl Message 0.24 Manual +@settitle Pterodactyl Message 0.25 Manual @synindex fn cp @synindex vr cp @synindex pg cp @@ -42,7 +42,7 @@ into another language, under the above conditions for modified versions. @tex @titlepage -@title Pterodactyl Message 0.24 Manual +@title Pterodactyl Message 0.25 Manual @author by Lars Magne Ingebrigtsen @page @@ -83,7 +83,7 @@ Message mode buffers. * Key Index:: List of Message mode keys. @end menu -This manual corresponds to Pterodactyl Message 0.24. Message is +This manual corresponds to Pterodactyl Message 0.25. Message is distributed with the Gnus distribution bearing the same version number as this manual.