mime-mc.el

   1 ;;; mime-mc.el --- Mailcrypt interface for SEMI -*- coding: iso-8859-4; -*-
   2
   3 ;; Copyright (C) 1996,1997,1998,1999 MORIOKA Tomohiko
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;;         Katsumi Yamaoka  <yamaoka@jpl.org>
   7 ;; Keywords: PGP, GnuPG, security, MIME, multimedia, mail, news
   8
   9 ;; This file is part of SEMI (Secure Emacs MIME Interface).
  10
  11 ;; This program is free software; you can redistribute it and/or
  12 ;; modify it under the terms of the GNU General Public License as
  13 ;; published by the Free Software Foundation; either version 2, or (at
  14 ;; your option) any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Code:
  27
  28 (require 'alist)
  29 (require 'std11)
  30 (require 'semi-def)
  31 (require 'mime-def)
  32 (require 'mailcrypt)
  33
  34 (eval-when-compile
  35   (load "expect" t)
  36   )
  37
  38 (eval-and-compile
  39   (mapcar
  40    (function (lambda (elem) (apply 'autoload elem)))
  41    '(
  42      (mc-gpg-debug-print        "mc-gpg")
  43
  44      (mc-gpg-encrypt-region     "mc-gpg")
  45      (mc-gpg-fetch-key          "mc-gpg")
  46      (mc-gpg-lookup-key         "mc-gpg")
  47      (mc-gpg-sign-region        "mc-gpg")
  48
  49      (mc-pgp50-encrypt-region   "mc-pgp5")
  50      (mc-pgp50-fetch-key        "mc-pgp5")
  51      (mc-pgp50-lookup-key       "mc-pgp5")
  52      (mc-pgp50-sign-region      "mc-pgp5")
  53
  54      (mc-pgp-encrypt-region     "mc-pgp")
  55      (mc-pgp-fetch-key          "mc-pgp")
  56      (mc-pgp-lookup-key         "mc-pgp")
  57      (mc-pgp-sign-region        "mc-pgp")
  58
  59      (mc-snarf-keys             "mc-toplev")
  60      )))
  61
  62 (defgroup mime-mc nil
  63   "Mailcrypt interface for SEMI."
  64   :prefix "mime-mc-"
  65   :group 'mime)
  66
  67 (defcustom mime-mc-shell-file-name "/bin/sh"
  68   "File name to load inferior shells from.  Bourne shell or its equivalent
  69 \(not tcsh) is needed for \"2>\"."
  70   :group 'mime-mc
  71   :type 'file)
  72
  73 (defcustom mime-mc-shell-command-switch "-c"
  74   "Switch used to have the shell execute its command line argument."
  75   :group 'mime-mc
  76   :type 'string)
  77
  78 (defcustom mime-mc-omit-micalg nil
  79   "Non-nil value means to omit the micalg parameter for multipart/signed.
  80 See draft-yamamoto-openpgp-mime-00.txt (OpenPGP/MIME) for more information."
  81   :group 'mime-mc
  82   :type 'boolean)
  83
  84 (defcustom mime-mc-comment-alist
  85   (let ((product-name (mime-product-name mime-user-interface-product))
  86         (version (mapconcat
  87                   (function number-to-string)
  88                   (mime-product-version mime-user-interface-product)
  89                   "."))
  90         (codename (mime-product-code-name mime-user-interface-product))
  91         string)
  92     (while (string-match "ò" codename)
  93       (setq codename (replace-match "o" t nil codename)))
  94     (while (string-match "þ" codename)
  95       (setq codename (replace-match "u" t nil codename)))
  96     (setq string (format "Processed by Mailcrypt %s under %s %s%s"
  97                          mc-version product-name version
  98                          (if (string-match "^[ -~]+$" codename)
  99                              (concat " - \"" codename "\"")
 100                            "")))
 101     (list (cons 'gpg string)
 102           (cons 'pgp50 string)
 103           (cons 'pgp string)))
 104   "Alist of the schemes and strings of the comment field to appear in ASCII
 105 armor output."
 106   :group 'mime-mc
 107   :type '(repeat (cons :format "%v"
 108                        (choice (choice-item :tag "GnuPG" gpg)
 109                                (choice-item :tag "PGP 5.0i" pgp50)
 110                                (choice-item :tag "PGP 2.6" pgp))
 111                        (string :tag "Comment"))))
 112
 113 (defvar mime-mc-symbol-format-alist
 114   '((comment            . "mc-%s-comment")
 115     (fetch-key          . "mc-%s-fetch-key")
 116     (insert-key         . "mc-%s-insert-public-key")
 117     (mime-encrypt       . "mime-mc-%s-encrypt-region")
 118     (mime-sign          . "mime-mc-%s-sign-region")
 119     (scheme             . "mc-scheme-%s")
 120     (traditional-sign   . "mc-%s-sign-region")
 121     )
 122   "Alist of service names and corresponding format strings.")
 123
 124 (defmacro mime-mc-symbol (service)
 125   (` (intern
 126       (format (cdr (assq (, service) mime-mc-symbol-format-alist))
 127               pgp-version))))
 128
 129 (defmacro mime-mc-comment ()
 130   "Return a string of the comment field."
 131   '(or (cdr (assq pgp-version mime-mc-comment-alist))
 132        (symbol-value (mime-mc-symbol 'comment))
 133        ))
 134
 135
 136 ;;; @ Internal variable
 137 ;;;
 138
 139 (defvar mime-mc-micalg-alist nil
 140   "Alist of KeyID and the value of message integrity check algorithm.")
 141
 142
 143 ;;; @ External variables (for avoid byte compile warnings)
 144 ;;;
 145
 146 (defvar mc-gpg-extra-args)
 147 (defvar mc-gpg-path)
 148 (defvar mc-gpg-user-id)
 149 (defvar mc-pgp50-pgps-path)
 150 (defvar mc-pgp50-user-id)
 151 (defvar mc-pgp-path)
 152 (defvar mc-pgp-user-id)
 153
 154
 155 ;;; @ Generic functions
 156 ;;;
 157
 158 (defun mime-mc-setversion (&optional version)
 159   "Select `pgp-version' and `mc-default-scheme' if possible.
 160 VERSION should be a string or a symbol."
 161   (interactive)
 162   (let ((oldversion pgp-version)
 163         (table '(("GnuPG" . gpg) ("PGP 5.0i" . pgp50) ("PGP 2.6" . pgp)
 164                  ("gnupg" . gpg) ("gpg" . gpg) ("pgp5" . pgp50)
 165                  ("pgp50" . pgp50) ("pgp2" . pgp) ("pgp" . pgp)
 166                  ("5.0" . pgp50) ("2.6" . pgp))))
 167     (if (interactive-p)
 168         (setq version (completing-read
 169                        (format "Select PGP version (currently %s): "
 170                                (car (rassoc oldversion table)))
 171                        table nil t)
 172               pgp-version (or (cdr (assoc version table))
 173                               oldversion))
 174       (if (stringp version)
 175           (setq pgp-version (or (cdr (assoc version table)) oldversion))
 176         (if (memq version '(gpg pgp50 pgp))
 177             (setq pgp-version version)
 178           )))
 179     (condition-case nil
 180         (mc-setversion
 181          (cdr (assq pgp-version
 182                     '((gpg . "gpg") (pgp50 . "5.0") (pgp . "2.6"))))
 183          )
 184       (error nil))
 185     (message "PGP version set to %s." (car (rassq pgp-version table)))
 186     ))
 187
 188 (defun mime-mc-replace-comment-field (comment &optional start end)
 189   (let ((regexp (if (eq 'pgp pgp-version)
 190                     "-----BEGIN PGP.*-----\nVersion:"
 191                   "^-----BEGIN PGP.*\n")))
 192     (save-excursion
 193       (save-restriction
 194         (narrow-to-region (or start (point-min)) (or end (point-max)))
 195         (goto-char (point-min))
 196         (while (re-search-forward regexp nil t)
 197           (forward-line 1)
 198           (save-restriction
 199             (narrow-to-region (point)
 200                               (if (search-forward "\n\n" nil t)
 201                                   (point)
 202                                 (point-max)))
 203             (goto-char (point-min))
 204             (if (re-search-forward "^Comment:.*$" nil t)
 205                 (replace-match (concat "Comment: " comment))
 206               )))
 207         (point-max)))))
 208
 209 (defun mime-mc-verify ()
 210   "Verify a message in the current buffer. Exact behavior depends on
 211 current major mode."
 212   (let ((mc-default-scheme (mime-mc-symbol 'scheme)))
 213     (mc-verify)
 214     ))
 215
 216 (defun mime-mc-decrypt ()
 217   "Decrypt a message in the current buffer. Exact behavior depends on
 218 current major mode."
 219   (let ((mc-default-scheme (mime-mc-symbol 'scheme)))
 220     (if (eq 'mc-scheme-gpg mc-default-scheme)
 221         (condition-case nil
 222             (mc-decrypt)
 223           (error
 224            (let ((ofunc (symbol-function 'mc-gpg-decrypt-region)))
 225              (message "\"mc-gpg.el\" may be broken.  Trying to fix it...")
 226              (sit-for 1)
 227              (defun mc-gpg-decrypt-region (start end &optional id)
 228                (funcall ofunc start end (or id mc-gpg-user-id)))
 229              (unwind-protect
 230                  (mc-decrypt)
 231                (fset 'mc-gpg-decrypt-region ofunc)))))
 232       (mc-decrypt)
 233       )))
 234
 235 (defun mime-mc-fetch-key (&optional id)
 236   "Attempt to fetch a key for addition to PGP or GnuPG keyring.
 237 Interactively, prompt for string matching key to fetch.
 238
 239 Non-interactively, ID must be a pair.  The CAR must be a bare Email
 240 address and the CDR a keyID (with \"0x\" prefix).  Either, but not
 241 both, may be nil.
 242
 243 Return t if we think we were successful; nil otherwise.  Note that nil
 244 is not necessarily an error, since we may have merely fired off an Email
 245 request for the key."
 246   (funcall (mime-mc-symbol 'fetch-key) id)
 247   )
 248
 249 (defun mime-mc-snarf-keys ()
 250   "Add all public keys in the buffer to your keyring."
 251   (let ((mc-default-scheme (mime-mc-symbol 'scheme)))
 252     (mc-snarf-keys)
 253     ))
 254
 255 (defun mime-mc-sign-region (start end &optional id unclear boundary)
 256   (funcall (mime-mc-symbol 'mime-sign) start end id unclear boundary)
 257   )
 258
 259 (defun mime-mc-traditional-sign-region (start end &optional id unclear)
 260   (funcall (mime-mc-symbol 'traditional-sign) start end id unclear)
 261   )
 262
 263 (defun mime-mc-encrypt-region (recipients start end &optional id sign)
 264   (funcall (mime-mc-symbol 'mime-encrypt) recipients start end id sign)
 265   )
 266
 267 (defun mime-mc-insert-public-key (&optional userid)
 268   "Insert your public key at point."
 269   (or (fboundp (mime-mc-symbol 'insert-key))
 270       (load (concat "mc-" (cdr (assq pgp-version '((gpg . "gpg")
 271                                                    (pgp50 . "pgp5")
 272                                                    (pgp . "pgp")))))))
 273   (let ((mc-comment (mime-mc-symbol 'comment))
 274         (comment (mime-mc-comment))
 275         (scheme (mime-mc-symbol 'scheme)))
 276     (eval (` (let (((, mc-comment) (if (, comment) "DUMMY")))
 277                (mc-insert-public-key (, userid) (quote (, scheme)))
 278                )))
 279     (if comment
 280         (mime-mc-replace-comment-field comment)
 281       )))
 282
 283
 284 ;;; @ GnuPG functions
 285 ;;;
 286
 287 (defun mime-mc-gpg-process-region
 288   (beg end passwd program args parser bufferdummy &optional boundary comment)
 289   "Similar to `mc-gpg-process-region', however enclose an processed data
 290 with BOUNDARY if it is specified and replace the comment field with the
 291 optional argument COMMENT if it is specified."
 292   (let ((obuf (current-buffer))
 293         (process-connection-type nil)
 294         (shell-file-name mime-mc-shell-file-name)
 295         (shell-command-switch mime-mc-shell-command-switch)
 296         ; other local vars
 297         mybuf
 298         stderr-tempfilename stderr-buf
 299         status-tempfilename status-buf
 300         proc rc status parser-result
 301         )
 302     (mc-gpg-debug-print (format
 303        "(mime-mc-gpg-process-region beg=%s end=%s passwd=%s program=%s args=%s parser=%s bufferdummy=%s boundary=%s comment=%s)"
 304        beg end passwd program args parser bufferdummy boundary comment))
 305     (setq stderr-tempfilename
 306           (make-temp-name (expand-file-name "mailcrypt-gpg-stderr-"
 307                                             mc-temp-directory)))
 308     (setq status-tempfilename
 309           (make-temp-name (expand-file-name "mailcrypt-gpg-status-"
 310                                             mc-temp-directory)))
 311     (unwind-protect
 312         (catch ;; Returns non-nil if success, otherwise nil with error message.
 313             'mime-mc-gpg-process-region-done
 314
 315           ;; get output places ready
 316           (setq mybuf (get-buffer-create " *mailcrypt stdout temp"))
 317           (set-buffer mybuf)
 318           (erase-buffer)
 319           (set-buffer obuf)
 320           (buffer-disable-undo mybuf)
 321
 322           (if passwd
 323               (setq args (append '("--passphrase-fd" "0") args)))
 324           (setq args (append (list (concat "2>" stderr-tempfilename)) args))
 325           (setq args (append (list (concat "3>" status-tempfilename)) args))
 326           (setq args (append '("--status-fd" "3") args))
 327
 328           (if comment
 329               (setq args (append '("--comment" "DUMMY") args))
 330             )
 331
 332           (if mc-gpg-extra-args
 333               (setq args (append mc-gpg-extra-args args)))
 334
 335           (mc-gpg-debug-print (format "prog is %s, args are %s"
 336                                       program
 337                                       (mapconcat '(lambda (x)
 338                                                     (format "'%s'" x))
 339                                                  args " ")))
 340
 341           (setq proc
 342                 (apply 'start-process-shell-command "*GPG*" mybuf
 343                        program args))
 344           ;; send in passwd if necessary
 345           (if passwd
 346               (progn
 347                 (process-send-string proc (concat passwd "\n"))
 348                 (or mc-passwd-timeout (mc-deactivate-passwd t))))
 349           ;; send in the region
 350           (process-send-region proc beg end)
 351           ;; finish it off
 352           (process-send-eof proc)
 353           ;; wait for it to finish
 354           (while (eq 'run (process-status proc))
 355             (accept-process-output proc 5))
 356           ;; remember result codes
 357           (setq status (process-status proc))
 358           (setq rc (process-exit-status proc))
 359           (mc-gpg-debug-print (format "prog finished, rc=%s" rc))
 360
 361           ;; Hack to force a status_notify() in Emacs 19.29
 362           (delete-process proc)
 363
 364           ;; remove the annoying "yes your process has finished" message
 365           (set-buffer mybuf)
 366           (goto-char (point-max))
 367           (if (re-search-backward "\nProcess \\*GPG.*\n\\'" nil t)
 368               (delete-region (match-beginning 0) (match-end 0)))
 369           (goto-char (point-min))
 370           ;; CRNL -> NL
 371           (while (search-forward "\r\n" nil t)
 372             (replace-match "\n"))
 373
 374           ;; ponder process death: signal, not just rc!=0
 375           (if (or (eq 'stop status) (eq 'signal status))
 376               ;; process died
 377               (progn
 378                 (message
 379                  "%s exited abnormally: '%s'" program rc) ;; is rc a string?
 380                 (throw 'mime-mc-gpg-process-region-done nil)
 381                 ))
 382
 383           (if (= 127 rc)
 384               (progn
 385                 (message
 386                  "%s could not be found" program) ;; at least on my system
 387                 (throw 'mime-mc-gpg-process-region-done nil)
 388                 ))
 389
 390           ;; fill stderr buf
 391           (setq stderr-buf (get-buffer-create " *mailcrypt stderr temp"))
 392           (buffer-disable-undo stderr-buf)
 393           (set-buffer stderr-buf)
 394           (erase-buffer)
 395           (insert-file-contents stderr-tempfilename)
 396
 397           ;; fill status buf
 398           (setq status-buf (get-buffer-create " *mailcrypt status temp"))
 399           (buffer-disable-undo status-buf)
 400           (set-buffer status-buf)
 401           (erase-buffer)
 402           (insert-file-contents status-tempfilename)
 403
 404           ;; replace comment string
 405           (set-buffer mybuf)
 406           (if comment
 407               (mime-mc-replace-comment-field comment)
 408             )
 409
 410           ;; feed the parser
 411           (condition-case err
 412               (setq parser-result
 413                     (if (boundp 'mc-gpg-handle-pre095)
 414                         (funcall parser mybuf stderr-buf status-buf rc)
 415                       (funcall parser mybuf stderr-buf status-buf rc nil))
 416                     )
 417             (error
 418              (message "%s" err)
 419              (throw 'mime-mc-gpg-process-region-done nil)
 420              ))
 421           (mc-gpg-debug-print (format " parser returned %s" parser-result))
 422
 423           ;; what did the parser tell us?
 424           (if (car parser-result)
 425               ;; yes, replace region
 426               (progn
 427                 (set-buffer obuf)
 428                 (if boundary
 429                     (save-restriction
 430                       (narrow-to-region beg end)
 431                       (goto-char beg)
 432                       (insert (format "--%s\n" boundary))
 433                       (goto-char (point-max))
 434                       (insert (format "\n--%s
 435 Content-Type: application/pgp-signature
 436 Content-Transfer-Encoding: 7bit
 437
 438 " boundary))
 439                       (insert-buffer-substring mybuf)
 440                       (goto-char (point-max))
 441                       (insert (format "\n--%s--\n" boundary))
 442                       )
 443                   (delete-region beg end)
 444                   (goto-char beg)
 445                   (insert-buffer-substring mybuf)
 446                   )))
 447
 448           ;; return result
 449           (cdr parser-result)
 450           )
 451       ;; cleanup forms
 452       (if (and proc (eq 'run (process-status proc)))
 453           ;; it is still running. kill it.
 454           (interrupt-process proc))
 455       (set-buffer obuf)
 456       (delete-file stderr-tempfilename)
 457       (delete-file status-tempfilename)
 458       ;; kill off temporary buffers (which would be useful for debugging)
 459       (if t ;; nil for easier debugging
 460           (progn
 461             (if (get-buffer " *mailcrypt stdout temp")
 462                 (kill-buffer " *mailcrypt stdout temp"))
 463             (if (get-buffer " *mailcrypt stderr temp")
 464                 (kill-buffer " *mailcrypt stderr temp"))
 465             (if (get-buffer " *mailcrypt status temp")
 466                 (kill-buffer " *mailcrypt status temp"))
 467             ))
 468       )))
 469
 470 (defun mime-mc-gpg-sign-region (start end &optional id unclear boundary)
 471   (if (not (fboundp 'mc-gpg-insert-parser))
 472       (load "mc-gpg")
 473     )
 474   (let ((buffer (get-buffer-create mc-buffer-name))
 475         passwd args key
 476         (parser (function mc-gpg-insert-parser))
 477         (pgp-path mc-gpg-path)
 478         micalg
 479         (comment (mime-mc-comment))
 480         )
 481     (setq key (mc-gpg-lookup-key (or id mc-gpg-user-id) 'sign))
 482     (setq passwd
 483           (mc-activate-passwd
 484            (car key)
 485            (format "GPG passphrase for %s (%s): " (car key) (cdr key))))
 486     (setq args (cons
 487                 (if boundary
 488                     "--detach-sign"
 489                   (if unclear
 490                       "--sign"
 491                     "--clearsign")
 492                   )
 493                 (list "--armor" "--batch" "--verbose"
 494                       "--local-user" (cdr key))
 495                 ))
 496     (if boundary
 497         (progn
 498           (if (string-match "^pgp-" boundary)
 499               (setq boundary
 500                     (concat "gpg-" (substring boundary (match-end 0))))
 501             )
 502           (if (not (or mime-mc-omit-micalg
 503                        (setq micalg
 504                              (cdr (assoc (cdr key) mime-mc-micalg-alist)))
 505                        ))
 506               (with-temp-buffer
 507                 (message "Detecting the value of `micalg'...")
 508                 (insert "\n")
 509                 (if (let ((mc-passwd-timeout 60)) ;; Don't deactivate passwd.
 510                       (mime-mc-gpg-process-region
 511                        1 2 passwd pgp-path
 512                        (list "--clearsign" "--armor" "--batch"
 513                              "--verbose" "--local-user" (cdr key))
 514                        parser buffer nil)
 515                       )
 516                     (progn
 517                       (std11-narrow-to-header)
 518                       (setq micalg
 519                             (downcase (or (std11-fetch-field "Hash") "md5"))
 520                             )
 521                       (set-alist 'mime-mc-micalg-alist (cdr key) micalg)
 522                       )
 523                   (or mc-passwd-timeout (mc-deactivate-passwd t))
 524                   ))
 525             )))
 526     (if (or mime-mc-omit-micalg micalg)
 527         (let ((cur (current-buffer))
 528               result)
 529           (message "Signing as %s ..." (car key))
 530           (if (with-temp-buffer
 531                 (insert-buffer-substring cur start end)
 532                 (goto-char (point-min))
 533                 (while (progn
 534                          (end-of-line)
 535                          (not (eobp)))
 536                   (insert "\r")
 537                   (forward-line 1))
 538                 (prog1
 539                     (mime-mc-gpg-process-region (point-min) (point-max)
 540                                                 passwd pgp-path args parser
 541                                                 buffer boundary comment)
 542                   (goto-char (point-min))
 543                   (while (search-forward "\r\n" nil t)
 544                     (forward-char -2)
 545                     (delete-char 1))
 546                   (setq result (buffer-string))))
 547               (progn
 548                 (delete-region (goto-char start) end)
 549                 (insert result)
 550                 (if boundary
 551                     (progn
 552                       (goto-char (point-min))
 553                       (insert
 554                        (format "\
 555 --[[multipart/signed; protocol=\"application/pgp-signature\";
 556  boundary=\"%s\"%s][7bit]]\n"
 557                                boundary
 558                                (if mime-mc-omit-micalg
 559                                    ""
 560                                  (concat "; micalg=pgp-" micalg)
 561                                  )
 562                                ))))
 563                 (message "Signing as %s ... Done." (car key))
 564                 t)
 565             nil)
 566           )
 567       nil)))
 568
 569 (defun mime-mc-gpg-encrypt-region (recipients start end &optional id sign)
 570   (if (not (fboundp 'mc-gpg-encrypt-region))
 571       (load "mc-gpg")
 572     )
 573   (let* ((mc-pgp-always-sign (if (eq sign 'maybe)
 574                                  mc-pgp-always-sign
 575                                'never))
 576          (comment (mime-mc-comment))
 577          (mc-gpg-comment (if comment "DUMMY")))
 578     (prog1
 579         (mc-gpg-encrypt-region
 580          (mc-split "\\([ \t\n]*,[ \t\n]*\\)+" recipients)
 581          start end id nil)
 582       (if comment
 583           (mime-mc-replace-comment-field comment)
 584         ))))
 585
 586
 587 ;;; @ PGP 5.0i functions
 588 ;;;
 589
 590 (defun mime-mc-pgp50-process-region
 591   (beg end passwd program args parser &optional buffer boundary comment)
 592   "Similar to `mc-pgp50-process-region', however enclose an processed data
 593 with BOUNDARY if it is specified and replace the comment field with the
 594 optional argument COMMENT if it is specified."
 595   (let ((obuf (current-buffer))
 596         (process-connection-type nil)
 597         (shell-file-name mime-mc-shell-file-name)
 598         (shell-command-switch mime-mc-shell-command-switch)
 599         mybuf result rgn proc results)
 600     (if comment
 601         (setq args (cons "+comment=DUMMY" args))
 602       )
 603     (unwind-protect
 604         (catch ;; Returns non-nil if success, otherwise nil with error message.
 605             'mime-mc-pgp50-process-region-done
 606
 607           (setq mybuf (or buffer (generate-new-buffer " *mailcrypt temp")))
 608           (set-buffer mybuf)
 609           (erase-buffer)
 610           (set-buffer obuf)
 611           (buffer-disable-undo mybuf)
 612           (setq proc
 613                 (apply 'start-process-shell-command "*PGP*" mybuf program
 614                        "2>&1" args))
 615
 616           ;; Now hand the process to the parser, which returns the exit
 617           ;; status of the dead process and the limits of the region
 618           ;; containing the PGP results.
 619           (condition-case err
 620               (setq results (funcall parser proc obuf beg end mybuf passwd))
 621             (error
 622              (message "%s" err)
 623              (throw 'mime-mc-pgp50-process-region-done nil)
 624              ))
 625           (setq result  (car results))
 626           (setq rgn     (cadr results))
 627
 628           ;; Hack to force a status_notify() in Emacs 19.29
 629           (set-buffer mybuf)
 630
 631           ;; replace comment string
 632           (if (and comment (consp rgn))
 633               (setcdr rgn (mime-mc-replace-comment-field
 634                            comment (car rgn) (cdr rgn)))
 635             )
 636
 637           ;; Hurm.  FIXME; must get better result codes.
 638           (if (stringp result)
 639               (mc-message result))
 640
 641             ;; If the parser found something, migrate it to the old
 642             ;; buffer.  In particular, the parser's job is to return
 643             ;; a cons of the form ( beg . end ) delimited the result
 644             ;; of PGP in the new buffer.
 645           (if (consp rgn)
 646               (progn
 647                 (set-buffer obuf)
 648                 (if boundary
 649                     (save-restriction
 650                       (narrow-to-region beg end)
 651                       (goto-char beg)
 652                       (insert (format "--%s\n" boundary))
 653                       (goto-char (point-max))
 654                       (insert (format "\n--%s
 655 Content-Type: application/pgp-signature
 656 Content-Transfer-Encoding: 7bit
 657
 658 " boundary))
 659                       (insert-buffer-substring mybuf (car rgn) (cdr rgn))
 660                       (goto-char (point-max))
 661                       (insert (format "\n--%s--\n" boundary))
 662                       )
 663                   (delete-region beg end)
 664                   (goto-char beg)
 665                   (insert-buffer-substring mybuf (car rgn) (cdr rgn))
 666                   )
 667                 (set-buffer mybuf)
 668                 (delete-region (car rgn) (cdr rgn))))
 669
 670           ;; Return nil on failure and exit code on success
 671           (if rgn result nil))
 672
 673       ;; Cleanup even on nonlocal exit
 674       (if (and proc (eq 'run (process-status proc)))
 675           (interrupt-process proc))
 676       (set-buffer obuf)
 677       (or buffer (null mybuf) (kill-buffer mybuf))
 678       rgn)))
 679
 680 (defun mime-mc-pgp50-sign-parser (proc oldbuf start end newbuf passwd)
 681   ;; This function is a copy of `mc-pgp50-sign-parser', however it is
 682   ;; modified for parsing a detached sign.
 683   (let (result results rgn)
 684     ;; (setenv "PGPPASSFD" "0")
 685     (set-buffer newbuf)
 686     (goto-char (point-max))
 687     (progn
 688       (unwind-protect
 689           (with-expect proc
 690             (message "Sending passphrase...")
 691             (expect-send (concat passwd "\n"))
 692             (or mc-passwd-timeout (mc-deactivate-passwd t))
 693             (expect "No files specified.  Using stdin."
 694               (message "Passphrase sent.  Signing...")
 695               (set-buffer oldbuf)
 696               (process-send-region proc start end)
 697               (set-buffer newbuf)
 698               (process-send-eof proc)
 699
 700               ;; Test output of the program, looking for
 701               ;; errors.
 702               (expect-cond
 703
 704                ;; OPTION 1:  Great!  The data is now signed!
 705                ("-----END PGP SIGNATURE-----"
 706
 707                 ;; Catch the exit status.
 708                 (setq result (process-exit-status proc))
 709                 (delete-process proc)
 710                 (message "Signing complete.")
 711
 712                 ;; Delete everything preceding the signed data.
 713                 (goto-char (point-max))
 714                 (re-search-backward
 715                  ;; "-----BEGIN PGP SIGNED MESSAGE-----" nil t)
 716                  "-----BEGIN PGP SIGNATURE-----" nil t)
 717                 (delete-region (point-min) (match-beginning 0))
 718                 (setq rgn (point-min))
 719
 720                 ;; Convert out CR/NL -> NL
 721                 (goto-char (point-min))
 722                 (while (search-forward "\r\n" nil t)
 723                   (replace-match "\n"))
 724
 725                 ;; Delete everything after the signature.
 726                 (goto-char (point-min))
 727                 (re-search-forward
 728                  "-----END PGP SIGNATURE-----\n" nil t)
 729                 (delete-region (match-end 0) (point-max))
 730
 731                 ;; Return the exit status, with the region
 732                 ;; limits!
 733                 (setq rgn (cons rgn (point-max)))
 734                 (setq results (list result rgn)))
 735
 736
 737                ;; OPTION 1.a:  The data is now signed, but is 8bit data.
 738                ("-----END PGP MESSAGE-----"
 739
 740                 ;; Catch the exit status.
 741                 (setq result (process-exit-status proc))
 742                 (delete-process proc)
 743                 (message "Signing complete.")
 744
 745                 ;; Delete everything preceding the signed data.
 746                 (goto-char (point-max))
 747                 (re-search-backward
 748                  "-----BEGIN PGP MESSAGE-----" nil t)
 749                 (delete-region (point-min) (match-beginning 0))
 750                 (setq rgn (point-min))
 751
 752                 ;; Convert out CR/NL -> NL
 753                 (goto-char (point-min))
 754                 (while (search-forward "\r\n" nil t)
 755                   (replace-match "\n"))
 756
 757                 ;; Delete everything after the signature.
 758                 (goto-char (point-min))
 759                 (re-search-forward
 760                  "-----END PGP MESSAGE-----\n" nil t)
 761                 (delete-region (match-end 0) (point-max))
 762
 763                 ;; Return the exit status, with the region
 764                 ;; limits!
 765                 (setq rgn (cons rgn (point-max)))
 766                 (setq results (list result rgn)))
 767
 768
 769                ;; OPTION 2:  Awww...bad passphrase!
 770                ("Enter pass phrase:"
 771                 (mc-deactivate-passwd t)
 772                 (interrupt-process proc)
 773                 (delete-process proc)
 774
 775                 ;; Return the bad news.
 776                 (setq results '("Incorrect passphrase" nil)))
 777
 778                ;; OPTION 3:  The program exits.
 779                (exit
 780                 (setq results (list
 781                                (process-exit-status proc) nil)))))))
 782       results)))
 783
 784 (defun mime-mc-pgp50-sign-region (start end &optional id unclear boundary)
 785   (if (not (fboundp 'mc-pgp50-sign-parser))
 786       (load "mc-pgp5")
 787     )
 788   (let ((process-environment process-environment)
 789         (buffer (get-buffer-create mc-buffer-name))
 790         passwd args key
 791         (parser (if boundary
 792                     (function mime-mc-pgp50-sign-parser)
 793                   (function mc-pgp50-sign-parser)))
 794         (pgp-path mc-pgp50-pgps-path)
 795         micalg
 796         (comment (mime-mc-comment))
 797         )
 798     (setq key (mc-pgp50-lookup-key (or id mc-pgp50-user-id)))
 799     (setq passwd
 800           (mc-activate-passwd
 801            (cdr key)
 802            (format "PGP passphrase for %s (%s): " (car key) (cdr key))))
 803     (setenv "PGPPASSFD" "0")
 804     (setq args (if boundary
 805                    (list "-fbat" "+verbose=1" "+language=us" "+batchmode"
 806                          "-u" (cdr key))
 807                  (list "-fat" "+verbose=1" "+language=us"
 808                        (format "+clearsig=%s" (if unclear "off" "on"))
 809                        "+batchmode" "-u" (cdr key))
 810                  ))
 811     (if (and boundary
 812              (not (or mime-mc-omit-micalg
 813                       (setq micalg
 814                             (cdr (assoc (cdr key) mime-mc-micalg-alist)))
 815                       )))
 816         (with-temp-buffer
 817           (message "Detecting the value of `micalg'...")
 818           (insert "\n")
 819           (if (let ((mc-passwd-timeout 60)) ;; Don't deactivate passwd.
 820                 (mime-mc-pgp50-process-region
 821                  1 2 passwd pgp-path
 822                  (list "-fat" "+verbose=1" "+language=us" "+clearsig=on"
 823                        "+batchmode" "-u" (cdr key))
 824                  (function mc-pgp50-sign-parser) buffer nil)
 825                 )
 826               (progn
 827                 (std11-narrow-to-header)
 828                 (setq micalg (downcase (or (std11-fetch-field "Hash") "md5")))
 829                 (set-alist 'mime-mc-micalg-alist (cdr key) micalg)
 830                 )
 831             (or mc-passwd-timeout (mc-deactivate-passwd t))
 832             ))
 833       )
 834     (if (or mime-mc-omit-micalg micalg)
 835         (progn
 836           (message "Signing as %s ..." (car key))
 837           (if (mime-mc-pgp50-process-region
 838                start end passwd pgp-path args parser buffer boundary comment)
 839               (progn
 840                 (if boundary
 841                     (progn
 842                       (goto-char (point-min))
 843                       (insert
 844                        (format "\
 845 --[[multipart/signed; protocol=\"application/pgp-signature\";
 846  boundary=\"%s\"%s][7bit]]\n"
 847                                boundary
 848                                (if mime-mc-omit-micalg
 849                                    ""
 850                                  (concat "; micalg=pgp-" micalg)
 851                                  )
 852                                ))))
 853                 (message "Signing as %s ... Done." (car key))
 854                 t)
 855             nil)
 856           )
 857       nil)))
 858
 859 (defun mime-mc-pgp50-encrypt-region (recipients start end &optional id sign)
 860   (if (not (fboundp 'mc-pgp50-encrypt-region))
 861       (load "mc-pgp5")
 862     )
 863   (let ((mc-pgp-always-sign (if (eq sign 'maybe)
 864                                 mc-pgp-always-sign
 865                               'never))
 866         (comment (mime-mc-comment))
 867         (mc-pgp50-comment "DUMMY"))
 868     (prog1
 869         (mc-pgp50-encrypt-region
 870          (mc-split "\\([ \t\n]*,[ \t\n]*\\)+" recipients)
 871          start end id nil)
 872       (if comment
 873           (mime-mc-replace-comment-field comment)
 874         ))))
 875
 876
 877 ;;; @ PGP 2.6 functions
 878 ;;;
 879
 880 (defun mime-mc-process-region
 881   (beg end passwd program args parser &optional buffer boundary comment)
 882   "Similar to `mc-pgp-process-region', however enclose an processed data
 883 with BOUNDARY if it is specified and replace the comment field with the
 884 optional argument COMMENT if it is specified."
 885   (let ((obuf (current-buffer))
 886         (process-connection-type nil)
 887         mybuf result rgn proc)
 888     (if comment
 889         (setq args (cons "+comment=DUMMY" args))
 890       )
 891     (unwind-protect
 892         (progn
 893           (setq mybuf (or buffer (generate-new-buffer " *mailcrypt temp")))
 894           (set-buffer mybuf)
 895           (erase-buffer)
 896           (set-buffer obuf)
 897           (buffer-disable-undo mybuf)
 898           (setq proc
 899                 (apply 'start-process "*PGP*" mybuf program args))
 900           (if passwd
 901               (progn
 902                 (process-send-string proc (concat passwd "\n"))
 903                 (or mc-passwd-timeout (mc-deactivate-passwd t))))
 904           (process-send-region proc beg end)
 905           (process-send-eof proc)
 906           (while (eq 'run (process-status proc))
 907             (accept-process-output proc 5))
 908           (setq result (process-exit-status proc))
 909           ;; Hack to force a status_notify() in Emacs 19.29
 910           (delete-process proc)
 911           (set-buffer mybuf)
 912           (goto-char (point-max))
 913           (if (re-search-backward "\nProcess \\*PGP.*\n\\'" nil t)
 914               (delete-region (match-beginning 0) (match-end 0)))
 915           (goto-char (point-min))
 916           ;; CRNL -> NL
 917           (while (search-forward "\r\n" nil t)
 918             (replace-match "\n"))
 919           ;; Hurm.  FIXME; must get better result codes.
 920           (if (stringp result)
 921               (error "%s exited abnormally: '%s'" program result)
 922             ;; replace comment string
 923             (if comment
 924                 (mime-mc-replace-comment-field comment)
 925               )
 926             (setq rgn (funcall parser result))
 927             ;; If the parser found something, migrate it
 928             (if (consp rgn)
 929                 (progn
 930                   (set-buffer obuf)
 931                   (if boundary
 932                       (save-restriction
 933                         (narrow-to-region beg end)
 934                         (goto-char beg)
 935                         (insert (format "--%s\n" boundary))
 936                         (goto-char (point-max))
 937                         (insert (format "\n--%s
 938 Content-Type: application/pgp-signature
 939 Content-Transfer-Encoding: 7bit
 940
 941 " boundary))
 942                         (insert-buffer-substring mybuf (car rgn) (cdr rgn))
 943                         (goto-char (point-max))
 944                         (insert (format "\n--%s--\n" boundary))
 945                         )
 946                     (delete-region beg end)
 947                     (goto-char beg)
 948                     (insert-buffer-substring mybuf (car rgn) (cdr rgn))
 949                     )
 950                   (set-buffer mybuf)
 951                   (delete-region (car rgn) (cdr rgn)))))
 952           ;; Return nil on failure and exit code on success
 953           (if rgn result))
 954       ;; Cleanup even on nonlocal exit
 955       (if (and proc (eq 'run (process-status proc)))
 956           (interrupt-process proc))
 957       (set-buffer obuf)
 958       (or buffer (null mybuf) (kill-buffer mybuf)))))
 959
 960 (defun mime-mc-pgp-sign-region (start end &optional id unclear boundary)
 961   (if (not (fboundp 'mc-pgp-generic-parser))
 962       (load "mc-pgp")
 963     )
 964   (let ((process-environment process-environment)
 965         (buffer (get-buffer-create mc-buffer-name))
 966         passwd args key
 967         (parser (function mc-pgp-generic-parser))
 968         (pgp-path mc-pgp-path)
 969         (comment (mime-mc-comment))
 970         )
 971     (setq key (mc-pgp-lookup-key (or id mc-pgp-user-id)))
 972     (setq passwd
 973           (mc-activate-passwd
 974            (cdr key)
 975            (format "PGP passphrase for %s (%s): " (car key) (cdr key))))
 976     (setenv "PGPPASSFD" "0")
 977     (setq args
 978           (cons
 979            (if boundary
 980                "-fbast"
 981              "-fast")
 982            (list "+verbose=1" "+language=en"
 983                  (format "+clearsig=%s" (if unclear "off" "on"))
 984                  "+batchmode" "-u" (cdr key))))
 985     (message "Signing as %s ..." (car key))
 986     (if (mime-mc-process-region
 987          start end passwd pgp-path args parser buffer boundary comment)
 988         (progn
 989           (if boundary
 990               (progn
 991                 (goto-char (point-min))
 992                 (insert
 993                  (format "\
 994 --[[multipart/signed; protocol=\"application/pgp-signature\";
 995  boundary=\"%s\"%s][7bit]]\n"
 996                          boundary
 997                          (if mime-mc-omit-micalg
 998                              ""
 999                            "; micalg=pgp-md5"
1000                            )
1001                          ))))
1002           (message "Signing as %s ... Done." (car key))
1003           t)
1004       nil)))
1005
1006 (defun mime-mc-pgp-encrypt-region (recipients start end &optional id sign)
1007   (if (not (fboundp 'mc-pgp-encrypt-region))
1008       (load "mc-pgp")
1009     )
1010   (let ((mc-pgp-always-sign (if (eq sign 'maybe)
1011                                 mc-pgp-always-sign
1012                               'never))
1013         (comment (mime-mc-comment))
1014         (mc-pgp-comment "DUMMY"))
1015     (prog1
1016         (mc-pgp-encrypt-region
1017          (mc-split "\\([ \t\n]*,[ \t\n]*\\)+" recipients)
1018          start end id nil)
1019       (if comment
1020           (mime-mc-replace-comment-field comment)
1021         ))))
1022
1023
1024 ;;; @ end
1025 ;;;
1026
1027 (provide 'mime-mc)
1028
1029 ;;; mime-mc.el ends here