Don't require cl at runtime. Require gnus-util at runtime.

[gnus] / contrib / gpg.el

diff --git a/contrib/gpg.el b/contrib/gpg.el
index c7b5763..80c5d8a 100644 (file)
--- a/contrib/gpg.el
+++ b/contrib/gpg.el
@@ -7,13 +7,11 @@
 ;; Keywords: crypto
 ;; Created: 2000-04-15
 
 ;; Keywords: crypto
 ;; Created: 2000-04-15
 

-;; $Id: gpg.el,v 6.2 2000/10/31 22:16:42 zsh Exp $
-

 ;; This file is NOT (yet?) 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
 ;; This file is NOT (yet?) 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)
+;; the Free Software Foundation; either version 3, or (at your option)

 ;; any later version.
 
 ;; GNU Emacs is distributed in the hope that it will be useful,
 ;; any later version.
 
 ;; GNU Emacs is distributed in the hope that it will be useful,


@@ -23,8 +21,8 @@
 
 ;; 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
 
 ;; 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.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.

 
 ;;; Commentary:
 
 
 ;;; Commentary:
 


@@ -41,8 +39,8 @@
 ;; * Customization for all flavors of PGP is possible.
 ;; * The main operations (verify, decrypt, sign, encrypt, sign &
 ;;   encrypt) are implemented.
 ;; * Customization for all flavors of PGP is possible.
 ;; * The main operations (verify, decrypt, sign, encrypt, sign &
 ;;   encrypt) are implemented.

-;; * Gero Treuner's gpg-2comp script is supported, and data which is is
-;;   compatible with PGP 2.6.3 is generated.
+;; * Optionally, Gero Treuner's gpg-2comp script is supported, 
+;;   to generate data which is compatible with PGP 2.6.3.

 
 ;; Customizing external programs 
 ;; =============================
 
 ;; Customizing external programs 
 ;; =============================


