+Fri Sep 11 08:09:40 1998 Lars Magne Ingebrigtsen <larsi@menja.ifi.uio.no>
+
+ * gnus.el: Pterodactyl Gnus v0.25 is released.
+
+1998-09-11 07:38:14 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * 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 <larsi@gnus.org>
+
+ * 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 <larsi@menja.ifi.uio.no>
* gnus.el: Pterodactyl Gnus v0.24 is released.
;;; 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.")
(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)
(cond
((eq c ?\")
(forward-sexp 1))
- ((memq c '(? ?\t))
+ ((memq c '(? ?\t ?\n))
(delete-char 1))
(t
(forward-char 1))))
(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
(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.
(setq entry nil)))
entry))
-
(defun earcon-button-push (marker)
;; Push button starting at MARKER.
(save-excursion
(require 'gnus-int)
(require 'browse-url)
(require 'mm-bodies)
+(require 'drums)
+(require 'mm-decode)
(defgroup gnus-article nil
"Article display."
(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
(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)
(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))))))
(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))))
(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))))))))))
(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."
(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)
(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.
(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
(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)
: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."
"\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
"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)
["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"
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))
(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)
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)
(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
'(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)))))
(require 'gnus-art)
(require 'message)
(require 'gnus-msg)
+(require 'mm-decode)
(defgroup gnus-extract nil
"Extracting encoded files."
(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))))
'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)
(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
: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)
: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)
(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.
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
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)
--- /dev/null
+;;; mailcap.el --- Functions for displaying MIME parts
+;; Copyright (C) 1998 Free Software Foundation, Inc.
+
+;; Author: William M. Perry <wmperry@aventail.com>
+;; Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; 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\" . <info>))
+ (\"text\"
+ (\"plain\" . <info>)))
+
+Where <info> 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
;;; 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
;;; 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
(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
(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
(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
(= (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...)")
\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
@tex
@titlepage
-@title Pterodactyl Gnus 0.24 Manual
+@title Pterodactyl Gnus 0.25 Manual
@author by Lars Magne Ingebrigtsen
@page
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
\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
@tex
@titlepage
-@title Pterodactyl Message 0.24 Manual
+@title Pterodactyl Message 0.25 Manual
@author by Lars Magne Ingebrigtsen
@page
* 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.
projects / elisp / gnus.git- / commitdiff