comparison lisp/gnus/mailcap.el @ 88155:d7ddb3e565de

sync with trunk

88154:8ce476d3ba36

;;; mailcap.el --- MIME media types configuration
;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.

;; Author: William M. Perry <[e-mail]>
;;	Lars Magne Ingebrigtsen <[e-mail]>
;; Keywords: news, mail, multimedia

;; 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:

;; Provides configuration of MIME media types from directly from Lisp
;; and via the usual mailcap mechanism (RFC 1524).  Deals with

    (modify-syntax-entry ?' "\"" table)
    (modify-syntax-entry ?` "\"" table)
    (modify-syntax-entry ?{ "(" table)
    (modify-syntax-entry ?} ")" table)
    table)
  "A syntax table for parsing sgml attributes.")

;; 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"
     ("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"

      (type . "application/x-x509-user-cert"))
     ("octet-stream"
      (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))
      ("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)
      (non-viewer . t)
      (type   . "application/x-tar"))
     ("x-latex"

     ("zip"
      (viewer . mailcap-save-binary-file)
      (non-viewer . t)
      (type   . "application/zip")
      ("copiousoutput"))
     ;; Prefer free viewers.
     ("pdf"
      (viewer . "gv %s")
      (type . "application/pdf")
      (test . window-system))
     ("pdf"
      (viewer . "xpdf %s")
      (type . "application/pdf")
      (test . (eq (mm-device-type) '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)))
     ("postscript"
      (viewer . "gv -safer %s")
      (type . "application/postscript")
      (test   . window-system)
      ("needsx11"))
     ("postscript"
      (viewer . "ghostview -dSAFER %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"))
     (".*"

    ("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"))
;;; 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))
      ("needsx11"))
     (".*"
      (viewer . "ee %s")
      (type . "image/*")
      (test   . (eq (mm-device-type) 'x))
      ("needsx11")))
    ("text"
     ("plain"
      (viewer  . w3-mode)
      (test    . (fboundp 'w3-mode))

      (type    . "text/plain"))
     ("plain"
      (viewer  . fundamental-mode)
      (type    . "text/plain"))
     ("enriched"
      (viewer . enriched-decode-region)
      (test   . (fboundp 'enriched-decode))
      (type   . "text/enriched"))
     ("html"
      (viewer . mm-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")

Content-Type header as argument to return a boolean value for the
validity.  Otherwise, if it is a non-function Lisp symbol or list
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.")

(defcustom mailcap-download-directory nil
  "*Directory to which `mailcap-save-binary-file' downloads files by default.
nil means your home directory."
  :type '(choice (const :tag "Home directory" nil)
		 directory)
  :group 'mailcap)

;;;
;;; Utility functions
;;;

  (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 '("~/.mailcap" "~/mail.cap" "~/etc/mail.cap")))
     (t (setq path
	      ;; This is per RFC 1524, specifically
	      ;; with /usr before /usr/local.
	      '("~/.mailcap" "/etc/mailcap" "/usr/etc/mailcap"

	(wildcard '()))
    (while major
      (cond
       ((equal (car (car major)) minor)
	(setq exact (cons (cdr (car major)) exact)))
       ((and minor (string-match (car (car major)) minor))
	(setq wildcard (cons (cdr (car major)) wildcard))))
      (setq major (cdr major)))
    (nconc exact wildcard)))

(defun mailcap-unescape-mime-test (test type-info)

(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
to supply to the test."
  (let* ((test-info (assq 'test viewer-info))
	 (test (cdr test-info))
	 (otest test)
	 (viewer (cdr (assoc 'viewer viewer-info)))

	(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
 	      (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))))))
      )))

(defun mailcap-add (type viewer &optional test)
  "Add VIEWER as a handler for TYPE.
If TEST is not given, it defaults to t."

       ((and (null viewer) (not (equal major "default")) request)
	(mailcap-mime-info "default" request))
       ((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)))
       ((eq request 'all)
	passed)
       (t
	;; MUST make a copy *sigh*, else we modify mailcap-mime-data
	(setq viewer (copy-sequence viewer))

    (".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")
    (".tex"   . "application/x-tex")

    (".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/xpm")
    (".xwd"   . "image/windowdump")
    (".zip"   . "application/zip")

  (when (or (not mailcap-mimetypes-parsed-p)
	    force)
    (cond
     (path nil)
     ((getenv "MIMETYPES") (setq path (getenv "MIMETYPES")))
     ((memq system-type '(ms-dos ms-windows windows-nt))
      (setq path '("~/mime.typ" "~/etc/mime.typ")))
     (t (setq path
	      ;; mime.types seems to be the normal name, definitely so
	      ;; on current GNUish systems.  The search order follows
	      ;; that for mailcap.

	       (cdr l))))
      mailcap-mime-data)))))

(provide 'mailcap)

;;; mailcap.el ends here

88155:d7ddb3e565de

;;; mailcap.el --- MIME media types configuration

;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;;   2005 Free Software Foundation, Inc.

;; Author: William M. Perry <[e-mail]>
;;	Lars Magne Ingebrigtsen <[e-mail]>
;; Keywords: news, mail, multimedia

;; 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., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;; Provides configuration of MIME media types from directly from Lisp
;; and via the usual mailcap mechanism (RFC 1524).  Deals with

    (modify-syntax-entry ?' "\"" table)
    (modify-syntax-entry ?` "\"" table)
    (modify-syntax-entry ?{ "(" table)
    (modify-syntax-entry ?} ")" table)
    table)
  "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"
     ("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))
      (type . "application/x-x509-ca-cert"))
     ("x-x509-user-cert"

      (type . "application/x-x509-user-cert"))
     ("octet-stream"
      (viewer . mailcap-save-binary-file)
      (non-viewer . t)
      (type . "application/octet-stream"))
     ("dvi"
      (viewer . "xdvi -safer %s")
      (test   . (eq window-system 'x))
      ("needsx11")
      (type   . "application/dvi")
      ("print" . "dvips -qRP %s"))
     ("dvi"
      (viewer . "dvitty %s")
      (test   . (not (getenv "DISPLAY")))
      (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)
      (type   . "application/x-tar"))
     ("x-latex"

     ("zip"
      (viewer . mailcap-save-binary-file)
      (non-viewer . t)
      (type   . "application/zip")
      ("copiousoutput"))
     ("pdf"
      (viewer . "gv -safer %s")
      (type . "application/pdf")
      (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")
      ("print" . ,(concat "pdftops %s - | " mailcap-print-command))
      (test . (eq window-system 'x)))
     ("pdf"
      (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 window-system 'x))
      ("print" . ,(concat mailcap-print-command " %s"))
      ("needsx11"))
     ("postscript"
      (viewer . "ps2ascii %s")
      (type . "application/postscript")
      (test . (not (getenv "DISPLAY")))
      ("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")
      (type   . "audio/x-mpeg"))
     (".*"

    ("image"
     ("x-xwd"
      (viewer  . "xwud -in %s")
      (type    . "image/x-xwd")
      ("compose" . "xwd -frame > %s")
      (test    . (eq window-system 'x))
      ("needsx11"))
     ("x11-dump"
      (viewer . "xwud -in %s")
      (type . "image/x-xwd")
      ("compose" . "xwd -frame > %s")
      (test   . (eq window-system 'x))
      ("needsx11"))
     ("windowdump"
      (viewer . "xwud -in %s")
      (type . "image/x-xwd")
      ("compose" . "xwd -frame > %s")
      (test   . (eq window-system 'x))
      ("needsx11"))
     (".*"
      (viewer . "display %s")
      (type . "image/*")
      (test   . (eq window-system 'x))
      ("needsx11"))
     (".*"
      (viewer . "ee %s")
      (type . "image/*")
      (test   . (eq window-system 'x))
      ("needsx11")))
    ("text"
     ("plain"
      (viewer  . w3-mode)
      (test    . (fboundp 'w3-mode))

      (type    . "text/plain"))
     ("plain"
      (viewer  . fundamental-mode)
      (type    . "text/plain"))
     ("enriched"
      (viewer . enriched-decode)
      (test   . (fboundp 'enriched-decode))
      (type   . "text/enriched"))
     ("html"
      (viewer . mm-w3-prepare-buffer)
      (test   . (fboundp 'w3-prepare-buffer))
      (type   . "text/html")))
    ("video"
     ("mpeg"
      (viewer . "mpeg_play %s")
      (type   . "video/mpeg")
      (test   . (eq window-system 'x))
      ("needsx11")))
    ("x-world"
     ("x-vrml"
      (viewer  . "webspace -remote %s -URL %u")
      (type    . "x-world/x-vrml")

Content-Type header as argument to return a boolean value for the
validity.  Otherwise, if it is a non-function Lisp symbol or list
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."
  :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
;;;

  (when (or (not mailcap-parsed-p)
	    force)
    (cond
     (path nil)
     ((getenv "MAILCAPS") (setq path (getenv "MAILCAPS")))
     ((memq system-type mailcap-poor-system-types)
      (setq path '("~/.mailcap" "~/mail.cap" "~/etc/mail.cap")))
     (t (setq path
	      ;; This is per RFC 1524, specifically
	      ;; with /usr before /usr/local.
	      '("~/.mailcap" "/etc/mailcap" "/usr/etc/mailcap"

	(wildcard '()))
    (while major
      (cond
       ((equal (car (car major)) minor)
	(setq exact (cons (cdr (car major)) exact)))
       ((and minor (string-match (concat "^" (car (car major)) "$") minor))
	(setq wildcard (cons (cdr (car major)) wildcard))))
      (setq major (cdr major)))
    (nconc exact wildcard)))

(defun mailcap-unescape-mime-test (test type-info)

(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 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))
	 (otest test)
	 (viewer (cdr (assoc 'viewer viewer-info)))

	(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)))
    (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
	      (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))))))
      )))

(defun mailcap-add (type viewer &optional test)
  "Add VIEWER as a handler for TYPE.
If TEST is not given, it defaults to t."

       ((and (null viewer) (not (equal major "default")) request)
	(mailcap-mime-info "default" request))
       ((or (null request) (equal request ""))
	(mailcap-unescape-mime-test (cdr (assq 'viewer viewer)) info))
       ((stringp request)
	(mailcap-unescape-mime-test
	 (cdr-safe (assoc request viewer)) info))
       ((eq request 'all)
	passed)
       (t
	;; MUST make a copy *sigh*, else we modify mailcap-mime-data
	(setq viewer (copy-sequence viewer))

    (".rgb"   . "image/x-rgb")
    (".rtf"   . "application/rtf")
    (".rtx"   . "text/richtext")
    (".sh"    . "application/x-sh")
    (".sit"   . "application/x-stuffit")
    (".siv"   . "application/sieve")
    (".snd"   . "audio/basic")
    (".src"   . "application/x-wais-source")
    (".tar"   . "archive/tar")
    (".tcl"   . "application/x-tcl")
    (".tex"   . "application/x-tex")

    (".txt"   . "text/plain")
    (".vbs"   . "video/mpeg")
    (".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")
    (".xwd"   . "image/windowdump")
    (".zip"   . "application/zip")

  (when (or (not mailcap-mimetypes-parsed-p)
	    force)
    (cond
     (path nil)
     ((getenv "MIMETYPES") (setq path (getenv "MIMETYPES")))
     ((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
	      ;; on current GNUish systems.  The search order follows
	      ;; that for mailcap.

	       (cdr l))))
      mailcap-mime-data)))))

(provide 'mailcap)

;;; arch-tag: 1fd4f9c9-c305-4d2e-9747-3a4d45baa0bd
;;; mailcap.el ends here