/[emacs]/emacs/lisp/gnus/mailcap.el
ViewVC logotype

Diff of /emacs/lisp/gnus/mailcap.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.6.4.3 by miles, Tue Apr 27 14:08:31 2004 UTC revision 1.6.4.4 by miles, Thu Sep 16 00:12:16 2004 UTC
# Line 1  Line 1 
1  ;;; mailcap.el --- MIME media types configuration  ;;; mailcap.el --- MIME media types configuration
2  ;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.  ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003
3    ;;       Free Software Foundation, Inc.
4    
5  ;; Author: William M. Perry <wmperry@aventail.com>  ;; Author: William M. Perry <wmperry@aventail.com>
6  ;;      Lars Magne Ingebrigtsen <larsi@gnus.org>  ;;      Lars Magne Ingebrigtsen <larsi@gnus.org>
# Line 46  Line 47 
47      (modify-syntax-entry ?{ "(" table)      (modify-syntax-entry ?{ "(" table)
48      (modify-syntax-entry ?} ")" table)      (modify-syntax-entry ?} ")" table)
49      table)      table)
50    "A syntax table for parsing sgml attributes.")    "A syntax table for parsing SGML attributes.")
51    
52    (eval-and-compile
53      (when (featurep 'xemacs)
54        (condition-case nil
55            (require 'lpr)
56          (error nil))))
57    
58    (defvar mailcap-print-command
59      (mapconcat 'identity
60                 (cons (if (boundp 'lpr-command)
61                           lpr-command
62                         "lpr")
63                       (when (boundp 'lpr-switches)
64                         (if (stringp lpr-switches)
65                             (list lpr-switches)
66                           lpr-switches)))
67                 " ")
68      "Shell command (including switches) used to print Postscript files.")
69    
70  ;; Postpone using defcustom for this as it's so big and we essentially  ;; Postpone using defcustom for this as it's so big and we essentially
71  ;; have to have two copies of the data around then.  Perhaps just  ;; have to have two copies of the data around then.  Perhaps just
72  ;; customize the Lisp viewers and rely on the normal configuration  ;; customize the Lisp viewers and rely on the normal configuration
73  ;; files for the rest?  -- fx  ;; files for the rest?  -- fx
74  (defvar mailcap-mime-data  (defvar mailcap-mime-data
75    '(("application"    `(("application"
76         ("vnd.ms-excel"
77          (viewer . "gnumeric %s")
78          (test   . (getenv "DISPLAY"))
79          (type . "application/vnd.ms-excel"))
80       ("x-x509-ca-cert"       ("x-x509-ca-cert"
81        (viewer . ssl-view-site-cert)        (viewer . ssl-view-site-cert)
82        (test . (fboundp 'ssl-view-site-cert))        (test . (fboundp 'ssl-view-site-cert))
# Line 66  Line 89 
89        (viewer . mailcap-save-binary-file)        (viewer . mailcap-save-binary-file)
90        (non-viewer . t)        (non-viewer . t)
91        (type . "application/octet-stream"))        (type . "application/octet-stream"))
 ;;; XEmacs says `ns' device-type not implemented.  
 ;;      ("dvi"  
 ;;       (viewer . "open %s")  
 ;;       (type   . "application/dvi")  
 ;;       (test   . (eq (mm-device-type) 'ns)))  
92       ("dvi"       ("dvi"
93        (viewer . "xdvi %s")        (viewer . "xdvi -safer %s")
94        (test   . (eq (mm-device-type) 'x))        (test   . (eq window-system 'x))
95        ("needsx11")        ("needsx11")
96        (type   . "application/dvi"))        (type   . "application/dvi")
97          ("print" . "dvips -qRP %s"))
98       ("dvi"       ("dvi"
99        (viewer . "dvitty %s")        (viewer . "dvitty %s")
100        (test   . (not (getenv "DISPLAY")))        (test   . (not (getenv "DISPLAY")))
101        (type   . "application/dvi"))        (type   . "application/dvi")
102          ("print" . "dvips -qRP %s"))
103       ("emacs-lisp"       ("emacs-lisp"
104        (viewer . mailcap-maybe-eval)        (viewer . mailcap-maybe-eval)
105        (type   . "application/emacs-lisp"))        (type   . "application/emacs-lisp"))
106         ("x-emacs-lisp"
107          (viewer . mailcap-maybe-eval)
108          (type   . "application/x-emacs-lisp"))
109       ("x-tar"       ("x-tar"
110        (viewer . mailcap-save-binary-file)        (viewer . mailcap-save-binary-file)
111        (non-viewer . t)        (non-viewer . t)
# Line 114  Line 137 
137        ("copiousoutput"))        ("copiousoutput"))
138       ;; Prefer free viewers.       ;; Prefer free viewers.
139       ("pdf"       ("pdf"
140        (viewer . "gv %s")        (viewer . "gv -safer %s")
141        (type . "application/pdf")        (type . "application/pdf")
142        (test . window-system))        (test . window-system)
143          ("print" . ,(concat "pdf2ps %s - | " mailcap-print-command)))
144       ("pdf"       ("pdf"
145        (viewer . "xpdf %s")        (viewer . "xpdf %s")
146        (type . "application/pdf")        (type . "application/pdf")
147        (test . (eq (mm-device-type) 'x)))        ("print" . ,(concat "pdftops %s - | " mailcap-print-command))
148          (test . (eq window-system 'x)))
149       ("pdf"       ("pdf"
150        (viewer . "acroread %s")        (viewer . "acroread %s")
151        (type   . "application/pdf"))        (type   . "application/pdf")
152  ;;; XEmacs says `ns' device-type not implemented.        ("print" . ,(concat "cat %s | acroread -toPostScript | "
153  ;;      ("postscript"                            mailcap-print-command))
154  ;;       (viewer . "open %s")        (test . window-system))
155  ;;       (type   . "application/postscript")       ("pdf"
156  ;;       (test   . (eq (mm-device-type) 'ns)))        (viewer . ,(concat "pdftotext %s -"))
157          (type   . "application/pdf")
158          ("print" . ,(concat "pdftops %s - | " mailcap-print-command))
159          ("copiousoutput"))
160       ("postscript"       ("postscript"
161        (viewer . "gv -safer %s")        (viewer . "gv -safer %s")
162        (type . "application/postscript")        (type . "application/postscript")
163        (test   . window-system)        (test   . window-system)
164          ("print" . ,(concat mailcap-print-command " %s"))
165        ("needsx11"))        ("needsx11"))
166       ("postscript"       ("postscript"
167        (viewer . "ghostview -dSAFER %s")        (viewer . "ghostview -dSAFER %s")
168        (type . "application/postscript")        (type . "application/postscript")
169        (test   . (eq (mm-device-type) 'x))        (test   . (eq window-system 'x))
170          ("print" . ,(concat mailcap-print-command " %s"))
171        ("needsx11"))        ("needsx11"))
172       ("postscript"       ("postscript"
173        (viewer . "ps2ascii %s")        (viewer . "ps2ascii %s")
174        (type . "application/postscript")        (type . "application/postscript")
175        (test . (not (getenv "DISPLAY")))        (test . (not (getenv "DISPLAY")))
176        ("copiousoutput")))        ("print" . ,(concat mailcap-print-command " %s"))
177          ("copiousoutput"))
178         ("sieve"
179          (viewer . sieve-mode)
180          (test   . (fboundp 'sieve-mode))
181          (type   . "application/sieve"))
182         ("pgp-keys"
183          (viewer . "gpg --import --interactive --verbose")
184          (type   . "application/pgp-keys")
185          ("needsterminal")))
186      ("audio"      ("audio"
187       ("x-mpeg"       ("x-mpeg"
188        (viewer . "maplay %s")        (viewer . "maplay %s")
# Line 173  Line 212 
212        (viewer  . "xwud -in %s")        (viewer  . "xwud -in %s")
213        (type    . "image/x-xwd")        (type    . "image/x-xwd")
214        ("compose" . "xwd -frame > %s")        ("compose" . "xwd -frame > %s")
215        (test    . (eq (mm-device-type) 'x))        (test    . (eq window-system 'x))
216        ("needsx11"))        ("needsx11"))
217       ("x11-dump"       ("x11-dump"
218        (viewer . "xwud -in %s")        (viewer . "xwud -in %s")
219        (type . "image/x-xwd")        (type . "image/x-xwd")
220        ("compose" . "xwd -frame > %s")        ("compose" . "xwd -frame > %s")
221        (test   . (eq (mm-device-type) 'x))        (test   . (eq window-system 'x))
222        ("needsx11"))        ("needsx11"))
223       ("windowdump"       ("windowdump"
224        (viewer . "xwud -in %s")        (viewer . "xwud -in %s")
225        (type . "image/x-xwd")        (type . "image/x-xwd")
226        ("compose" . "xwd -frame > %s")        ("compose" . "xwd -frame > %s")
227        (test   . (eq (mm-device-type) 'x))        (test   . (eq window-system 'x))
228        ("needsx11"))        ("needsx11"))
 ;;; XEmacs says `ns' device-type not implemented.  
 ;;      (".*"  
 ;;       (viewer . "aopen %s")  
 ;;       (type   . "image/*")  
 ;;       (test   . (eq (mm-device-type) 'ns)))  
229       (".*"       (".*"
230        (viewer . "display %s")        (viewer . "display %s")
231        (type . "image/*")        (type . "image/*")
232        (test   . (eq (mm-device-type) 'x))        (test   . (eq window-system 'x))
233        ("needsx11"))        ("needsx11"))
234       (".*"       (".*"
235        (viewer . "ee %s")        (viewer . "ee %s")
236        (type . "image/*")        (type . "image/*")
237        (test   . (eq (mm-device-type) 'x))        (test   . (eq window-system 'x))
238        ("needsx11")))        ("needsx11")))
239      ("text"      ("text"
240       ("plain"       ("plain"
# Line 215  Line 249 
249        (viewer  . fundamental-mode)        (viewer  . fundamental-mode)
250        (type    . "text/plain"))        (type    . "text/plain"))
251       ("enriched"       ("enriched"
252        (viewer . enriched-decode-region)        (viewer . enriched-decode)
253        (test   . (fboundp 'enriched-decode))        (test   . (fboundp 'enriched-decode))
254        (type   . "text/enriched"))        (type   . "text/enriched"))
255       ("html"       ("html"
# Line 226  Line 260 
260       ("mpeg"       ("mpeg"
261        (viewer . "mpeg_play %s")        (viewer . "mpeg_play %s")
262        (type   . "video/mpeg")        (type   . "video/mpeg")
263        (test   . (eq (mm-device-type) 'x))        (test   . (eq window-system 'x))
264        ("needsx11")))        ("needsx11")))
265      ("x-world"      ("x-world"
266       ("x-vrml"       ("x-vrml"
# Line 280  nil means your home directory." Line 314  nil means your home directory."
314                   directory)                   directory)
315    :group 'mailcap)    :group 'mailcap)
316    
317    (defvar mailcap-poor-system-types
318      '(ms-dos ms-windows windows-nt win32 w32 mswindows)
319      "Systems that don't have a Unix-like directory hierarchy.")
320    
321  ;;;  ;;;
322  ;;; Utility functions  ;;; Utility functions
323  ;;;  ;;;
# Line 356  MAILCAPS if set; otherwise (on Unix) use Line 394  MAILCAPS if set; otherwise (on Unix) use
394      (cond      (cond
395       (path nil)       (path nil)
396       ((getenv "MAILCAPS") (setq path (getenv "MAILCAPS")))       ((getenv "MAILCAPS") (setq path (getenv "MAILCAPS")))
397       ((memq system-type '(ms-dos ms-windows windows-nt))       ((memq system-type mailcap-poor-system-types)
398        (setq path '("~/.mailcap" "~/mail.cap" "~/etc/mail.cap")))        (setq path '("~/.mailcap" "~/mail.cap" "~/etc/mail.cap")))
399       (t (setq path       (t (setq path
400                ;; This is per RFC 1524, specifically                ;; This is per RFC 1524, specifically
# Line 533  Also return non-nil if no test clause is Line 571  Also return non-nil if no test clause is
571        (cond        (cond
572         ((equal (car (car major)) minor)         ((equal (car (car major)) minor)
573          (setq exact (cons (cdr (car major)) exact)))          (setq exact (cons (cdr (car major)) exact)))
574         ((and minor (string-match (car (car major)) minor))         ((and minor (string-match (concat "^" (car (car major)) "$") minor))
575          (setq wildcard (cons (cdr (car major)) wildcard))))          (setq wildcard (cons (cdr (car major)) wildcard))))
576        (setq major (cdr major)))        (setq major (cdr major)))
577      (nconc exact wildcard)))      (nconc exact wildcard)))
# Line 590  Also return non-nil if no test clause is Line 628  Also return non-nil if no test clause is
628    
629  (defun mailcap-viewer-passes-test (viewer-info type-info)  (defun mailcap-viewer-passes-test (viewer-info type-info)
630    "Return non-nil iff viewer specified by VIEWER-INFO passes its test clause.    "Return non-nil iff viewer specified by VIEWER-INFO passes its test clause.
631  Also retun non-nil if it has no test clause.  TYPE-INFO is an argument  Also return non-nil if it has no test clause.  TYPE-INFO is an argument
632  to supply to the test."  to supply to the test."
633    (let* ((test-info (assq 'test viewer-info))    (let* ((test-info (assq 'test viewer-info))
634           (test (cdr test-info))           (test (cdr test-info))
# Line 619  to supply to the test." Line 657  to supply to the test."
657                 test (list shell-file-name nil nil nil                 test (list shell-file-name nil nil nil
658                            shell-command-switch test)                            shell-command-switch test)
659                 status (apply 'call-process test))                 status (apply 'call-process test))
660           (= 0 status))))           (eq 0 status))))
661        (push (list otest result) mailcap-viewer-test-cache)        (push (list otest result) mailcap-viewer-test-cache)
662        result)))        result)))
663    
# Line 629  to supply to the test." Line 667  to supply to the test."
667          (setq mailcap-mime-data          (setq mailcap-mime-data
668                (cons (cons major (list (cons minor info)))                (cons (cons major (list (cons minor info)))
669                      mailcap-mime-data))                      mailcap-mime-data))
670         (let ((cur-minor (assoc minor old-major)))        (let ((cur-minor (assoc minor old-major)))
671          (cond          (cond
672           ((or (null cur-minor)          ; New minor area, or           ((or (null cur-minor)          ; New minor area, or
673                (assq 'test info))        ; Has a test, insert at beginning                (assq 'test info))        ; Has a test, insert at beginning
674            (setcdr old-major (cons (cons minor info) (cdr old-major))))            (setcdr old-major (cons (cons minor info) (cdr old-major))))
675           ((and (not (assq 'test info))  ; No test info, replace completely           ((and (not (assq 'test info))  ; No test info, replace completely
676                 (not (assq 'test cur-minor))                 (not (assq 'test cur-minor))
677                 (equal (assq 'viewer info)  ; Keep alternative viewer                 (equal (assq 'viewer info)  ; Keep alternative viewer
678                        (assq 'viewer cur-minor)))                        (assq 'viewer cur-minor)))
679            (setcdr cur-minor info))            (setcdr cur-minor info))
680           (t           (t
681            (setcdr old-major (cons (cons minor info) (cdr old-major))))))            (setcdr old-major (cons (cons minor info) (cdr old-major))))))
682        )))        )))
683    
684  (defun mailcap-add (type viewer &optional test)  (defun mailcap-add (type viewer &optional test)
# Line 723  this type is returned." Line 761  this type is returned."
761         ((or (null request) (equal request ""))         ((or (null request) (equal request ""))
762          (mailcap-unescape-mime-test (cdr (assq 'viewer viewer)) info))          (mailcap-unescape-mime-test (cdr (assq 'viewer viewer)) info))
763         ((stringp request)         ((stringp request)
764          (if (or (eq request 'test) (eq request 'viewer))          (mailcap-unescape-mime-test
765              (mailcap-unescape-mime-test           (cdr-safe (assoc request viewer)) info))
              (cdr-safe (assoc request viewer)) info)))  
766         ((eq request 'all)         ((eq request 'all)
767          passed)          passed)
768         (t         (t
# Line 808  this type is returned." Line 845  this type is returned."
845      (".rtx"   . "text/richtext")      (".rtx"   . "text/richtext")
846      (".sh"    . "application/x-sh")      (".sh"    . "application/x-sh")
847      (".sit"   . "application/x-stuffit")      (".sit"   . "application/x-stuffit")
848        (".siv"   . "application/sieve")
849      (".snd"   . "audio/basic")      (".snd"   . "audio/basic")
850      (".src"   . "application/x-wais-source")      (".src"   . "application/x-wais-source")
851      (".tar"   . "archive/tar")      (".tar"   . "archive/tar")
# Line 825  this type is returned." Line 863  this type is returned."
863      (".vox"   . "audio/basic")      (".vox"   . "audio/basic")
864      (".vrml"  . "x-world/x-vrml")      (".vrml"  . "x-world/x-vrml")
865      (".wav"   . "audio/x-wav")      (".wav"   . "audio/x-wav")
866        (".xls"   . "application/vnd.ms-excel")
867      (".wrl"   . "x-world/x-vrml")      (".wrl"   . "x-world/x-vrml")
868      (".xbm"   . "image/xbm")      (".xbm"   . "image/xbm")
869      (".xpm"   . "image/xpm")      (".xpm"   . "image/xpm")
# Line 851  If FORCE, re-parse even if already parse Line 890  If FORCE, re-parse even if already parse
890      (cond      (cond
891       (path nil)       (path nil)
892       ((getenv "MIMETYPES") (setq path (getenv "MIMETYPES")))       ((getenv "MIMETYPES") (setq path (getenv "MIMETYPES")))
893       ((memq system-type '(ms-dos ms-windows windows-nt))       ((memq system-type mailcap-poor-system-types)
894        (setq path '("~/mime.typ" "~/etc/mime.typ")))        (setq path '("~/mime.typ" "~/etc/mime.typ")))
895       (t (setq path       (t (setq path
896                ;; mime.types seems to be the normal name, definitely so                ;; mime.types seems to be the normal name, definitely so

Legend:
Removed from v.1.6.4.3  
changed lines
  Added in v.1.6.4.4

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26