Importing Pterodactyl Gnus v0.95.

[elisp/gnus.git-] / lisp / mailcap.el

diff --git a/lisp/mailcap.el b/lisp/mailcap.el
index 0cf68b2..7a1c05b 100644 (file)
--- a/lisp/mailcap.el
+++ b/lisp/mailcap.el
@@ -1,5 +1,5 @@
 ;;; mailcap.el --- Functions for displaying MIME parts
 ;;; mailcap.el --- Functions for displaying MIME parts

-;; Copyright (C) 1998 Free Software Foundation, Inc.
+;; Copyright (C) 1998,99 Free Software Foundation, Inc.

 
 ;; Author: William M. Perry <wmperry@aventail.com>
 ;;     Lars Magne Ingebrigtsen <larsi@gnus.org>
 
 ;; Author: William M. Perry <wmperry@aventail.com>
 ;;     Lars Magne Ingebrigtsen <larsi@gnus.org>

@@ -51,6 +51,7 @@
       (type . "application/x-x509-user-cert"))
      ("octet-stream"
       (viewer . mailcap-save-binary-file)
       (type . "application/x-x509-user-cert"))
      ("octet-stream"
       (viewer . mailcap-save-binary-file)

+      (non-viewer . t)

       (type ."application/octet-stream"))
      ("dvi"
       (viewer . "open %s")
       (type ."application/octet-stream"))
      ("dvi"
       (viewer . "open %s")

@@ -70,6 +71,7 @@
       (type   . "application/emacs-lisp"))
      ("x-tar"
       (viewer . mailcap-save-binary-file)
       (type   . "application/emacs-lisp"))
      ("x-tar"
       (viewer . mailcap-save-binary-file)

+      (non-viewer . t)

       (type   . "application/x-tar"))
      ("x-latex"
       (viewer . tex-mode)
       (type   . "application/x-tar"))
      ("x-latex"
       (viewer . tex-mode)

@@ -93,6 +95,7 @@
       (type   . "application/tex"))
      ("zip"
       (viewer . mailcap-save-binary-file)
       (type   . "application/tex"))
      ("zip"
       (viewer . mailcap-save-binary-file)

+      (non-viewer . t)

       (type   . "application/zip")
       ("copiousoutput"))
      ("pdf"
       (type   . "application/zip")
       ("copiousoutput"))
      ("pdf"

@@ -103,7 +106,7 @@
       (type   . "application/postscript")
       (test   . (eq (mm-device-type) 'ns)))
      ("postscript"
       (type   . "application/postscript")
       (test   . (eq (mm-device-type) 'ns)))
      ("postscript"

-      (viewer . "ghostview %s")
+      (viewer . "ghostview -dSAFER %s")

       (type . "application/postscript")
       (test   . (eq (mm-device-type) 'x))
       ("needsx11"))
       (type . "application/postscript")
       (test   . (eq (mm-device-type) 'x))
       ("needsx11"))

@@ -117,7 +120,8 @@
       (viewer . "maplay %s")
       (type   . "audio/x-mpeg"))
      (".*"
       (viewer . "maplay %s")
       (type   . "audio/x-mpeg"))
      (".*"

-      (viewer . mm-view-sound-file)
+      (viewer . mailcap-save-binary-file)
+      (non-viewer . t)

       (test   . (or (featurep 'nas-sound)
                      (featurep 'native-sound)))
       (type   . "audio/*"))
       (test   . (or (featurep 'nas-sound)
                      (featurep 'native-sound)))
       (type   . "audio/*"))

@@ -126,25 +130,25 @@
       (type   . "audio/*")))
     ("message"
      ("rfc-*822"
       (type   . "audio/*")))
     ("message"
      ("rfc-*822"

-      (viewer . gnus-article-prepare-display)
+      (viewer . mm-view-message)

       (test   . (and (featurep 'gnus)
                     (gnus-alive-p)))
       (test   . (and (featurep 'gnus)
                     (gnus-alive-p)))

-      (type   . "message/rfc-822"))
+      (type   . "message/rfc822"))

      ("rfc-*822"
       (viewer . vm-mode)
       (test   . (fboundp 'vm-mode))
      ("rfc-*822"
       (viewer . vm-mode)
       (test   . (fboundp 'vm-mode))

-      (type   . "message/rfc-822"))
+      (type   . "message/rfc822"))

      ("rfc-*822"
       (viewer . w3-mode)
       (test   . (fboundp 'w3-mode))
      ("rfc-*822"
       (viewer . w3-mode)
       (test   . (fboundp 'w3-mode))

-      (type   . "message/rfc-822"))
+      (type   . "message/rfc822"))

      ("rfc-*822"
       (viewer . view-mode)
       (test   . (fboundp 'view-mode))
      ("rfc-*822"
       (viewer . view-mode)
       (test   . (fboundp 'view-mode))

-      (type   . "message/rfc-822"))
+      (type   . "message/rfc822"))

      ("rfc-*822"
       (viewer . fundamental-mode)
      ("rfc-*822"
       (viewer . fundamental-mode)

-      (type   . "message/rfc-822")))
+      (type   . "message/rfc822")))

     ("image"
      ("x-xwd"
       (viewer  . "xwud -in %s")
     ("image"
      ("x-xwd"
       (viewer  . "xwud -in %s")

@@ -169,7 +173,12 @@
       (type   . "image/*")
       (test   . (eq (mm-device-type) 'ns)))
      (".*"
       (type   . "image/*")
       (test   . (eq (mm-device-type) 'ns)))
      (".*"

-      (viewer . "xv -perfect %s")
+      (viewer . "display %s")
+      (type . "image/*")
+      (test   . (eq (mm-device-type) 'x))
+      ("needsx11"))
+     (".*"
+      (viewer . "ee %s")

       (type . "image/*")
       (test   . (eq (mm-device-type) 'x))
       ("needsx11")))
       (type . "image/*")
       (test   . (eq (mm-device-type) 'x))
       ("needsx11")))

@@ -210,7 +219,7 @@
       (viewer . tar-mode)
       (type . "archive/tar")
       (test . (fboundp 'tar-mode)))))
       (viewer . tar-mode)
       (type . "archive/tar")
       (test . (fboundp 'tar-mode)))))

-     "*The mailcap structure is an assoc list of assoc lists.
+     "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)
 
 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)
 

@@ -241,7 +250,10 @@ not.")
 (defvar mailcap-download-directory nil
   "*Where downloaded files should go by default.")
 
 (defvar mailcap-download-directory nil
   "*Where downloaded files should go by default.")
 

-(defvar mailcap-temporary-directory (or (getenv "TMPDIR") "/tmp")
+(defvar mailcap-temporary-directory
+  (cond ((fboundp 'temp-directory) (temp-directory))
+       ((boundp 'temporary-file-directory) temporary-file-directory)
+       ("/tmp/"))

   "*Where temporary files go.")
 
 ;;;
   "*Where temporary files go.")
 
 ;;;

@@ -271,11 +283,13 @@ not.")
       (expand-file-name fname mailcap-temporary-directory))))
 
 (defun mailcap-save-binary-file ()
       (expand-file-name fname mailcap-temporary-directory))))
 
 (defun mailcap-save-binary-file ()

-  (let ((file (read-file-name
-              "Filename to save as: "
-              (or mailcap-download-directory "~/")))
-       (require-final-newline nil))
-    (write-region (point-min) (point-max) file)
+  (goto-char (point-min))
+  (unwind-protect
+      (let ((file (read-file-name
+                  "Filename to save as: "
+                  (or mailcap-download-directory "~/")))
+           (require-final-newline nil))
+       (write-region (point-min) (point-max) file))

     (kill-buffer (current-buffer))))
 
 (defun mailcap-maybe-eval ()
     (kill-buffer (current-buffer))))
 
 (defun mailcap-maybe-eval ()

@@ -299,14 +313,15 @@ not.")
 (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."
 (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."

-  (interactive)
+  (interactive (list nil t))

   (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))
   (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")
+      (setq path (mapconcat 'expand-file-name
+                           '("~/mail.cap" "~/etc/mail.cap" "~/.mailcap")

                            ";")))
      (t (setq path (mapconcat 'expand-file-name
                              '("~/.mailcap"
                            ";")))
      (t (setq path (mapconcat 'expand-file-name
                              '("~/.mailcap"

@@ -321,7 +336,8 @@ If FORCE, re-parse even if already parsed."
          fname)
       (while fnames
        (setq fname (car fnames))
          fname)
       (while fnames
        (setq fname (car fnames))

-       (if (and (file-exists-p fname) (file-readable-p fname))
+       (if (and (file-exists-p fname) (file-readable-p fname)
+                (file-regular-p fname))

            (mailcap-parse-mailcap (car fnames)))
        (setq fnames (cdr fnames))))
     (setq mailcap-parsed-p t)))
            (mailcap-parse-mailcap (car fnames)))
        (setq fnames (cdr fnames))))
     (setq mailcap-parsed-p t)))

@@ -358,9 +374,9 @@ If FORCE, re-parse even if already parsed."
        (downcase-region save-pos (point))
        (setq minor
              (cond
        (downcase-region save-pos (point))
        (setq minor
              (cond

-              ((= ?* (or (char-after save-pos) 0)) ".*")
+              ((eq ?* (or (char-after save-pos) 0)) ".*")

               ((= (point) save-pos) ".*")
               ((= (point) save-pos) ".*")

-              (t (buffer-substring save-pos (point)))))
+              (t (regexp-quote (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
        (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

@@ -368,7 +384,12 @@ If FORCE, re-parse even if already parsed."
        (skip-chars-forward "; \t\n")
        (setq save-pos (point))
        (skip-chars-forward "^;\n")
        (skip-chars-forward "; \t\n")
        (setq save-pos (point))
        (skip-chars-forward "^;\n")

-       (if (= (or (char-after save-pos) 0) ?')
+       ;;; skip \;
+       (while (eq (char-before) ?\\)
+         (backward-delete-char 1)
+         (skip-chars-forward ";")
+         (skip-chars-forward "^;\n"))
+       (if (eq (or (char-after save-pos) 0) ?')

            (setq viewer (progn
                           (narrow-to-region (1+ save-pos) (point))
                           (goto-char (point-min))
            (setq viewer (progn
                           (narrow-to-region (1+ save-pos) (point))
                           (goto-char (point-min))

@@ -403,14 +424,13 @@ If FORCE, re-parse even if already parsed."
       (skip-chars-forward " \n\t;")
       (while (not (eobp))
        (setq done nil)
       (skip-chars-forward " \n\t;")
       (while (not (eobp))
        (setq done nil)

-       (skip-chars-forward " \";\n\t")

        (setq name-pos (point))
        (setq name-pos (point))

-       (skip-chars-forward "^ \n\t=")
+       (skip-chars-forward "^ \n\t=;")

        (downcase-region name-pos (point))
        (setq name (buffer-substring name-pos (point)))
        (skip-chars-forward " \t\n")
        (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)
+       (if (not (eq (char-after (point)) ?=)) ; There is no value
+           (setq value t)

          (skip-chars-forward " \t\n=")
          (setq val-pos (point))
          (if (memq (char-after val-pos) '(?\" ?'))
          (skip-chars-forward " \t\n=")
          (setq val-pos (point))
          (if (memq (char-after val-pos) '(?\" ?'))

@@ -423,13 +443,14 @@ If FORCE, re-parse even if already parsed."
                  (error (goto-char (point-max)))))
            (while (not done)
              (skip-chars-forward "^;")
                  (error (goto-char (point-max)))))
            (while (not done)
              (skip-chars-forward "^;")

-             (if (= (or (char-after (1- (point))) 0) ?\\ )
+             (if (eq (char-after (1- (point))) ?\\ )

                  (progn
                    (subst-char-in-region (1- (point)) (point) ?\\ ? )
                    (skip-chars-forward ";"))
                (setq done t))))
          (setq value (buffer-substring val-pos (point))))
                  (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)))
+       (setq results (cons (cons name value) results))
+       (skip-chars-forward " \";\n\t"))

       results)))
 
 (defun mailcap-mailcap-entry-passes-test (info)
       results)))
 
 (defun mailcap-mailcap-entry-passes-test (info)

@@ -439,7 +460,10 @@ If FORCE, re-parse even if already parsed."
        (test (assq 'test info))        ; The test clause
        )
     (setq status (and test (split-string (cdr test) " ")))
        (test (assq 'test info))        ; The test clause
        )
     (setq status (and test (split-string (cdr test) " ")))

-    (if (and (assoc "needsx11" info) (not (getenv "DISPLAY")))
+    (if (and (or (assoc "needsterm" info)
+                (assoc "needsterminal" info)
+                (assoc "needsx11" info))
+            (not (getenv "DISPLAY")))

        (setq status nil)
       (cond
        ((and (equal (nth 0 status) "test")
        (setq status nil)
       (cond
        ((and (equal (nth 0 status) "test")

@@ -468,7 +492,7 @@ If FORCE, re-parse even if already parsed."
       (cond
        ((equal (car (car major)) minor)
        (setq exact (cons (cdr (car major)) exact)))
       (cond
        ((equal (car (car major)) minor)
        (setq exact (cons (cdr (car major)) exact)))

-       ((string-match (car (car major)) minor)
+       ((and minor (string-match (car (car major)) minor))

        (setq wildcard (cons (cdr (car major)) wildcard))))
       (setq major (cdr major)))
     (nconc (nreverse exact) (nreverse wildcard))))
        (setq wildcard (cons (cdr (car major)) wildcard))))
       (setq major (cdr major)))
     (nconc (nreverse exact) (nreverse wildcard))))

@@ -575,6 +599,19 @@ If FORCE, re-parse even if already parsed."
         (t
          (setcdr old-major (cons (cons minor info) (cdr old-major)))))))))
 
         (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."
+  (let ((tl (split-string type "/")))
+    (when (or (not (car tl))
+             (not (cadr tl)))
+      (error "%s is not a valid MIME type" type))
+    (mailcap-add-mailcap-entry
+     (car tl) (cadr tl)
+     `((viewer . ,viewer)
+       (test . ,(if test test t))
+       (type . ,type)))))
+

 ;;;
 ;;; The main whabbo
 ;;;
 ;;;
 ;;; The main whabbo
 ;;;

@@ -709,6 +746,7 @@ this type is returned."
     (".nc"       . "application/x-netcdf")
     (".nc"       . "application/x-netcdf")
     (".oda"      . "application/oda")
     (".nc"       . "application/x-netcdf")
     (".nc"       . "application/x-netcdf")
     (".oda"      . "application/oda")

+    (".patch"    . "text/x-patch")

     (".pbm"      . "image/x-portable-bitmap")
     (".pdf"      . "application/pdf")
     (".pgm"      . "image/portable-graymap")
     (".pbm"      . "image/x-portable-bitmap")
     (".pdf"      . "application/pdf")
     (".pgm"      . "image/portable-graymap")

@@ -744,14 +782,13 @@ this type is returned."
     (".wav"      . "audio/x-wav")
     (".wrl"      . "x-world/x-vrml")
     (".xbm"      . "image/xbm")
     (".wav"      . "audio/x-wav")
     (".wrl"      . "x-world/x-vrml")
     (".xbm"      . "image/xbm")

-    (".xpm"      . "image/x-pixmap")
+    (".xpm"      . "image/xpm")

     (".xwd"      . "image/windowdump")
     (".zip"      . "application/zip")
     (".ai"       . "application/postscript")
     (".jpe"      . "image/jpeg")
     (".jpeg"     . "image/jpeg"))
     (".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.")
+  "An assoc list of file extensions and corresponding MIME content-types.")

 
 (defun mailcap-parse-mimetypes (&optional path)
   ;; Parse out all the mimetypes specified in a unix-style path string PATH
 
 (defun mailcap-parse-mimetypes (&optional path)
   ;; Parse out all the mimetypes specified in a unix-style path string PATH

@@ -820,16 +857,30 @@ correspond to.")
       (setq extn (concat "." extn)))
   (cdr (assoc (downcase extn) mailcap-mime-extensions)))
 
       (setq extn (concat "." extn)))
   (cdr (assoc (downcase extn) mailcap-mime-extensions)))
 

+(defvar mailcap-binary-suffixes
+  (if (memq system-type '(ms-dos windows-nt))
+      '(".exe" ".com" ".bat" ".cmd" ".btm" "")
+    '("")))
+

 (defun mailcap-command-p (command)
 (defun mailcap-command-p (command)

-  "Say whether COMMAND is in the exec path."
+  "Say whether COMMAND is in the exec path.
+The path of COMMAND will be returned iff COMMAND is a command."

   (let ((path (if (file-name-absolute-p command) '(nil) exec-path))
   (let ((path (if (file-name-absolute-p command) '(nil) exec-path))

-       file)
+       file dir)

     (catch 'found
     (catch 'found

-      (while path
-       (when (and (file-executable-p
-                   (setq file (expand-file-name command (pop path))))
-                  (not (file-directory-p file)))
-         (throw 'found file))))))
+      (while (setq dir (pop path))
+       (let ((suffixes mailcap-binary-suffixes))
+         (while suffixes
+           (when (and (file-executable-p
+                       (setq file (expand-file-name
+                                   (concat command (pop suffixes))
+                                   dir)))
+                      (not (file-directory-p file)))
+             (throw 'found file))))))))
+
+(defun mailcap-mime-types ()
+  "Return a list of MIME media types."
+  (delete-duplicates (mapcar 'cdr mailcap-mime-extensions)))

 
 (provide 'mailcap)
 
 
 (provide 'mailcap)