From: yamaoka Date: Fri, 11 Sep 1998 09:14:57 +0000 (+0000) Subject: * lisp/gnus.el (gnus-version-number): Update to 6.10.017. X-Git-Tag: pgnus-ichikawa-199811302358~218 X-Git-Url: http://git.chise.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=11800479556d89be98bf0af4f992e1337109f665;p=elisp%2Fgnus.git- * lisp/gnus.el (gnus-version-number): Update to 6.10.017. * lisp/gnus-art.el (gnus-show-mime) (gnus-summary-toggle-mime): Revived. * lisp/gnus-mailcap.el: New file. Renamed from `mailcap.el'. * Sync up with Pterodactyl Gnus 0.25. A snapshot is available from ftp://ftp.jpl.org/pub/tmp/semi-gnus-pgnus-ichikawa-19980911-2.tar.gz --- diff --git a/ChangeLog b/ChangeLog index 16ae315..0107831 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,16 @@ 1998-09-11 Katsumi Yamaoka + * lisp/gnus.el (gnus-version-number): Update to 6.10.017. + + * lisp/gnus-art.el (gnus-show-mime) (gnus-summary-toggle-mime): + Revived. + + * lisp/gnus-mailcap.el: New file. Renamed from `mailcap.el'. + + * Sync up with Pterodactyl Gnus 0.25. + +1998-09-11 Katsumi Yamaoka + * lisp/gnus-art.el (article-make-date-line): Add TZ value to `local' and `ut' date. 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 c99f47e..6fb1f84 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -376,11 +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-article-display-method-for-mime 'gnus-article-display-mime-message "Function to display a MIME message. @@ -557,7 +552,9 @@ displayed by the first non-nil matching CONTENT face." (face :value default))))) (defcustom gnus-article-decode-hook nil - "*Hook run to decode charsets in articles.") + "*Hook run to decode charsets in articles." + :group 'gnus-article-headers + :type 'hook) ;;; Internal variables @@ -904,7 +901,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)))))) @@ -1071,7 +1070,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." @@ -2084,10 +2085,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." (if gnus-show-mime (progn (mime-parse-buffer) - (if (or (not gnus-strict-mime) - (mime-fetch-field "MIME-Version")) - gnus-article-display-method-for-mime - gnus-article-display-method-for-encoded-word)) + gnus-article-display-method-for-mime) gnus-article-display-method-for-traditional))) ;; Hooks for getting information from the article. ;; This hook must be called before being narrowed. diff --git a/lisp/gnus-mailcap.el b/lisp/gnus-mailcap.el new file mode 100644 index 0000000..d401499 --- /dev/null +++ b/lisp/gnus-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/gnus-sum.el b/lisp/gnus-sum.el index 3fe444e..0aed40d 100644 --- a/lisp/gnus-sum.el +++ b/lisp/gnus-sum.el @@ -335,7 +335,7 @@ variable." (defcustom gnus-show-mime t "*If non-nil, do mime processing of articles. The articles will simply be fed to the function given by -`gnus-show-mime-method'." +`gnus-article-display-method-for-mime'." :group 'gnus-article-mime :type 'boolean) diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el index 233960a..43facf4 100644 --- a/lisp/gnus-util.el +++ b/lisp/gnus-util.el @@ -308,7 +308,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-xmas.el b/lisp/gnus-xmas.el index 8e28a46..ac5c95d 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) @@ -904,6 +905,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 677024c..29e6152 100644 --- a/lisp/gnus.el +++ b/lisp/gnus.el @@ -253,10 +253,10 @@ is restarted, and sometimes reloaded." (defconst gnus-product-name "T-gnus" "Product name of this version of gnus.") -(defconst gnus-version-number "6.10.016" +(defconst gnus-version-number "6.10.017" "Version number for this version of gnus.") -(defconst gnus-original-version-number "0.24" +(defconst gnus-original-version-number "0.25" "Version number for this version of Gnus.") (defconst gnus-original-product-name "Pterodactyl Gnus" @@ -280,8 +280,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) @@ -301,7 +299,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. diff --git a/lisp/lpath.el b/lisp/lpath.el index 7757473..bcd48a3 100644 --- a/lisp/lpath.el +++ b/lisp/lpath.el @@ -39,7 +39,6 @@ url-view-url w3-prepare-buffer set-buffer-multibyte find-non-ascii-charset-region char-charset - mule-write-region-no-coding-system find-charset-region base64-decode-string find-coding-systems-region get-charset-property coding-system-get)) @@ -69,8 +68,7 @@ pp-to-string color-name gnus-mule-get-coding-system decode-coding-string mail-aliases-setup - url-view-url w3-prepare-buffer - mule-write-region-no-coding-system char-int))) + url-view-url w3-prepare-buffer char-int))) (setq load-path (cons "." load-path)) (require 'custom) 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 48a0586..038541c 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-ja.texi b/texi/gnus-ja.texi index be48633..6333eb2 100644 --- a/texi/gnus-ja.texi +++ b/texi/gnus-ja.texi @@ -1,7 +1,7 @@ \input texinfo @c -*-texinfo-*- @setfilename gnus-ja -@settitle Semi-gnus 6.10.016 Manual +@settitle Semi-gnus 6.10.017 Manual @synindex fn cp @synindex vr cp @synindex pg cp @@ -345,7 +345,7 @@ into another language, under the above conditions for modified versions. @tex @titlepage -@title Semi-gnus 6.10.016 Manual +@title Semi-gnus 6.10.017 Manual @author by Lars Magne Ingebrigtsen @author by members of Semi-gnus mailing-list @@ -399,7 +399,7 @@ Semi-gnus は、大きな絵が入っていたりさまざまな形式を用いたりしているちょっ な言語圏を差別しません。ああ、クリンゴンの方は Unicode Next Generationを お待ちください。 -この説明書は Semi-gnus 6.10.016 に対応します。 +この説明書は Semi-gnus 6.10.017 に対応します。 @end ifinfo diff --git a/texi/gnus.texi b/texi/gnus.texi index ab23e52..f2e4f41 100644 --- a/texi/gnus.texi +++ b/texi/gnus.texi @@ -1,7 +1,7 @@ \input texinfo @c -*-texinfo-*- @setfilename gnus -@settitle Semi-gnus 6.10.016 Manual +@settitle Semi-gnus 6.10.017 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 Semi-gnus 6.10.016 Manual +@title Semi-gnus 6.10.017 Manual @author by Lars Magne Ingebrigtsen @page @@ -361,7 +361,7 @@ internationalization/localization and multiscript features based on MULE API. So Semi-gnus does not discriminate various language communities. Oh, if you are a Klingon, please wait Unicode Next Generation. -This manual corresponds to Semi-gnus 6.10.016. +This manual corresponds to Semi-gnus 6.10.017. @end ifinfo diff --git a/texi/message.texi b/texi/message.texi index 1ff0844..ba7c0d9 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.