mime-mc.el

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