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