tm-edit-mc.el

   1 ;;; tm-edit-mc.el --- Mailcrypt interface for tm-edit
   2
   3 ;; Copyright (C) 1996 MORIOKA Tomohiko
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; Version: $Id: tm-edit-mc.el,v 1.1 1996/11/16 07:47:47 morioka Exp $
   7 ;; Keywords: mail, news, MIME, multimedia, multilingual, security, PGP
   8
   9 ;; This file is part of tm (Tools for MIME).
  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 'mailcrypt)
  29 (load "mc-pgp")
  30
  31 (defun tm:mc-pgp-generic-parser (result)
  32   (let ((ret (mc-pgp-generic-parser result)))
  33     (if (consp ret)
  34         (vector (car ret)(cdr ret))
  35       )))
  36
  37 (defun tm:mc-process-region
  38   (beg end passwd program args parser &optional buffer boundary)
  39   (let ((obuf (current-buffer))
  40         (process-connection-type nil)
  41         mybuf result rgn proc)
  42     (unwind-protect
  43         (progn
  44           (setq mybuf (or buffer (generate-new-buffer " *mailcrypt temp")))
  45           (set-buffer mybuf)
  46           (erase-buffer)
  47           (set-buffer obuf)
  48           (buffer-disable-undo mybuf)
  49           (setq proc
  50                 (apply 'start-process "*PGP*" mybuf program args))
  51           (if passwd
  52               (progn
  53                 (process-send-string proc (concat passwd "\n"))
  54                 (or mc-passwd-timeout (mc-deactivate-passwd t))))
  55           (process-send-region proc beg end)
  56           (process-send-eof proc)
  57           (while (eq 'run (process-status proc))
  58             (accept-process-output proc 5))
  59           (setq result (process-exit-status proc))
  60           ;; Hack to force a status_notify() in Emacs 19.29
  61           (delete-process proc)
  62           (set-buffer mybuf)
  63           (goto-char (point-max))
  64           (if (re-search-backward "\nProcess \\*PGP.*\n\\'" nil t)
  65               (delete-region (match-beginning 0) (match-end 0)))
  66           (goto-char (point-min))
  67           ;; CRNL -> NL
  68           (while (search-forward "\r\n" nil t)
  69             (replace-match "\n"))
  70           ;; Hurm.  FIXME; must get better result codes.
  71           (if (stringp result)
  72               (error "%s exited abnormally: '%s'" program result)
  73             (setq rgn (funcall parser result))
  74             ;; If the parser found something, migrate it
  75             (if (consp rgn)
  76                 (progn
  77                   (set-buffer obuf)
  78                   (if boundary
  79                       (save-restriction
  80                         (narrow-to-region beg end)
  81                         (goto-char beg)
  82                         (insert (format "--%s\n" boundary))
  83                         (goto-char (point-max))
  84                         (insert (format "\n--%s
  85 Content-Type: application/pgp-signature
  86 Content-Transfer-Encoding: 7bit
  87
  88 " boundary))
  89                         (insert-buffer-substring mybuf (car rgn) (cdr rgn))
  90                         (goto-char (point-max))
  91                         (insert (format "\n--%s--\n" boundary))
  92                         )
  93                     (delete-region beg end)
  94                     (goto-char beg)
  95                     (insert-buffer-substring mybuf (car rgn) (cdr rgn))
  96                     )
  97                   (set-buffer mybuf)
  98                   (delete-region (car rgn) (cdr rgn)))))
  99           ;; Return nil on failure and exit code on success
 100           (if rgn result))
 101       ;; Cleanup even on nonlocal exit
 102       (if (and proc (eq 'run (process-status proc)))
 103           (interrupt-process proc))
 104       (set-buffer obuf)
 105       (or buffer (null mybuf) (kill-buffer mybuf)))))
 106
 107 (defun tm:mc-pgp-sign-region (start end &optional id unclear boundary)
 108   ;; (if (not (boundp 'mc-pgp-user-id))
 109   ;;     (load "mc-pgp")
 110   ;;   )
 111   (let ((process-environment process-environment)
 112         (buffer (get-buffer-create mc-buffer-name))
 113         passwd args key
 114         (parser (function mc-pgp-generic-parser))
 115         (pgp-path mc-pgp-path)
 116         )
 117     (setq key (mc-pgp-lookup-key (or id mc-pgp-user-id)))
 118     (setq passwd
 119           (mc-activate-passwd
 120            (cdr key)
 121            (format "PGP passphrase for %s (%s): " (car key) (cdr key))))
 122     (setenv "PGPPASSFD" "0")
 123     (setq args
 124           (cons
 125            (if boundary
 126                "-fbast"
 127              "-fast")
 128            (list "+verbose=1" "+language=en"
 129                  (format "+clearsig=%s" (if unclear "off" "on"))
 130                  "+batchmode" "-u" (cdr key))))
 131     (if mc-pgp-comment
 132         (setq args (cons (format "+comment=%s" mc-pgp-comment) args))
 133       )
 134     (message "Signing as %s ..." (car key))
 135     (if (tm:mc-process-region
 136          start end passwd pgp-path args parser buffer boundary)
 137         (progn
 138           (if boundary
 139               (progn
 140                 (goto-char (point-min))
 141                 (insert
 142                  (format "\
 143 --[[multipart/signed; protocol=\"application/pgp-signature\";
 144  boundary=\"%s\"; micalg=pgp-md5][7bit]]\n" boundary))
 145                 ))
 146           (message "Signing as %s ... Done." (car key))
 147           t)
 148       nil)))
 149
 150 (defun tm:mc-pgp-encrypt-region (recipients start end &optional id sign)
 151   (let ((mc-pgp-always-sign (if (eq sign 'maybe)
 152                                 mc-pgp-always-sign
 153                               'never)))
 154     (mc-pgp-encrypt-region
 155      (mc-split "\\([ \t\n]*,[ \t\n]*\\)+" recipients)
 156      start end id nil)
 157     ))
 158
 159
 160 ;;; @ end
 161 ;;;
 162
 163 (provide 'tm-edit-mc)
 164
 165 ;;; tm-edit-mc.el ends here