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