mime-mc.el

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