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