mime-mc.el

   1 ;;; mime-mc.el --- Mailcrypt interface for SEMI
   2
   3 ;; Copyright (C) 1996,1997,1998 MORIOKA Tomohiko
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; Keywords: PGP, security, MIME, multimedia, mail, news
   7
   8 ;; This file is part of SEMI (Secure Emacs MIME Interface).
   9
  10 ;; This program is free software; you can redistribute it and/or
  11 ;; modify it under the terms of the GNU General Public License as
  12 ;; published by the Free Software Foundation; either version 2, or (at
  13 ;; your option) any later version.
  14
  15 ;; This program is distributed in the hope that it will be useful, but
  16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, USA.
  24
  25 ;;; Code:
  26
  27 (require 'mailcrypt)
  28 (eval-and-compile (load "mc-pgp"))
  29
  30 (defun mime-mc-pgp-generic-parser (result)
  31   (let ((ret (mc-pgp-generic-parser result)))
  32     (if (consp ret)
  33         (vector (car ret)(cdr ret))
  34       )))
  35
  36 (defun mime-mc-process-region
  37   (beg end passwd program args parser &optional buffer boundary)
  38   (let ((obuf (current-buffer))
  39         (process-connection-type nil)
  40         mybuf result rgn proc)
  41     (unwind-protect
  42         (progn
  43           (setq mybuf (or buffer (generate-new-buffer " *mailcrypt temp")))
  44           (set-buffer mybuf)
  45           (erase-buffer)
  46           (set-buffer obuf)
  47           (buffer-disable-undo mybuf)
  48           (setq proc
  49                 (apply 'start-process "*PGP*" mybuf program args))
  50           (if passwd
  51               (progn
  52                 (process-send-string proc (concat passwd "\n"))
  53                 (or mc-passwd-timeout (mc-deactivate-passwd t))))
  54           (process-send-region proc beg end)
  55           (process-send-eof proc)
  56           (while (eq 'run (process-status proc))
  57             (accept-process-output proc 5))
  58           (setq result (process-exit-status proc))
  59           ;; Hack to force a status_notify() in Emacs 19.29
  60           (delete-process proc)
  61           (set-buffer mybuf)
  62           (goto-char (point-max))
  63           (if (re-search-backward "\nProcess \\*PGP.*\n\\'" nil t)
  64               (delete-region (match-beginning 0) (match-end 0)))
  65           (goto-char (point-min))
  66           ;; CRNL -> NL
  67           (while (search-forward "\r\n" nil t)
  68             (replace-match "\n"))
  69           ;; Hurm.  FIXME; must get better result codes.
  70           (if (stringp result)
  71               (error "%s exited abnormally: '%s'" program result)
  72             (setq rgn (funcall parser result))
  73             ;; If the parser found something, migrate it
  74             (if (consp rgn)
  75                 (progn
  76                   (set-buffer obuf)
  77                   (if boundary
  78                       (save-restriction
  79                         (narrow-to-region beg end)
  80                         (goto-char beg)
  81                         (insert (format "--%s\n" boundary))
  82                         (goto-char (point-max))
  83                         (insert (format "\n--%s
  84 Content-Type: application/pgp-signature
  85 Content-Transfer-Encoding: 7bit
  86
  87 " boundary))
  88                         (insert-buffer-substring mybuf (car rgn) (cdr rgn))
  89                         (goto-char (point-max))
  90                         (insert (format "\n--%s--\n" boundary))
  91                         )
  92                     (delete-region beg end)
  93                     (goto-char beg)
  94                     (insert-buffer-substring mybuf (car rgn) (cdr rgn))
  95                     )
  96                   (set-buffer mybuf)
  97                   (delete-region (car rgn) (cdr rgn)))))
  98           ;; Return nil on failure and exit code on success
  99           (if rgn result))
 100       ;; Cleanup even on nonlocal exit
 101       (if (and proc (eq 'run (process-status proc)))
 102           (interrupt-process proc))
 103       (set-buffer obuf)
 104       (or buffer (null mybuf) (kill-buffer mybuf)))))
 105
 106 (defun mime-mc-pgp-sign-region (start end &optional id unclear boundary)
 107   ;; (if (not (boundp 'mc-pgp-user-id))
 108   ;;     (load "mc-pgp")
 109   ;;   )
 110   (let ((process-environment process-environment)
 111         (buffer (get-buffer-create mc-buffer-name))
 112         passwd args key
 113         (parser (function mc-pgp-generic-parser))
 114         (pgp-path mc-pgp-path)
 115         )
 116     (setq key (mc-pgp-lookup-key (or id mc-pgp-user-id)))
 117     (setq passwd
 118           (mc-activate-passwd
 119            (cdr key)
 120            (format "PGP passphrase for %s (%s): " (car key) (cdr key))))
 121     (setenv "PGPPASSFD" "0")
 122     (setq args
 123           (cons
 124            (if boundary
 125                "-fbast"
 126              "-fast")
 127            (list "+verbose=1" "+language=en"
 128                  (format "+clearsig=%s" (if unclear "off" "on"))
 129                  "+batchmode" "-u" (cdr key))))
 130     (if mc-pgp-comment
 131         (setq args (cons (format "+comment=%s" mc-pgp-comment) args))
 132       )
 133     (message "Signing as %s..." (car key))
 134     (if (mime-mc-process-region
 135          start end passwd pgp-path args parser buffer boundary)
 136         (progn
 137           (if boundary
 138               (progn
 139                 (goto-char (point-min))
 140                 (insert
 141                  (format "\
 142 --[[multipart/signed; protocol=\"application/pgp-signature\";
 143  boundary=\"%s\"; micalg=pgp-md5][7bit]]\n" boundary))
 144                 ))
 145           (message "Signing as %s...done" (car key))
 146           t)
 147       nil)))
 148
 149 (defun mime-mc-pgp-encrypt-region (recipients start end &optional id sign)
 150   (let ((mc-pgp-always-sign (if (eq sign 'maybe)
 151                                 mc-pgp-always-sign
 152                               'never)))
 153     (mc-pgp-encrypt-region
 154      (mc-split "\\([ \t\n]*,[ \t\n]*\\)+" recipients)
 155      start end id nil)
 156     ))
 157
 158
 159 ;;; @ end
 160 ;;;
 161
 162 (provide 'mime-mc)
 163
 164 ;;; mime-mc.el ends here