;;; mime-mc.el --- Mailcrypt interface for SEMI
-;; Copyright (C) 1996,1997 MORIOKA Tomohiko
+;; Copyright (C) 1996,1997,1998,1999 MORIOKA Tomohiko
;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; Version: $Id: mime-mc.el,v 0.1 1997-11-20 13:26:48 morioka Exp $
-;; Keywords: PGP, security, MIME, multimedia, mail, news
+;; Katsumi Yamaoka <yamaoka@jpl.org>
+;; Keywords: PGP, GnuPG, security, MIME, multimedia, mail, news
;; This file is part of SEMI (Secure Emacs MIME Interface).
;;; Code:
+(require 'alist)
+(require 'std11)
+(require 'semi-def)
+(require 'mime-def)
(require 'mailcrypt)
-(load "mc-pgp")
-(defun mime-mc-pgp-generic-parser (result)
- (let ((ret (mc-pgp-generic-parser result)))
- (if (consp ret)
- (vector (car ret)(cdr ret))
+(eval-when-compile
+ (load "expect" t)
+ )
+
+(eval-and-compile
+ (mapcar
+ (function (lambda (elem) (apply 'autoload elem)))
+ '(
+ (mc-gpg-debug-print "mc-gpg")
+
+ (mc-gpg-encrypt-region "mc-gpg")
+ (mc-gpg-fetch-key "mc-gpg")
+ (mc-gpg-lookup-key "mc-gpg")
+ (mc-gpg-sign-region "mc-gpg")
+
+ (mc-pgp50-encrypt-region "mc-pgp5")
+ (mc-pgp50-fetch-key "mc-pgp5")
+ (mc-pgp50-lookup-key "mc-pgp5")
+ (mc-pgp50-sign-region "mc-pgp5")
+
+ (mc-pgp-encrypt-region "mc-pgp")
+ (mc-pgp-fetch-key "mc-pgp")
+ (mc-pgp-lookup-key "mc-pgp")
+ (mc-pgp-sign-region "mc-pgp")
+
+ (mc-snarf-keys "mc-toplev")
+ )))
+
+(defgroup mime-mc nil
+ "Mailcrypt interface for SEMI."
+ :prefix "mime-mc-"
+ :group 'mime)
+
+(defcustom mime-mc-shell-file-name "/bin/sh"
+ "File name to load inferior shells from. Bourne shell or its equivalent
+\(not tcsh) is needed for \"2>\"."
+ :group 'mime-mc
+ :type 'file)
+
+(defcustom mime-mc-shell-command-switch "-c"
+ "Switch used to have the shell execute its command line argument."
+ :group 'mime-mc
+ :type 'string)
+
+(defcustom mime-mc-omit-micalg nil
+ "Non-nil value means to omit the micalg parameter for multipart/signed.
+See draft-yamamoto-openpgp-mime-00.txt (OpenPGP/MIME) for more information."
+ :group 'mime-mc
+ :type 'boolean)
+
+(defcustom mime-mc-comment-alist
+ (let ((product-name (mime-product-name mime-user-interface-product))
+ (version (mapconcat
+ (function number-to-string)
+ (mime-product-version mime-user-interface-product)
+ "."))
+ (codename (mime-product-code-name mime-user-interface-product))
+ string)
+ (setq string (format "Processed by Mailcrypt %s under %s %s%s"
+ mc-version product-name version
+ (if (string-match "^[ -~]+$" codename)
+ (concat " - \"" codename "\"")
+ "")))
+ (list (cons 'gpg string)
+ (cons 'pgp50 string)
+ (cons 'pgp string)))
+ "Alist of the schemes and strings of the comment field to appear in ASCII
+armor output."
+ :group 'mime-mc
+ :type '(repeat (cons :format "%v"
+ (choice (choice-item :tag "GnuPG" gpg)
+ (choice-item :tag "PGP 5.0i" pgp50)
+ (choice-item :tag "PGP 2.6" pgp))
+ (string :tag "Comment"))))
+
+(defvar mime-mc-symbol-format-alist
+ '((comment . "mc-%s-comment")
+ (fetch-key . "mc-%s-fetch-key")
+ (insert-key . "mc-%s-insert-public-key")
+ (mime-encrypt . "mime-mc-%s-encrypt-region")
+ (mime-sign . "mime-mc-%s-sign-region")
+ (scheme . "mc-scheme-%s")
+ (traditional-sign . "mc-%s-sign-region")
+ )
+ "Alist of service names and corresponding format strings.")
+
+(defmacro mime-mc-symbol (service)
+ (` (intern
+ (format (cdr (assq (, service) mime-mc-symbol-format-alist))
+ pgp-version))))
+
+(defmacro mime-mc-comment ()
+ "Return a string of the comment field."
+ '(or (cdr (assq pgp-version mime-mc-comment-alist))
+ (symbol-value (mime-mc-symbol 'comment))
+ ))
+
+
+;;; @ Internal variable
+;;;
+
+(defvar mime-mc-micalg-alist nil
+ "Alist of KeyID and the value of message integrity check algorithm.")
+
+
+;;; @ External variables (for avoid byte compile warnings)
+;;;
+
+(defvar mc-gpg-extra-args)
+(defvar mc-gpg-path)
+(defvar mc-gpg-user-id)
+(defvar mc-pgp50-pgps-path)
+(defvar mc-pgp50-user-id)
+(defvar mc-pgp-path)
+(defvar mc-pgp-user-id)
+
+
+;;; @ Generic functions
+;;;
+
+(defun mime-mc-setversion (&optional version)
+ "Select `pgp-version' and `mc-default-scheme' if possible.
+VERSION should be a string or a symbol."
+ (interactive)
+ (let ((oldversion pgp-version)
+ (table '(("GnuPG" . gpg) ("PGP 5.0i" . pgp50) ("PGP 2.6" . pgp)
+ ("gnupg" . gpg) ("gpg" . gpg) ("pgp5" . pgp50)
+ ("pgp50" . pgp50) ("pgp2" . pgp) ("pgp" . pgp)
+ ("5.0" . pgp50) ("2.6" . pgp))))
+ (if (interactive-p)
+ (setq version (completing-read
+ (format "Select PGP version (currently %s): "
+ (car (rassoc oldversion table)))
+ table nil t)
+ pgp-version (or (cdr (assoc version table))
+ oldversion))
+ (if (stringp version)
+ (setq pgp-version (or (cdr (assoc version table)) oldversion))
+ (if (memq version '(gpg pgp50 pgp))
+ (setq pgp-version version)
+ )))
+ (condition-case nil
+ (mc-setversion
+ (cdr (assq pgp-version
+ '((gpg . "gpg") (pgp50 . "5.0") (pgp . "2.6"))))
+ )
+ (error nil))
+ (message "PGP version set to %s." (car (rassq pgp-version table)))
+ ))
+
+(defun mime-mc-replace-comment-field (comment &optional start end)
+ (let ((regexp (if (eq 'pgp pgp-version)
+ "-----BEGIN PGP.*-----\nVersion:"
+ "^-----BEGIN PGP.*\n")))
+ (save-excursion
+ (save-restriction
+ (narrow-to-region (or start (point-min)) (or end (point-max)))
+ (goto-char (point-min))
+ (while (re-search-forward regexp nil t)
+ (forward-line 1)
+ (save-restriction
+ (narrow-to-region (point)
+ (if (search-forward "\n\n" nil t)
+ (point)
+ (point-max)))
+ (goto-char (point-min))
+ (if (re-search-forward "^Comment:.*$" nil t)
+ (replace-match (concat "Comment: " comment))
+ )))
+ (point-max)))))
+
+(defun mime-mc-verify ()
+ "Verify a message in the current buffer. Exact behavior depends on
+current major mode."
+ (let ((mc-default-scheme (mime-mc-symbol 'scheme)))
+ (mc-verify)
+ ))
+
+(defun mime-mc-decrypt ()
+ "Decrypt a message in the current buffer. Exact behavior depends on
+current major mode."
+ (let ((mc-default-scheme (mime-mc-symbol 'scheme)))
+ (mc-decrypt)
+ ))
+
+(defun mime-mc-fetch-key (&optional id)
+ "Attempt to fetch a key for addition to PGP or GnuPG keyring.
+Interactively, prompt for string matching key to fetch.
+
+Non-interactively, ID must be a pair. The CAR must be a bare Email
+address and the CDR a keyID (with \"0x\" prefix). Either, but not
+both, may be nil.
+
+Return t if we think we were successful; nil otherwise. Note that nil
+is not necessarily an error, since we may have merely fired off an Email
+request for the key."
+ (funcall (mime-mc-symbol 'fetch-key) id)
+ )
+
+(defun mime-mc-snarf-keys ()
+ "Add all public keys in the buffer to your keyring."
+ (let ((mc-default-scheme (mime-mc-symbol 'scheme)))
+ (mc-snarf-keys)
+ ))
+
+(defun mime-mc-sign-region (start end &optional id unclear boundary)
+ (funcall (mime-mc-symbol 'mime-sign) start end id unclear boundary)
+ )
+
+(defun mime-mc-traditional-sign-region (start end &optional id unclear)
+ (funcall (mime-mc-symbol 'traditional-sign) start end id unclear)
+ )
+
+(defun mime-mc-encrypt-region (recipients start end &optional id sign)
+ (funcall (mime-mc-symbol 'mime-encrypt) recipients start end id sign)
+ )
+
+(defun mime-mc-insert-public-key (&optional userid)
+ "Insert your public key at point."
+ (or (fboundp (mime-mc-symbol 'insert-key))
+ (load (concat "mc-" (cdr (assq pgp-version '((gpg . "gpg")
+ (pgp50 . "pgp5")
+ (pgp . "pgp")))))))
+ (let ((mc-comment (mime-mc-symbol 'comment))
+ (comment (mime-mc-comment))
+ (scheme (mime-mc-symbol 'scheme)))
+ (eval (` (let (((, mc-comment) (if (, comment) "DUMMY")))
+ (mc-insert-public-key (, userid) (quote (, scheme)))
+ )))
+ (if comment
+ (mime-mc-replace-comment-field comment)
)))
+
+;;; @ GnuPG functions
+;;;
+
+(defun mime-mc-gpg-process-region
+ (beg end passwd program args parser bufferdummy &optional boundary comment)
+ "Similar to `mc-gpg-process-region', however enclose an processed data
+with BOUNDARY if it is specified and replace the comment field with the
+optional argument COMMENT if it is specified."
+ (let ((obuf (current-buffer))
+ (process-connection-type nil)
+ (shell-file-name mime-mc-shell-file-name)
+ (shell-command-switch mime-mc-shell-command-switch)
+ ; other local vars
+ mybuf
+ stderr-tempfilename stderr-buf
+ status-tempfilename status-buf
+ proc rc status parser-result
+ )
+ (mc-gpg-debug-print (format
+ "(mime-mc-gpg-process-region beg=%s end=%s passwd=%s program=%s args=%s parser=%s bufferdummy=%s boundary=%s comment=%s)"
+ beg end passwd program args parser bufferdummy boundary comment))
+ (setq stderr-tempfilename
+ (make-temp-name (expand-file-name "mailcrypt-gpg-stderr-"
+ mc-temp-directory)))
+ (setq status-tempfilename
+ (make-temp-name (expand-file-name "mailcrypt-gpg-status-"
+ mc-temp-directory)))
+ (unwind-protect
+ (catch ;; Returns non-nil if success, otherwise nil with error message.
+ 'mime-mc-gpg-process-region-done
+
+ ;; get output places ready
+ (setq mybuf (get-buffer-create " *mailcrypt stdout temp"))
+ (set-buffer mybuf)
+ (erase-buffer)
+ (set-buffer obuf)
+ (buffer-disable-undo mybuf)
+
+ (if passwd
+ (setq args (append '("--passphrase-fd" "0") args)))
+ (setq args (append (list (concat "2>" stderr-tempfilename)) args))
+ (setq args (append (list (concat "3>" status-tempfilename)) args))
+ (setq args (append '("--status-fd" "3") args))
+
+ (if comment
+ (setq args (append '("--comment" "DUMMY") args))
+ )
+
+ (if mc-gpg-extra-args
+ (setq args (append mc-gpg-extra-args args)))
+
+ (mc-gpg-debug-print (format "prog is %s, args are %s"
+ program
+ (mapconcat '(lambda (x)
+ (format "'%s'" x))
+ args " ")))
+
+ (setq proc
+ (apply 'start-process-shell-command "*GPG*" mybuf
+ program args))
+ ;; send in passwd if necessary
+ (if passwd
+ (progn
+ (process-send-string proc (concat passwd "\n"))
+ (or mc-passwd-timeout (mc-deactivate-passwd t))))
+ ;; send in the region
+ (process-send-region proc beg end)
+ ;; finish it off
+ (process-send-eof proc)
+ ;; wait for it to finish
+ (while (eq 'run (process-status proc))
+ (accept-process-output proc 5))
+ ;; remember result codes
+ (setq status (process-status proc))
+ (setq rc (process-exit-status proc))
+ (mc-gpg-debug-print (format "prog finished, rc=%s" rc))
+
+ ;; Hack to force a status_notify() in Emacs 19.29
+ (delete-process proc)
+
+ ;; remove the annoying "yes your process has finished" message
+ (set-buffer mybuf)
+ (goto-char (point-max))
+ (if (re-search-backward "\nProcess \\*GPG.*\n\\'" nil t)
+ (delete-region (match-beginning 0) (match-end 0)))
+ (goto-char (point-min))
+ ;; CRNL -> NL
+ (while (search-forward "\r\n" nil t)
+ (replace-match "\n"))
+
+ ;; ponder process death: signal, not just rc!=0
+ (if (or (eq 'stop status) (eq 'signal status))
+ ;; process died
+ (progn
+ (message
+ "%s exited abnormally: '%s'" program rc) ;; is rc a string?
+ (throw 'mime-mc-gpg-process-region-done nil)
+ ))
+
+ (if (= 127 rc)
+ (progn
+ (message
+ "%s could not be found" program) ;; at least on my system
+ (throw 'mime-mc-gpg-process-region-done nil)
+ ))
+
+ ;; fill stderr buf
+ (setq stderr-buf (get-buffer-create " *mailcrypt stderr temp"))
+ (buffer-disable-undo stderr-buf)
+ (set-buffer stderr-buf)
+ (erase-buffer)
+ (insert-file-contents stderr-tempfilename)
+
+ ;; fill status buf
+ (setq status-buf (get-buffer-create " *mailcrypt status temp"))
+ (buffer-disable-undo status-buf)
+ (set-buffer status-buf)
+ (erase-buffer)
+ (insert-file-contents status-tempfilename)
+
+ ;; replace comment string
+ (set-buffer mybuf)
+ (if comment
+ (mime-mc-replace-comment-field comment)
+ )
+
+ ;; feed the parser
+ (condition-case err
+ (setq parser-result
+ (funcall parser mybuf stderr-buf status-buf rc)
+ )
+ (error
+ (message "%s" err)
+ (throw 'mime-mc-gpg-process-region-done nil)
+ ))
+ (mc-gpg-debug-print (format " parser returned %s" parser-result))
+
+ ;; what did the parser tell us?
+ (if (car parser-result)
+ ;; yes, replace region
+ (progn
+ (set-buffer obuf)
+ (if boundary
+ (save-restriction
+ (narrow-to-region beg end)
+ (goto-char beg)
+ (insert (format "--%s\n" boundary))
+ (goto-char (point-max))
+ (insert (format "\n--%s
+Content-Type: application/pgp-signature
+Content-Transfer-Encoding: 7bit
+
+" boundary))
+ (insert-buffer-substring mybuf)
+ (goto-char (point-max))
+ (insert (format "\n--%s--\n" boundary))
+ )
+ (delete-region beg end)
+ (goto-char beg)
+ (insert-buffer-substring mybuf)
+ )))
+
+ ;; return result
+ (cdr parser-result)
+ )
+ ;; cleanup forms
+ (if (and proc (eq 'run (process-status proc)))
+ ;; it is still running. kill it.
+ (interrupt-process proc))
+ (set-buffer obuf)
+ (delete-file stderr-tempfilename)
+ (delete-file status-tempfilename)
+ ;; kill off temporary buffers (which would be useful for debugging)
+ (if t ;; nil for easier debugging
+ (progn
+ (if (get-buffer " *mailcrypt stdout temp")
+ (kill-buffer " *mailcrypt stdout temp"))
+ (if (get-buffer " *mailcrypt stderr temp")
+ (kill-buffer " *mailcrypt stderr temp"))
+ (if (get-buffer " *mailcrypt status temp")
+ (kill-buffer " *mailcrypt status temp"))
+ ))
+ )))
+
+(defun mime-mc-gpg-sign-region (start end &optional id unclear boundary)
+ (if (not (fboundp 'mc-gpg-insert-parser))
+ (load "mc-gpg")
+ )
+ (let ((buffer (get-buffer-create mc-buffer-name))
+ passwd args key
+ (parser (function mc-gpg-insert-parser))
+ (pgp-path mc-gpg-path)
+ micalg
+ (comment (mime-mc-comment))
+ )
+ (setq key (mc-gpg-lookup-key (or id mc-gpg-user-id)))
+ (setq passwd
+ (mc-activate-passwd
+ (cdr key)
+ (format "GnuPG passphrase for %s (%s): " (car key) (cdr key))))
+ (setq args (cons
+ (if boundary
+ "--detach-sign"
+ (if unclear
+ "--sign"
+ "--clearsign")
+ )
+ (list "--armor" "--batch" "--textmode" "--verbose"
+ "--local-user" (cdr key))
+ ))
+ (if boundary
+ (progn
+ (if (string-match "^pgp-" boundary)
+ (setq boundary
+ (concat "gpg-" (substring boundary (match-end 0))))
+ )
+ (if (not (or mime-mc-omit-micalg
+ (setq micalg
+ (cdr (assoc (cdr key) mime-mc-micalg-alist)))
+ ))
+ (with-temp-buffer
+ (message "Detecting the value of `micalg'...")
+ (insert "\n")
+ (if (let ((mc-passwd-timeout 60)) ;; Don't deactivate passwd.
+ (mime-mc-gpg-process-region
+ 1 2 passwd pgp-path
+ (list "--clearsign" "--armor" "--batch" "--textmode"
+ "--verbose" "--local-user" (cdr key))
+ parser buffer nil)
+ )
+ (progn
+ (std11-narrow-to-header)
+ (setq micalg
+ (downcase (or (std11-fetch-field "Hash") "md5"))
+ )
+ (set-alist 'mime-mc-micalg-alist (cdr key) micalg)
+ )
+ (or mc-passwd-timeout (mc-deactivate-passwd t))
+ ))
+ )))
+ (if (or mime-mc-omit-micalg micalg)
+ (progn
+ (message "Signing as %s ..." (car key))
+ (if (mime-mc-gpg-process-region
+ start end passwd pgp-path args parser buffer boundary comment)
+ (progn
+ (if boundary
+ (progn
+ (goto-char (point-min))
+ (insert
+ (format "\
+--[[multipart/signed; protocol=\"application/pgp-signature\";
+ boundary=\"%s\"%s][7bit]]\n"
+ boundary
+ (if mime-mc-omit-micalg
+ ""
+ (concat "; micalg=pgp-" micalg)
+ )
+ ))))
+ (message "Signing as %s ... Done." (car key))
+ t)
+ nil)
+ )
+ nil)))
+
+(defun mime-mc-gpg-encrypt-region (recipients start end &optional id sign)
+ (if (not (fboundp 'mc-gpg-encrypt-region))
+ (load "mc-gpg")
+ )
+ (let ((mc-pgp-always-sign (if (eq sign 'maybe)
+ mc-pgp-always-sign
+ 'never))
+ (comment (mime-mc-comment)))
+ (prog1
+ (mc-gpg-encrypt-region
+ (mc-split "\\([ \t\n]*,[ \t\n]*\\)+" recipients)
+ start end id nil)
+ (if comment
+ (mime-mc-replace-comment-field comment)
+ ))))
+
+
+;;; @ PGP 5.0i functions
+;;;
+
+(defun mime-mc-pgp50-process-region
+ (beg end passwd program args parser &optional buffer boundary comment)
+ "Similar to `mc-pgp50-process-region', however enclose an processed data
+with BOUNDARY if it is specified and replace the comment field with the
+optional argument COMMENT if it is specified."
+ (let ((obuf (current-buffer))
+ (process-connection-type nil)
+ (shell-file-name mime-mc-shell-file-name)
+ (shell-command-switch mime-mc-shell-command-switch)
+ mybuf result rgn proc results)
+ (if comment
+ (setq args (cons "+comment=DUMMY" args))
+ )
+ (unwind-protect
+ (catch ;; Returns non-nil if success, otherwise nil with error message.
+ 'mime-mc-pgp50-process-region-done
+
+ (setq mybuf (or buffer (generate-new-buffer " *mailcrypt temp")))
+ (set-buffer mybuf)
+ (erase-buffer)
+ (set-buffer obuf)
+ (buffer-disable-undo mybuf)
+ (setq proc
+ (apply 'start-process-shell-command "*PGP*" mybuf program
+ "2>&1" args))
+
+ ;; Now hand the process to the parser, which returns the exit
+ ;; status of the dead process and the limits of the region
+ ;; containing the PGP results.
+ (condition-case err
+ (setq results (funcall parser proc obuf beg end mybuf passwd))
+ (error
+ (message "%s" err)
+ (throw 'mime-mc-pgp50-process-region-done nil)
+ ))
+ (setq result (car results))
+ (setq rgn (cadr results))
+
+ ;; Hack to force a status_notify() in Emacs 19.29
+ (set-buffer mybuf)
+
+ ;; replace comment string
+ (if (and comment (consp rgn))
+ (setcdr rgn (mime-mc-replace-comment-field
+ comment (car rgn) (cdr rgn)))
+ )
+
+ ;; Hurm. FIXME; must get better result codes.
+ (if (stringp result)
+ (mc-message result))
+
+ ;; If the parser found something, migrate it to the old
+ ;; buffer. In particular, the parser's job is to return
+ ;; a cons of the form ( beg . end ) delimited the result
+ ;; of PGP in the new buffer.
+ (if (consp rgn)
+ (progn
+ (set-buffer obuf)
+ (if boundary
+ (save-restriction
+ (narrow-to-region beg end)
+ (goto-char beg)
+ (insert (format "--%s\n" boundary))
+ (goto-char (point-max))
+ (insert (format "\n--%s
+Content-Type: application/pgp-signature
+Content-Transfer-Encoding: 7bit
+
+" boundary))
+ (insert-buffer-substring mybuf (car rgn) (cdr rgn))
+ (goto-char (point-max))
+ (insert (format "\n--%s--\n" boundary))
+ )
+ (delete-region beg end)
+ (goto-char beg)
+ (insert-buffer-substring mybuf (car rgn) (cdr rgn))
+ )
+ (set-buffer mybuf)
+ (delete-region (car rgn) (cdr rgn))))
+
+ ;; Return nil on failure and exit code on success
+ (if rgn result nil))
+
+ ;; Cleanup even on nonlocal exit
+ (if (and proc (eq 'run (process-status proc)))
+ (interrupt-process proc))
+ (set-buffer obuf)
+ (or buffer (null mybuf) (kill-buffer mybuf))
+ rgn)))
+
+(defun mime-mc-pgp50-sign-parser (proc oldbuf start end newbuf passwd)
+ ;; This function is a copy of `mc-pgp50-sign-parser', however it is
+ ;; modified for parsing a detached sign.
+ (let (result results rgn)
+ ;; (setenv "PGPPASSFD" "0")
+ (set-buffer newbuf)
+ (goto-char (point-max))
+ (progn
+ (unwind-protect
+ (with-expect proc
+ (message "Sending passphrase...")
+ (expect-send (concat passwd "\n"))
+ (or mc-passwd-timeout (mc-deactivate-passwd t))
+ (expect "No files specified. Using stdin."
+ (message "Passphrase sent. Signing...")
+ (set-buffer oldbuf)
+ (process-send-region proc start end)
+ (set-buffer newbuf)
+ (process-send-eof proc)
+
+ ;; Test output of the program, looking for
+ ;; errors.
+ (expect-cond
+
+ ;; OPTION 1: Great! The data is now signed!
+ ("-----END PGP SIGNATURE-----"
+
+ ;; Catch the exit status.
+ (setq result (process-exit-status proc))
+ (delete-process proc)
+ (message "Signing complete.")
+
+ ;; Delete everything preceding the signed data.
+ (goto-char (point-max))
+ (re-search-backward
+ ;; "-----BEGIN PGP SIGNED MESSAGE-----" nil t)
+ "-----BEGIN PGP SIGNATURE-----" nil t)
+ (delete-region (point-min) (match-beginning 0))
+ (setq rgn (point-min))
+
+ ;; Convert out CR/NL -> NL
+ (goto-char (point-min))
+ (while (search-forward "\r\n" nil t)
+ (replace-match "\n"))
+
+ ;; Delete everything after the signature.
+ (goto-char (point-min))
+ (re-search-forward
+ "-----END PGP SIGNATURE-----\n" nil t)
+ (delete-region (match-end 0) (point-max))
+
+ ;; Return the exit status, with the region
+ ;; limits!
+ (setq rgn (cons rgn (point-max)))
+ (setq results (list result rgn)))
+
+
+ ;; OPTION 1.a: The data is now signed, but is 8bit data.
+ ("-----END PGP MESSAGE-----"
+
+ ;; Catch the exit status.
+ (setq result (process-exit-status proc))
+ (delete-process proc)
+ (message "Signing complete.")
+
+ ;; Delete everything preceding the signed data.
+ (goto-char (point-max))
+ (re-search-backward
+ "-----BEGIN PGP MESSAGE-----" nil t)
+ (delete-region (point-min) (match-beginning 0))
+ (setq rgn (point-min))
+
+ ;; Convert out CR/NL -> NL
+ (goto-char (point-min))
+ (while (search-forward "\r\n" nil t)
+ (replace-match "\n"))
+
+ ;; Delete everything after the signature.
+ (goto-char (point-min))
+ (re-search-forward
+ "-----END PGP MESSAGE-----\n" nil t)
+ (delete-region (match-end 0) (point-max))
+
+ ;; Return the exit status, with the region
+ ;; limits!
+ (setq rgn (cons rgn (point-max)))
+ (setq results (list result rgn)))
+
+
+ ;; OPTION 2: Awww...bad passphrase!
+ ("Enter pass phrase:"
+ (mc-deactivate-passwd t)
+ (interrupt-process proc)
+ (delete-process proc)
+
+ ;; Return the bad news.
+ (setq results '("Incorrect passphrase" nil)))
+
+ ;; OPTION 3: The program exits.
+ (exit
+ (setq results (list
+ (process-exit-status proc) nil)))))))
+ results)))
+
+(defun mime-mc-pgp50-sign-region (start end &optional id unclear boundary)
+ (if (not (fboundp 'mc-pgp50-sign-parser))
+ (load "mc-pgp5")
+ )
+ (let ((process-environment process-environment)
+ (buffer (get-buffer-create mc-buffer-name))
+ passwd args key
+ (parser (if boundary
+ (function mime-mc-pgp50-sign-parser)
+ (function mc-pgp50-sign-parser)))
+ (pgp-path mc-pgp50-pgps-path)
+ micalg
+ (comment (mime-mc-comment))
+ )
+ (setq key (mc-pgp50-lookup-key (or id mc-pgp50-user-id)))
+ (setq passwd
+ (mc-activate-passwd
+ (cdr key)
+ (format "PGP passphrase for %s (%s): " (car key) (cdr key))))
+ (setenv "PGPPASSFD" "0")
+ (setq args (if boundary
+ (list "-fbat" "+verbose=1" "+language=us" "+batchmode"
+ "-u" (cdr key))
+ (list "-fat" "+verbose=1" "+language=us"
+ (format "+clearsig=%s" (if unclear "off" "on"))
+ "+batchmode" "-u" (cdr key))
+ ))
+ (if (and boundary
+ (not (or mime-mc-omit-micalg
+ (setq micalg
+ (cdr (assoc (cdr key) mime-mc-micalg-alist)))
+ )))
+ (with-temp-buffer
+ (message "Detecting the value of `micalg'...")
+ (insert "\n")
+ (if (let ((mc-passwd-timeout 60)) ;; Don't deactivate passwd.
+ (mime-mc-pgp50-process-region
+ 1 2 passwd pgp-path
+ (list "-fat" "+verbose=1" "+language=us" "+clearsig=on"
+ "+batchmode" "-u" (cdr key))
+ (function mc-pgp50-sign-parser) buffer nil)
+ )
+ (progn
+ (std11-narrow-to-header)
+ (setq micalg (downcase (or (std11-fetch-field "Hash") "md5")))
+ (set-alist 'mime-mc-micalg-alist (cdr key) micalg)
+ )
+ (or mc-passwd-timeout (mc-deactivate-passwd t))
+ ))
+ )
+ (if (or mime-mc-omit-micalg micalg)
+ (progn
+ (message "Signing as %s ..." (car key))
+ (if (mime-mc-pgp50-process-region
+ start end passwd pgp-path args parser buffer boundary comment)
+ (progn
+ (if boundary
+ (progn
+ (goto-char (point-min))
+ (insert
+ (format "\
+--[[multipart/signed; protocol=\"application/pgp-signature\";
+ boundary=\"%s\"%s][7bit]]\n"
+ boundary
+ (if mime-mc-omit-micalg
+ ""
+ (concat "; micalg=pgp-" micalg)
+ )
+ ))))
+ (message "Signing as %s ... Done." (car key))
+ t)
+ nil)
+ )
+ nil)))
+
+(defun mime-mc-pgp50-encrypt-region (recipients start end &optional id sign)
+ (if (not (fboundp 'mc-pgp50-encrypt-region))
+ (load "mc-pgp5")
+ )
+ (let ((mc-pgp-always-sign (if (eq sign 'maybe)
+ mc-pgp-always-sign
+ 'never))
+ (comment (mime-mc-comment))
+ (mc-pgp50-comment "DUMMY"))
+ (prog1
+ (mc-pgp50-encrypt-region
+ (mc-split "\\([ \t\n]*,[ \t\n]*\\)+" recipients)
+ start end id nil)
+ (if comment
+ (mime-mc-replace-comment-field comment)
+ ))))
+
+
+;;; @ PGP 2.6 functions
+;;;
+
(defun mime-mc-process-region
- (beg end passwd program args parser &optional buffer boundary)
+ (beg end passwd program args parser &optional buffer boundary comment)
+ "Similar to `mc-pgp-process-region', however enclose an processed data
+with BOUNDARY if it is specified and replace the comment field with the
+optional argument COMMENT if it is specified."
(let ((obuf (current-buffer))
(process-connection-type nil)
mybuf result rgn proc)
+ (if comment
+ (setq args (cons "+comment=DUMMY" args))
+ )
(unwind-protect
(progn
(setq mybuf (or buffer (generate-new-buffer " *mailcrypt temp")))
;; Hurm. FIXME; must get better result codes.
(if (stringp result)
(error "%s exited abnormally: '%s'" program result)
+ ;; replace comment string
+ (if comment
+ (mime-mc-replace-comment-field comment)
+ )
(setq rgn (funcall parser result))
;; If the parser found something, migrate it
(if (consp rgn)
(or buffer (null mybuf) (kill-buffer mybuf)))))
(defun mime-mc-pgp-sign-region (start end &optional id unclear boundary)
- ;; (if (not (boundp 'mc-pgp-user-id))
- ;; (load "mc-pgp")
- ;; )
+ (if (not (fboundp 'mc-pgp-generic-parser))
+ (load "mc-pgp")
+ )
(let ((process-environment process-environment)
(buffer (get-buffer-create mc-buffer-name))
passwd args key
(parser (function mc-pgp-generic-parser))
(pgp-path mc-pgp-path)
+ (comment (mime-mc-comment))
)
(setq key (mc-pgp-lookup-key (or id mc-pgp-user-id)))
(setq passwd
(list "+verbose=1" "+language=en"
(format "+clearsig=%s" (if unclear "off" "on"))
"+batchmode" "-u" (cdr key))))
- (if mc-pgp-comment
- (setq args (cons (format "+comment=%s" mc-pgp-comment) args))
- )
(message "Signing as %s ..." (car key))
(if (mime-mc-process-region
- start end passwd pgp-path args parser buffer boundary)
+ start end passwd pgp-path args parser buffer boundary comment)
(progn
(if boundary
(progn
(insert
(format "\
--[[multipart/signed; protocol=\"application/pgp-signature\";
- boundary=\"%s\"; micalg=pgp-md5][7bit]]\n" boundary))
- ))
+ boundary=\"%s\"%s][7bit]]\n"
+ boundary
+ (if mime-mc-omit-micalg
+ ""
+ "; micalg=pgp-md5"
+ )
+ ))))
(message "Signing as %s ... Done." (car key))
t)
nil)))
(defun mime-mc-pgp-encrypt-region (recipients start end &optional id sign)
+ (if (not (fboundp 'mc-pgp-encrypt-region))
+ (load "mc-pgp")
+ )
(let ((mc-pgp-always-sign (if (eq sign 'maybe)
mc-pgp-always-sign
- 'never)))
- (mc-pgp-encrypt-region
- (mc-split "\\([ \t\n]*,[ \t\n]*\\)+" recipients)
- start end id nil)
- ))
+ 'never))
+ (comment (mime-mc-comment))
+ (mc-pgp-comment "DUMMY"))
+ (prog1
+ (mc-pgp-encrypt-region
+ (mc-split "\\([ \t\n]*,[ \t\n]*\\)+" recipients)
+ start end id nil)
+ (if comment
+ (mime-mc-replace-comment-field comment)
+ ))))
+
-
;;; @ end
;;;
projects / elisp / semi.git / blobdiff