;;; mailcap.el --- MIME media types configuration
-;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.
+
+;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
+;; 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
;; Author: William M. Perry <wmperry@aventail.com>
;; Lars Magne Ingebrigtsen <larsi@gnus.org>
;; This file is part of GNU Emacs.
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; 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.
+;; the Free Software Foundation, either version 3 of the License, 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
+;; 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.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(eval-when-compile (require 'cl))
-(require 'mail-parse)
-(require 'mm-util)
+(autoload 'mail-header-parse-content-type "mail-parse")
+
+;; `mm-delete-duplicates' is an alias for `delete-dups' in Emacs 22.
+(defalias 'mailcap-delete-duplicates
+ (if (fboundp 'delete-dups)
+ 'delete-dups
+ (autoload 'mm-delete-duplicates "mm-util")
+ 'mm-delete-duplicates))
+
+;; `mailcap-replace-in-string' is an alias like `gnus-replace-in-string'.
+(eval-and-compile
+ (cond
+ ((fboundp 'replace-regexp-in-string)
+ (defun mailcap-replace-in-string (string regexp newtext &optional literal)
+ "Replace all matches for REGEXP with NEWTEXT in STRING.
+If LITERAL is non-nil, insert NEWTEXT literally. Return a new
+string containing the replacements.
+This is a compatibility function for different Emacsen."
+ (replace-regexp-in-string regexp newtext string nil literal)))
+ ((fboundp 'replace-in-string)
+ (defalias 'mailcap-replace-in-string 'replace-in-string))))
(defgroup mailcap nil
"Definition of viewers for MIME types."
(modify-syntax-entry ?{ "(" table)
(modify-syntax-entry ?} ")" table)
table)
- "A syntax table for parsing sgml attributes.")
+ "A syntax table for parsing SGML attributes.")
+
+(eval-and-compile
+ (when (featurep 'xemacs)
+ (condition-case nil
+ (require 'lpr)
+ (error nil))))
+
+(defvar mailcap-print-command
+ (mapconcat 'identity
+ (cons (if (boundp 'lpr-command)
+ lpr-command
+ "lpr")
+ (when (boundp 'lpr-switches)
+ (if (stringp lpr-switches)
+ (list lpr-switches)
+ lpr-switches)))
+ " ")
+ "Shell command (including switches) used to print Postscript files.")
;; Postpone using defcustom for this as it's so big and we essentially
;; have to have two copies of the data around then. Perhaps just
;; customize the Lisp viewers and rely on the normal configuration
;; files for the rest? -- fx
(defvar mailcap-mime-data
- '(("application"
+ `(("application"
+ ("vnd.ms-excel"
+ (viewer . "gnumeric %s")
+ (test . (getenv "DISPLAY"))
+ (type . "application/vnd.ms-excel"))
("x-x509-ca-cert"
(viewer . ssl-view-site-cert)
(test . (fboundp 'ssl-view-site-cert))
(viewer . mailcap-save-binary-file)
(non-viewer . t)
(type . "application/octet-stream"))
-;;; XEmacs says `ns' device-type not implemented.
-;; ("dvi"
-;; (viewer . "open %s")
-;; (type . "application/dvi")
-;; (test . (eq (mm-device-type) 'ns)))
("dvi"
- (viewer . "xdvi %s")
- (test . (eq (mm-device-type) 'x))
+ (viewer . "xdvi -safer %s")
+ (test . (eq window-system 'x))
("needsx11")
- (type . "application/dvi"))
+ (type . "application/dvi")
+ ("print" . "dvips -qRP %s"))
("dvi"
(viewer . "dvitty %s")
(test . (not (getenv "DISPLAY")))
- (type . "application/dvi"))
+ (type . "application/dvi")
+ ("print" . "dvips -qRP %s"))
("emacs-lisp"
(viewer . mailcap-maybe-eval)
(type . "application/emacs-lisp"))
+ ("x-emacs-lisp"
+ (viewer . mailcap-maybe-eval)
+ (type . "application/x-emacs-lisp"))
("x-tar"
(viewer . mailcap-save-binary-file)
(non-viewer . t)
(non-viewer . t)
(type . "application/zip")
("copiousoutput"))
- ;; Prefer free viewers.
("pdf"
- (viewer . "gv %s")
+ (viewer . "gv -safer %s")
(type . "application/pdf")
- (test . window-system))
+ (test . window-system)
+ ("print" . ,(concat "pdf2ps %s - | " mailcap-print-command)))
+ ("pdf"
+ (viewer . "gpdf %s")
+ (type . "application/pdf")
+ ("print" . ,(concat "pdftops %s - | " mailcap-print-command))
+ (test . (eq window-system 'x)))
("pdf"
(viewer . "xpdf %s")
(type . "application/pdf")
- (test . (eq (mm-device-type) 'x)))
+ ("print" . ,(concat "pdftops %s - | " mailcap-print-command))
+ (test . (eq window-system 'x)))
("pdf"
- (viewer . "acroread %s")
- (type . "application/pdf"))
-;;; XEmacs says `ns' device-type not implemented.
-;; ("postscript"
-;; (viewer . "open %s")
-;; (type . "application/postscript")
-;; (test . (eq (mm-device-type) 'ns)))
+ (viewer . ,(concat "pdftotext %s -"))
+ (type . "application/pdf")
+ ("print" . ,(concat "pdftops %s - | " mailcap-print-command))
+ ("copiousoutput"))
("postscript"
(viewer . "gv -safer %s")
(type . "application/postscript")
(test . window-system)
+ ("print" . ,(concat mailcap-print-command " %s"))
("needsx11"))
("postscript"
(viewer . "ghostview -dSAFER %s")
(type . "application/postscript")
- (test . (eq (mm-device-type) 'x))
+ (test . (eq window-system 'x))
+ ("print" . ,(concat mailcap-print-command " %s"))
("needsx11"))
("postscript"
(viewer . "ps2ascii %s")
(type . "application/postscript")
(test . (not (getenv "DISPLAY")))
- ("copiousoutput")))
+ ("print" . ,(concat mailcap-print-command " %s"))
+ ("copiousoutput"))
+ ("sieve"
+ (viewer . sieve-mode)
+ (test . (fboundp 'sieve-mode))
+ (type . "application/sieve"))
+ ("pgp-keys"
+ (viewer . "gpg --import --interactive --verbose")
+ (type . "application/pgp-keys")
+ ("needsterminal")))
("audio"
("x-mpeg"
(viewer . "maplay %s")
(viewer . "xwud -in %s")
(type . "image/x-xwd")
("compose" . "xwd -frame > %s")
- (test . (eq (mm-device-type) 'x))
+ (test . (eq window-system 'x))
("needsx11"))
("x11-dump"
(viewer . "xwud -in %s")
(type . "image/x-xwd")
("compose" . "xwd -frame > %s")
- (test . (eq (mm-device-type) 'x))
+ (test . (eq window-system 'x))
("needsx11"))
("windowdump"
(viewer . "xwud -in %s")
(type . "image/x-xwd")
("compose" . "xwd -frame > %s")
- (test . (eq (mm-device-type) 'x))
+ (test . (eq window-system 'x))
("needsx11"))
-;;; XEmacs says `ns' device-type not implemented.
-;; (".*"
-;; (viewer . "aopen %s")
-;; (type . "image/*")
-;; (test . (eq (mm-device-type) 'ns)))
(".*"
(viewer . "display %s")
(type . "image/*")
- (test . (eq (mm-device-type) 'x))
+ (test . (eq window-system 'x))
("needsx11"))
(".*"
(viewer . "ee %s")
(type . "image/*")
- (test . (eq (mm-device-type) 'x))
+ (test . (eq window-system 'x))
("needsx11")))
("text"
("plain"
(viewer . fundamental-mode)
(type . "text/plain"))
("enriched"
- (viewer . enriched-decode-region)
+ (viewer . enriched-decode)
(test . (fboundp 'enriched-decode))
(type . "text/enriched"))
("html"
(viewer . mm-w3-prepare-buffer)
(test . (fboundp 'w3-prepare-buffer))
- (type . "text/html")))
+ (type . "text/html"))
+ ("dns"
+ (viewer . dns-mode)
+ (test . (fboundp 'dns-mode))
+ (type . "text/dns")))
("video"
("mpeg"
(viewer . "mpeg_play %s")
(type . "video/mpeg")
- (test . (eq (mm-device-type) 'x))
+ (test . (eq window-system 'x))
("needsx11")))
("x-world"
("x-vrml"
whose car is a symbol, it is `eval'led to yield the validity. If it
is a string or list of strings, it represents a shell command to run
to return a true or false shell value for the validity.")
+(put 'mailcap-mime-data 'risky-local-variable t)
(defcustom mailcap-download-directory nil
"*Directory to which `mailcap-save-binary-file' downloads files by default.
-Nil means your home directory."
+nil means your home directory."
:type '(choice (const :tag "Home directory" nil)
directory)
:group 'mailcap)
+(defvar mailcap-poor-system-types
+ '(ms-dos ms-windows windows-nt win32 w32 mswindows)
+ "Systems that don't have a Unix-like directory hierarchy.")
+
;;;
;;; Utility functions
;;;
"Text of warning message displayed by `mailcap-maybe-eval'.
Make sure that this text consists only of few text lines. Otherwise,
Gnus might fail to display all of it.")
-
+
(defun mailcap-maybe-eval ()
"Maybe evaluate a buffer of Emacs Lisp code."
(let ((lisp-buffer (current-buffer)))
(cond
(path nil)
((getenv "MAILCAPS") (setq path (getenv "MAILCAPS")))
- ((memq system-type '(ms-dos ms-windows windows-nt))
+ ((memq system-type mailcap-poor-system-types)
(setq path '("~/.mailcap" "~/mail.cap" "~/etc/mail.cap")))
(t (setq path
;; This is per RFC 1524, specifically
(skip-chars-forward ";"))
(setq done t))))
(setq value (buffer-substring val-pos (point))))
- (setq results (cons (cons name value) results))
+ ;; `test' as symbol, others like "copiousoutput" and "needsx11" as
+ ;; strings
+ (setq results (cons (cons (if (string-equal name "test")
+ 'test
+ name)
+ value) results))
(skip-chars-forward " \";\n\t"))
results)))
(defun mailcap-mailcap-entry-passes-test (info)
- "Return non-nil iff mailcap entry INFO passes its test clause.
+ "Return non-nil if mailcap entry INFO passes its test clause.
Also return non-nil if no test clause is present."
(let ((test (assq 'test info)) ; The test clause
status)
(defvar mailcap-viewer-test-cache nil)
(defun mailcap-viewer-passes-test (viewer-info type-info)
- "Return non-nil iff viewer specified by VIEWER-INFO passes its test clause.
-Also retun non-nil if it has no test clause. TYPE-INFO is an argument
+ "Return non-nil if viewer specified by VIEWER-INFO passes its test clause.
+Also return non-nil if it has no test clause. TYPE-INFO is an argument
to supply to the test."
(let* ((test-info (assq 'test viewer-info))
(test (cdr test-info))
(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
- ((functionp test) ; Lisp function as 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)))
+ (cond ((setq cache (assoc test mailcap-viewer-test-cache))
+ (cadr cache))
+ ((not test-info) t) ; No test clause
+ (t
+ (setq
+ result
+ (cond
+ ((not test) nil) ; Already failed test
+ ((eq test t) t) ; Already passed test
+ ((functionp test) ; Lisp function as 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))
+ (eq 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)))
(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
- (assq 'test info)) ; Has a test, insert at beginning
- (setcdr old-major (cons (cons minor info) (cdr old-major))))
- ((and (not (assq 'test info)) ; No test info, replace completely
- (not (assq 'test cur-minor))
+ (let ((cur-minor (assoc minor old-major)))
+ (cond
+ ((or (null cur-minor) ; New minor area, or
+ (assq 'test info)) ; Has a test, insert at beginning
+ (setcdr old-major (cons (cons minor info) (cdr old-major))))
+ ((and (not (assq 'test info)) ; No test info, replace completely
+ (not (assq 'test cur-minor))
(equal (assq 'viewer info) ; Keep alternative viewer
(assq 'viewer cur-minor)))
- (setcdr cur-minor info))
- (t
- (setcdr old-major (cons (cons minor info) (cdr old-major))))))
+ (setcdr cur-minor info))
+ (t
+ (setcdr old-major (cons (cons minor info) (cdr old-major))))))
)))
(defun mailcap-add (type viewer &optional test)
;;;
(defun mailcap-viewer-lessp (x y)
- "Return t iff viewer X is more desirable than viewer Y."
+ "Return t if viewer X is more desirable than viewer Y."
(let ((x-wild (string-match "[*?]" (or (cdr-safe (assq 'type x)) "")))
(y-wild (string-match "[*?]" (or (cdr-safe (assq 'type y)) "")))
(x-lisp (not (stringp (or (cdr-safe (assq 'viewer x)) ""))))
t)
(t nil))))
-(defun mailcap-mime-info (string &optional request)
+(defun mailcap-mime-info (string &optional request no-decode)
"Get the MIME viewer command for STRING, return nil if none found.
Expects a complete content-type header line as its argument.
corresponding to that string will be returned (print, description,
whatever). If a number, then all the information for this specific
viewer is returned. If `all', then all possible viewers for
-this type is returned."
+this type is returned.
+
+If NO-DECODE is non-nil, don't decode STRING."
+ ;; NO-DECODE avoids calling `mail-header-parse-content-type' from
+ ;; `mail-parse.el'
(let (
major ; Major encoding (text, etc)
minor ; Minor encoding (html, etc)
viewer ; The one and only viewer
ctl)
(save-excursion
- (setq ctl (mail-header-parse-content-type (or string "text/plain")))
+ (setq ctl
+ (if no-decode
+ (list (or string "text/plain"))
+ (mail-header-parse-content-type (or string "text/plain"))))
(setq major (split-string (car ctl) "/"))
(setq minor (cadr major)
major (car major))
(setq viewer (car passed)))
(cond
((and (null viewer) (not (equal major "default")) request)
- (mailcap-mime-info "default" request))
+ (mailcap-mime-info "default" request no-decode))
((or (null request) (equal request ""))
(mailcap-unescape-mime-test (cdr (assq 'viewer viewer)) info))
((stringp request)
- (if (or (eq request 'test) (eq request 'viewer))
- (mailcap-unescape-mime-test
- (cdr-safe (assoc request viewer)) info)))
+ (mailcap-unescape-mime-test
+ (cdr-safe (assoc request viewer)) info))
((eq request 'all)
passed)
(t
(".rtx" . "text/richtext")
(".sh" . "application/x-sh")
(".sit" . "application/x-stuffit")
+ (".siv" . "application/sieve")
(".snd" . "audio/basic")
+ (".soa" . "text/dns")
(".src" . "application/x-wais-source")
(".tar" . "archive/tar")
(".tcl" . "application/x-tcl")
(".vox" . "audio/basic")
(".vrml" . "x-world/x-vrml")
(".wav" . "audio/x-wav")
+ (".xls" . "application/vnd.ms-excel")
(".wrl" . "x-world/x-vrml")
(".xbm" . "image/xbm")
(".xpm" . "image/xpm")
(cond
(path nil)
((getenv "MIMETYPES") (setq path (getenv "MIMETYPES")))
- ((memq system-type '(ms-dos ms-windows windows-nt))
+ ((memq system-type mailcap-poor-system-types)
(setq path '("~/mime.typ" "~/etc/mime.typ")))
(t (setq path
;; mime.types seems to be the normal name, definitely so
(defun mailcap-mime-types ()
"Return a list of MIME media types."
(mailcap-parse-mimetypes)
- (mm-delete-duplicates
+ (mailcap-delete-duplicates
(nconc
(mapcar 'cdr mailcap-mime-extensions)
(apply
(cdr l))))
mailcap-mime-data)))))
+;;;
+;;; Useful supplementary functions
+;;;
+
+(defun mailcap-file-default-commands (files)
+ "Return a list of default commands for FILES."
+ (mailcap-parse-mailcaps)
+ (mailcap-parse-mimetypes)
+ (let* ((all-mime-type
+ ;; All unique MIME types from file extensions
+ (mailcap-delete-duplicates
+ (mapcar (lambda (file)
+ (mailcap-extension-to-mime
+ (file-name-extension file t)))
+ files)))
+ (all-mime-info
+ ;; All MIME info lists
+ (mailcap-delete-duplicates
+ (mapcar (lambda (mime-type)
+ (mailcap-mime-info mime-type 'all))
+ all-mime-type)))
+ (common-mime-info
+ ;; Intersection of mime-infos from different mime-types;
+ ;; or just the first MIME info for a single MIME type
+ (if (cdr all-mime-info)
+ (delq nil (mapcar (lambda (mi1)
+ (unless (memq nil (mapcar
+ (lambda (mi2)
+ (member mi1 mi2))
+ (cdr all-mime-info)))
+ mi1))
+ (car all-mime-info)))
+ (car all-mime-info)))
+ (commands
+ ;; Command strings from `viewer' field of the MIME info
+ (mailcap-delete-duplicates
+ (delq nil (mapcar (lambda (mime-info)
+ (let ((command (cdr (assoc 'viewer mime-info))))
+ (if (stringp command)
+ (mailcap-replace-in-string
+ ;; Replace mailcap's `%s' placeholder
+ ;; with dired's `?' placeholder
+ (mailcap-replace-in-string
+ ;; Remove the final filename placeholder
+ command "[ \t\n]*\\('\\)?%s\\1?[ \t\n]*\\'" "" t)
+ "%s" "?" t))))
+ common-mime-info)))))
+ commands))
+
(provide 'mailcap)
+;; arch-tag: 1fd4f9c9-c305-4d2e-9747-3a4d45baa0bd
;;; mailcap.el ends here
projects / gnus / blobdiff