@@ -106,11 +104,33 @@
 ;; function (bound to `C-h l' by default).
 
 \f
 ;; function (bound to `C-h l' by default).
 
 \f

-;;;; Code:
-
-(require 'timer)
-(eval-when-compile 
-  (require 'cl))
+;;; Code:
+
+(if (featurep 'xemacs)
+    (require 'timer-funcs)
+  (require 'timer))
+(eval-when-compile (require 'cl))
+
+(eval-and-compile 
+  (defalias 'gpg-point-at-eol
+    (if (fboundp 'point-at-eol)
+       'point-at-eol
+      'line-end-position)))
+
+;; itimer/timer compatibility
+(eval-and-compile
+  (if (featurep 'xemacs)
+      (progn
+       (defalias 'gpg-cancel-timer 'delete-itimer)
+       (defalias 'gpg-timer-activate 'activate-itimer)
+       (defalias 'gpg-timer-create 'make-itimer)
+       (defalias 'gpg-timer-set-function 'set-itimer-function)
+       (defalias 'gpg-timer-set-time 'set-itimer-value))
+    (defalias 'gpg-cancel-timer 'cancel-timer)
+    (defalias 'gpg-timer-activate 'timer-activate)
+    (defalias 'gpg-timer-create 'timer-create)
+    (defalias 'gpg-timer-set-function 'timer-set-function)
+    (defalias 'gpg-timer-set-time 'timer-set-time)))

 
 ;;;; Customization:
 
 
 ;;;; Customization:
 


@@ -138,12 +158,19 @@
 
 ;;; Customization: Widgets:
 
 
 ;;; Customization: Widgets:
 

-(define-widget 'gpg-command-alist 'alist
-  "An association list for GnuPG command names."
-  :key-type '(symbol :tag   "Abbreviation")
-  :value-type '(string :tag "Program name")
-  :convert-widget 'widget-alist-convert-widget
-  :tag "Alist")
+(if (get 'alist 'widget-type)
+    (define-widget 'gpg-command-alist 'alist
+      "An association list for GnuPG command names."
+      :key-type '(symbol :tag   "Abbreviation")
+      :value-type '(string :tag "Program name")
+      :convert-widget 'widget-alist-convert-widget
+      :tag "Alist")
+    (define-widget 'gpg-command-alist 'repeat
+      "An association list for GnuPG command names."
+      :args '((cons :format "%v"
+                   (symbol :tag   "Abbreviation")
+                   (string :tag "Program name")))
+      :tag "Alist"))

 
 (define-widget 'gpg-command-program 'choice
   "Widget for entering the name of a program (mostly the GnuPG binary)."
 
 (define-widget 'gpg-command-program 'choice
   "Widget for entering the name of a program (mostly the GnuPG binary)."


@@ -215,16 +242,22 @@ If you are running Emacs 20, this directory must have mode 0700."
 
 (defcustom gpg-command-default-alist 
   '((gpg . "gpg")
 
 (defcustom gpg-command-default-alist 
   '((gpg . "gpg")

-    (gpg-2comp . "gpg-2comp"))
+    (gpg-2comp . "gpg"))

   "Default paths for some GnuPG-related programs.
 Modify this variable if you have to change the paths to the
   "Default paths for some GnuPG-related programs.
 Modify this variable if you have to change the paths to the

-executables required by the GnuPG interface.  You can enter \"gpg\"
-for `gpg-2comp' if you don't have this script, but you'll lose PGP
-2.6.x compatibility."
+executables required by the GnuPG interface.  You can enter \"gpg-2comp\"
+for `gpg-2comp' if you have obtained this script, in order to gain
+PGP 2.6.x compatibility."

   :tag "GnuPG programs"
   :type 'gpg-command-alist
   :group 'gpg-options)
 
   :tag "GnuPG programs"
   :type 'gpg-command-alist
   :group 'gpg-options)
 

+(defcustom gpg-command-all-arglist
+  nil
+  "List of arguments to add to all GPG commands."
+  :tag "All command args"
+  :group 'gpg-options)
+

 (defcustom gpg-command-flag-textmode "--textmode"
   "The flag to indicate canonical text mode to GnuPG."
   :tag "Text mode flag"
 (defcustom gpg-command-flag-textmode "--textmode"
   "The flag to indicate canonical text mode to GnuPG."
   :tag "Text mode flag"


@@ -284,7 +317,7 @@ indicate that it should read the passphrase from standard input."
 ;;; Customization: Variables: GnuPG Commands:
 
 (defcustom gpg-command-verify
 ;;; Customization: Variables: GnuPG Commands:
 
 (defcustom gpg-command-verify

-  '(gpg . ("--batch" "--verbose" "--verify" signature-file message-file))
+  '(gpg . ("--status-fd" "1" "--batch" "--verbose" "--verify" signature-file message-file))

   "Command to verify a detached signature.
 The invoked program has to read the signed message and the signature
 from the given files.  It should write human-readable information to
   "Command to verify a detached signature.
 The invoked program has to read the signed message and the signature
 from the given files.  It should write human-readable information to


@@ -304,8 +337,27 @@ charsets or line endings; the input data shall be treated as binary."
            (string :format "%v"))))
   :group 'gpg-commands)
 
            (string :format "%v"))))
   :group 'gpg-commands)
 

+(defcustom gpg-command-verify-cleartext
+  '(gpg . ("--status-fd" "1" "--batch" "--verbose" "--verify" message-file))
+  "Command to verify a message.
+The invoked program has to read the signed message from the given
+file.  It should write human-readable information to standard output
+and/or standard error.  The program shall not convert charsets or line
+endings; the input data shall be treated as binary."
+  :tag "Cleartext Verify Command"
+  :type '(cons 
+         gpg-command-program
+         (repeat 
+          :tag "Arguments"
+          (choice 
+           :format "%[Type%] %v"
+           (const :tag "Insert name of file containing the message here." 
+                  :value message-file)
+           (string :format "%v"))))
+  :group 'gpg-commands)
+

 (defcustom gpg-command-decrypt
 (defcustom gpg-command-decrypt

-  '(gpg . ("--decrypt" "--batch" "--passphrase-fd=0"))
+  '(gpg . ("--status-fd" "2" "--decrypt" "--batch" "--passphrase-fd=0"))

   "Command to decrypt a message.
 The invoked program has to read the passphrase from standard
 input, followed by the encrypted message.  It writes the decrypted
   "Command to decrypt a message.
 The invoked program has to read the passphrase from standard
 input, followed by the encrypted message.  It writes the decrypted


@@ -327,7 +379,7 @@ standard error."
   '(gpg-2comp . ("--batch" "--passphrase-fd=0" "--output=-"
                 armor textmode  "--clearsign"
                 sign-with-key))
   '(gpg-2comp . ("--batch" "--passphrase-fd=0" "--output=-"
                 armor textmode  "--clearsign"
                 sign-with-key))

-  "Command to create a create a \"clearsign\" text file.  
+  "Command to create a \"clearsign\" text file.  

 The invoked program has to read the passphrase from standard input,
 followed by the message to sign.  It should write the ASCII-amored
 signed text message to standard output, and diagnostic messages to
 The invoked program has to read the passphrase from standard input,
 followed by the message to sign.  It should write the ASCII-amored
 signed text message to standard output, and diagnostic messages to


@@ -340,7 +392,7 @@ standard error."
   '(gpg-2comp . ("--batch" "--passphrase-fd=0" "--output=-"
                 armor textmode "--detach-sign" 
                 sign-with-key))
   '(gpg-2comp . ("--batch" "--passphrase-fd=0" "--output=-"
                 armor textmode "--detach-sign" 
                 sign-with-key))

-  "Command to create a create a detached signature. 
+  "Command to create a detached signature. 

 The invoked program has to read the passphrase from standard input,
 followed by the message to sign.  It should write the ASCII-amored
 detached signature to standard output, and diagnostic messages to
 The invoked program has to read the passphrase from standard input,
 followed by the message to sign.  It should write the ASCII-amored
 detached signature to standard output, and diagnostic messages to


@@ -512,7 +564,7 @@ it are replaced by SUBSTITUTIONS.
 SUBSTITIONS is a list of (SYMBOL . SEXP) pairs, where SEXP is either a
 string (which is inserted literally), a list of strings (which are
 inserted as well), or nil, which means to insert nothing."
 SUBSTITIONS is a list of (SYMBOL . SEXP) pairs, where SEXP is either a
 string (which is inserted literally), a list of strings (which are
 inserted as well), or nil, which means to insert nothing."

-  (let (arglist)
+  (let ((arglist (copy-sequence gpg-command-all-arglist)))

     (while template
       (let* ((templ (pop template))
             (repl (assoc templ substitutions))
     (while template
       (let* ((templ (pop template))
             (repl (assoc templ substitutions))


@@ -577,20 +629,24 @@ adjust according to `gpg-command-passphrase-env'."
         (when gpg-command-passphrase-env
           ;; This will clear the variable if it wasn't set before.
           (setenv (car gpg-command-passphrase-env) ,env-value))))))
         (when gpg-command-passphrase-env
           ;; This will clear the variable if it wasn't set before.
           (setenv (car gpg-command-passphrase-env) ,env-value))))))

+(put 'gpg-with-passphrase-env 'lisp-indent-function 0)
+(put 'gpg-with-passphrase-env 'edebug-form-spec '(body))

 
 ;;; Temporary files:
 
 (defun gpg-make-temp-file ()
   "Create a temporary file in a safe way"
 
 ;;; Temporary files:
 
 (defun gpg-make-temp-file ()
   "Create a temporary file in a safe way"

-  (let ((name (concat gpg-temp-directory "/gnupg")))
+  (let ((name  ;; User may use "~/"
+        (expand-file-name "gnupg" gpg-temp-directory)))

     (if (fboundp 'make-temp-file)
        ;; If we've got make-temp-file, we are on the save side.
        (make-temp-file name)
       ;; make-temp-name doesn't create the file, and an ordinary
       ;; write-file operation is prone to nasty symlink attacks if the
       ;; temporary file resides in a world-writable directory.
     (if (fboundp 'make-temp-file)
        ;; If we've got make-temp-file, we are on the save side.
        (make-temp-file name)
       ;; make-temp-name doesn't create the file, and an ordinary
       ;; write-file operation is prone to nasty symlink attacks if the
       ;; temporary file resides in a world-writable directory.

-      (unless (eq (file-modes gpg-temp-directory) 448) ; mode 0700
-       (error "Directory for temporary files must have mode 0700."))
+      (unless (or (memq system-type '(windows-nt cygwin32 win32 w32 mswindows))
+                 (eq (file-modes gpg-temp-directory) 448)) ; mode 0700
+       (error "Directory for temporary files (%s) must have mode 0700" gpg-temp-directory))

       (setq name (make-temp-name name))
       (let ((mode (default-file-modes)))
        (unwind-protect
       (setq name (make-temp-name name))
       (let ((mode (default-file-modes)))
        (unwind-protect


@@ -630,6 +686,8 @@ arguments."
            (gpg-with-temp-files-create ,count)
            ,@body)
        (gpg-with-temp-files-delete))))
            (gpg-with-temp-files-create ,count)
            ,@body)
        (gpg-with-temp-files-delete))))

+(put 'gpg-with-temp-files 'lisp-indent-function 1)
+(put 'gpg-with-temp-files 'edebug-form-spec '(body))

 
 ;;;  Making subprocesses:
 
 
 ;;;  Making subprocesses:
 


@@ -684,7 +742,7 @@ to this file."
                 (apply 'call-process-region (point-min) (point-max) cpr-args)
                 ;; Wipe out passphrase.
                 (goto-char (point-min))
                 (apply 'call-process-region (point-min) (point-max) cpr-args)
                 ;; Wipe out passphrase.
                 (goto-char (point-min))

-                (translate-region (point) (line-end-position)
+                (translate-region (point) (gpg-point-at-eol)

                                   (make-string 256 ? )))
             (if (listp stdin)
                 (with-current-buffer (car stdin)
                                   (make-string 256 ? )))
             (if (listp stdin)
                 (with-current-buffer (car stdin)


@@ -720,7 +778,7 @@ Never set this variable directly, use `gpg-show-result' instead.")
       (save-window-excursion
        (display-buffer (current-buffer))
        (unless (y-or-n-p "Continue? ")
       (save-window-excursion
        (display-buffer (current-buffer))
        (unless (y-or-n-p "Continue? ")

-         (error "GnuPG operation aborted."))))))
+         (error "GnuPG operation aborted"))))))

 
 (defmacro gpg-show-result (always-show &rest body)
   "Show GnuPG result to user for confirmation.
 
 (defmacro gpg-show-result (always-show &rest body)
   "Show GnuPG result to user for confirmation.


@@ -732,11 +790,13 @@ evaluates BODY, like `progn'.  If BODY evaluates to `nil' (or
      (unwind-protect
         (gpg-show-result-buffer ,always-show (progn ,@body))
        (kill-buffer gpg-result-buffer))))
      (unwind-protect
         (gpg-show-result-buffer ,always-show (progn ,@body))
        (kill-buffer gpg-result-buffer))))

+(put 'gpg-show-result 'lisp-indent-function 1)
+(put 'gpg-show-result 'edebug-form-spec '(body))

 
 ;;; Passphrase handling:
 
 (defvar gpg-passphrase-timer
 
 ;;; Passphrase handling:
 
 (defvar gpg-passphrase-timer

-  (timer-create)
+  (gpg-timer-create)

   "This timer will clear the passphrase cache periodically.")
 
 (defvar gpg-passphrase
   "This timer will clear the passphrase cache periodically.")
 
 (defvar gpg-passphrase


@@ -755,22 +815,28 @@ evaluates BODY, like `progn'.  If BODY evaluates to `nil' (or
 (defun gpg-passphrase-forget ()
   "Forget stored passphrase."
   (interactive)
 (defun gpg-passphrase-forget ()
   "Forget stored passphrase."
   (interactive)

-  (cancel-timer gpg-passphrase-timer)
-  (gpg-passphrase-clear-string gpg-passphrase)
-  (setq gpg-passphrase nil))
+  (when gpg-passphrase
+    (gpg-cancel-timer gpg-passphrase-timer)
+    (setq gpg-passphrase-timer nil)
+    (gpg-passphrase-clear-string gpg-passphrase)
+    (setq gpg-passphrase nil)))

 
 (defun gpg-passphrase-store (passphrase)
   "Store PASSPHRASE in cache.
 Updates the timeout for clearing the cache to `gpg-passphrase-timeout'."
   (unless (equal gpg-passphrase-timeout 0)
 
 (defun gpg-passphrase-store (passphrase)
   "Store PASSPHRASE in cache.
 Updates the timeout for clearing the cache to `gpg-passphrase-timeout'."
   (unless (equal gpg-passphrase-timeout 0)

-    (timer-set-time gpg-passphrase-timer 
-                   (timer-relative-time (current-time) 
-                                        gpg-passphrase-timeout))
-    (timer-set-function gpg-passphrase-timer 'gpg-passphrase-forget)
-    (timer-activate gpg-passphrase-timer)
+    (if (null gpg-passphrase-timer)
+       (setq gpg-passphrase-timer (gpg-timer-create)))
+    (gpg-timer-set-time gpg-passphrase-timer 
+                       (timer-relative-time (current-time) 
+                                            gpg-passphrase-timeout))
+    (gpg-timer-set-function gpg-passphrase-timer 'gpg-passphrase-forget)
+    (unless (and (fboundp 'itimer-live-p)
+                (itimer-live-p gpg-passphrase-timer))
+      (gpg-timer-activate gpg-passphrase-timer))

     (setq gpg-passphrase passphrase))
   passphrase)
     (setq gpg-passphrase passphrase))
   passphrase)

-  
+

 (defun gpg-passphrase-read ()
   "Read a passphrase and remember it for some time."
   (interactive)
 (defun gpg-passphrase-read ()
   "Read a passphrase and remember it for some time."
   (interactive)


@@ -821,6 +887,39 @@ buffer RESULT for details."
            nil)
        t))))
 
            nil)
        t))))
 

+;;;###autoload
+(defun gpg-verify-cleartext (message result)
+  "Verify message in buffer MESSAGE.
+Returns t if everything worked out well, nil otherwise.  Consult
+buffer RESULT for details.
+
+NOTE: Use of this function is deprecated."
+  (interactive "bBuffer containing message: \nbBuffor for result: ")
+  (gpg-with-temp-files 1
+    (let* ((msg-file    (nth 0 gpg-temp-files))
+          (cmd (gpg-exec-path gpg-command-verify-cleartext))
+          (args (gpg-build-arg-list (cdr gpg-command-verify-cleartext)
+                                    `((message-file . ,msg-file))))
+          res)
+      (with-temp-file msg-file 
+       (buffer-disable-undo)
+       (apply 'insert-buffer-substring (if (listp message)
+                                           message
+                                         (list message))))
+      (setq res (apply 'call-process-region
+                      (point-min) (point-min) ; no data
+                      cmd
+                      nil              ; don't delete
+                      result
+                      nil              ; don't display
+                      args))
+      (if (or (stringp res) (> res 0))
+         ;; Signal or abnormal exit.
+         (with-current-buffer result
+           (insert (format "\nCommand exit status: %s\n" res))
+           nil)
+       t))))
+

 ;;;###autoload
 (defun gpg-decrypt (ciphertext plaintext result &optional passphrase)
   "Decrypt buffer CIPHERTEXT to buffer PLAINTEXT.
 ;;;###autoload
 (defun gpg-decrypt (ciphertext plaintext result &optional passphrase)
   "Decrypt buffer CIPHERTEXT to buffer PLAINTEXT.


@@ -1027,12 +1126,7 @@ documentation for details)."
 
 (defun gpg-key-lessp (a b)
   "Returns t if primary user ID of A is less than B."
 
 (defun gpg-key-lessp (a b)
   "Returns t if primary user ID of A is less than B."

-  (let ((res (compare-strings (gpg-key-primary-user-id a) 0 nil
-                             (gpg-key-primary-user-id b) 0 nil
-                             t)))
-    (if (eq res t)
-       nil
-      (< res 0))))
+  (string-lessp (gpg-key-primary-user-id a) (gpg-key-primary-user-id b) ))

 
 ;;; Accessing the key database:
 
 
 ;;; Accessing the key database:
 


@@ -1057,7 +1151,7 @@ documentation for details)."
 
 (defun gpg-key-list-keys-parse-line ()
   "Parse the line in the current buffer and return a vector of fields."
 
 (defun gpg-key-list-keys-parse-line ()
   "Parse the line in the current buffer and return a vector of fields."

-  (let* ((eol (line-end-position))
+  (let* ((eol (gpg-point-at-eol))

         (v (if (eolp)
                nil
              (vector
         (v (if (eolp)
                nil
              (vector


@@ -1100,6 +1194,14 @@ documentation for details)."
     (?u . trust-ultimate))
   "Alist mapping GnuPG trust value short forms to long symbols.")
 
     (?u . trust-ultimate))
   "Alist mapping GnuPG trust value short forms to long symbols.")
 

+(defconst gpg-unabbrev-trust-alist
+  '(("TRUST_UNDEFINED" . trust-undefined)
+    ("TRUST_NEVER"     . trust-none)
+    ("TRUST_MARGINAL"  . trust-marginal)
+    ("TRUST_FULLY"     . trust-full)
+    ("TRUST_ULTIMATE"  . trust-ultimate))
+  "Alist mapping capitalized GnuPG trust values to long symbols.")
+

 (defmacro gpg-key-list-keys-in-buffer-store ()
   '(when primary-user-id
      (sort user-id 'string-lessp)
 (defmacro gpg-key-list-keys-in-buffer-store ()
   '(when primary-user-id
      (sort user-id 'string-lessp)


@@ -1234,4 +1336,5 @@ before point.")
 
 (provide 'gpg)
 
 
 (provide 'gpg)
 

+;;; arch-tag: c972455d-9bc5-4de1-9dc7-4f494d63053b

 ;;; gpg.el ends here
 ;;; gpg.el ends here