From 28c11cce460070d60da87d8e4644458d6e802d01 Mon Sep 17 00:00:00 2001 From: hayashi Date: Mon, 7 Feb 2000 07:19:50 +0000 Subject: [PATCH] Synch up with EMIKO 1.13.11. Guess gzipped file sent as application/octet-stream and show ungzipped contents. --- ChangeLog | 47 +++ Makefile | 17 +- NEWS | 10 + README.en | 5 +- SEMI-ELS | 18 +- emy.texi | 2 +- mime-edit.el | 1002 ++++++++++++++++++++++++++----------------------------- mime-image.el | 305 ++++++++++------- mime-partial.el | 26 +- mime-pgp.el | 253 +++++++------- mime-play.el | 200 ++++------- mime-setup.el | 6 +- mime-ui-en.sgml | 30 +- mime-ui-en.texi | 27 +- mime-ui-ja.sgml | 28 +- mime-ui-ja.texi | 27 +- mime-view.el | 276 ++++++--------- mime-w3.el | 6 +- pgg-def.el | 75 +++++ pgg-gpg.el | 268 +++++++++++++++ pgg-parse.el | 494 +++++++++++++++++++++++++++ pgg-pgp.el | 240 +++++++++++++ pgg-pgp5.el | 244 ++++++++++++++ pgg.el | 424 +++++++++++++++++++++++ semi-def.el | 74 +--- semi-setup.el | 57 ++-- signature.el | 24 +- smime.el | 334 +++++++++++++++++++ 28 files changed, 3233 insertions(+), 1286 deletions(-) create mode 100644 pgg-def.el create mode 100644 pgg-gpg.el create mode 100644 pgg-parse.el create mode 100644 pgg-pgp.el create mode 100644 pgg-pgp5.el create mode 100644 pgg.el create mode 100644 smime.el diff --git a/ChangeLog b/ChangeLog index a8753e4..dbd8aba 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,50 @@ +2000-02-07 Yoshiki Hayashi + + * EMY 1.13.2 is released. + +2000-02-07 Yoshiki Hayashi + + * mime-view.el (mime-display-message): Add new local variable + line-move-ignore-invisible. Bind it to t. + +2000-02-06 Yoshiki Hayashi + + * pgg-def.el (pgg-default-scheme): Improve custom options. + +2000-02-05 Yoshiki Hayashi + + * Makefile: Format Info file. + +2000-02-04 Yoshiki Hayashi + + * mime-edit.el: Synch with EMIKO 1.13.11. + * mime-image.el: Ditto. + * mime-pgp.el: Ditto. + * semi-def.el: Ditto. + * semi-setup.el: Ditto. + * mime-ui-en.sgml: Ditto. + * mime-ui-en.texi: Ditto. + * mime-ui-ja.sgml: Ditto. + * mime-ui-ja.texi: Ditto. + + * pgg-def.el: Synch with EMIKO 1.13.11. New file. + * pgg-gpg.el: Ditto. + * pgg-parse.el: Ditto. + * pgg-pgp.el: Ditto. + * pgg-pgp5.el: Ditto. + * pgg.el: Ditto. + * smime.el: Ditto. + +2000-02-03 Yoshiki Hayashi + + * mime-edit.el (mime-file-types): Defaults type of patch to + text/plain. There's not much reason to use application/octet-stream. + + * mime-view.el (mime-display-detect-application/octet-stream): + New function. + * mime-view.el (mime-display-gzipped): New function. + Ungzip content and inline it. Requires external gzip program. + 2000-01-31 Yoshiki Hayashi * EMY 1.13.1 is released. diff --git a/Makefile b/Makefile index 108695c..92f4820 100644 --- a/Makefile +++ b/Makefile @@ -14,7 +14,10 @@ CP = /bin/cp -p EMACS = emacs XEMACS = xemacs -FLAGS = -batch -q -no-site-file -l SEMI-MK +VANILLA = -batch -q -no-site-file +FLAGS = $(VANILLA) -l SEMI-MK +TEXINFMT = $(VANILLA) -l texinfmt +TEXIF = -f texinfo-format-buffer -f save-buffer PREFIX = NONE LISPDIR = NONE @@ -26,7 +29,7 @@ GOMI = *.elc *.info VERSION = $(API).$(RELEASE) ARC_DIR = /pub/mule/semi/semi-$(API)-for-flim-$(FLIM_API) -all: elc +all: elc info elc: $(EMACS) $(FLAGS) -f compile-semi \ @@ -39,15 +42,19 @@ install-elc: elc install: install-elc -package: +package: package-elc info + +package-elc: $(XEMACS) $(FLAGS) -f compile-semi-package $(PACKAGEDIR) install-package: package $(XEMACS) $(FLAGS) -f install-semi-package $(PACKAGEDIR) -info: - makeinfo -o emy.info emy.texi +info: emy.info + +%.info: %.texi + makeinfo -o $@ $< clean: -$(RM) $(GOMI) diff --git a/NEWS b/NEWS index 529574f..bff6af4 100644 --- a/NEWS +++ b/NEWS @@ -3,6 +3,16 @@ Copyright (C) 1998,1999 Free Software Foundation, Inc. * Changes in SEMI 1.13 +** PGP 5.0i and GnuPG are now supported for PGP/MIME + + You can select the various PGP or GnuPG commands by the user option +`pgg-default-scheme' or `pgg-scheme'. The former is for encrypting and +signing, the latter could be bound for controlling which command is +used to process the incoming PGP armors. Note that Mailcrypt is not +needed anymore. A user interface for editing or viewing has never +changed. Note also that `pgp-function' and `pgp-functions-alist' are +abolished in this version. + ** Requires FLIM 1.13 API diff --git a/README.en b/README.en index 72945ee..249dd36 100644 --- a/README.en +++ b/README.en @@ -39,8 +39,9 @@ Required environment EMY supports XEmacs 21.1 or later with mule, and Emacs 20.4 or later. - EMY does not support any other version. If you make patches to - make EMY to work on them, those might be applied. + EMY does not support any other version. If you write patches to + support version, those might be applied. It depends on the + cleanliness of the patch. EMY requires APEL (9.20 or later) and FLIM (1.13.1 or later) package. Please install them before installing it. APEL package is diff --git a/SEMI-ELS b/SEMI-ELS index 6ffa7fc..aea7e99 100644 --- a/SEMI-ELS +++ b/SEMI-ELS @@ -6,6 +6,8 @@ (setq semi-modules-to-compile '(signature + pgg-def pgg pgg-parse pgg-gpg pgg-pgp5 pgg-pgp mime-pgp + smime semi-def mime-view mime-play mime-partial mime-edit semi-setup mail-mime-setup)) @@ -14,25 +16,19 @@ (mapcar (function (lambda (cell) (let ((c-module (car cell)) - (i-modules (cdr cell)) - ) + (i-modules (cdr cell))) (if (module-installed-p c-module) (setq semi-modules-to-compile (nconc semi-modules-to-compile i-modules)) (setq semi-modules-not-to-compile - (nconc semi-modules-not-to-compile i-modules)) - ) - ))) - '((mailcrypt mime-pgp mime-mc) - (bbdb mime-bbdb) - (w3 mime-w3) - )) + (nconc semi-modules-not-to-compile i-modules)))))) + '((bbdb mime-bbdb) + (w3 mime-w3))) (if (or (string-match "XEmacs" emacs-version) (featurep 'mule)) (setq semi-modules-to-compile - (nconc semi-modules-to-compile '(mime-image))) - ) + (nconc semi-modules-to-compile '(mime-image)))) (setq semi-modules (append semi-modules-to-compile semi-modules-not-to-compile)) diff --git a/emy.texi b/emy.texi index 8dc36fe..f2c3e27 100644 --- a/emy.texi +++ b/emy.texi @@ -258,7 +258,7 @@ This means you will have buttons around message/* and multipart/alternative, and before application/*. @node How to deal with broken MUA -@section Illegal MIME messages +@section Invalid MIME messages Some MUAs send totally broken MIME messages. According to the standard, it's perfectly fine for EMY not to grok those message. However, EMY diff --git a/mime-edit.el b/mime-edit.el index d432797..a5a06e1 100644 --- a/mime-edit.el +++ b/mime-edit.el @@ -3,7 +3,8 @@ ;; Copyright (C) 1993,94,95,96,97,98,99 Free Software Foundation, Inc. ;; Author: UMEDA Masanobu -;; MORIOKA Tomohiko +;; MORIOKA Tomohiko +;; Daiki Ueno ;; Created: 1994/08/21 renamed from mime.el ;; Renamed: 1997/2/21 from tm-edit.el ;; Keywords: MIME, multimedia, multilingual, mail, news @@ -114,6 +115,19 @@ (require 'signature) (require 'alist) (require 'invisible) +(require 'pgg-def) +(require 'pgg-parse) + +(autoload 'pgg-encrypt-region "pgg" + "PGP encryption of current region." t) +(autoload 'pgg-sign-region "pgg" + "PGP signature of current region." t) +(autoload 'pgg-insert-key "pgg" + "Insert PGP public key at point." t) +(autoload 'smime-encrypt-region "smime" + "S/MIME encryption of current region.") +(autoload 'smime-sign-region "smime" + "S/MIME signature of current region.") ;;; @ version @@ -212,11 +226,9 @@ To insert a signature file automatically, call the function ("mail-server" ("server" "ftpmail@nic.karrn.ad.jp") ("subject")) - ("url" ("url")) - )) + ("url" ("url")))) ("rfc822") - ("news") - ) + ("news")) ("application" ("octet-stream" ("type" "" "tar" "shar")) ("postscript") @@ -230,11 +242,9 @@ To insert a signature file automatically, call the function ("x-pic") ("x-mag") ("x-xwd") - ("x-xbm") - ) + ("x-xbm")) ("audio" ("basic")) - ("video" ("mpeg")) - ) + ("video" ("mpeg"))) "*Alist of content-type, subtype, parameters and its values.") (defcustom mime-file-types @@ -245,34 +255,29 @@ To insert a signature file automatically, call the function ("\\.cc$" "application" "octet-stream" (("type" . "C++")) "7bit" - "attachment" (("filename" . file)) - ) + "attachment" (("filename" . file))) ("\\.el$" "application" "octet-stream" (("type" . "emacs-lisp")) "7bit" - "attachment" (("filename" . file)) - ) + "attachment" (("filename" . file))) ("\\.lsp$" "application" "octet-stream" (("type" . "common-lisp")) "7bit" - "attachment" (("filename" . file)) - ) + "attachment" (("filename" . file))) ("\\.pl$" "application" "octet-stream" (("type" . "perl")) "7bit" - "attachment" (("filename" . file)) - ) + "attachment" (("filename" . file))) ;; Text or translated text ("\\.txt$" "text" "plain" nil nil - "inline" (("filename" . file)) - ) + "inline" (("filename" . file))) ;; .rc : procmail modules pm-xxxx.rc ;; *rc : other resource files @@ -280,8 +285,7 @@ To insert a signature file automatically, call the function ("\\.\\(rc\\|lst\\|log\\|sql\\|mak\\)$\\|\\..*rc$" "text" "plain" nil nil - "attachment" (("filename" . file)) - ) + "attachment" (("filename" . file))) ("\\.html$" "text" "html" nil @@ -289,10 +293,9 @@ To insert a signature file automatically, call the function nil nil) ("\\.diff$\\|\\.patch$" - "application" "octet-stream" (("type" . "patch")) + "text" "plain" (("type" . "patch")) nil - "attachment" (("filename" . file)) - ) + "inline" (("filename" . file))) ("\\.signature" "text" "plain" nil nil nil nil) @@ -303,125 +306,102 @@ To insert a signature file automatically, call the function ("\\.doc$" ;MS Word "application" "winword" nil "base64" - "attachment" (("filename" . file)) - ) + "attachment" (("filename" . file))) ("\\.ppt$" ; MS Power Point "application" "vnd.ms-powerpoint" nil "base64" - "attachment" (("filename" . file)) - ) + "attachment" (("filename" . file))) ("\\.pln$" "text" "plain" nil nil - "inline" (("filename" . file)) - ) + "inline" (("filename" . file))) ("\\.ps$" "application" "postscript" nil "quoted-printable" - "attachment" (("filename" . file)) - ) + "attachment" (("filename" . file))) ;; Pure binary ("\\.jpg$" "image" "jpeg" nil "base64" - "inline" (("filename" . file)) - ) + "inline" (("filename" . file))) ("\\.gif$" "image" "gif" nil "base64" - "inline" (("filename" . file)) - ) + "inline" (("filename" . file))) ("\\.png$" "image" "png" nil "base64" - "inline" (("filename" . file)) - ) + "inline" (("filename" . file))) ("\\.tiff$" "image" "tiff" nil "base64" - "inline" (("filename" . file)) - ) + "inline" (("filename" . file))) ("\\.pic$" "image" "x-pic" nil "base64" - "inline" (("filename" . file)) - ) + "inline" (("filename" . file))) ("\\.mag$" "image" "x-mag" nil "base64" - "inline" (("filename" . file)) - ) + "inline" (("filename" . file))) ("\\.xbm$" "image" "x-xbm" nil "base64" - "inline" (("filename" . file)) - ) + "inline" (("filename" . file))) ("\\.xwd$" "image" "x-xwd" nil "base64" - "inline" (("filename" . file)) - ) + "inline" (("filename" . file))) ("\\.au$" "audio" "basic" nil "base64" - "attachment" (("filename" . file)) - ) + "attachment" (("filename" . file))) ("\\.mpg$" "video" "mpeg" nil "base64" - "attachment" (("filename" . file)) - ) + "attachment" (("filename" . file))) ("\\.tar\\.gz$" "application" "octet-stream" (("type" . "tar+gzip")) "base64" - "attachment" (("filename" . file)) - ) + "attachment" (("filename" . file))) ("\\.tgz$" "application" "octet-stream" (("type" . "tar+gzip")) "base64" - "attachment" (("filename" . file)) - ) + "attachment" (("filename" . file))) ("\\.tar\\.Z$" "application" "octet-stream" (("type" . "tar+compress")) "base64" - "attachment" (("filename" . file)) - ) + "attachment" (("filename" . file))) ("\\.taz$" "application" "octet-stream" (("type" . "tar+compress")) "base64" - "attachment" (("filename" . file)) - ) + "attachment" (("filename" . file))) ("\\.gz$" "application" "octet-stream" (("type" . "gzip")) "base64" - "attachment" (("filename" . file)) - ) + "attachment" (("filename" . file))) ("\\.Z$" "application" "octet-stream" (("type" . "compress")) "base64" - "attachment" (("filename" . file)) - ) + "attachment" (("filename" . file))) ("\\.lzh$" "application" "octet-stream" (("type" . "lha")) "base64" - "attachment" (("filename" . file)) - ) + "attachment" (("filename" . file))) ("\\.zip$" "application" "zip" nil "base64" - "attachment" (("filename" . file)) - ) + "attachment" (("filename" . file))) ;; Rest (".*" "application" "octet-stream" nil nil - "attachment" (("filename" . file))) - ) + "attachment" (("filename" . file)))) "*Alist of file name, types, parameters, and default encoding. If encoding is nil, it is determined from its contents." :type `(repeat @@ -429,8 +409,7 @@ If encoding is nil, it is determined from its contents." ;; primary-type (choice :tag "Primary-Type" ,@(nconc (mapcar (lambda (cell) - (list 'item (car cell)) - ) + (list 'item (car cell))) mime-content-types) '(string))) ;; subtype @@ -439,8 +418,7 @@ If encoding is nil, it is determined from its contents." (apply #'nconc (mapcar (lambda (cell) (mapcar (lambda (cell) - (list 'item (car cell)) - ) + (list 'item (car cell))) (cdr cell))) mime-content-types)) '(string))) @@ -452,8 +430,7 @@ If encoding is nil, it is determined from its contents." ,@(cons '(const nil) (mapcar (lambda (cell) - (list 'item cell) - ) + (list 'item cell)) (mime-encoding-list)))) ;; disposition-type (choice :tag "Disposition-Type" @@ -463,8 +440,7 @@ If encoding is nil, it is determined from its contents." string) ;; parameters (repeat :tag "Parameters of Content-Disposition field" - (cons string (choice string symbol))) - )) + (cons string (choice string symbol))))) :group 'mime-edit) (defvar mime-content-disposition-types @@ -502,8 +478,7 @@ either type/subtype or type only." (shift_jis 8 "base64") (tis-620 8 "base64") (iso-2022-jp-2 7 "base64") - (iso-2022-int-1 7 "base64") - )) + (iso-2022-int-1 7 "base64"))) (defvar mime-transfer-level 7 "*A number of network transfer level. It should be bigger than 7.") @@ -512,8 +487,7 @@ either type/subtype or type only." (defsubst mime-encoding-name (transfer-level &optional not-omit) (cond ((> transfer-level 8) "binary") ((= transfer-level 8) "8bit") - (not-omit "7bit") - )) + (not-omit "7bit"))) (defvar mime-transfer-level-string (mime-encoding-name mime-transfer-level 'not-omit) @@ -682,8 +656,7 @@ If it is not specified for a major-mode, (if (string-match "^Meadow-" mver) (concat " Meadow/" (substring mver - (match-end 0))) - )))) + (match-end 0))))))) (concat "MULE/" mule-version " (based on Emacs " ver ")")) (concat "Emacs/" ver " (" system-configuration ")"))))) @@ -797,8 +770,7 @@ Tspecials means any character that matches with it in header must be quoted.") (sign "About sign" mime-edit-set-sign) (encrypt "About encryption" mime-edit-set-encrypt) (preview "Preview Message" mime-edit-preview-message) - (level "Toggle transfer-level" mime-edit-toggle-transfer-level) - ) + (level "Toggle transfer-level" mime-edit-toggle-transfer-level)) "MIME-edit menubar entry.") (cond ((featurep 'xemacs) @@ -815,10 +787,8 @@ Tspecials means any character that matches with it in header must be quoted.") (mapcar (function (lambda (item) (vector (nth 1 item)(nth 2 item) - mime-edit-mode-flag) - )) - mime-edit-menu-list))) - ))) + mime-edit-mode-flag))) + mime-edit-menu-list)))))) ;; modified by Steven L. Baur ;; 1995/12/6 (c.f. [tm-en:209]) @@ -829,9 +799,7 @@ Tspecials means any character that matches with it in header must be quoted.") (vector (nth 1 item) (nth 2 item) t))) - mime-edit-menu-list))) - ) - ) + mime-edit-menu-list))))) ((>= emacs-major-version 19) (define-key mime-edit-mode-map [menu-bar mime-edit] (cons mime-edit-menu-title @@ -840,12 +808,8 @@ Tspecials means any character that matches with it in header must be quoted.") (lambda (item) (define-key mime-edit-mode-map (vector 'menu-bar 'mime-edit (car item)) - (cons (nth 1 item)(nth 2 item)) - ) - )) - (reverse mime-edit-menu-list) - ) - )) + (cons (nth 1 item)(nth 2 item))))) + (reverse mime-edit-menu-list)))) ;;; @ macros ;;; @@ -1006,8 +970,7 @@ User customizable variables (not documented all of them): (mime-edit-again) (make-local-variable 'mime-edit-touched-flag) (setq mime-edit-touched-flag t) - (turn-on-mime-edit) - ))) + (turn-on-mime-edit)))) (cond ((featurep 'xemacs) @@ -1015,16 +978,14 @@ User customizable variables (not documented all of them): '((" MIME-Edit " mime-transfer-level-string)) mime-edit-mode-map nil - 'mime-edit-mode) - ) + 'mime-edit-mode)) (t (set-alist 'minor-mode-alist 'mime-edit-mode-flag '((" MIME-Edit " mime-transfer-level-string))) (set-alist 'minor-mode-map-alist 'mime-edit-mode-flag - mime-edit-mode-map) - )) + mime-edit-mode-map))) ;;;###autoload @@ -1043,8 +1004,7 @@ User customizable variables (not documented all of them): ;; Define menu for XEmacs. (if (featurep 'xemacs) - (mime-edit-define-menu-for-xemacs) - ) + (mime-edit-define-menu-for-xemacs)) (enable-invisible) @@ -1058,8 +1018,7 @@ User customizable variables (not documented all of them): (run-hooks 'mime-edit-mode-hook) (message (substitute-command-keys - "Type \\[mime-edit-exit] to exit MIME mode, and type \\[mime-edit-help] to get help.")) - )) + "Type \\[mime-edit-exit] to exit MIME mode, and type \\[mime-edit-help] to get help.")))) ;;;###autoload (defalias 'edit-mime 'turn-on-mime-edit) ; for convenience @@ -1072,8 +1031,7 @@ just return to previous mode." (interactive "P") (if (not mime-edit-mode-flag) (if (null no-error) - (error "You aren't editing a MIME message.") - ) + (error "You aren't editing a MIME message.")) (if (not nomime) (progn (run-hooks 'mime-edit-translate-hook) @@ -1082,19 +1040,16 @@ just return to previous mode." (setq mime-edit-mode-flag nil) (if (and (featurep 'xemacs) (featurep 'menubar)) - (delete-menu-item (list mime-edit-menu-title)) - ) + (delete-menu-item (list mime-edit-menu-title))) (end-of-invisible) (set-buffer-modified-p (buffer-modified-p)) (run-hooks 'mime-edit-exit-hook) - (message "Exit MIME editor mode.") - )) + (message "Exit MIME editor mode."))) (defun mime-edit-maybe-translate () (interactive) (mime-edit-exit nil t) - (call-interactively 'mime-edit-maybe-split-and-send) - ) + (call-interactively 'mime-edit-maybe-split-and-send)) (defun mime-edit-help () "Show help message about MIME mode." @@ -1115,15 +1070,12 @@ If optional argument SUBTYPE is not nil, text/SUBTYPE tag is inserted." (progn ;; Make a space between the following message. (insert "\n") - (forward-char -1) - )) + (forward-char -1))) (if (and (member (cadr ret) '("enriched")) (fboundp 'enriched-mode)) (enriched-mode t) (if (boundp 'enriched-mode) - (enriched-mode -1) - )) - ))) + (enriched-mode -1)))))) (defun mime-edit-insert-file (file &optional verbose) "Insert a message from a file." @@ -1134,8 +1086,7 @@ If optional argument SUBTYPE is not nil, text/SUBTYPE tag is inserted." (parameters (nth 2 guess)) (encoding (nth 3 guess)) (disposition-type (nth 4 guess)) - (disposition-params (nth 5 guess)) - ) + (disposition-params (nth 5 guess))) (if verbose (setq type (mime-prompt-for-type type) subtype (mime-prompt-for-subtype type subtype))) @@ -1214,8 +1165,7 @@ If optional argument SUBTYPE is not nil, text/SUBTYPE tag is inserted." (progn (insert "\n") (invisible-region (point-min)(point-max)) - (goto-char (point-max)) - )))))) + (goto-char (point-max)))))))) (defun mime-edit-insert-signature (&optional arg) "Insert a signature file." @@ -1225,11 +1175,8 @@ If optional argument SUBTYPE is not nil, text/SUBTYPE tag is inserted." (lambda () (let ((items (mime-find-file-type signature-file-name))) (apply (function mime-edit-insert-tag) - (car items) (cadr items) (list (caddr items)))) - ))) - ) - (insert-signature arg) - )) + (car items) (cadr items) (list (caddr items)))))))) + (insert-signature arg))) ;; Insert a new tag around a point. @@ -1242,15 +1189,12 @@ If nothing is inserted, return nil." (mime-edit-goto-tag) (if (and (re-search-forward mime-edit-tag-regexp nil t) (< (match-beginning 0) p) - (< p (match-end 0)) - ) + (< p (match-end 0))) (goto-char (match-beginning 0)) - (goto-char p) - )) + (goto-char p))) (let ((oldtag nil) (newtag nil) - (current (point)) - ) + (current (point))) (setq pritype (or pritype (mime-prompt-for-type))) @@ -1268,8 +1212,7 @@ If nothing is inserted, return nil." (if (mime-edit-goto-tag) (buffer-substring (match-beginning 0) (match-end 0)) ;; Assume content type is 'text/plan'. - (mime-make-tag "text" "plain") - ))) + (mime-make-tag "text" "plain")))) ;; We are only interested in TEXT. (if (and oldtag (not (mime-test-content-type @@ -1288,8 +1231,7 @@ If nothing is inserted, return nil." ;; Restore previous point. (goto-char current) nil ;Nothing is created. - ) - )) + ))) (defun mime-edit-insert-binary-file (file &optional encoding) "Insert binary FILE at point. @@ -1301,31 +1243,24 @@ Optional argument ENCODING specifies an encoding method such as base64." (let ((en (downcase encoding))) (or (string-equal en "7bit") (string-equal en "8bit") - (string-equal en "binary") - ))))) - ) + (string-equal en "binary"))))))) (save-restriction (narrow-to-region tagend (point)) (mime-insert-encoded-file file encoding) (if hide-p (progn (invisible-region (point-min) (point-max)) - (goto-char (point-max)) - ) - (goto-char (point-max)) - )) + (goto-char (point-max))) + (goto-char (point-max)))) (or hide-p (looking-at mime-edit-tag-regexp) (= (point)(point-max)) - (mime-edit-insert-tag "text" "plain") - ) + (mime-edit-insert-tag "text" "plain")) ;; Define encoding even if it is 7bit. (if (stringp encoding) (save-excursion (goto-char tagend) ; Make sure which line the tag is on. - (mime-edit-define-encoding encoding) - )) - )) + (mime-edit-define-encoding encoding))))) ;; Commands work on a current message flagment. @@ -1340,17 +1275,14 @@ Optional argument ENCODING specifies an encoding method such as base64." (goto-char (1- (match-beginning 0))) ;For multiline tag ) (t - (goto-char (point-max)) - )) + (goto-char (point-max)))) ;; Then search for the beginning. (re-search-backward mime-edit-end-tag-regexp nil t) (or (looking-at mime-edit-beginning-tag-regexp) ;; Restore previous point. (progn (goto-char current) - nil - )) - ))) + nil))))) (defun mime-edit-content-beginning () "Return the point of the beginning of content." @@ -1371,8 +1303,7 @@ Optional argument ENCODING specifies an encoding method such as base64." (concat "\n" (regexp-quote mail-header-separator) (if mime-ignore-preceding-spaces "[ \t\n]*\n" "\n")) nil 'move) - (point)) - ))) + (point))))) (defun mime-edit-content-end () "Return the point of the end of content." @@ -1385,17 +1316,14 @@ Optional argument ENCODING specifies an encoding method such as base64." ;; Move to the end of this text. (if (re-search-forward mime-edit-tag-regexp nil 'move) ;; Don't forget a multiline tag. - (goto-char (match-beginning 0)) - ) - (point) - )) + (goto-char (match-beginning 0))) + (point))) ;; Assume the message begins with text/plain. (goto-char (mime-edit-content-beginning)) (if (re-search-forward mime-edit-tag-regexp nil 'move) ;; Don't forget a multiline tag. (goto-char (match-beginning 0))) - (point)) - )) + (point)))) (defun mime-edit-define-charset (charset) "Set charset of current tag to CHARSET." @@ -1408,8 +1336,7 @@ Optional argument ENCODING specifies an encoding method such as base64." (mime-edit-set-parameter (mime-edit-get-contype tag) "charset" (upcase (symbol-name charset))) - (mime-edit-get-encoding tag))) - )))) + (mime-edit-get-encoding tag))))))) (defun mime-edit-define-encoding (encoding) "Set encoding of current tag to ENCODING." @@ -1417,13 +1344,11 @@ Optional argument ENCODING specifies an encoding method such as base64." (if (mime-edit-goto-tag) (let ((tag (buffer-substring (match-beginning 0) (match-end 0)))) (delete-region (match-beginning 0) (match-end 0)) - (insert (mime-create-tag (mime-edit-get-contype tag) encoding))) - ))) + (insert (mime-create-tag (mime-edit-get-contype tag) encoding)))))) (defun mime-edit-choose-charset () "Choose charset of a text following current point." - (detect-mime-charset-region (point) (mime-edit-content-end)) - ) + (detect-mime-charset-region (point) (mime-edit-content-end))) (defun mime-make-text-tag (&optional subtype) "Make a tag for a text after current point. @@ -1454,10 +1379,8 @@ Otherwise, it is obtained from mime-content-types." (and (stringp tag) (or (string-match mime-edit-single-part-tag-regexp tag) (string-match mime-edit-multipart-beginning-regexp tag) - (string-match mime-edit-multipart-end-regexp tag) - ) - (substring tag (match-beginning 1) (match-end 1)) - )) + (string-match mime-edit-multipart-end-regexp tag)) + (substring tag (match-beginning 1) (match-end 1)))) (defun mime-edit-get-encoding (tag) "Return encoding of TAG." @@ -1486,8 +1409,7 @@ Nil if no such parameter." (if (string-match "\n[^ \t\n\r]+:" contype) (setq ctype (substring contype 0 (match-beginning 0)) opt-fields (substring contype (match-beginning 0))) - (setq ctype contype) - ) + (setq ctype contype)) (if (string-match (concat ";[ \t\n]*\\(" @@ -1526,8 +1448,7 @@ Nil if no such parameter." (if (string-match (car (car guesses)) file) (setq guess (cdr (car guesses)))) (setq guesses (cdr guesses))) - guess - )) + guess)) (defun mime-prompt-for-type (&optional default) "Ask for Content-type." @@ -1539,15 +1460,12 @@ Nil if no such parameter." mime-content-types nil 'require-match ;Type must be specified. - default - )) + default)) (if (string-equal type "") (progn (message "Content type is required.") (beep) - (sit-for 1) - )) - ) + (sit-for 1)))) type)) (defun mime-prompt-for-subtype (type &optional default) @@ -1555,8 +1473,7 @@ Nil if no such parameter." (let ((subtypes (cdr (assoc type mime-content-types)))) (or (and default (assoc default subtypes)) - (setq default (car (car subtypes))) - )) + (setq default (car (car subtypes))))) (let* ((answer (completing-read (if default @@ -1566,8 +1483,7 @@ Nil if no such parameter." (cdr (assoc type mime-content-types)) nil 'require-match ;Subtype must be specified. - nil - ))) + nil))) (if (string-equal answer "") default answer))) (defun mime-prompt-for-parameters (pritype subtype &optional delimiter) @@ -1581,8 +1497,7 @@ Optional DELIMITER specifies parameter delimiter (';' by default)." (mime-prompt-for-parameters-1 (cdr (assoc subtype (cdr (assoc pritype mime-content-types)))))) - delimiter - ))) + delimiter))) (if (and (stringp parameters) (not (string-equal parameters ""))) (concat delimiter parameters) @@ -1623,8 +1538,7 @@ Parameter must be '(PROMPT CHOICE1 (CHOISE2 ...))." ;; Note: control characters ignored! (if (string-match mime-tspecials-regexp answer) (concat "\"" answer "\"") answer))) - (mime-prompt-for-parameters-1 (cdr (assoc answer (cdr parameter))))) - )) + (mime-prompt-for-parameters-1 (cdr (assoc answer (cdr parameter))))))) (defun mime-prompt-for-encoding (default) "Ask for Content-Transfer-Encoding." @@ -1633,8 +1547,7 @@ Parameter must be '(PROMPT CHOICE1 (CHOISE2 ...))." (setq encoding (completing-read "What transfer encoding: " - (mime-encoding-alist) nil t default) - ) + (mime-encoding-alist) nil t default)) "")) encoding)) @@ -1658,20 +1571,18 @@ Parameter must be '(PROMPT CHOICE1 (CHOISE2 ...))." (defun mime-edit-translate-header () "Encode the message header into network representation." (eword-encode-header 'code-conversion) - (run-hooks 'mime-edit-translate-header-hook) - ) + (run-hooks 'mime-edit-translate-header-hook)) (defun mime-edit-translate-buffer () "Encode the tagged MIME message in current buffer in MIME compliant message." (interactive) + (undo-boundary) (if (catch 'mime-edit-error (save-excursion - (run-hooks 'mime-edit-translate-buffer-hook) - )) + (run-hooks 'mime-edit-translate-buffer-hook))) (progn (undo) - (error "Translation error!") - ))) + (error "Translation error!")))) (defun mime-edit-find-inmost () (goto-char (point-min)) @@ -1684,26 +1595,22 @@ Parameter must be '(PROMPT CHOICE1 (CHOISE2 ...))." (widen) (if (re-search-forward end-exp nil t) (setq eb (match-beginning 0)) - (setq eb (point-max)) - ) + (setq eb (point-max))) (narrow-to-region be eb) (goto-char be) (if (re-search-forward mime-edit-multipart-beginning-regexp nil t) (progn (narrow-to-region (match-beginning 0)(point-max)) - (mime-edit-find-inmost) - ) + (mime-edit-find-inmost)) (widen) - (list type bb be eb) - )))) + (list type bb be eb))))) (defun mime-edit-process-multipart-1 (boundary) (let ((ret (mime-edit-find-inmost))) (if ret (let ((type (car ret)) (bb (nth 1 ret))(be (nth 2 ret)) - (eb (nth 3 ret)) - ) + (eb (nth 3 ret))) (narrow-to-region bb eb) (delete-region bb be) (setq bb (point-min)) @@ -1712,28 +1619,25 @@ Parameter must be '(PROMPT CHOICE1 (CHOISE2 ...))." (goto-char eb) (if (looking-at mime-edit-multipart-end-regexp) (let ((beg (match-beginning 0)) - (end (match-end 0)) - ) + (end (match-end 0))) (delete-region beg end) (or (looking-at mime-edit-beginning-tag-regexp) (eobp) - (insert (concat (mime-make-text-tag) "\n")) - ))) + (insert (concat (mime-make-text-tag) "\n"))))) (cond ((string-equal type "quote") - (mime-edit-enquote-region bb eb) - ) + (mime-edit-enquote-region bb eb)) ((string-equal type "pgp-signed") - (mime-edit-sign-pgp-mime bb eb boundary) - ) + (mime-edit-sign-pgp-mime bb eb boundary)) ((string-equal type "pgp-encrypted") - (mime-edit-encrypt-pgp-mime bb eb boundary) - ) + (mime-edit-encrypt-pgp-mime bb eb boundary)) ((string-equal type "kazu-signed") - (mime-edit-sign-pgp-kazu bb eb boundary) - ) + (mime-edit-sign-pgp-kazu bb eb boundary)) ((string-equal type "kazu-encrypted") - (mime-edit-encrypt-pgp-kazu bb eb boundary) - ) + (mime-edit-encrypt-pgp-kazu bb eb boundary)) + ((string-equal type "smime-signed") + (mime-edit-sign-smime bb eb boundary)) + ((string-equal type "smime-encrypted") + (mime-edit-encrypt-smime bb eb boundary)) (t (setq boundary (nth 2 (mime-edit-translate-region bb eb @@ -1742,8 +1646,7 @@ Parameter must be '(PROMPT CHOICE1 (CHOISE2 ...))." (insert (format "--[[multipart/%s; boundary=\"%s\"][7bit]]\n" - type boundary)) - )) + type boundary)))) boundary)))) (defun mime-edit-enquote-region (beg end) @@ -1753,8 +1656,7 @@ Parameter must be '(PROMPT CHOICE1 (CHOISE2 ...))." (goto-char beg) (while (re-search-forward mime-edit-single-part-tag-regexp nil t) (let ((tag (buffer-substring (match-beginning 0)(match-end 0)))) - (replace-match (concat "- " (substring tag 1))) - ))))) + (replace-match (concat "- " (substring tag 1)))))))) (defun mime-edit-dequote-region (beg end) (save-excursion @@ -1764,30 +1666,55 @@ Parameter must be '(PROMPT CHOICE1 (CHOISE2 ...))." (while (re-search-forward mime-edit-quoted-single-part-tag-regexp nil t) (let ((tag (buffer-substring (match-beginning 0)(match-end 0)))) - (replace-match (concat "-" (substring tag 2))) - ))))) + (replace-match (concat "-" (substring tag 2)))))))) (defun mime-edit-sign-pgp-mime (beg end boundary) (save-excursion (save-restriction - (narrow-to-region beg end) - (let* ((ret - (mime-edit-translate-region beg end boundary)) + (let* ((from (std11-field-body "From" mail-header-separator)) + (ret (progn + (narrow-to-region beg end) + (mime-edit-translate-region beg end boundary))) (ctype (car ret)) (encoding (nth 1 ret)) - (pgp-boundary (concat "pgp-sign-" boundary))) + (pgp-boundary (concat "pgp-sign-" boundary)) + micalg) (goto-char beg) (insert (format "Content-Type: %s\n" ctype)) (if encoding - (insert (format "Content-Transfer-Encoding: %s\n" encoding)) - ) + (insert (format "Content-Transfer-Encoding: %s\n" encoding))) (insert "\n") - (or (as-binary-process - (funcall (pgp-function 'mime-sign) - (point-min)(point-max) nil nil pgp-boundary)) - (throw 'mime-edit-error 'pgp-error) - ) - )))) + (or (let ((pgg-default-user-id + (or mime-edit-pgp-user-id + (if from + (nth 1 (std11-extract-address-components from)) + pgg-default-user-id)))) + (pgg-sign-region (point-min)(point-max))) + (throw 'mime-edit-error 'pgp-error)) + (setq micalg + (cdr (assq 'hash-algorithm + (cdar (with-current-buffer pgg-output-buffer + (pgg-parse-armor-region + (point-min)(point-max)))))) + micalg + (if micalg + (concat "; micalg=pgp-" (downcase (symbol-name micalg))) + "")) + (goto-char beg) + (insert (format "--[[multipart/signed; + boundary=\"%s\"%s; + protocol=\"application/pgp-signature\"][7bit]] +--%s +" pgp-boundary micalg pgp-boundary)) + (goto-char (point-max)) + (insert (format "\n--%s +Content-Type: application/pgp-signature +Content-Transfer-Encoding: 7bit + +" pgp-boundary)) + (insert-buffer-substring pgg-output-buffer) + (goto-char (point-max)) + (insert (format "\n--%s--\n" pgp-boundary)))))) (defvar mime-edit-encrypt-recipient-fields-list '("To" "cc")) @@ -1802,26 +1729,21 @@ Parameter must be '(PROMPT CHOICE1 (CHOISE2 ...))." (header (and (stringp from) (if (string-equal from "") "" - (format "From: %s\n" from) - ))) + (format "From: %s\n" from)))) recipients) (while (and names values) (let ((name (car names)) - (value (car values)) - ) + (value (car values))) (and (stringp value) (or (string-equal value "") (progn (setq header (concat header name ": " value "\n") recipients (if recipients (concat recipients " ," value) - value)) - )))) + value)))))) (setq names (cdr names) - values (cdr values)) - ) - (vector from recipients header) - )) + values (cdr values))) + (vector from recipients header))) (defun mime-edit-encrypt-pgp-mime (beg end boundary) (save-excursion @@ -1830,25 +1752,34 @@ Parameter must be '(PROMPT CHOICE1 (CHOISE2 ...))." (let ((ret (mime-edit-make-encrypt-recipient-header))) (setq from (aref ret 0) recipients (aref ret 1) - header (aref ret 2)) - ) - (narrow-to-region beg end) - (let* ((ret - (mime-edit-translate-region beg end boundary)) - (ctype (car ret)) - (encoding (nth 1 ret)) - (pgp-boundary (concat "pgp-" boundary))) - (goto-char beg) - (insert header) - (insert (format "Content-Type: %s\n" ctype)) - (if encoding - (insert (format "Content-Transfer-Encoding: %s\n" encoding)) - ) - (insert "\n") - (or (funcall (pgp-function 'encrypt) - recipients (point-min) (point-max) from) - (throw 'mime-edit-error 'pgp-error) - ) + header (aref ret 2))) + (narrow-to-region beg end) + (let* ((ret + (mime-edit-translate-region beg end boundary)) + (ctype (car ret)) + (encoding (nth 1 ret)) + (pgp-boundary (concat "pgp-" boundary))) + (goto-char beg) + (insert header) + (insert (format "Content-Type: %s\n" ctype)) + (if encoding + (insert (format "Content-Transfer-Encoding: %s\n" encoding))) + (insert "\n") + (eword-encode-header) + (or (let ((pgg-default-user-id + (or mime-edit-pgp-user-id + (if from + (nth 1 (std11-extract-address-components from)) + pgg-default-user-id)))) + (pgg-encrypt-region + (point-min) (point-max) + (mapcar (lambda (recipient) + (nth 1 (std11-extract-address-components + recipient))) + (split-string recipients + "\\([ \t\n]*,[ \t\n]*\\)+")))) + (throw 'mime-edit-error 'pgp-error)) + (delete-region (point-min)(point-max)) (goto-char beg) (insert (format "--[[multipart/encrypted; boundary=\"%s\"; @@ -1861,9 +1792,9 @@ Content-Type: application/octet-stream Content-Transfer-Encoding: 7bit " pgp-boundary pgp-boundary pgp-boundary)) + (insert-buffer-substring pgg-output-buffer) (goto-char (point-max)) - (insert (format "\n--%s--\n" pgp-boundary)) - ))))) + (insert (format "\n--%s--\n" pgp-boundary))))))) (defun mime-edit-sign-pgp-kazu (beg end boundary) (save-excursion @@ -1876,27 +1807,21 @@ Content-Transfer-Encoding: 7bit (goto-char beg) (insert (format "Content-Type: %s\n" ctype)) (if encoding - (insert (format "Content-Transfer-Encoding: %s\n" encoding)) - ) + (insert (format "Content-Transfer-Encoding: %s\n" encoding))) (insert "\n") - (or (as-binary-process - (funcall (pgp-function 'traditional-sign) - beg (point-max))) - (throw 'mime-edit-error 'pgp-error) - ) + (or (pgg-sign-region beg (point-max) 'clearsign) + (throw 'mime-edit-error 'pgp-error)) (goto-char beg) (insert "--[[application/pgp; format=mime][7bit]]\n") - )) - )) + )))) (defun mime-edit-encrypt-pgp-kazu (beg end boundary) (save-excursion (let (recipients header) (let ((ret (mime-edit-make-encrypt-recipient-header))) (setq recipients (aref ret 1) - header (aref ret 2)) - ) + header (aref ret 2))) (save-restriction (narrow-to-region beg end) (let* ((ret @@ -1907,20 +1832,80 @@ Content-Transfer-Encoding: 7bit (insert header) (insert (format "Content-Type: %s\n" ctype)) (if encoding - (insert (format "Content-Transfer-Encoding: %s\n" encoding)) - ) + (insert (format "Content-Transfer-Encoding: %s\n" encoding))) (insert "\n") - (or (as-binary-process - (funcall (pgp-function 'encrypt) - recipients beg (point-max) nil 'maybe) - ) - (throw 'mime-edit-error 'pgp-error) - ) + (or (pgg-encrypt-region beg (point-max) recipients) + (throw 'mime-edit-error 'pgp-error)) (goto-char beg) (insert "--[[application/pgp; format=mime][7bit]]\n") - )) - ))) + ))))) + +(defun mime-edit-sign-smime (beg end boundary) + (save-excursion + (save-restriction + (let* ((ret (progn + (narrow-to-region beg end) + (mime-edit-translate-region beg end boundary))) + (ctype (car ret)) + (encoding (nth 1 ret)) + (smime-boundary (concat "smime-sign-" boundary))) + (goto-char beg) + (insert (format "Content-Type: %s\n" ctype)) + (if encoding + (insert (format "Content-Transfer-Encoding: %s\n" encoding))) + (insert "\n") + (let (buffer-undo-list) + (goto-char (point-min)) + (while (progn (end-of-line) (not (eobp))) + (insert "\r") + (forward-line 1)) + (or (prog1 (smime-sign-region (point-min)(point-max)) + (push nil buffer-undo-list) + (ignore-errors (undo))) + (throw 'mime-edit-error 'pgp-error))) + (goto-char beg) + (insert (format "--[[multipart/signed; + boundary=\"%s\"; micalg=sha1; + protocol=\"application/pkcs7-signature\"][7bit]] +--%s +" smime-boundary smime-boundary)) + (goto-char (point-max)) + (insert (format "\n--%s +Content-Type: application/pkcs7-signature; name=\"smime.p7s\" +Content-Transfer-Encoding: base64 +Content-Disposition: attachment; filename=\"smime.p7s\" +Content-Description: S/MIME Cryptographic Signature + +" smime-boundary)) + (insert-buffer-substring smime-output-buffer) + (goto-char (point-max)) + (insert (format "\n--%s--\n" smime-boundary)))))) + +(defun mime-edit-encrypt-smime (beg end boundary) + (save-excursion + (save-restriction + (let* ((ret (progn + (narrow-to-region beg end) + (mime-edit-translate-region beg end boundary))) + (ctype (car ret)) + (encoding (nth 1 ret))) + (goto-char beg) + (insert (format "Content-Type: %s\n" ctype)) + (if encoding + (insert (format "Content-Transfer-Encoding: %s\n" encoding))) + (insert "\n") + (goto-char (point-min)) + (while (progn (end-of-line) (not (eobp))) + (insert "\r") + (forward-line 1)) + (or (smime-encrypt-region (point-min)(point-max)) + (throw 'mime-edit-error 'pgp-error)) + (delete-region (point-min)(point-max)) + (insert "--[[application/pkcs7-mime; name=\"smime.p7m\" +Content-Disposition: attachment; filename=\"smime.p7m\" +Content-Description: S/MIME Encrypted Message][base64]]\n") + (insert-buffer-substring smime-output-buffer))))) (defsubst replace-space-with-underline (str) (mapconcat (function @@ -1928,13 +1913,11 @@ Content-Transfer-Encoding: 7bit (char-to-string (if (eq arg ?\ ) ?_ - arg)))) str "") - ) + arg)))) str "")) (defun mime-edit-make-boundary () (concat mime-multipart-boundary "_" - (replace-space-with-underline (current-time-string)) - )) + (replace-space-with-underline (current-time-string)))) (defun mime-edit-translate-body () "Encode the tagged MIME body in current buffer in MIME compliant message." @@ -1945,8 +1928,7 @@ Content-Transfer-Encoding: 7bit ret) (while (mime-edit-process-multipart-1 (format "%s-%d" boundary i)) - (setq i (1+ i)) - ) + (setq i (1+ i))) (save-restriction ;; We are interested in message body. (let* ((beg @@ -1966,8 +1948,7 @@ Content-Transfer-Encoding: 7bit (point)))) (setq ret (mime-edit-translate-region beg end - (format "%s-%d" boundary i))) - )) + (format "%s-%d" boundary i))))) (mime-edit-dequote-region (point-min)(point-max)) (let ((contype (car ret)) ;Content-Type (encoding (nth 1 ret)) ;Content-Transfer-Encoding @@ -1975,8 +1956,7 @@ Content-Transfer-Encoding: 7bit ;; Insert User-Agent field (and mime-edit-insert-user-agent-field (or (mail-position-on-field "User-Agent") - (insert mime-edit-user-agent-value) - )) + (insert mime-edit-user-agent-value))) ;; Make primary MIME headers. (or (mail-position-on-field "MIME-Version") (insert mime-edit-mime-version-value)) @@ -1994,8 +1974,7 @@ Content-Transfer-Encoding: 7bit (if encoding (progn (mail-position-on-field "Content-Transfer-Encoding") - (insert encoding))) - )))) + (insert encoding))))))) (defun mime-edit-translate-single-part-tag (boundary &optional prefix) "Translate single-part-tag to MIME header." @@ -2012,18 +1991,15 @@ Content-Transfer-Encoding: 7bit (insert "Content-Type: " contype "\n") (if encoding (insert "Content-Transfer-Encoding: " encoding "\n")) - (eword-encode-header) - ) + (eword-encode-header)) (cons (and contype (downcase contype)) (and encoding - (downcase encoding)))) - ))) + (downcase encoding))))))) (defun mime-edit-translate-region (beg end &optional boundary multipart) (or boundary - (setq boundary (mime-edit-make-boundary)) - ) + (setq boundary (mime-edit-make-boundary))) (save-excursion (save-restriction (narrow-to-region beg end) @@ -2049,8 +2025,7 @@ Content-Transfer-Encoding: 7bit (buffer-substring (match-beginning 0) (match-end 0))) (delete-region (match-beginning 0) (1+ (match-end 0))) (setq contype (mime-edit-get-contype tag)) - (setq encoding (mime-edit-get-encoding tag)) - )) + (setq encoding (mime-edit-get-encoding tag)))) (t ;; It's a multipart message. (goto-char (point-min)) @@ -2070,10 +2045,8 @@ Content-Transfer-Encoding: 7bit (setq encoding (car prio)) ;; Insert the trailer. (goto-char (point-max)) - (insert "\n--" boundary "--\n") - ))) - (list contype encoding boundary nparts) - )))) + (insert "\n--" boundary "--\n")))) + (list contype encoding boundary nparts))))) (defun mime-edit-normalize-body () "Normalize the body part by inserting appropriate message tags." @@ -2092,23 +2065,19 @@ Content-Transfer-Encoding: 7bit (if (looking-at "[ \t]+$") (delete-region (match-beginning 0) (match-end 0))) (let ((beg (point)) - (end (mime-edit-content-end)) - ) + (end (mime-edit-content-end))) (if (= end (point-max)) nil (goto-char end) (or (looking-at mime-edit-beginning-tag-regexp) (eobp) - (insert (mime-make-text-tag) "\n") - )) + (insert (mime-make-text-tag) "\n"))) (visible-region beg end) - (goto-char beg) - ) + (goto-char beg)) (cond ((mime-test-content-type contype "message") ;; Content-type "message" should be sent as is. - (forward-line 1) - ) + (forward-line 1)) ((mime-test-content-type contype "text") ;; Define charset for text if necessary. (setq charset (if charset @@ -2118,15 +2087,13 @@ Content-Transfer-Encoding: 7bit (cond ((string-equal contype "text/x-rot13-47-48") (save-excursion (forward-line) - (mule-caesar-region (point) (mime-edit-content-end)) - )) + (mule-caesar-region (point) (mime-edit-content-end)))) ((string-equal contype "text/enriched") (save-excursion (let ((beg (progn (forward-line) (point))) - (end (mime-edit-content-end)) - ) + (end (mime-edit-content-end))) ;; Patch for hard newlines ;; (save-excursion ;; (goto-char beg) @@ -2138,9 +2105,7 @@ Content-Transfer-Encoding: 7bit (enriched-encode beg end) (goto-char beg) (if (search-forward "\n\n") - (delete-region beg (match-end 0)) - ) - )))) + (delete-region beg (match-end 0))))))) ;; Point is now on current tag. ;; Define encoding and encode text if necessary. (or encoding ;Encoding is not specified. @@ -2171,10 +2136,8 @@ Content-Transfer-Encoding: 7bit x-ctext)) (while (progn (replace-match "\e(BFrom ") - (re-search-forward "^From " nil t) - )) - (setq encoding "quoted-printable") - ))))) + (re-search-forward "^From " nil t))) + (setq encoding "quoted-printable")))))) ;; canonicalize line break code (or (member encoding '(nil "7bit" "8bit" "quoted-printable")) (save-restriction @@ -2185,10 +2148,8 @@ Content-Transfer-Encoding: 7bit (goto-char beg) (mime-encode-region beg (mime-edit-content-end) (or encoding "7bit")) - (mime-edit-define-encoding encoding) - )) - (goto-char (mime-edit-content-end)) - ) + (mime-edit-define-encoding encoding))) + (goto-char (mime-edit-content-end))) ((null encoding) ;Encoding is not specified. ;; Application, image, audio, video, and any other ;; unknown content-type without encoding should be @@ -2198,9 +2159,7 @@ Content-Transfer-Encoding: 7bit (end (mime-edit-content-end))) (mime-encode-region beg end encoding) (mime-edit-define-encoding encoding)) - (forward-line 1) - )) - ))) + (forward-line 1)))))) (defun mime-delete-field (field) "Delete header FIELD." @@ -2222,8 +2181,7 @@ Content-Transfer-Encoding: 7bit and insert data encoded as ENCODING." (message "Start the recording on %s. Type C-g to finish the recording..." (system-name)) - (mime-insert-encoded-file "/dev/audio" encoding) - ) + (mime-insert-encoded-file "/dev/audio" encoding)) ;;; @ Other useful commands. @@ -2239,10 +2197,8 @@ and insert data encoded as ENCODING." (mime-edit-insert-place '("message" "rfc822") (mime-edit-insert-tag "message" "rfc822") - (funcall inserter message)) - ) - (message "Sorry, I don't have message inserter for your MUA.") - ))) + (funcall inserter message))) + (message "Sorry, I don't have message inserter for your MUA.")))) (defun mime-edit-insert-mail (&optional message) (interactive) @@ -2252,10 +2208,8 @@ and insert data encoded as ENCODING." (mime-edit-insert-place '("message" "rfc822") (mime-edit-insert-tag "message" "rfc822") - (funcall inserter message)) - ) - (message "Sorry, I don't have mail inserter for your MUA.") - ))) + (funcall inserter message))) + (message "Sorry, I don't have mail inserter for your MUA.")))) (defun mime-edit-inserted-message-filter () (save-excursion @@ -2266,17 +2220,13 @@ and insert data encoded as ENCODING." ;; for Emacs 18 ;; (if (re-search-forward "^$" (marker-position (mark-marker))) (if (re-search-forward "^$" (mark t)) - (narrow-to-region header-start (match-beginning 0)) - ) + (narrow-to-region header-start (match-beginning 0))) (goto-char header-start) (while (and (re-search-forward mime-edit-yank-ignored-field-regexp nil t) (setq beg (match-beginning 0)) - (setq end (1+ (std11-field-end))) - ) - (delete-region beg end) - ) - )))) + (setq end (1+ (std11-field-end)))) + (delete-region beg end)))))) ;;; @ multipart enclosure @@ -2290,66 +2240,61 @@ and insert data encoded as ENCODING." (insert (format "--<<%s>>-{\n" type)) (goto-char (point-max)) (insert (format "--}-<<%s>>\n" type)) - (goto-char (point-max)) - ) + (goto-char (point-max))) (or (looking-at mime-edit-beginning-tag-regexp) (eobp) - (insert (mime-make-text-tag) "\n") - ) - )) + (insert (mime-make-text-tag) "\n")))) (defun mime-edit-enclose-quote-region (beg end) (interactive "*r") - (mime-edit-enclose-region-internal 'quote beg end) - ) + (mime-edit-enclose-region-internal 'quote beg end)) (defun mime-edit-enclose-mixed-region (beg end) (interactive "*r") - (mime-edit-enclose-region-internal 'mixed beg end) - ) + (mime-edit-enclose-region-internal 'mixed beg end)) (defun mime-edit-enclose-parallel-region (beg end) (interactive "*r") - (mime-edit-enclose-region-internal 'parallel beg end) - ) + (mime-edit-enclose-region-internal 'parallel beg end)) (defun mime-edit-enclose-digest-region (beg end) (interactive "*r") - (mime-edit-enclose-region-internal 'digest beg end) - ) + (mime-edit-enclose-region-internal 'digest beg end)) (defun mime-edit-enclose-alternative-region (beg end) (interactive "*r") - (mime-edit-enclose-region-internal 'alternative beg end) - ) + (mime-edit-enclose-region-internal 'alternative beg end)) (defun mime-edit-enclose-pgp-signed-region (beg end) (interactive "*r") - (mime-edit-enclose-region-internal 'pgp-signed beg end) - ) + (mime-edit-enclose-region-internal 'pgp-signed beg end)) (defun mime-edit-enclose-pgp-encrypted-region (beg end) (interactive "*r") - (mime-edit-enclose-region-internal 'pgp-encrypted beg end) - ) + (mime-edit-enclose-region-internal 'pgp-encrypted beg end)) (defun mime-edit-enclose-kazu-signed-region (beg end) (interactive "*r") - (mime-edit-enclose-region-internal 'kazu-signed beg end) - ) + (mime-edit-enclose-region-internal 'kazu-signed beg end)) (defun mime-edit-enclose-kazu-encrypted-region (beg end) (interactive "*r") - (mime-edit-enclose-region-internal 'kazu-encrypted beg end) - ) + (mime-edit-enclose-region-internal 'kazu-encrypted beg end)) + +(defun mime-edit-enclose-smime-signed-region (beg end) + (interactive "*r") + (mime-edit-enclose-region-internal 'smime-signed beg end)) + +(defun mime-edit-enclose-smime-encrypted-region (beg end) + (interactive "*r") + (mime-edit-enclose-region-internal 'smime-encrypted beg end)) (defun mime-edit-insert-key (&optional arg) "Insert a pgp public key." (interactive "P") (mime-edit-insert-tag "application" "pgp-keys") (mime-edit-define-encoding "7bit") - (funcall (pgp-function 'insert-key)) - ) + (pgg-insert-key)) ;;; @ flag setting @@ -2358,13 +2303,11 @@ and insert data encoded as ENCODING." (defun mime-edit-set-split (arg) (interactive (list - (y-or-n-p "Do you want to enable split? ") - )) + (y-or-n-p "Do you want to enable split? "))) (setq mime-edit-split-message arg) (if arg (message "This message is enabled to split.") - (message "This message is not enabled to split.") - )) + (message "This message is not enabled to split."))) (defun mime-edit-toggle-transfer-level (&optional transfer-level) "Toggle transfer-level is 7bit or 8bit through. @@ -2375,24 +2318,20 @@ Optional TRANSFER-LEVEL is a number of transfer-level, 7 or 8." (setq mime-transfer-level transfer-level) (if (< mime-transfer-level 8) (setq mime-transfer-level 8) - (setq mime-transfer-level 7) - )) + (setq mime-transfer-level 7))) (message (format "Current transfer-level is %d bit" mime-transfer-level)) (setq mime-transfer-level-string (mime-encoding-name mime-transfer-level 'not-omit)) - (force-mode-line-update) - ) + (force-mode-line-update)) (defun mime-edit-set-transfer-level-7bit () (interactive) - (mime-edit-toggle-transfer-level 7) - ) + (mime-edit-toggle-transfer-level 7)) (defun mime-edit-set-transfer-level-8bit () (interactive) - (mime-edit-toggle-transfer-level 8) - ) + (mime-edit-toggle-transfer-level 8)) ;;; @ pgp @@ -2401,54 +2340,52 @@ Optional TRANSFER-LEVEL is a number of transfer-level, 7 or 8." (defvar mime-edit-pgp-processing nil) (make-variable-buffer-local 'mime-edit-pgp-processing) +(defvar mime-edit-pgp-user-id nil) + (defun mime-edit-set-sign (arg) (interactive (list - (y-or-n-p "Do you want to sign? ") - )) + (y-or-n-p "Do you want to sign? "))) (if arg (progn - (setq mime-edit-pgp-processing 'sign) - (message "This message will be signed.") - ) - (if (eq mime-edit-pgp-processing 'sign) - (setq mime-edit-pgp-processing nil) - ) - (message "This message will not be signed.") - )) + (or (memq 'sign mime-edit-pgp-processing) + (setq mime-edit-pgp-processing + (nconc mime-edit-pgp-processing + (copy-sequence '(sign))))) + (message "This message will be signed.")) + (setq mime-edit-pgp-processing + (delq 'sign mime-edit-pgp-processing)) + (message "This message will not be signed."))) (defun mime-edit-set-encrypt (arg) (interactive (list - (y-or-n-p "Do you want to encrypt? ") - )) + (y-or-n-p "Do you want to encrypt? "))) (if arg (progn - (setq mime-edit-pgp-processing 'encrypt) - (message "This message will be encrypt.") - ) - (if (eq mime-edit-pgp-processing 'encrypt) - (setq mime-edit-pgp-processing nil) - ) - (message "This message will not be encrypt.") - )) + (or (memq 'encrypt mime-edit-pgp-processing) + (setq mime-edit-pgp-processing + (nconc mime-edit-pgp-processing + (copy-sequence '(encrypt))))) + (message "This message will be encrypt.")) + (setq mime-edit-pgp-processing + (delq 'encrypt mime-edit-pgp-processing)) + (message "This message will not be encrypt."))) (defun mime-edit-pgp-enclose-buffer () (let ((beg (save-excursion (goto-char (point-min)) (if (search-forward (concat "\n" mail-header-separator "\n")) - (match-end 0) - ))) - (end (point-max)) - ) + (match-end 0))))) (if beg - (cond ((eq mime-edit-pgp-processing 'sign) - (mime-edit-enclose-pgp-signed-region beg end) - ) - ((eq mime-edit-pgp-processing 'encrypt) - (mime-edit-enclose-pgp-encrypted-region beg end) - )) - ))) + (dolist (pgp-processing mime-edit-pgp-processing) + (case pgp-processing + (sign + (mime-edit-enclose-pgp-signed-region + beg (point-max))) + (encrypt + (mime-edit-enclose-pgp-encrypted-region + beg (point-max)))))))) ;;; @ split @@ -2461,21 +2398,18 @@ Optional TRANSFER-LEVEL is a number of transfer-level, 7 or 8." (insert mime-edit-mime-version-field-for-message/partial) (insert (format "\ Content-Type: message/partial; id=%s; number=%d; total=%d\n%s\n" - id number total separator)) - ) + id number total separator))) (defun mime-edit-split-and-send (&optional cmd lines mime-edit-message-max-length) (interactive) (or lines (setq lines - (count-lines (point-min) (point-max))) - ) + (count-lines (point-min) (point-max)))) (or mime-edit-message-max-length (setq mime-edit-message-max-length (or (cdr (assq major-mode mime-edit-message-max-lines-alist)) - mime-edit-message-default-max-lines)) - ) + mime-edit-message-default-max-lines))) (let* ((mime-edit-draft-file-name (or (buffer-file-name) (make-temp-name @@ -2501,9 +2435,7 @@ Content-Type: message/partial; id=%s; number=%d; total=%d\n%s\n" (function (lambda () (interactive) - (error "Split sender is not specified for `%s'." major-mode) - )) - )) + (error "Split sender is not specified for `%s'." major-mode))))) (mime-edit-partial-number 1) data) (save-excursion @@ -2515,13 +2447,11 @@ Content-Type: message/partial; id=%s; number=%d; total=%d\n%s\n" (concat "^" (regexp-quote separator) "$") nil t) (let ((he (match-beginning 0))) (replace-match "") - (narrow-to-region (point-min) he) - )) + (narrow-to-region (point-min) he))) (goto-char (point-min)) (while (re-search-forward mime-edit-split-blind-field-regexp nil t) (delete-region (match-beginning 0) - (1+ (std11-field-end))) - ))) + (1+ (std11-field-end)))))) (while (< mime-edit-partial-number total) (erase-buffer) (save-excursion @@ -2530,10 +2460,8 @@ Content-Type: message/partial; id=%s; number=%d; total=%d\n%s\n" (point-min) (progn (goto-line mime-edit-message-max-length) - (point)) - )) - (delete-region (point-min)(point)) - ) + (point)))) + (delete-region (point-min)(point))) (mime-edit-insert-partial-header header subject id mime-edit-partial-number total separator) (insert data) @@ -2542,17 +2470,14 @@ Content-Type: message/partial; id=%s; number=%d; total=%d\n%s\n" mime-edit-partial-number total)) (call-interactively command) (message (format "Sending %d/%d... done" - mime-edit-partial-number total)) - ) + mime-edit-partial-number total))) (setq mime-edit-partial-number - (1+ mime-edit-partial-number)) - ) + (1+ mime-edit-partial-number))) (erase-buffer) (save-excursion (set-buffer copy-buf) (setq data (buffer-string)) - (erase-buffer) - ) + (erase-buffer)) (mime-edit-insert-partial-header header subject id mime-edit-partial-number total separator) (insert data) @@ -2560,9 +2485,7 @@ Content-Type: message/partial; id=%s; number=%d; total=%d\n%s\n" (message (format "Sending %d/%d..." mime-edit-partial-number total)) (message (format "Sending %d/%d... done" - mime-edit-partial-number total)) - ) - ))) + mime-edit-partial-number total)))))) (defun mime-edit-maybe-split-and-send (&optional cmd) (interactive) @@ -2570,12 +2493,10 @@ Content-Type: message/partial; id=%s; number=%d; total=%d\n%s\n" (let ((mime-edit-message-max-length (or (cdr (assq major-mode mime-edit-message-max-lines-alist)) mime-edit-message-default-max-lines)) - (lines (count-lines (point-min) (point-max))) - ) + (lines (count-lines (point-min) (point-max)))) (if (and (> lines mime-edit-message-max-length) mime-edit-split-message) - (mime-edit-split-and-send cmd lines mime-edit-message-max-length) - ))) + (mime-edit-split-and-send cmd lines mime-edit-message-max-length)))) ;;; @ preview message @@ -2592,31 +2513,28 @@ Content-Type: message/partial; id=%s; number=%d; total=%d\n%s\n" (buf-name (buffer-name)) (temp-buf-name (concat "*temp-article:" buf-name "*")) (buf (get-buffer temp-buf-name)) - ) + (pgp-processing mime-edit-pgp-processing)) (if buf (progn (switch-to-buffer buf) - (erase-buffer) - ) + (erase-buffer)) (setq buf (get-buffer-create temp-buf-name)) - (switch-to-buffer buf) - ) + (switch-to-buffer buf)) (insert str) (setq major-mode 'mime-temp-message-mode) (make-local-variable 'mail-header-separator) (setq mail-header-separator separator) (make-local-variable 'mime-edit-buffer) (setq mime-edit-buffer the-buf) + (setq mime-edit-pgp-processing pgp-processing) (run-hooks 'mime-edit-translate-hook) (mime-edit-translate-buffer) (goto-char (point-min)) (if (re-search-forward (concat "^" (regexp-quote separator) "$")) - (replace-match "") - ) - (mime-view-buffer) - )) + (replace-match "")) + (mime-view-buffer))) (defun mime-edit-quitting-method () "Quitting method for mime-view." @@ -2627,8 +2545,7 @@ Content-Type: message/partial; id=%s; number=%d; total=%d\n%s\n" (set-buffer temp) (setq buf mime-edit-buffer) (kill-buffer temp) - (switch-to-buffer buf) - )) + (switch-to-buffer buf))) (set-alist 'mime-preview-quitting-method-alist 'mime-temp-message-mode @@ -2651,7 +2568,12 @@ Content-Type: message/partial; id=%s; number=%d; total=%d\n%s\n" string)) (defun mime-edit-decode-multipart-in-buffer (content-type not-decode-text) - (let* ((subtype (mime-content-type-subtype content-type)) + (let* ((subtype + (or + (cdr (assoc (mime-content-type-parameter content-type "protocol") + '(("application/pgp-encrypted" . pgp-encrypted) + ("application/pgp-signature" . pgp-signed)))) + (mime-content-type-subtype content-type))) (boundary (mime-content-type-parameter content-type "boundary")) (boundary-pat (concat "\n--" (regexp-quote boundary) "[ \t]*\n"))) (re-search-forward boundary-pat nil t) @@ -2675,29 +2597,45 @@ Content-Type: message/partial; id=%s; number=%d; total=%d\n%s\n" (save-excursion (if (re-search-forward boundary-pat nil t) (setq end (match-beginning 0)) - (setq end (point-max)) - ) + (setq end (point-max))) (save-restriction (narrow-to-region beg end) - (mime-edit-decode-message-in-buffer - (if (eq subtype 'digest) - (eval-when-compile - (make-mime-content-type 'message 'rfc822)) - ) - not-decode-text) - (goto-char (point-max)) - )))) - )) + (cond + ((eq subtype 'pgp-encrypted) + (when (and + (progn + (goto-char (point-min)) + (re-search-forward "^-+BEGIN PGP MESSAGE-+$" + nil t)) + (prog1 + (save-window-excursion + (pgg-decrypt-region (match-beginning 0) + (point-max))) + (delete-region (point-min)(point-max)))) + (insert-buffer-substring pgg-output-buffer) + (mime-edit-decode-message-in-buffer + nil not-decode-text) + (delete-region (goto-char (point-min)) + (if (search-forward "\n\n" nil t) + (match-end 0) + (point-min))) + (goto-char (point-max)))) + (t + (mime-edit-decode-message-in-buffer + (if (eq subtype 'digest) + (eval-when-compile + (make-mime-content-type 'message 'rfc822))) + not-decode-text) + (goto-char (point-max)))))))))) (goto-char (point-min)) (or (= (point-min) 1) (delete-region (point-min) (if (search-forward "\n\n" nil t) (match-end 0) - (point-min) - ))) - )) + (point-min)))))) -(defun mime-edit-decode-single-part-in-buffer (content-type not-decode-text) +(defun mime-edit-decode-single-part-in-buffer + (content-type not-decode-text &optional content-disposition) (let* ((type (mime-content-type-primary-type content-type)) (subtype (mime-content-type-subtype content-type)) (ctype (format "%s/%s" type subtype)) @@ -2717,14 +2655,41 @@ Content-Type: message/partial; id=%s; number=%d; total=%d\n%s\n" (concat "; " str) (setq bytes (+ bs 1)) (concat ";\n " str) - ) - )))) + ))))) (mime-content-type-parameters content-type) ""))) encoding encoded (limit (save-excursion (if (search-forward "\n\n" nil t) - (1- (point)))))) + (1- (point))))) + (disposition-type + (mime-content-disposition-type content-disposition)) + (disposition-str + (if disposition-type + (let ((bytes (+ 21 (length (format "%s" disposition-type))))) + (mapconcat (function + (lambda (attr) + (let* ((str (concat + (car attr) + "=" + (if (string-equal "filename" + (car attr)) + (std11-wrap-as-quoted-string + (cdr attr)) + (cdr attr)))) + (bs (length str))) + (setq bytes (+ bytes bs 2)) + (if (< bytes 76) + (concat "; " str) + (setq bytes (+ bs 1)) + (concat ";\n " str) + )))) + (mime-content-disposition-parameters + content-disposition) + ""))))) + (if disposition-type + (setq pstr (format "%s\nContent-Disposition: %s%s" + pstr disposition-type disposition-str))) (save-excursion (if (re-search-forward "^Content-Transfer-Encoding:" limit t) @@ -2745,26 +2710,21 @@ Content-Type: message/partial; id=%s; number=%d; total=%d\n%s\n" (mime-decode-region (match-end 0)(point-max) encoding) (setq encoded t - encoding nil) - ))))))) + encoding nil)))))))) (if (or encoded (not not-decode-text)) (progn (save-excursion (goto-char (point-min)) (while (re-search-forward "\r\n" nil t) - (replace-match "\n") - )) + (replace-match "\n"))) (decode-mime-charset-region (point-min)(point-max) - (or charset default-mime-charset)) - )) + (or charset default-mime-charset)))) (let ((he (if (re-search-forward "^$" nil t) (match-end 0) - (point-min) - ))) + (point-min)))) (if (and (eq type 'text) (eq subtype 'x-rot13-47-48)) - (mule-caesar-region he (point-max)) - ) + (mule-caesar-region he (point-max))) (if (= (point-min) 1) (progn (goto-char he) @@ -2772,14 +2732,11 @@ Content-Type: message/partial; id=%s; number=%d; total=%d\n%s\n" (concat "\n" (mime-create-tag (format "%s/%s%s" type subtype pstr) - encoding))) - ) + encoding)))) (delete-region (point-min) he) (insert (mime-create-tag (format "%s/%s%s" type subtype pstr) - encoding)) - )) - )) + encoding)))))) ;;;###autoload (defun mime-edit-decode-message-in-buffer (&optional default-content-type @@ -2793,26 +2750,24 @@ Content-Type: message/partial; id=%s; number=%d; total=%d\n%s\n" (cond ((and (eq type 'application) (eq (mime-content-type-subtype ctl) 'pgp-signature)) - (delete-region (point-min)(point-max)) - ) + (delete-region (point-min)(point-max))) ((eq type 'multipart) - (mime-edit-decode-multipart-in-buffer ctl not-decode-text) - ) + (mime-edit-decode-multipart-in-buffer ctl not-decode-text)) (t - (mime-edit-decode-single-part-in-buffer ctl not-decode-text) - ))) + (mime-edit-decode-single-part-in-buffer + ctl not-decode-text (mime-read-Content-Disposition))))) (or not-decode-text (decode-mime-charset-region (point-min) (point-max) - default-mime-charset)) - ) - (save-restriction - (std11-narrow-to-header) - (goto-char (point-min)) - (while (re-search-forward mime-edit-again-ignored-field-regexp nil t) - (delete-region (match-beginning 0) (1+ (std11-field-end))) - )) - (mime-decode-header-in-buffer (not not-decode-text)) - ))) + default-mime-charset))) + (if (= (point-min) 1) + (progn + (save-restriction + (std11-narrow-to-header) + (goto-char (point-min)) + (while (re-search-forward + mime-edit-again-ignored-field-regexp nil t) + (delete-region (match-beginning 0) (1+ (std11-field-end))))) + (mime-decode-header-in-buffer (not not-decode-text))))))) ;;;###autoload (defun mime-edit-again (&optional not-decode-text no-separator not-turn-on) @@ -2824,17 +2779,14 @@ converted to MIME-Edit tags." (if (search-forward (concat "\n" (regexp-quote mail-header-separator) "\n") nil t) - (replace-match "\n\n") - ) + (replace-match "\n\n")) (mime-edit-decode-message-in-buffer nil not-decode-text) (goto-char (point-min)) (or no-separator (and (re-search-forward "^$") - (replace-match mail-header-separator) - )) + (replace-match mail-header-separator))) (or not-turn-on - (turn-on-mime-edit) - )) + (turn-on-mime-edit))) ;;; @ end diff --git a/mime-image.el b/mime-image.el index d5e4aa0..ac3e957 100644 --- a/mime-image.el +++ b/mime-image.el @@ -4,7 +4,9 @@ ;; Copyright (C) 1996 Dan Rich ;; Author: MORIOKA Tomohiko -;; Dan Rich +;; Dan Rich +;; Daiki Ueno +;; Katsumi Yamaoka ;; Maintainer: MORIOKA Tomohiko ;; Created: 1995/12/15 ;; Renamed: 1997/2/21 from tm-image.el @@ -34,139 +36,194 @@ ;;; Code: +(eval-when-compile (require 'static)) + (require 'mime-view) (require 'alist) - -(cond ((featurep 'xemacs) - (require 'images) - - (defun-maybe image-inline-p (format) - (or (memq format image-native-formats) - (find-if (function - (lambda (native) - (image-converter-chain format native) - )) - image-native-formats) - )) - - (image-register-netpbm-utilities) - (image-register-converter 'pic 'ppm "pictoppm") - (image-register-converter 'mag 'ppm "magtoppm") - - (defun bitmap-insert-xbm-file (file) - (let ((gl (make-glyph (list (cons 'x file)))) - (e (make-extent (point) (point))) - ) - (set-extent-end-glyph e gl) - )) - - ;; - ;; X-Face - ;; - (autoload 'highlight-headers "highlight-headers") - - (defun mime-preview-x-face-function-use-highlight-headers () - (highlight-headers (point-min) (re-search-forward "^$" nil t) t) - ) - - (add-hook 'mime-display-header-hook - 'mime-preview-x-face-function-use-highlight-headers) - - ) - ((featurep 'mule) - ;; for MULE 2.* or mule merged EMACS - (require 'x-face-mule) - - (defvar image-native-formats '(xbm)) - - (defun-maybe image-inline-p (format) - (memq format image-native-formats) - ) - - (defun-maybe image-normalize (format data) - (and (eq format 'xbm) - (vector 'xbm ':data data) - )) - - ;; - ;; X-Face - ;; - (if (exec-installed-p uncompface-program exec-path) - (add-hook 'mime-display-header-hook - 'x-face-decode-message-header) - ) - )) - -(or (fboundp 'image-invalid-glyph-p) - (defsubst image-invalid-glyph-p (glyph) - (or (null (aref glyph 0)) - (null (aref glyph 2)) - (equal (aref glyph 2) "") - )) - ) - -(mapcar (function - (lambda (rule) - (let ((type (car rule)) - (subtype (nth 1 rule)) - (format (nth 2 rule))) - (if (image-inline-p format) - (ctree-set-calist-strictly - 'mime-preview-condition - (list (cons 'type type)(cons 'subtype subtype) - '(body . visible) - (cons 'body-presentation-method #'mime-display-image) - (cons 'image-format format)) - ))))) - '((image jpeg jpeg) - (image gif gif) - (image tiff tiff) - (image x-tiff tiff) - (image xbm xbm) - (image x-xbm xbm) - (image x-xpixmap xpm) - (image x-pic pic) - (image x-mag mag) - (image png png) - )) +(require 'path-util) + +(cond + ((featurep 'xemacs) + + (require 'images) + + (defun-maybe image-inline-p (format) + (or (memq format image-native-formats) + (find-if (function + (lambda (native) + (image-converter-chain format native))) + image-native-formats))) + + (image-register-netpbm-utilities) + (image-register-converter 'pic 'ppm "pictoppm") + (image-register-converter 'mag 'ppm "magtoppm") + + (defun image-insert-at-point (image) + (let ((e (make-extent (point) (point)))) + (set-extent-end-glyph e (make-glyph image)))) + + (defsubst-maybe image-invalid-glyph-p (glyph) + (or (null (aref glyph 0)) + (null (aref glyph 2)) + (equal (aref glyph 2) "")))) + ((featurep 'mule) + + (eval-when-compile (ignore-errors (require 'image))) + + (eval-and-compile + (autoload 'bitmap-insert-xbm-buffer "bitmap")) + + (static-if (fboundp 'image-type-available-p) + (defalias-maybe 'image-inline-p 'image-type-available-p) + (defvar image-native-formats '(xbm)) + (defun-maybe image-inline-p (format) + (memq format image-native-formats))) + + (static-unless (or (not (fboundp 'create-image)) + (memq 'data-p (aref (symbol-function 'create-image) 0))) + (defadvice create-image + (around data-p (file-or-data &optional type data-p &rest props) activate) + (if (ad-get-arg 2) + (setq ad-return-value + (nconc + (list 'image ':type (ad-get-arg 1) ':data (ad-get-arg 0)) + props)) + (ad-set-args 0 (list (ad-get-arg 0) (ad-get-arg 1) (ad-get-arg 3))) + ad-do-it))) + + (defun-maybe image-normalize (format data) + (if (memq format '(xbm xpm)) + (create-image data format 'data) + (let ((image-file + (make-temp-name + (expand-file-name "tm" temporary-file-directory)))) + (with-temp-buffer + (insert data) + (write-region-as-binary (point-min)(point-max) image-file)) + (create-image image-file format)))) + + (defun image-insert-at-point (image) + (static-if (fboundp 'insert-image) + (unwind-protect + (save-excursion + (static-if (condition-case nil + (progn (insert-image '(image)) nil) + (wrong-number-of-arguments t)) + (insert-image image "x") + (insert-image image)) + (insert "\n") + (save-window-excursion + (set-window-buffer (selected-window)(current-buffer)) + (sit-for 0))) + (let ((file (plist-get (cdr image) ':file))) + (and file (file-exists-p file) + (delete-file file)))) + (when (eq (plist-get (cdr image) ':type) 'xbm) + (save-restriction + (narrow-to-region (point)(point)) + (insert (plist-get (cdr image) ':data)) + (let ((mark (set-marker (make-marker) (point)))) + (bitmap-insert-xbm-buffer (current-buffer)) + (delete-region (point-min) mark)))))) + + (defsubst-maybe image-invalid-glyph-p (glyph) + (not (eq 'image (nth 0 glyph)))))) + +;; +;; X-Face +;; + +(cond + ((module-installed-p 'highlight-headers) + (eval-and-compile + (autoload 'highlight-headers "highlight-headers")) + + (defun mime-preview-x-face-function-use-highlight-headers () + (highlight-headers (point-min) (re-search-forward "^$" nil t) t)) + (add-hook 'mime-display-header-hook + 'mime-preview-x-face-function-use-highlight-headers)) + ((and (featurep 'mule) + (condition-case nil + (require 'x-face-mule) + (file-error nil)) + (exec-installed-p uncompface-program exec-path)) + (add-hook 'mime-display-header-hook 'x-face-decode-message-header))) + +(defvar mime-image-format-alist + '((image jpeg jpeg) + (image gif gif) + (image tiff tiff) + (image x-tiff tiff) + (image xbm xbm) + (image x-xbm xbm) + (image x-xpixmap xpm) + (image x-pic pic) + (image x-mag mag) + (image png png))) + +(dolist (rule mime-image-format-alist) + (let ((type (car rule)) + (subtype (nth 1 rule)) + (format (nth 2 rule))) + (when (image-inline-p format) + (ctree-set-calist-strictly + 'mime-preview-condition + (list (cons 'type type)(cons 'subtype subtype) + '(body . visible) + (cons 'body-presentation-method #'mime-display-image) + (cons 'image-format format)))))) ;;; @ content filter for images ;;; ;; (for XEmacs 19.12 or later) +(eval-when-compile + (defmacro mime-image-normalize-xbm (entity) + (` (with-temp-buffer + (mime-insert-entity-content (, entity)) + (let ((cur (current-buffer)) + width height) + (goto-char (point-min)) + (search-forward "width ") + (setq width (read cur)) + (goto-char (point-min)) + (search-forward "height ") + (setq height (read cur)) + (goto-char (point-min)) + (search-forward "{") + (delete-region (point-min) (point)) + (insert "\"") + (search-forward "}") + (delete-region (1- (point)) (point-max)) + (insert "\"") + (goto-char (point-min)) + (while (re-search-forward "[^\"0-9A-FXa-fx]+" nil t) + (replace-match "")) + (goto-char (point-min)) + (while (search-forward "0x" nil t) + (replace-match "\\\\x")) + (goto-char (point-min)) + (, (if (featurep 'xemacs) + (` (vector 'xbm :data + (list width height (read cur)))) + '(` (image :type xbm :width (, width) :height (, height) + :data (, (read cur))))))))))) + (defun mime-display-image (entity situation) (message "Decoding image...") - (let ((gl (image-normalize (cdr (assq 'image-format situation)) - (mime-entity-content entity)))) - (cond ((image-invalid-glyph-p gl) - (setq gl nil) - (message "Invalid glyph!") - ) - ((eq (aref gl 0) 'xbm) - (let ((xbm-file - (make-temp-name - (expand-file-name "tm" temporary-file-directory)))) - (with-temp-buffer - (insert (aref gl 2)) - (write-region (point-min)(point-max) xbm-file) - ) - (message "Decoding image...") - (bitmap-insert-xbm-file xbm-file) - (delete-file xbm-file) - ) - (message "Decoding image... done") - ) - (t - (setq gl (make-glyph gl)) - (let ((e (make-extent (point) (point)))) - (set-extent-end-glyph e gl) - ) - (message "Decoding image... done") - )) - ) - (insert "\n") - ) + (let* ((format (cdr (assq 'image-format situation))) + (image (if (or (featurep 'xemacs) (boundp 'image-types)) + (if (eq 'xbm format) + (mime-image-normalize-xbm entity) + (image-normalize format (mime-entity-content entity))) + (image-normalize format (mime-entity-content entity))))) + (if (image-invalid-glyph-p image) + (message "Invalid glyph!") + (image-insert-at-point image) + (message "Decoding image... done"))) + (static-when (featurep 'xemacs) + (insert "\n"))) ;;; @ end diff --git a/mime-partial.el b/mime-partial.el index 618c5a6..2243882 100644 --- a/mime-partial.el +++ b/mime-partial.el @@ -47,18 +47,15 @@ automatically." (setq full-file (concat root-dir "/FULL")) (if (null target) - (error "%s is not supported. Sorry." target) - ) + (error "%s is not supported. Sorry." target)) ;; if you can't parse the subject line, try simple decoding method (if (or (file-exists-p full-file) - (not (y-or-n-p "Merge partials?")) - ) + (not (y-or-n-p "Merge partials?"))) (mime-store-message/partial-piece entity situation) (setq subject-id (mime-entity-read-field entity 'Subject)) (if (string-match "[0-9\n]+" subject-id) - (setq subject-id (substring subject-id 0 (match-beginning 0))) - ) + (setq subject-id (substring subject-id 0 (match-beginning 0)))) (save-excursion (set-buffer subject-buf) (while (search-backward subject-id nil t)) @@ -67,25 +64,18 @@ automatically." (let* ((message ;; request message at the cursor in Subject buffer. (save-window-excursion - (funcall request-partial-message-method) - )) + (funcall request-partial-message-method))) (situation (mime-entity-situation message)) (the-id (cdr (assoc "id" situation)))) (when (string= the-id id) (with-current-buffer mother - (mime-store-message/partial-piece message situation) - ) + (mime-store-message/partial-piece message situation)) (if (file-exists-p full-file) - (throw 'tag nil) - )) + (throw 'tag nil))) (if (not (progn (end-of-line) - (search-forward subject-id nil t) - )) - (error "not found") - ) - )) - ))))) + (search-forward subject-id nil t))) + (error "not found"))))))))) ;;; @ end diff --git a/mime-pgp.el b/mime-pgp.el index fb76f45..7bfdb61 100644 --- a/mime-pgp.el +++ b/mime-pgp.el @@ -3,6 +3,7 @@ ;; Copyright (C) 1995,1996,1997,1998,1999 MORIOKA Tomohiko ;; Author: MORIOKA Tomohiko +;; Daiki Ueno ;; Created: 1995/12/7 ;; Renamed: 1997/2/27 from tm-pgp.el ;; Keywords: PGP, security, MIME, multimedia, mail, news @@ -41,9 +42,25 @@ ;; by Kazuhiko Yamamoto (1995/10; ;; expired) +;; [OpenPGP/MIME] draft-yamamoto-openpgp-mime-00.txt: "MIME +;; Security with OpenPGP (OpenPGP/MIME)" by Kazuhiko YAMAMOTO +;; (1998/1) + ;;; Code: (require 'mime-play) +(require 'pgg-def) + +(autoload 'pgg-decrypt-region "pgg" + "PGP decryption of current region." t) +(autoload 'pgg-verify-region "pgg" + "PGP verification of current region." t) +(autoload 'pgg-snarf-keys-region "pgg" + "Snarf PGP public keys in current region." t) +(autoload 'smime-decrypt-region "smime" + "S/MIME decryption of current region.") +(autoload 'smime-verify-region "smime" + "S/MIME verification of current region.") ;;; @ Internal method for multipart/signed @@ -68,6 +85,7 @@ (new-name (format "%s-%s" (buffer-name) (mime-entity-number entity))) (mother (current-buffer)) + (preview-buffer (concat "*Preview-" (buffer-name) "*")) representation-type) (set-buffer (get-buffer-create new-name)) (erase-buffer) @@ -75,7 +93,7 @@ (cond ((progn (goto-char (point-min)) (re-search-forward "^-+BEGIN PGP SIGNED MESSAGE-+$" nil t)) - (funcall (pgp-function 'verify)) + (pgg-verify-region (match-beginning 0)(point-max) nil 'fetch) (goto-char (point-min)) (delete-region (point-min) @@ -88,69 +106,26 @@ (point-max)) (goto-char (point-min)) (while (re-search-forward "^- -" nil t) - (replace-match "-") - ) + (replace-match "-")) (setq representation-type (if (mime-entity-cooked-p entity) - 'cooked)) - ) + 'cooked))) ((progn (goto-char (point-min)) (re-search-forward "^-+BEGIN PGP MESSAGE-+$" nil t)) - (as-binary-process (funcall (pgp-function 'decrypt))) - (goto-char (point-min)) - (delete-region (point-min) - (and - (search-forward "\n\n") - (match-end 0))) - (setq representation-type 'binary) - )) + (pgg-decrypt-region (point-min)(point-max)) + (delete-region (point-min)(point-max)) + (insert-buffer pgg-output-buffer) + (setq representation-type 'binary))) (setq major-mode 'mime-show-message-mode) - (save-window-excursion (mime-view-buffer nil nil mother + (save-window-excursion (mime-view-buffer nil preview-buffer mother nil representation-type)) - (set-window-buffer p-win mime-preview-buffer) - )) + (set-window-buffer p-win preview-buffer))) ;;; @ Internal method for application/pgp-signature ;;; -;;; It is based on RFC 2015 (PGP/MIME). - -(defvar mime-pgp-command "pgp" - "*Name of the PGP command.") - -(defvar mime-pgp-default-language 'en - "*Symbol of language for pgp. -It should be ISO 639 2 letter language code such as en, ja, ...") - -(defvar mime-pgp-good-signature-regexp-alist - '((en . "Good signature from user.*$")) - "Alist of language vs regexp to detect ``Good signature''.") - -(defvar mime-pgp-key-expected-regexp-alist - '((en . "Key matching expected Key ID \\(\\S +\\) not found")) - "Alist of language vs regexp to detect ``Key expected''.") - -(defun mime-pgp-check-signature (output-buffer sig-file orig-file) - (save-excursion - (set-buffer output-buffer) - (erase-buffer)) - (let* ((lang (or mime-pgp-default-language 'en)) - (status (call-process-region (point-min)(point-max) - mime-pgp-command - nil output-buffer nil - sig-file orig-file (format "+language=%s" lang))) - (regexp (cdr (assq lang mime-pgp-good-signature-regexp-alist)))) - (if (= status 0) - (save-excursion - (set-buffer output-buffer) - (goto-char (point-min)) - (message - (cond ((not (stringp regexp)) - "Please specify right regexp for specified language") - ((re-search-forward regexp nil t) - (buffer-substring (match-beginning 0) (match-end 0))) - (t "Bad signature"))) - )))) +;;; It is based on RFC 2015 (PGP/MIME) and +;;; draft-yamamoto-openpgp-mime-00.txt (OpenPGP/MIME). (defun mime-verify-application/pgp-signature (entity situation) "Internal method to check PGP/MIME signature." @@ -162,49 +137,35 @@ It should be ISO 639 2 letter language code such as en, ja, ...") (1+ knum))) (orig-entity (nth onum (mime-entity-children mother))) (basename (expand-file-name "tm" temporary-file-directory)) - (orig-file (make-temp-name basename)) - (sig-file (concat orig-file ".sig")) - ) - (mime-write-entity orig-entity orig-file) - (save-excursion (mime-show-echo-buffer)) + (sig-file (concat (make-temp-name basename) ".asc")) + status) + (save-excursion + (mime-show-echo-buffer) + (set-buffer mime-echo-buffer-name) + (set-window-start + (get-buffer-window mime-echo-buffer-name) + (point-max))) (mime-write-entity-content entity sig-file) - (or (mime-pgp-check-signature mime-echo-buffer-name sig-file orig-file) - (let (pgp-id) - (save-excursion + (unwind-protect + (with-temp-buffer + (mime-insert-entity orig-entity) + (goto-char (point-min)) + (while (progn (end-of-line) (not (eobp))) + (insert "\r") + (forward-line 1)) + (setq status (pgg-verify-region (point-min)(point-max) + sig-file 'fetch)) + (save-excursion (set-buffer mime-echo-buffer-name) - (goto-char (point-min)) - (let ((regexp (cdr (assq (or mime-pgp-default-language 'en) - mime-pgp-key-expected-regexp-alist)))) - (cond ((not (stringp regexp)) - (message - "Please specify right regexp for specified language") - ) - ((re-search-forward regexp nil t) - (setq pgp-id - (concat "0x" (buffer-substring-no-properties - (match-beginning 1) - (match-end 1)))) - )))) - (if (and pgp-id - (y-or-n-p - (format "Key %s not found; attempt to fetch? " pgp-id)) - ) - (progn - (funcall (pgp-function 'fetch-key) (cons nil pgp-id)) - (mime-pgp-check-signature mime-echo-buffer-name orig-file) - )) - )) - (let ((other-window-scroll-buffer mime-echo-buffer-name)) - (scroll-other-window 8) - ) - (delete-file orig-file) - (delete-file sig-file) - )) + (insert-buffer-substring (if status pgg-output-buffer + pgg-errors-buffer)))) + (delete-file sig-file)))) ;;; @ Internal method for application/pgp-encrypted ;;; -;;; It is based on RFC 2015 (PGP/MIME). +;;; It is based on RFC 2015 (PGP/MIME) and +;;; draft-yamamoto-openpgp-mime-00.txt (OpenPGP/MIME). (defun mime-decrypt-application/pgp-encrypted (entity situation) (let* ((entity-node-id (mime-entity-node-id entity)) @@ -214,36 +175,98 @@ It should be ISO 639 2 letter language code such as en, ja, ...") (1- knum) (1+ knum))) (orig-entity (nth onum (mime-entity-children mother)))) - (mime-view-application/pgp orig-entity situation) - )) + (mime-view-application/pgp orig-entity situation))) ;;; @ Internal method for application/pgp-keys ;;; -;;; It is based on RFC 2015 (PGP/MIME). +;;; It is based on RFC 2015 (PGP/MIME) and +;;; draft-yamamoto-openpgp-mime-00.txt (OpenPGP/MIME). (defun mime-add-application/pgp-keys (entity situation) - (let* ((start (mime-entity-point-min entity)) - (end (mime-entity-point-max entity)) - (entity-number (mime-entity-number entity)) - (new-name (format "%s-%s" (buffer-name) entity-number)) - (encoding (cdr (assq 'encoding situation))) - str) - (setq str (buffer-substring start end)) - (switch-to-buffer new-name) - (setq buffer-read-only nil) - (erase-buffer) - (insert str) - (goto-char (point-min)) - (if (re-search-forward "^\n" nil t) - (delete-region (point-min) (match-end 0)) - ) - (mime-decode-region (point-min)(point-max) encoding) - (funcall (pgp-function 'snarf-keys)) - (kill-buffer (current-buffer)) - )) - - + (save-excursion + (mime-show-echo-buffer) + (set-buffer mime-echo-buffer-name) + (set-window-start + (get-buffer-window mime-echo-buffer-name) + (point-max))) + (with-temp-buffer + (mime-insert-entity-content entity) + (mime-decode-region (point-min) (point-max) + (cdr (assq 'encoding situation))) + (let ((status (pgg-snarf-keys-region (point-min)(point-max)))) + (save-excursion + (set-buffer mime-echo-buffer-name) + (insert-buffer-substring (if status pgg-output-buffer + pgg-errors-buffer)))))) + + +;;; @ Internal method for application/pkcs7-signature +;;; +;;; It is based on RFC 2633 (S/MIME version 3). + +(defun mime-verify-application/pkcs7-signature (entity situation) + "Internal method to check S/MIME signature." + (let* ((entity-node-id (mime-entity-node-id entity)) + (mother (mime-entity-parent entity)) + (knum (car entity-node-id)) + (onum (if (> knum 0) + (1- knum) + (1+ knum))) + (orig-entity (nth onum (mime-entity-children mother))) + (basename (expand-file-name "tm" temporary-file-directory)) + (sig-file (concat (make-temp-name basename) ".asc")) + status) + (save-excursion + (mime-show-echo-buffer) + (set-buffer mime-echo-buffer-name) + (set-window-start + (get-buffer-window mime-echo-buffer-name) + (point-max))) + (mime-write-entity entity sig-file) + (unwind-protect + (with-temp-buffer + (mime-insert-entity orig-entity) + (goto-char (point-min)) + (while (progn (end-of-line) (not (eobp))) + (insert "\r") + (forward-line 1)) + (setq status (smime-verify-region (point-min)(point-max) + sig-file)) + (save-excursion + (set-buffer mime-echo-buffer-name) + (insert-buffer-substring (if status smime-output-buffer + smime-errors-buffer)))) + (delete-file sig-file)))) + + +;;; @ Internal method for application/pkcs7-mime +;;; +;;; It is based on RFC 2633 (S/MIME version 3). + +(defun mime-view-application/pkcs7-mime (entity situation) + (let* ((p-win (or (get-buffer-window (current-buffer)) + (get-largest-window))) + (new-name + (format "%s-%s" (buffer-name) (mime-entity-number entity))) + (mother (current-buffer)) + (preview-buffer (concat "*Preview-" (buffer-name) "*"))) + (when (memq (or (cdr (assq 'smime-type situation)) enveloped-data) + '(enveloped-data signed-data)) + (set-buffer (get-buffer-create new-name)) + (let ((inhibit-read-only t) + buffer-read-only) + (erase-buffer) + (mime-insert-entity entity) + (smime-decrypt-region (point-min)(point-max)) + (delete-region (point-min)(point-max)) + (insert-buffer smime-output-buffer)) + (setq major-mode 'mime-show-message-mode) + (save-window-excursion (mime-view-buffer nil preview-buffer mother + nil 'binary)) + (set-window-buffer p-win preview-buffer)))) + + ;;; @ end ;;; diff --git a/mime-play.el b/mime-play.el index 1e7e35b..a114399 100644 --- a/mime-play.el +++ b/mime-play.el @@ -34,8 +34,7 @@ (eval-when-compile (condition-case nil (require 'bbdb) - (error (defvar bbdb-buffer-name nil))) - ) + (error (defvar bbdb-buffer-name nil)))) (defcustom mime-save-directory "~/" "*Name of the directory where MIME entity will be saved in. @@ -100,8 +99,7 @@ If t, it means current directory." min-freq freq d-i i d-j j - dest (cons (cdr ret) freq)) - ) + dest (cons (cdr ret) freq))) ((= max-sim sim) (cond ((> min-det-ret det-ret) (setq min-det-ret det-ret @@ -109,27 +107,20 @@ If t, it means current directory." min-freq freq d-i i d-j j - dest (cons (cdr ret) freq)) - ) + dest (cons (cdr ret) freq))) ((= min-det-ret det-ret) (cond ((> min-det-org det-org) (setq min-det-org det-org min-freq freq d-i i d-j j - dest (cons (cdr ret) freq)) - ) + dest (cons (cdr ret) freq))) ((= min-det-org det-org) (cond ((> min-freq freq) (setq min-freq freq d-i i d-j j - dest (cons (cdr ret) freq)) - )) - )) - )) - )) - ) + dest (cons (cdr ret) freq))))))))))) (setq jr (cdr jr) j (1+ j))) (setq ir (cdr ir) @@ -144,13 +135,11 @@ If t, it means current directory." (setq mime-acting-situation-example-list (cdr mime-acting-situation-example-list)) (setq ir (nthcdr (1- d-i) mime-acting-situation-example-list)) - (setcdr ir (cddr ir)) - ) + (setcdr ir (cddr ir))) (if (setq ir (assoc (car dest) mime-acting-situation-example-list)) (setcdr ir (+ (cdr ir)(cdr dest))) (setq mime-acting-situation-example-list - (cons dest mime-acting-situation-example-list)) - ))) + (cons dest mime-acting-situation-example-list))))) ;;; @ content decoder @@ -180,8 +169,7 @@ If MODE is specified, play as it. Default MODE is \"play\"." (setq situation (cons (cons 'ignore-examples ignore-examples) situation))) - (mime-play-entity entity situation) - )))) + (mime-play-entity entity situation))))) (defun mime-sort-situation (situation) (sort situation @@ -193,30 +181,23 @@ If MODE is specified, play as it. Default MODE is \"play\"." (mode . 3) (method . 4) (major-mode . 5) - (disposition-type . 6) - )) + (disposition-type . 6))) a-order b-order) (if (symbolp a-t) (let ((ret (assq a-t order))) (if ret (setq a-order (cdr ret)) - (setq a-order 7) - )) - (setq a-order 8) - ) + (setq a-order 7))) + (setq a-order 8)) (if (symbolp b-t) (let ((ret (assq b-t order))) (if ret (setq b-order (cdr ret)) - (setq b-order 7) - )) - (setq b-order 8) - ) + (setq b-order 7))) + (setq b-order 8)) (if (= a-order b-order) (string< (format "%s" a-t)(format "%s" b-t)) - (< a-order b-order)) - ))) - ) + (< a-order b-order)))))) (defsubst mime-delq-null-situation (situations field &optional ignored-value) @@ -226,8 +207,7 @@ If MODE is specified, play as it. Default MODE is \"play\"." (cell (assq field situation))) (if cell (or (eq (cdr cell) ignored-value) - (setq dest (cons situation dest)) - ))) + (setq dest (cons situation dest))))) (setq situations (cdr situations))) dest)) @@ -241,13 +221,9 @@ If MODE is specified, play as it. Default MODE is \"play\"." (when ecell (if (equal cell ecell) (setq match (1+ match)) - (setq example (delq ecell example)) - )) - ) - (setq situation (cdr situation)) - ) - (cons match example) - )) + (setq example (delq ecell example))))) + (setq situation (cdr situation))) + (cons match example))) ;;;###autoload (defun mime-play-entity (entity &optional situation ignored-method) @@ -282,21 +258,18 @@ specified, play as it. Default MODE is \"play\"." (setq max-score ret-score max-escore (cdar examples) max-examples (list (cdr ret)) - max-situations (list situation)) - ) + max-situations (list situation))) ((= ret-score max-score) (cond ((> (cdar examples) max-escore) (setq max-escore (cdar examples) max-examples (list (cdr ret)) - max-situations (list situation)) - ) + max-situations (list situation))) ((= (cdar examples) max-escore) (setq max-examples (cons (cdr ret) max-examples)) (or (member situation max-situations) (setq max-situations - (cons situation max-situations))) - ))))) + (cons situation max-situations)))))))) (setq examples (cdr examples)))) (setq rest (cdr rest))) (when max-situations @@ -309,10 +282,8 @@ specified, play as it. Default MODE is \"play\"." (setcdr cell (1+ (cdr cell))) (setq mime-acting-situation-example-list (cons (cons example 0) - mime-acting-situation-example-list)) - )) - (setq max-examples (cdr max-examples)) - ))))) + mime-acting-situation-example-list)))) + (setq max-examples (cdr max-examples))))))) (cond ((cdr ret) (setq ret (select-menu-alist "Methods" @@ -324,19 +295,15 @@ specified, play as it. Default MODE is \"play\"." situation))) ret))) (setq ret (mime-sort-situation ret)) - (add-to-list 'mime-acting-situation-example-list (cons ret 0)) - ) + (add-to-list 'mime-acting-situation-example-list (cons ret 0))) (t - (setq ret (car ret)) - )) + (setq ret (car ret)))) (setq method (cdr (assq 'method ret))) (cond ((and (symbolp method) (fboundp method)) - (funcall method entity ret) - ) + (funcall method entity ret)) ((stringp method) - (mime-activate-mailcap-method entity ret) - ) + (mime-activate-mailcap-method entity ret)) ;; ((and (listp method)(stringp (car method))) ;; (mime-activate-external-method entity ret) ;; ) @@ -346,9 +313,7 @@ specified, play as it. Default MODE is \"play\"." (cdr (assq 'type situation)) (cdr (assq 'subtype situation)))) (if (y-or-n-p "Do you want to save current entity to disk?") - (mime-save-content entity situation)) - )) - )) + (mime-save-content entity situation)))))) ;;; @ external decoder @@ -363,8 +328,7 @@ specified, play as it. Default MODE is \"play\"." (if (and name (not (string= name ""))) (expand-file-name name temporary-file-directory) (make-temp-name - (expand-file-name "EMI" temporary-file-directory)) - )) + (expand-file-name "EMI" temporary-file-directory)))) (mime-write-entity-content entity name) (message "External method is starting...") (let ((process @@ -373,18 +337,14 @@ specified, play as it. Default MODE is \"play\"." method (cons (cons 'filename name) situation)))) (start-process command mime-echo-buffer-name - shell-file-name shell-command-switch command) - ))) + shell-file-name shell-command-switch command)))) (set-alist 'mime-mailcap-method-filename-alist process name) - (set-process-sentinel process 'mime-mailcap-method-sentinel) - ) - )) + (set-process-sentinel process 'mime-mailcap-method-sentinel)))) (defun mime-mailcap-method-sentinel (process event) (let ((file (cdr (assq process mime-mailcap-method-filename-alist)))) (if (file-exists-p file) - (delete-file file) - )) + (delete-file file))) (remove-alist 'mime-mailcap-method-filename-alist process) (message (format "%s %s" process event))) @@ -395,8 +355,7 @@ specified, play as it. Default MODE is \"play\"." (defvar mime-echo-window-height (function (lambda () - (/ (window-height) 5) - )) + (/ (window-height) 5))) "*Size of mime-echo window. It allows function or integer. If it is function, `mime-show-echo-buffer' calls it to get height of mime-echo window. @@ -419,19 +378,14 @@ window.") (- (window-height) (if (functionp mime-echo-window-height) (funcall mime-echo-window-height) - mime-echo-window-height) - ))) - ) - (set-window-buffer win mime-echo-buffer-name) - ) + mime-echo-window-height))))) + (set-window-buffer win mime-echo-buffer-name)) (select-window win) (goto-char (point-max)) (if forms (let ((buffer-read-only nil)) - (insert (apply (function format) forms)) - )) - (select-window the-win) - )) + (insert (apply (function format) forms)))) + (select-window the-win))) ;;; @ file name @@ -456,11 +410,9 @@ window.") (if (and subj (or (string-match mime-view-file-name-regexp-1 subj) (string-match mime-view-file-name-regexp-2 subj))) - (substring subj (match-beginning 0)(match-end 0)) - ))))) + (substring subj (match-beginning 0)(match-end 0))))))) (if filename - (replace-as-filename filename) - ))) + (replace-as-filename filename)))) ;;; @ file extraction @@ -520,8 +472,7 @@ window.") ("^II\\*\000" image tiff) ("^MM\000\\*" image tiff) ("^MThd" audio midi) - ("^\000\000\001\263" video mpeg) - ) + ("^\000\000\001\263" video mpeg)) "*Alist of regexp about magic-number vs. corresponding media-types. Each element looks like (REGEXP TYPE SUBTYPE). REGEXP is a regular expression to match against the beginning of the @@ -537,8 +488,7 @@ SUBTYPE is symbol to indicate subtype of media-type.") (if cell (if (string-match (car cell) mdata) (setq type (nth 1 cell) - subtype (nth 2 cell)) - ) + subtype (nth 2 cell))) t))) (setq rest (cdr rest)))) (setq situation (del-alist 'method (copy-alist situation))) @@ -564,8 +514,7 @@ It is registered to variable `mime-preview-quitting-method-alist'." (kill-buffer raw-buffer) (mime-preview-kill-buffer) (set-window-configuration win-conf) - (pop-to-buffer mother) - )) + (pop-to-buffer mother))) (defun mime-view-message/rfc822 (entity situation) (let* ((new-name @@ -581,8 +530,7 @@ It is registered to variable `mime-preview-quitting-method-alist'." (let ((m-win (get-buffer-window mother))) (if m-win (set-window-buffer m-win preview-buffer) - (switch-to-buffer preview-buffer) - ))))) + (switch-to-buffer preview-buffer)))))) ;;; @ message/partial @@ -615,11 +563,9 @@ It is registered to variable `mime-preview-quitting-method-alist'." (as-binary-input-file (insert-file-contents file)) (setq major-mode 'mime-show-message-mode) (mime-view-buffer (current-buffer) nil mother) - (setq pbuf (current-buffer)) - ) + (setq pbuf (current-buffer))) (set-window-buffer pwin pbuf) - (select-window pwin) - ) + (select-window pwin)) (setq file (concat root-dir "/" number)) (mime-write-entity-body entity file) (let ((total-file (concat root-dir "/CT"))) @@ -633,10 +579,8 @@ It is registered to variable `mime-preview-quitting-method-alist'." (erase-buffer) (insert total) (write-region (point-min)(point-max) total-file) - (kill-buffer (current-buffer)) - )) - (string-to-number total) - ) + (kill-buffer (current-buffer)))) + (string-to-number total)) (and (file-exists-p total-file) (save-excursion (set-buffer (find-file-noselect total-file)) @@ -644,11 +588,8 @@ It is registered to variable `mime-preview-quitting-method-alist'." (and (re-search-forward "[0-9]+" nil t) (string-to-number (buffer-substring (match-beginning 0) - (match-end 0))) - ) - (kill-buffer (current-buffer)) - ))) - ))) + (match-end 0)))) + (kill-buffer (current-buffer)))))))) (if (and total (> total 0) (>= (length (directory-files root-dir nil "^[0-9]+$" t)) total)) @@ -661,12 +602,10 @@ It is registered to variable `mime-preview-quitting-method-alist'." (while (<= i total) (setq file (concat root-dir "/" (int-to-string i))) (or (file-exists-p file) - (throw 'tag nil) - ) + (throw 'tag nil)) (as-binary-input-file (insert-file-contents file)) (goto-char (point-max)) - (setq i (1+ i)) - )) + (setq i (1+ i)))) (as-binary-output-file (write-region (point-min)(point-max) (expand-file-name "FULL" root-dir))) @@ -674,23 +613,18 @@ It is registered to variable `mime-preview-quitting-method-alist'." (while (<= i total) (let ((file (format "%s/%d" root-dir i))) (and (file-exists-p file) - (delete-file file) - )) - (setq i (1+ i)) - )) + (delete-file file))) + (setq i (1+ i)))) (let ((file (expand-file-name "CT" root-dir))) (and (file-exists-p file) - (delete-file file) - )) + (delete-file file))) (let ((pwin (or (get-buffer-window mother) (get-largest-window))) (pbuf (mime-display-message (mime-open-entity 'buffer (current-buffer)) nil mother nil 'mime-show-message-mode))) (set-window-buffer pwin pbuf) - (select-window pwin) - ))))) - ))) + (select-window pwin))))))))) ;;; @ message/external-body @@ -699,15 +633,13 @@ It is registered to variable `mime-preview-quitting-method-alist'." (defvar mime-raw-dired-function (if (and (>= emacs-major-version 19) window-system) (function dired-other-frame) - (function mime-raw-dired-function-for-one-frame) - )) + (function mime-raw-dired-function-for-one-frame))) (defun mime-raw-dired-function-for-one-frame (dir) (let ((win (or (get-buffer-window mime-preview-buffer) (get-largest-window)))) (select-window win) - (dired dir) - )) + (dired dir))) (defun mime-view-message/external-anon-ftp (entity cal) (let* ((site (cdr (assoc "site" cal))) @@ -717,8 +649,7 @@ It is registered to variable `mime-preview-quitting-method-alist'." (message (concat "Accessing " (expand-file-name name pathname) " ...")) (funcall mime-raw-dired-function pathname) (goto-char (point-min)) - (search-forward name) - )) + (search-forward name))) (defvar mime-raw-browse-url-function mime-browse-url-function) @@ -740,15 +671,12 @@ It is registered to variable `mime-preview-quitting-method-alist'." (erase-buffer) (mime-insert-text-content entity) (mule-caesar-region (point-min) (point-max)) - (set-buffer-modified-p nil) - ) + (set-buffer-modified-p nil)) (let ((win (get-buffer-window (current-buffer)))) (or (eq (selected-window) win) - (select-window (or win (get-largest-window))) - )) + (select-window (or win (get-largest-window))))) (view-buffer buf) - (goto-char (point-min)) - )) + (goto-char (point-min)))) ;;; @ end @@ -772,10 +700,8 @@ It is registered to variable `mime-preview-quitting-method-alist'." mime-acting-situation-example-list-max-size) (< i 16)) (mime-reduce-acting-situation-examples) - (setq i (1+ i)) - )) - (error (setq mime-acting-situation-example-list nil))) - ) + (setq i (1+ i)))) + (error (setq mime-acting-situation-example-list nil)))) (kill-buffer buffer)))) ;;; mime-play.el ends here diff --git a/mime-setup.el b/mime-setup.el index dae2871..ac23d11 100644 --- a/mime-setup.el +++ b/mime-setup.el @@ -28,13 +28,11 @@ (condition-case nil (load "gnus-mime-setup") - (error (message "gnus-mime-setup is not found.")) - ) + (error (message "gnus-mime-setup is not found."))) (condition-case nil (load "emh-setup") - (error (message "emh-setup is not found.")) - ) + (error (message "emh-setup is not found."))) ;;; @ end diff --git a/mime-ui-en.sgml b/mime-ui-en.sgml index 6f1b876..7a02f72 100644 --- a/mime-ui-en.sgml +++ b/mime-ui-en.sgml @@ -370,7 +370,7 @@ Insert signature. C-c C-x C-k -Insert PGP public key. (It requires Mailcrypt package.) +Insert PGP public key. C-c C-x t @@ -609,29 +609,21 @@ mime-edit provides PGP encryption, signature and inserting public-key features based on PGP/MIME (RFC 2015) or PGP-kazu (draft-kazu-pgp-mime-00.txt).

-This feature requires pgp command and pgp interface package, such as -Mailcrypt package. +This feature requires your pgp command. - +

-Alist of service names vs. corresponding functions and its filenames. -Each element looks like (SERVICE FUNCTION FILE). -

-SERVICE is a symbol of PGP processing. It allows `verify', `decrypt', -`fetch-key', `snarf-keys', `mime-sign', `traditional-sign', `encrypt' -or `insert-key'. -

-Function is a symbol of function to do specified SERVICE. -

-FILE is string of filename which has definition of corresponding -FUNCTION. +Version of PGP or GnuPG command to be used for encryption or sign. +The value should be a symbol. Allowed versions are gpg, +pgp or pgp5. - - method +

-Return function to do service method. - +Version of PGP or GnuPG command to be used for decryption or verification. +The value should be a symbol. Allowed versions are gpg, +pgp or pgp5. +

Mouse button diff --git a/mime-ui-en.texi b/mime-ui-en.texi index 9946c5f..2cde0f9 100644 --- a/mime-ui-en.texi +++ b/mime-ui-en.texi @@ -681,29 +681,22 @@ mime-edit provides PGP encryption, signature and inserting public-key features based on @strong{PGP/MIME} (RFC 2015) or @strong{PGP-kazu} (draft-kazu-pgp-mime-00.txt).@refill -This feature requires pgp command and pgp interface package, such as -Mailcrypt package (@ref{(mailcrypt)}). +This feature requires your pgp command. -@defvar pgp-function-alist +@defvar pgg-default-scheme -Alist of service names vs. corresponding functions and its filenames. -Each element looks like @code{(SERVICE FUNCTION FILE)}.@refill - -SERVICE is a symbol of PGP processing. It allows `verify', `decrypt', -`fetch-key', `snarf-keys', `mime-sign', `traditional-sign', `encrypt' or -`insert-key'.@refill - -Function is a symbol of function to do specified SERVICE.@refill - -FILE is string of filename which has definition of corresponding -FUNCTION. +Version of PGP or GnuPG command to be used for encryption or sign. +The value should be a symbol. Allowed versions are @code{gpg}, +@code{pgp} or @code{pgp5}.@refill @end defvar -@defun pgp-function method +@defvar pgg-scheme -Return function to do service @var{method}. -@end defun +Version of PGP or GnuPG command to be used for decryption or verification. +The value should be a symbol. Allowed versions are @code{gpg}, +@code{pgp} or @code{pgp5}.@refill +@end defvar diff --git a/mime-ui-ja.sgml b/mime-ui-ja.sgml index 2e1094a..9bb5473 100644 --- a/mime-ui-ja.sgml +++ b/mime-ui-ja.sgml @@ -624,29 +624,21 @@ mime-edit $B$G$O(B PGP/MIME (RFC 2015) $B$*$h$S(B PGP-kazu (draft-kazu-pgp-mime-00.txt) $B$K$h$k0E9f2=!&(B $BEE;R=pL>!&8x3+80$NA^F~5!G=$rMxMQ$9$k$3$H$,$G$-$^$9!#(B

-$BC"$7!"$3$N5!G=$rMxMQ$9$k$K$O(B Mailcrypt package -$B$H(B pgp command $B$,I,MW$G$9!#(B +$BC"$7!"$3$N5!G=$rMxMQ$9$k$K$O3F +

-Alist of service names vs. corresponding functions and its filenames. -Each element looks like (SERVICE FUNCTION FILE). -

-SERVICE is a symbol of PGP processing. It allows `verify', `decrypt', -`fetch-key', `snarf-keys', `mime-sign', `traditional-sign', `encrypt' -or `insert-key'. -

-Function is a symbol of function to do specified SERVICE. -

-FILE is string of filename which has definition of corresponding -FUNCTION. +Version of PGP or GnuPG command to be used for encryption or sign. +The value should be a symbol. Allowed versions are gpg, +pgp or pgp5. - - method +

-Return function to do service method. - +Version of PGP or GnuPG command to be used for decryption or verification. +The value should be a symbol. Allowed versions are gpg, +pgp or pgp5. +

$B2!KU(B diff --git a/mime-ui-ja.texi b/mime-ui-ja.texi index 24583c1..8293821 100644 --- a/mime-ui-ja.texi +++ b/mime-ui-ja.texi @@ -698,29 +698,22 @@ mime-edit $B$G$O(B @strong{PGP/MIME} (RFC 2015) $B$*$h$S(B@strong{PGP-kazu} (draft-kazu-pgp-mime-00.txt) $B$K$h$k0E9f2=!&EE;R=pL>!&8x3+80$NA^F~5!G=$r(B $BMxMQ$9$k$3$H$,$G$-$^$9!#(B@refill -$BC"$7!"$3$N5!G=$rMxMQ$9$k$K$O(B Mailcrypt package (@ref{(mailcrypt)}) $B$H(B -pgp command $B$,I,MW$G$9!#(B +$BC"$7!"$3$N5!G=$rMxMQ$9$k$K$O3F (point) (buffer-size)) @@ -203,15 +201,13 @@ mother-buffer." (setq rest (or (mime-entity-content-type entity) (make-mime-content-type 'text 'plain)) situation (cons (car rest) situation) - rest (cdr rest)) - ) + rest (cdr rest))) (unless (assq 'subtype situation) (or rest (setq rest (or (cdr (mime-entity-content-type entity)) '((subtype . plain))))) (setq situation (cons (car rest) situation) - rest (cdr rest)) - ) + rest (cdr rest))) (while rest (setq param (car rest)) (or (assoc (car param) situation) @@ -226,8 +222,7 @@ mother-buffer." (setq situation (cons (cons 'disposition-type (mime-content-disposition-type rest)) situation) - rest (mime-content-disposition-parameters rest)) - )) + rest (mime-content-disposition-parameters rest)))) (while rest (setq param (car rest) name (car param)) @@ -450,8 +445,7 @@ Each elements are regexp of field-name.") field-type field-value) (let ((s-field (assq field-type calist))) (cond ((null s-field) - (cons (cons field-type field-value) calist) - ) + (cons (cons field-type field-value) calist)) (t calist)))) (define-calist-field-match-method @@ -464,10 +458,11 @@ Each elements are regexp of field-name.") (defvar mime-preview-condition nil "Condition-tree about how to display entity.") -(ctree-set-calist-strictly - 'mime-preview-condition '((type . application)(subtype . t) - (encoding . nil) - (body . visible))) +;;(ctree-set-calist-strictly +;; 'mime-preview-condition '((type . application)(subtype . octet-stream) +;; (encoding . nil) +;; (body . visible))) + (ctree-set-calist-strictly 'mime-preview-condition '((type . application)(subtype . t) (encoding . "7bit") @@ -527,6 +522,12 @@ Each elements are regexp of field-name.") (body-presentation-method . mime-display-application/x-postpet))) (ctree-set-calist-strictly + 'mime-preview-condition '((type . application)(subtype . t) + (encoding . t) + (body . invisible) + (body-presentation-method . mime-display-detect-application/octet-stream))) + +(ctree-set-calist-strictly 'mime-preview-condition '((type . text)(subtype . t) (body . visible) @@ -572,11 +573,9 @@ Each elements are regexp of field-name.") (run-hooks 'mime-text-decode-hook) (goto-char (point-max)) (if (not (eq (char-after (1- (point))) ?\n)) - (insert "\n") - ) + (insert "\n")) (mime-add-url-buttons) - (run-hooks 'mime-display-text/plain-hook) - )) + (run-hooks 'mime-display-text/plain-hook))) (defun mime-display-text/richtext (entity situation) (save-restriction @@ -585,8 +584,7 @@ Each elements are regexp of field-name.") (run-hooks 'mime-text-decode-hook) (let ((beg (point-min))) (remove-text-properties beg (point-max) '(face nil)) - (richtext-decode beg (point-max)) - ))) + (richtext-decode beg (point-max))))) (defun mime-display-text/enriched (entity situation) (save-restriction @@ -595,8 +593,7 @@ Each elements are regexp of field-name.") (run-hooks 'mime-text-decode-hook) (let ((beg (point-min))) (remove-text-properties beg (point-max) '(face nil)) - (enriched-decode beg (point-max)) - ))) + (enriched-decode beg (point-max))))) (defun mime-display-text/x-rot13-47-48 (entity situation) (save-restriction @@ -701,8 +698,7 @@ Each elements are regexp of field-name.") "Brain: " (int-to-string (cdr (assq 'brain pet))) "\n" "Happiness: " (int-to-string (cdr (assq 'happiness pet))) "\n" "Treasure: " (int-to-string (cdr (assq 'treasure pet))) "\n" - "Money: " (int-to-string (cdr (assq 'money pet))) "\n" - ) + "Money: " (int-to-string (cdr (assq 'money pet))) "\n") (insert "Invalid format\n")) (run-hooks 'mime-display-application/x-postpet-hook)))) @@ -715,21 +711,18 @@ Each elements are regexp of field-name.") \[[ or click here by mouse button-2. ]]" "\ \[[ This is message/partial style split message. ]] -\[[ Please press `v' key in this buffer. ]]" - )) +\[[ Please press `v' key in this buffer. ]]")) (defun mime-display-message/partial-button (&optional entity situation) (save-restriction (goto-char (point-max)) (if (not (search-backward "\n\n" nil t)) - (insert "\n") - ) + (insert "\n")) (goto-char (point-max)) (narrow-to-region (point-max)(point-max)) (insert mime-view-announcement-for-message/partial) (mime-add-button (point-min)(point-max) - #'mime-preview-play-current-entity) - )) + #'mime-preview-play-current-entity))) (defun mime-display-multipart/mixed (entity situation) (let ((children (mime-entity-children entity)) @@ -741,8 +734,7 @@ Each elements are regexp of field-name.") (cons original-major-mode-cell default-situation))) (while children (mime-display-entity (car children) nil default-situation) - (setq children (cdr children)) - ))) + (setq children (cdr children))))) (defun mime-display-multipart/alternative (entity situation) (let* ((children (mime-entity-children entity)) @@ -778,15 +770,12 @@ Each elements are regexp of field-name.") mime-view-type-subtype-score-alist) (assq t - mime-view-type-subtype-score-alist) - )))) + mime-view-type-subtype-score-alist))))) (if (> score max-score) (setq p i - max-score score) - ))) + max-score score)))) (setq i (1+ i)) - situation) - )) + situation))) children)) (setq i 0) (while children @@ -795,12 +784,29 @@ Each elements are regexp of field-name.") (mime-display-entity child (if (= i p) situation (del-alist 'body-presentation-method - (copy-alist situation)))) - ) + (copy-alist situation))))) (setq children (cdr children) situations (cdr situations) - i (1+ i)) - ))) + i (1+ i))))) + +(defun mime-display-detect-application/octet-stream (entity situation) + "Detect unknown part and display it inline. +This can only handle gzipped contents." + (or (and (mime-entity-filename entity) + (string-match "\\.gz$" (mime-entity-filename entity)) + (mime-display-gzipped entity situation)) + (mime-display-text/plain entity situation))) + +(defun mime-display-gzipped (entity situation) + "Ungzip gzipped part and display" + (insert + (with-temp-buffer + (insert (mime-entity-content entity)) + (as-binary-process + (call-process-region (point-min) (point-max) "gzip" t t + nil "-cd")) + (buffer-string (point-min) (point-max)))) + t) (defun mime-preview-inline () "View part as text without code conversion" @@ -973,10 +979,8 @@ With prefix, it prompts for coding-system." (cond ((eq field-type 'view) (setq view field)) ((eq field-type 'print) (setq print field)) ((memq field-type '(compose composetyped edit))) - (t (setq shared (cons field shared)))) - ) - (setq entry (cdr entry)) - ) + (t (setq shared (cons field shared))))) + (setq entry (cdr entry))) (setq shared (nreverse shared)) (ctree-set-calist-with-default 'mime-acting-condition @@ -985,18 +989,14 @@ With prefix, it prompts for coding-system." (ctree-set-calist-with-default 'mime-acting-condition (append shared - (list '(mode . "print")(cons 'method (cdr view)))) - )) - ) - (setq entries (cdr entries)) - ))) + (list '(mode . "print")(cons 'method (cdr view))))))) + (setq entries (cdr entries))))) (ctree-set-calist-strictly 'mime-acting-condition '((type . application)(subtype . octet-stream) (mode . "play") - (method . mime-detect-content) - )) + (method . mime-detect-content))) (ctree-set-calist-with-default 'mime-acting-condition @@ -1006,44 +1006,37 @@ With prefix, it prompts for coding-system." (ctree-set-calist-strictly 'mime-acting-condition '((type . text)(subtype . x-rot13-47)(mode . "play") - (method . mime-view-caesar) - )) + (method . mime-view-caesar))) (ctree-set-calist-strictly 'mime-acting-condition '((type . text)(subtype . x-rot13-47-48)(mode . "play") - (method . mime-view-caesar) - )) + (method . mime-view-caesar))) (ctree-set-calist-strictly 'mime-acting-condition '((type . message)(subtype . rfc822)(mode . "play") - (method . mime-view-message/rfc822) - )) + (method . mime-view-message/rfc822))) (ctree-set-calist-strictly 'mime-acting-condition '((type . message)(subtype . partial)(mode . "play") - (method . mime-store-message/partial-piece) - )) + (method . mime-store-message/partial-piece))) (ctree-set-calist-strictly 'mime-acting-condition '((type . message)(subtype . external-body) ("access-type" . "anon-ftp") - (method . mime-view-message/external-anon-ftp) - )) + (method . mime-view-message/external-anon-ftp))) (ctree-set-calist-strictly 'mime-acting-condition '((type . message)(subtype . external-body) ("access-type" . "url") - (method . mime-view-message/external-url) - )) + (method . mime-view-message/external-url))) (ctree-set-calist-strictly 'mime-acting-condition '((type . application)(subtype . octet-stream) - (method . mime-save-content) - )) + (method . mime-save-content))) ;;; @ quitting method @@ -1152,9 +1145,7 @@ With prefix, it prompts for coding-system." (or header-is-visible (progn (goto-char (point-max)) - (insert "\n") - )) - )) + (insert "\n"))))) (setq ne (point-max))) (put-text-property nb ne 'mime-view-entity entity) (put-text-property nb ne 'mime-view-situation situation) @@ -1181,8 +1172,7 @@ With prefix, it prompts for coding-system." (print "Print current entity" mime-preview-print-current-entity) (raw "View text without code conversion" mime-preview-inline) (text "View text with code conversion" mime-preview-text) - (type "View internally as type" mime-preview-type) - ) + (type "View internally as type" mime-preview-type)) "Menu for MIME Viewer") (cond ((featurep 'xemacs) @@ -1190,8 +1180,7 @@ With prefix, it prompts for coding-system." (cons mime-view-menu-title (mapcar (function (lambda (item) - (vector (nth 1 item)(nth 2 item) t) - )) + (vector (nth 1 item)(nth 2 item) t))) mime-view-menu-list))) (defun mime-view-xemacs-popup-menu (event) "Popup the menu in the MIME Viewer buffer" @@ -1199,17 +1188,14 @@ With prefix, it prompts for coding-system." (select-window (event-window event)) (set-buffer (event-buffer event)) (popup-menu 'mime-view-xemacs-popup-menu)) - (defvar mouse-button-2 'button2) - ) + (defvar mouse-button-2 'button2)) (t - (defvar mouse-button-2 [mouse-2]) - )) + (defvar mouse-button-2 [mouse-2]))) (defun mime-view-define-keymap (&optional default) (let ((mime-view-mode-map (if (keymapp default) (copy-keymap default) - (make-sparse-keymap) - ))) + (make-sparse-keymap)))) (define-key mime-view-mode-map "u" (function mime-preview-move-to-upper)) (define-key mime-view-mode-map @@ -1266,20 +1252,16 @@ With prefix, it prompts for coding-system." [backspace] (function mime-preview-scroll-down-entity)) (if (functionp default) (cond ((featurep 'xemacs) - (set-keymap-default-binding mime-view-mode-map default) - ) + (set-keymap-default-binding mime-view-mode-map default)) (t (setq mime-view-mode-map - (append mime-view-mode-map (list (cons t default)))) - ))) + (append mime-view-mode-map (list (cons t default))))))) (if mouse-button-2 (define-key mime-view-mode-map - mouse-button-2 (function mime-button-dispatcher)) - ) + mouse-button-2 (function mime-button-dispatcher))) (cond ((featurep 'xemacs) (define-key mime-view-mode-map - mouse-button-3 (function mime-view-xemacs-popup-menu)) - ) + mouse-button-3 (function mime-view-xemacs-popup-menu))) ((>= emacs-major-version 19) (define-key mime-view-mode-map [menu-bar mime-view] (cons mime-view-menu-title @@ -1288,15 +1270,10 @@ With prefix, it prompts for coding-system." (lambda (item) (define-key mime-view-mode-map (vector 'menu-bar 'mime-view (car item)) - (cons (nth 1 item)(nth 2 item)) - ) - )) - (reverse mime-view-menu-list) - ) - )) + (cons (nth 1 item)(nth 2 item))))) + (reverse mime-view-menu-list)))) (use-local-map mime-view-mode-map) - (run-hooks 'mime-view-define-keymap-hook) - )) + (run-hooks 'mime-view-define-keymap-hook))) (defsubst mime-maybe-hide-echo-buffer () "Clear mime-echo buffer and delete window for it." @@ -1307,10 +1284,8 @@ With prefix, it prompts for coding-system." (erase-buffer) (let ((win (get-buffer-window buf))) (if win - (delete-window win) - )) - (bury-buffer buf) - )))) + (delete-window win))) + (bury-buffer buf))))) (defvar mime-view-redisplay nil) @@ -1343,8 +1318,7 @@ keymap of MIME-View mode." (widen) (erase-buffer) (if mother - (setq mime-mother-buffer mother) - ) + (setq mime-mother-buffer mother)) (setq mime-preview-original-window-configuration win-conf) (setq major-mode 'mime-view-mode) (setq mode-name "MIME-View") @@ -1354,13 +1328,13 @@ keymap of MIME-View mode." (major-mode . ,original-major-mode)) preview-buffer) (mime-view-define-keymap default-keymap-or-function) + (set (make-local-variable 'line-move-ignore-invisible) t) (let ((point (next-single-property-change (point-min) 'mime-view-entity))) (if point (goto-char point) (goto-char (point-min)) - (search-forward "\n\n" nil t) - )) + (search-forward "\n\n" nil t))) (run-hooks 'mime-view-mode-hook) (set-buffer-modified-p nil) (setq buffer-read-only t) @@ -1388,11 +1362,9 @@ message. It must be nil, `binary' or `cooked'. If it is nil, (save-excursion (set-buffer raw-buffer) (cdr (or (assq major-mode mime-raw-representation-type-alist) - (assq t mime-raw-representation-type-alist))) - ))) + (assq t mime-raw-representation-type-alist)))))) (if (eq representation-type 'binary) - (setq representation-type 'buffer) - ) + (setq representation-type 'buffer)) (setq preview-buffer (mime-display-message (mime-open-entity representation-type raw-buffer) preview-buffer mother default-keymap-or-function)) @@ -1403,8 +1375,7 @@ message. It must be nil, `binary' or `cooked'. If it is nil, (let ((m-win (and mother (get-buffer-window mother)))) (if m-win (set-window-buffer m-win preview-buffer) - (switch-to-buffer preview-buffer) - )))))) + (switch-to-buffer preview-buffer))))))) (defun mime-view-mode (&optional mother ctl encoding raw-buffer preview-buffer @@ -1440,19 +1411,15 @@ button-2 Move to point under the mouse cursor (or (assq major-mode mime-raw-representation-type-alist) (assq t mime-raw-representation-type-alist))))) (if (eq type 'binary) - (setq type 'buffer) - ) + (setq type 'buffer)) (setq mime-message-structure (mime-open-entity type raw-buffer)) (or (mime-entity-content-type mime-message-structure) (mime-entity-set-content-type-internal - mime-message-structure ctl)) - ) + mime-message-structure ctl))) (or (mime-entity-encoding mime-message-structure) - (mime-entity-set-encoding-internal mime-message-structure encoding)) - )) + (mime-entity-set-encoding-internal mime-message-structure encoding)))) (mime-display-message mime-message-structure preview-buffer - mother default-keymap-or-function) - ) + mother default-keymap-or-function)) ;;; @@ playing @@ -1467,8 +1434,7 @@ It decodes current entity to call internal or external method as \"extract\" mode. The method is selected from variable `mime-acting-condition'." (interactive "P") - (mime-preview-play-current-entity ignore-examples "extract") - ) + (mime-preview-play-current-entity ignore-examples "extract")) (defun mime-preview-print-current-entity (&optional ignore-examples) "Print current entity (maybe). @@ -1476,8 +1442,7 @@ It decodes current entity to call internal or external method as \"print\" mode. The method is selected from variable `mime-acting-condition'." (interactive "P") - (mime-preview-play-current-entity ignore-examples "print") - ) + (mime-preview-play-current-entity ignore-examples "print")) ;;; @@ following @@ -1491,34 +1456,28 @@ It calls following-method selected from variable (let (entity) (while (null (setq entity (get-text-property (point) 'mime-view-entity))) - (backward-char) - ) + (backward-char)) (let* ((p-beg (previous-single-property-change (point) 'mime-view-entity)) p-end ph-end (entity-node-id (mime-entity-node-id entity)) - (len (length entity-node-id)) - ) + (len (length entity-node-id))) (cond ((null p-beg) (setq p-beg (if (eq (next-single-property-change (point-min) 'mime-view-entity) (point)) (point) - (point-min))) - ) + (point-min)))) ((eq (next-single-property-change p-beg 'mime-view-entity) (point)) - (setq p-beg (point)) - )) + (setq p-beg (point)))) (setq p-end (next-single-property-change p-beg 'mime-view-entity)) (cond ((null p-end) - (setq p-end (point-max)) - ) + (setq p-end (point-max))) ((null entity-node-id) - (setq p-end (point-max)) - ) + (setq p-end (point-max))) (t (save-excursion (goto-char p-end) @@ -1533,19 +1492,14 @@ It calls following-method selected from variable 'mime-view-entity)))) (or (equal entity-node-id (nthcdr (- (length rc) len) rc)) - (throw 'tag nil) - )) - (setq p-end e) - )) - (setq p-end (point-max)) - )) - )) + (throw 'tag nil))) + (setq p-end e))) + (setq p-end (point-max)))))) (setq ph-end (previous-single-property-change p-end 'mime-view-entity-header)) (if (or (null ph-end) (< ph-end p-beg)) - (setq ph-end p-beg) - ) + (setq ph-end p-beg)) (let* ((mode (mime-preview-original-major-mode 'recursive)) (new-name (format "%s-%s" (buffer-name) (reverse entity-node-id))) @@ -1588,13 +1542,10 @@ It calls following-method selected from variable current-entity) 'rfc822)) nil (if str - (insert str) - ) + (insert str)) t))) (setq fields (std11-collect-field-names) - current-entity (mime-entity-parent current-entity)) - ) - ) + current-entity (mime-entity-parent current-entity)))) (let ((rest mime-view-following-required-fields-list) field-name ret) (while rest @@ -1611,21 +1562,16 @@ It calls following-method selected from variable 'mime-view-entity) field-name)))) (if ret - (insert (concat field-name ": " ret "\n")) - ))) - (setq rest (cdr rest)) - )) - (mime-decode-header-in-buffer) - ) + (insert (concat field-name ": " ret "\n"))))) + (setq rest (cdr rest)))) + (mime-decode-header-in-buffer)) (let ((f (cdr (assq mode mime-preview-following-method-alist)))) (if (functionp f) (funcall f new-buf) (message (format "Sorry, following method for %s is not implemented yet." - mode)) - )) - )))) + mode)))))))) ;;; @@ moving @@ -1665,8 +1611,7 @@ variable `mime-preview-over-to-previous-method-alist'." (interactive) (while (and (not (bobp)) (null (get-text-property (point) 'mime-view-entity))) - (backward-char) - ) + (backward-char)) (let ((point (previous-single-property-change (point) 'mime-view-entity))) (if (and point (>= point (point-min))) @@ -1683,8 +1628,7 @@ variable `mime-preview-over-to-previous-method-alist'." (point))))) (recenter next-screen-context-lines))) (goto-char (1- point)) - (mime-preview-move-to-previous) - ) + (mime-preview-move-to-previous)) (let ((f (assq (mime-preview-original-major-mode) mime-preview-over-to-previous-method-alist))) (if f @@ -1792,13 +1736,11 @@ It calls function registered in variable (let ((r (assq (mime-preview-original-major-mode) mime-preview-quitting-method-alist))) (if r - (funcall (cdr r)) - ))) + (funcall (cdr r))))) (defun mime-preview-kill-buffer () (interactive) - (kill-buffer (current-buffer)) - ) + (kill-buffer (current-buffer))) ;;; @ end diff --git a/mime-w3.el b/mime-w3.el index c337ce3..2033599 100644 --- a/mime-w3.el +++ b/mime-w3.el @@ -48,8 +48,7 @@ `(let ((color (color-name (face-background 'default)))) (prog1 (progn ,@body) - (font-set-face-background 'default color (current-buffer)) - )) + (font-set-face-background 'default color (current-buffer)))) (cons 'progn body))) (defun mime-preview-text/html (entity situation) @@ -76,8 +75,7 @@ 'mime-view-entity))))) (when entity (mime-insert-entity-content entity) - (setq url-current-mime-type (mime-entity-type/subtype entity)) - ))) + (setq url-current-mime-type (mime-entity-type/subtype entity))))) (url-register-protocol "cid" 'url-cid diff --git a/pgg-def.el b/pgg-def.el new file mode 100644 index 0000000..1227996 --- /dev/null +++ b/pgg-def.el @@ -0,0 +1,75 @@ +;;; pgg-def.el --- functions/macros for defining PGG functions + +;; Copyright (C) 1999 Daiki Ueno + +;; Author: Daiki Ueno +;; Created: 1999/11/02 +;; Keywords: PGP, OpenPGP, GnuPG + +;; This file is part of SEMI (Secure Emacs MIME Interface). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(require 'pcustom) + +(defgroup pgg () + "Glue for the various PGP implementations." + :group 'mime) + +(defcustom pgg-default-scheme 'gpg + "Default PGP scheme." + :group 'pgg + :type '(choice (const :tag "GnuPG" gpg) + (const :tag "PGP 5" pgp5) + (const :tag "PGP" pgp))) + +(defcustom pgg-default-user-id (user-login-name) + "User ID of your default identity." + :group 'pgg + :type 'string) + +(defcustom pgg-default-keyserver-address "wwwkeys.pgp.net" + "Host name of keyserver." + :group 'pgg + :type 'string) + +(defcustom pgg-encrypt-for-me nil + "If t, encrypt all outgoing messages with user's public key." + :group 'pgg + :type 'boolean) + +(defcustom pgg-cache-passphrase t + "If t, cache passphrase." + :group 'pgg + :type 'boolean) + +(defvar pgg-status-buffer " *PGG status*") +(defvar pgg-errors-buffer " *PGG errors*") +(defvar pgg-output-buffer " *PGG output*") + +(defvar pgg-echo-buffer "*PGG-echo*") + +(defvar pgg-scheme nil + "Current scheme of PGP implementation.") + +(defmacro pgg-truncate-key-identifier (key) + `(if (> (length ,key) 8) (substring ,key 8) ,key)) + +(provide 'pgg-def) + +;;; pgg-def.el ends here diff --git a/pgg-gpg.el b/pgg-gpg.el new file mode 100644 index 0000000..2bcb3c7 --- /dev/null +++ b/pgg-gpg.el @@ -0,0 +1,268 @@ +;;; pgg-gpg.el --- GnuPG support for PGG. + +;; Copyright (C) 1999,2000 Daiki Ueno + +;; Author: Daiki Ueno +;; Created: 1999/10/28 +;; Keywords: PGP, OpenPGP, GnuPG + +;; This file is part of SEMI (Secure Emacs MIME Interface). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(eval-when-compile (require 'pgg)) + +(defgroup pgg-gpg () + "GnuPG interface" + :group 'pgg) + +(defcustom pgg-gpg-program "gpg" + "The GnuPG executable." + :group 'pgg-gpg + :type 'string) + +(defcustom pgg-gpg-shell-file-name "/bin/sh" + "File name to load inferior shells from. Bourne shell or its equivalent +\(not tcsh) is needed for \"2>\"." + :group 'pgg-gpg + :type 'string) + +(defcustom pgg-gpg-shell-command-switch "-c" + "Switch used to have the shell execute its command line argument." + :group 'pgg-gpg + :type 'string) + +(defcustom pgg-gpg-extra-args nil + "Extra arguments for every GnuPG invocation." + :group 'pgg-gpg + :type 'string) + +(eval-and-compile + (luna-define-class pgg-scheme-gpg (pgg-scheme))) + +(defvar pgg-gpg-user-id nil + "GnuPG ID of your default identity.") + +(defvar pgg-scheme-gpg-instance nil) + +;;;###autoload +(defun pgg-make-scheme-gpg () + (or pgg-scheme-gpg-instance + (setq pgg-scheme-gpg-instance + (luna-make-entity 'pgg-scheme-gpg)))) + +(defun pgg-gpg-process-region (start end passphrase program args) + (let* ((errors-file-name + (concat temporary-file-directory + (make-temp-name "pgg-errors"))) + (status-file-name + (concat temporary-file-directory + (make-temp-name "pgg-status"))) + (args + (append + `("--status-fd" "3" + ,@(if passphrase '("--passphrase-fd" "0")) + ,@pgg-gpg-extra-args) + args + (list (concat "2>" errors-file-name) + (concat "3>" status-file-name)))) + (shell-file-name pgg-gpg-shell-file-name) + (shell-command-switch pgg-gpg-shell-command-switch) + (output-buffer pgg-output-buffer) + (errors-buffer pgg-errors-buffer) + (status-buffer pgg-status-buffer) + (process-connection-type nil) + process status exit-status) + (with-current-buffer (get-buffer-create output-buffer) + (buffer-disable-undo) + (erase-buffer)) + (as-binary-process + (setq process + (apply #'start-process-shell-command "*GnuPG*" output-buffer + program args))) + (set-process-sentinel process #'ignore) + (when passphrase + (process-send-string process (concat passphrase "\n"))) + (process-send-region process start end) + (process-send-eof process) + (while (eq 'run (process-status process)) + (accept-process-output process 5)) + (setq status (process-status process) + exit-status (process-exit-status process)) + (delete-process process) + (with-current-buffer output-buffer + (pgg-convert-lbt-region (point-min)(point-max) 'LF) + + (if (memq status '(stop signal)) + (error "%s exited abnormally: '%s'" program exit-status)) + (if (= 127 exit-status) + (error "%s could not be found" program)) + + (set-buffer (get-buffer-create errors-buffer)) + (buffer-disable-undo) + (erase-buffer) + (insert-file-contents errors-file-name) + (delete-file errors-file-name) + + (set-buffer (get-buffer-create status-buffer)) + (buffer-disable-undo) + (erase-buffer) + (insert-file-contents status-file-name) + (delete-file status-file-name) + + (if (and process (eq 'run (process-status process))) + (interrupt-process process))))) + +(luna-define-method pgg-scheme-lookup-key ((scheme pgg-scheme-gpg) + string &optional type) + (let ((args (list "--with-colons" "--no-greeting" "--batch" + (if type "--list-secret-keys" "--list-keys") + string))) + (with-current-buffer (get-buffer-create pgg-output-buffer) + (buffer-disable-undo) + (erase-buffer) + (apply #'call-process pgg-gpg-program nil t nil args) + (goto-char (point-min)) + (when (re-search-forward "^\\(sec\\|pub\\):" nil t) + (substring + (nth 3 (split-string + (buffer-substring (match-end 0) + (progn (end-of-line)(point))) + ":")) + 8))))) + +(luna-define-method pgg-scheme-encrypt-region ((scheme pgg-scheme-gpg) + start end recipients) + (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id)) + (args + `("--batch" "--armor" "--always-trust" "--encrypt" + ,@(if recipients + (apply #'append + (mapcar (lambda (rcpt) + (list "--remote-user" + (concat "\"" rcpt "\""))) + (append recipients + (if pgg-encrypt-for-me + (list pgg-gpg-user-id))))))))) + (pgg-as-lbt start end 'CRLF + (pgg-gpg-process-region start end nil pgg-gpg-program args)) + (pgg-process-when-success + (pgg-convert-lbt-region (point-min)(point-max) 'LF)))) + +(luna-define-method pgg-scheme-decrypt-region ((scheme pgg-scheme-gpg) + start end) + (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id)) + (passphrase + (pgg-read-passphrase + (format "GnuPG passphrase for %s: " pgg-gpg-user-id) + (pgg-scheme-lookup-key scheme pgg-gpg-user-id 'encrypt))) + (args '("--batch" "--decrypt"))) + (pgg-gpg-process-region start end passphrase pgg-gpg-program args) + (pgg-process-when-success nil))) + +(luna-define-method pgg-scheme-sign-region ((scheme pgg-scheme-gpg) + start end &optional cleartext) + (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id)) + (passphrase + (pgg-read-passphrase + (format "GnuPG passphrase for %s: " pgg-gpg-user-id) + (pgg-scheme-lookup-key scheme pgg-gpg-user-id 'sign))) + (args + (list (if cleartext "--clearsign" "--detach-sign") + "--armor" "--batch" "--verbose" + "--local-user" pgg-gpg-user-id)) + (inhibit-read-only t) + buffer-read-only) + (pgg-as-lbt start end 'CRLF + (pgg-gpg-process-region start end passphrase pgg-gpg-program args)) + (pgg-process-when-success + (pgg-convert-lbt-region (point-min)(point-max) 'LF) + (when (re-search-forward "^-+BEGIN PGP SIGNATURE" nil t);XXX + (let ((packet + (cdr (assq 2 (pgg-parse-armor-region + (progn (beginning-of-line 2) + (point)) + (point-max)))))) + (if pgg-cache-passphrase + (pgg-add-passphrase-cache + (cdr (assq 'key-identifier packet)) + passphrase))))))) + +(luna-define-method pgg-scheme-verify-region ((scheme pgg-scheme-gpg) + start end &optional signature) + (let ((args '("--batch" "--verify"))) + (when (stringp signature) + (setq args (append args (list signature)))) + (pgg-gpg-process-region start end nil pgg-gpg-program args) + (save-excursion + (set-buffer pgg-errors-buffer) + (goto-char (point-min)) + (while (re-search-forward "^gpg: " nil t) + (replace-match "")) + (goto-char (point-min)) + (let ((case-fold-search t)) + (while (re-search-forward "^warning: " nil t) + (delete-region (match-beginning 0) + (progn (beginning-of-line 2) (point))))) + (set-buffer pgg-status-buffer) + (goto-char (point-min)) + (if (re-search-forward "^\\[GNUPG:] +GOODSIG +" nil t) + (progn + (set-buffer pgg-output-buffer) + (insert-buffer-substring pgg-errors-buffer) + t) + nil)))) + +(luna-define-method pgg-scheme-insert-key ((scheme pgg-scheme-gpg)) + (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id)) + (args (list "--batch" "--export" "--armor" + (concat "\"" pgg-gpg-user-id "\"")))) + (pgg-gpg-process-region (point)(point) nil pgg-gpg-program args) + (insert-buffer-substring pgg-output-buffer))) + +(luna-define-method pgg-scheme-snarf-keys-region ((scheme pgg-scheme-gpg) + start end) + (let ((args '("--import" "--batch" "-")) status) + (pgg-gpg-process-region start end nil pgg-gpg-program args) + (set-buffer pgg-status-buffer) + (goto-char (point-min)) + (when (re-search-forward "^\\[GNUPG:] +IMPORT_RES +" nil t) + (setq status (buffer-substring (match-end 0) + (progn (end-of-line) + (point))) + status (vconcat (mapcar #'string-to-int + (split-string status)))) + (erase-buffer) + (insert (format "Imported %d key(s). +\tArmor contains %d key(s) [%d bad, %d old].\n" + (+ (aref status 2) + (aref status 10)) + (aref status 0) + (aref status 1) + (+ (aref status 4) + (aref status 11))) + (if (zerop (aref status 9)) + "" + "\tSecret keys are imported.\n"))) + (append-to-buffer pgg-output-buffer + (point-min)(point-max)) + (pgg-process-when-success nil))) + +(provide 'pgg-gpg) + +;;; pgg-gpg.el ends here diff --git a/pgg-parse.el b/pgg-parse.el new file mode 100644 index 0000000..4a631c5 --- /dev/null +++ b/pgg-parse.el @@ -0,0 +1,494 @@ +;;; pgg-parse.el --- OpenPGP packet parsing + +;; Copyright (C) 1999 Daiki Ueno + +;; Author: Daiki Ueno +;; Created: 1999/10/28 +;; Keywords: PGP, OpenPGP, GnuPG + +;; This file is part of SEMI (Secure Emacs MIME Interface). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This module is based on + +;; [OpenPGP] RFC 2440: "OpenPGP Message Format" +;; by John W. Noerenberg, II , +;; Jon Callas , Lutz Donnerhacke , +;; Hal Finney and Rodney Thayer +;; (1998/11) + +;;; Code: + +(eval-when-compile (require 'cl)) + +(eval-when-compile (require 'static)) + +(require 'poem) +(require 'pccl) +(require 'pcustom) +(require 'mel) + +(defgroup pgg-parse () + "OpenPGP packet parsing" + :group 'pgg) + +(defcustom pgg-parse-public-key-algorithm-alist + '((1 . RSA) (2 . RSA-E) (3 . RSA-S) (16 . ELG-E) (17 . DSA) (20 . ELG)) + "Alist of the assigned number to the public key algorithm." + :group 'pgg-parse + :type 'alist) + +(defcustom pgg-parse-symmetric-key-algorithm-alist + '((1 . IDEA) (2 . 3DES) (4 . CAST5) (5 . SAFER-SK128)) + "Alist of the assigned number to the simmetric key algorithm." + :group 'pgg-parse + :type 'alist) + +(defcustom pgg-parse-hash-algorithm-alist + '((1 . MD5) (2 . SHA1) (3 . RIPEMD160) (5 . MD2)) + "Alist of the assigned number to the cryptographic hash algorithm." + :group 'pgg-parse + :type 'alist) + +(defcustom pgg-parse-compression-algorithm-alist + '((0 . nil); Uncompressed + (1 . ZIP) + (2 . ZLIB)) + "Alist of the assigned number to the compression algorithm." + :group 'pgg-parse + :type 'alist) + +(defcustom pgg-parse-signature-type-alist + '((0 . "Signature of a binary document") + (1 . "Signature of a canonical text document") + (2 . "Standalone signature") + (16 . "Generic certification of a User ID and Public Key packet") + (17 . "Persona certification of a User ID and Public Key packet") + (18 . "Casual certification of a User ID and Public Key packet") + (19 . "Positive certification of a User ID and Public Key packet") + (24 . "Subkey Binding Signature") + (31 . "Signature directly on a key") + (32 . "Key revocation signature") + (40 . "Subkey revocation signature") + (48 . "Certification revocation signature") + (64 . "Timestamp signature.")) + "Alist of the assigned number to the signature type." + :group 'pgg-parse + :type 'alist) + +(defcustom pgg-ignore-packet-checksum t; XXX + "If non-nil checksum of each ascii armored packet will be ignored." + :group 'pgg-parse + :type 'boolean) + +(defvar pgg-armor-header-lines + '("^-----BEGIN PGP MESSAGE\\(, PART [0-9]+\\(/[0-9]+\\)?\\)?-----\r?$" + "^-----BEGIN PGP PUBLIC KEY BLOCK-----\r?$" + "^-----BEGIN PGP PRIVATE KEY BLOCK-----\r?$" + "^-----BEGIN PGP SIGNATURE-----\r?$") + "Armor headers") + +(defmacro pgg-format-key-identifier (string) + `(upcase (apply #'format "%02x%02x%02x%02x%02x%02x%02x%02x" + (string-to-int-list ,string)))) + +(defmacro pgg-parse-time-field (bytes) + `(list (logior (lsh (car ,bytes) 8) + (nth 1 ,bytes)) + (logior (lsh (nth 2 ,bytes) 8) + (nth 3 ,bytes)) + 0)) + +(defmacro pgg-byte-after (&optional pos) + `(char-int (char-after ,(or pos `(point))))) + +(defmacro pgg-read-byte () + `(char-int (char-after (prog1 (point) (forward-char))))) + +(defmacro pgg-read-bytes-string (nbytes) + `(buffer-substring + (point) (prog1 (+ ,nbytes (point)) + (forward-char ,nbytes)))) + +(defmacro pgg-read-bytes (nbytes) + `(string-to-int-list (pgg-read-bytes-string ,nbytes))) + +(defmacro pgg-read-body-string (ptag) + `(if (nth 1 ,ptag) + (pgg-read-bytes-string (nth 1 ,ptag)) + (pgg-read-bytes-string (- (point-max) (point))))) + +(defmacro pgg-read-body (ptag) + `(string-to-int-list (pgg-read-body-string ,ptag))) + +(defalias 'pgg-skip-bytes 'forward-char) + +(defmacro pgg-skip-header (ptag) + `(pgg-skip-bytes (nth 2 ,ptag))) + +(defmacro pgg-skip-body (ptag) + `(pgg-skip-bytes (nth 1 ,ptag))) + +(defmacro pgg-set-alist (alist key value) + `(setq ,alist (nconc ,alist (list (cons ,key ,value))))) + +(unless-broken ccl-usable + (define-ccl-program pgg-parse-crc24 + '(1 + ((loop + (read r0) (r1 ^= r0) (r2 ^= 0) + (r5 = 0) + (loop + (r1 <<= 1) + (r1 += ((r2 >> 15) & 1)) + (r2 <<= 1) + (if (r1 & 256) + ((r1 ^= 390) (r2 ^= 19707))) + (if (r5 < 7) + ((r5 += 1) + (repeat)))) + (repeat))))) + + (defun pgg-parse-crc24-string (string) + (let ((h (vector nil 183 1230 nil nil nil nil nil nil))) + (ccl-execute-on-string pgg-parse-crc24 h string) + (format "%c%c%c" + (logand (aref h 1) 255) + (logand (lsh (aref h 2) -8) 255) + (logand (aref h 2) 255))))) + +(defmacro pgg-parse-length-type (c) + `(cond + ((< ,c 192) (cons ,c 1)) + ((< ,c 224) + (cons (+ (lsh (- ,c 192) 8) + (pgg-byte-after (+ 2 (point))) + 192) + 2)) + ((= ,c 255) + (cons (cons (logior (lsh (pgg-byte-after (+ 2 (point))) 8) + (pgg-byte-after (+ 3 (point)))) + (logior (lsh (pgg-byte-after (+ 4 (point))) 8) + (pgg-byte-after (+ 5 (point))))) + 5)) + (t;partial body length + '(0 . 0)))) + +(defun pgg-parse-packet-header () + (let ((ptag (pgg-byte-after)) + length-type content-tag packet-bytes header-bytes) + (if (zerop (logand 64 ptag));Old format + (progn + (setq length-type (logand ptag 3) + length-type (if (= 3 length-type) 0 (lsh 1 length-type)) + content-tag (logand 15 (lsh ptag -2)) + packet-bytes 0 + header-bytes (1+ length-type)) + (dotimes (i length-type) + (setq packet-bytes + (logior (lsh packet-bytes 8) + (pgg-byte-after (+ 1 i (point))))))) + (setq content-tag (logand 63 ptag) + length-type (pgg-parse-length-type + (pgg-byte-after (1+ (point)))) + packet-bytes (car length-type) + header-bytes (1+ (cdr length-type)))) + (list content-tag packet-bytes header-bytes))) + +(defun pgg-parse-packet (ptag) + (case (car ptag) + (1 ;Public-Key Encrypted Session Key Packet + (pgg-parse-public-key-encrypted-session-key-packet ptag)) + (2 ;Signature Packet + (pgg-parse-signature-packet ptag)) + (3 ;Symmetric-Key Encrypted Session Key Packet + (pgg-parse-symmetric-key-encrypted-session-key-packet ptag)) + ;; 4 -- One-Pass Signature Packet + ;; 5 -- Secret Key Packet + (6 ;Public Key Packet + (pgg-parse-public-key-packet ptag)) + ;; 7 -- Secret Subkey Packet + ;; 8 -- Compressed Data Packet + (9 ;Symmetrically Encrypted Data Packet + (pgg-read-body-string ptag)) + (10 ;Marker Packet + (pgg-read-body-string ptag)) + (11 ;Literal Data Packet + (pgg-read-body-string ptag)) + ;; 12 -- Trust Packet + (13 ;User ID Packet + (pgg-read-body-string ptag)) + ;; 14 -- Public Subkey Packet + ;; 60 .. 63 -- Private or Experimental Values + )) + +(defun pgg-parse-packets (&optional header-parser body-parser) + (let ((header-parser + (or header-parser + (function pgg-parse-packet-header))) + (body-parser + (or body-parser + (function pgg-parse-packet))) + result ptag) + (while (> (point-max) (1+ (point))) + (setq ptag (funcall header-parser)) + (pgg-skip-header ptag) + (push (cons (car ptag) + (save-excursion + (funcall body-parser ptag))) + result) + (if (zerop (nth 1 ptag)) + (goto-char (point-max)) + (forward-char (nth 1 ptag)))) + result)) + +(defun pgg-parse-signature-subpacket-header () + (let ((length-type (pgg-parse-length-type (pgg-byte-after)))) + (list (pgg-byte-after (+ (cdr length-type) (point))) + (1- (car length-type)) + (1+ (cdr length-type))))) + +(defun pgg-parse-signature-subpacket (ptag) + (case (car ptag) + (2 ;signature creation time + (cons 'creation-time + (let ((bytes (pgg-read-bytes 4))) + (pgg-parse-time-field bytes)))) + (3 ;signature expiration time + (cons 'signature-expiry + (let ((bytes (pgg-read-bytes 4))) + (pgg-parse-time-field bytes)))) + (4 ;exportable certification + (cons 'exportability (pgg-read-byte))) + (5 ;trust signature + (cons 'trust-level (pgg-read-byte))) + (6 ;regular expression + (cons 'regular-expression + (pgg-read-body-string ptag))) + (7 ;revocable + (cons 'revocability (pgg-read-byte))) + (9 ;key expiration time + (cons 'key-expiry + (let ((bytes (pgg-read-bytes 4))) + (pgg-parse-time-field bytes)))) + ;; 10 = placeholder for backward compatibility + (11 ;preferred symmetric algorithms + (cons 'preferred-symmetric-key-algorithm + (cdr (assq (pgg-read-byte) + pgg-parse-symmetric-key-algorithm-alist)))) + (12 ;revocation key + ) + (16 ;issuer key ID + (cons 'key-identifier + (pgg-format-key-identifier (pgg-read-body-string ptag)))) + (20 ;notation data + (pgg-skip-bytes 4) + (cons 'notation + (let ((name-bytes (pgg-read-bytes 2)) + (value-bytes (pgg-read-bytes 2))) + (cons (pgg-read-bytes-string + (logior (lsh (car name-bytes) 8) + (nth 1 name-bytes))) + (pgg-read-bytes-string + (logior (lsh (car value-bytes) 8) + (nth 1 value-bytes))))))) + (21 ;preferred hash algorithms + (cons 'preferred-hash-algorithm + (cdr (assq (pgg-read-byte) + pgg-parse-hash-algorithm-alist)))) + (22 ;preferred compression algorithms + (cons 'preferred-compression-algorithm + (cdr (assq (pgg-read-byte) + pgg-parse-compression-algorithm-alist)))) + (23 ;key server preferences + (cons 'key-server-preferences + (pgg-read-body ptag))) + (24 ;preferred key server + (cons 'preferred-key-server + (pgg-read-body-string ptag))) + ;; 25 = primary user id + (26 ;policy URL + (cons 'policy-url (pgg-read-body-string ptag))) + ;; 27 = key flags + ;; 28 = signer's user id + ;; 29 = reason for revocation + ;; 100 to 110 = internal or user-defined + )) + +(defun pgg-parse-signature-packet (ptag) + (let* ((signature-version (pgg-byte-after)) + (result (list (cons 'version signature-version))) + hashed-material field n) + (cond + ((= signature-version 3) + (pgg-skip-bytes 2) + (setq hashed-material (pgg-read-bytes 5)) + (pgg-set-alist result + 'signature-type + (cdr (assq (pop hashed-material) + pgg-parse-signature-type-alist))) + (pgg-set-alist result + 'creation-time + (pgg-parse-time-field hashed-material)) + (pgg-set-alist result + 'key-identifier + (pgg-format-key-identifier + (pgg-read-bytes-string 8))) + (pgg-set-alist result + 'public-key-algorithm (pgg-read-byte)) + (pgg-set-alist result + 'hash-algorithm (pgg-read-byte))) + ((= signature-version 4) + (pgg-skip-bytes 1) + (pgg-set-alist result + 'signature-type + (cdr (assq (pgg-read-byte) + pgg-parse-signature-type-alist))) + (pgg-set-alist result + 'public-key-algorithm + (pgg-read-byte)) + (pgg-set-alist result + 'hash-algorithm (pgg-read-byte)) + (when (>= 10000 (setq n (pgg-read-bytes 2) + n (logior (lsh (car n) 8) + (nth 1 n)))) + (save-restriction + (narrow-to-region (point)(+ n (point))) + (nconc result + (mapcar (function cdr) ;remove packet types + (pgg-parse-packets + #'pgg-parse-signature-subpacket-header + #'pgg-parse-signature-subpacket))) + (goto-char (point-max)))) + (when (>= 10000 (setq n (pgg-read-bytes 2) + n (logior (lsh (car n) 8) + (nth 1 n)))) + (save-restriction + (narrow-to-region (point)(+ n (point))) + (nconc result + (mapcar (function cdr) ;remove packet types + (pgg-parse-packets + #'pgg-parse-signature-subpacket-header + #'pgg-parse-signature-subpacket))))))) + + (setcdr (setq field (assq 'public-key-algorithm + result)) + (cdr (assq (cdr field) + pgg-parse-public-key-algorithm-alist))) + (setcdr (setq field (assq 'hash-algorithm + result)) + (cdr (assq (cdr field) + pgg-parse-hash-algorithm-alist))) + result)) + +(defun pgg-parse-public-key-encrypted-session-key-packet (ptag) + (let (result) + (pgg-set-alist result + 'version (pgg-read-byte)) + (pgg-set-alist result + 'key-identifier + (pgg-format-key-identifier + (pgg-read-bytes-string 8))) + (pgg-set-alist result + 'public-key-algorithm + (cdr (assq (pgg-read-byte) + pgg-parse-public-key-algorithm-alist))) + result)) + +(defun pgg-parse-symmetric-key-encrypted-session-key-packet (ptag) + (let (result) + (pgg-set-alist result + 'version + (pgg-read-byte)) + (pgg-set-alist result + 'symmetric-key-algorithm + (cdr (assq (pgg-read-byte) + pgg-parse-symmetric-key-algorithm-alist))) + result)) + +(defun pgg-parse-public-key-packet (ptag) + (let* ((key-version (pgg-read-byte)) + (result (list (cons 'version key-version))) + field) + (cond + ((= 3 key-version) + (pgg-set-alist result + 'creation-time + (let ((bytes (pgg-read-bytes 4))) + (pgg-parse-time-field bytes))) + (pgg-set-alist result + 'key-expiry (pgg-read-bytes 2)) + (pgg-set-alist result + 'public-key-algorithm (pgg-read-byte))) + ((= 4 key-version) + (pgg-set-alist result + 'creation-time + (let ((bytes (pgg-read-bytes 4))) + (pgg-parse-time-field bytes))) + (pgg-set-alist result + 'public-key-algorithm (pgg-read-byte)))) + + (setcdr (setq field (assq 'public-key-algorithm + result)) + (cdr (assq (cdr field) + pgg-parse-public-key-algorithm-alist))) + result)) + +(defun pgg-decode-packets () + (let* ((marker + (set-marker (make-marker) + (and (re-search-forward "^=") + (match-beginning 0)))) + (checksum (buffer-substring (point) (+ 4 (point))))) + (delete-region marker (point-max)) + (mime-decode-region (point-min) marker "base64") + (static-when (fboundp 'pgg-parse-crc24-string ) + (or pgg-ignore-packet-checksum + (string-equal + (funcall (mel-find-function 'mime-encode-string "base64") + (pgg-parse-crc24-string + (buffer-substring (point-min)(point-max)))) + checksum) + (error "PGP packet checksum does not match."))))) + +(defun pgg-decode-armor-region (start end) + (save-restriction + (narrow-to-region start end) + (goto-char (point-min)) + (re-search-forward "^-+BEGIN PGP" nil t) + (delete-region (point-min) + (and (search-forward "\n\n") + (match-end 0))) + (pgg-decode-packets) + (goto-char (point-min)) + (pgg-parse-packets))) + +(defun pgg-parse-armor (string) + (with-temp-buffer + (buffer-disable-undo) + (set-buffer-multibyte nil) + (insert string) + (pgg-decode-armor-region (point-min)(point)))) + +(defun pgg-parse-armor-region (start end) + (pgg-parse-armor (string-as-unibyte (buffer-substring start end)))) + +(provide 'pgg-parse) + +;;; pgg-parse.el ends here diff --git a/pgg-pgp.el b/pgg-pgp.el new file mode 100644 index 0000000..e7e2ee7 --- /dev/null +++ b/pgg-pgp.el @@ -0,0 +1,240 @@ +;;; pgg-pgp.el --- PGP 2.* and 6.* support for PGG. + +;; Copyright (C) 1999,2000 Daiki Ueno + +;; Author: Daiki Ueno +;; Created: 1999/11/02 +;; Keywords: PGP, OpenPGP + +;; This file is part of SEMI (Secure Emacs MIME Interface). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(eval-when-compile (require 'pgg)) + +(defgroup pgg-pgp () + "PGP 2.* and 6.* interface" + :group 'pgg) + +(defcustom pgg-pgp-program "pgp" + "PGP 2.* and 6.* executable." + :group 'pgg-pgp + :type 'string) + +(defcustom pgg-pgp-shell-file-name "/bin/sh" + "File name to load inferior shells from. Bourne shell or its equivalent +\(not tcsh) is needed for \"2>\"." + :group 'pgg-pgp + :type 'string) + +(defcustom pgg-pgp-shell-command-switch "-c" + "Switch used to have the shell execute its command line argument." + :group 'pgg-pgp + :type 'string) + +(defcustom pgg-pgp-extra-args nil + "Extra arguments for every PGP invocation." + :group 'pgg-pgp + :type 'string) + +(eval-and-compile + (luna-define-class pgg-scheme-pgp (pgg-scheme))) + +(defvar pgg-pgp-user-id nil + "GnuPG ID of your default identity.") + +(defvar pgg-scheme-pgp-instance nil) + +;;;###autoload +(defun pgg-make-scheme-pgp () + (or pgg-scheme-pgp-instance + (setq pgg-scheme-pgp-instance + (luna-make-entity 'pgg-scheme-pgp)))) + +(defun pgg-pgp-process-region (start end passphrase program args) + (let* ((errors-file-name + (concat temporary-file-directory + (make-temp-name "pgg-errors"))) + (args + (append args + pgg-pgp-extra-args + (list (concat "2>" errors-file-name)))) + (shell-file-name pgg-pgp-shell-file-name) + (shell-command-switch pgg-pgp-shell-command-switch) + (output-buffer pgg-output-buffer) + (errors-buffer pgg-errors-buffer) + (process-connection-type nil) + process status exit-status) + (with-current-buffer (get-buffer-create output-buffer) + (buffer-disable-undo) + (erase-buffer)) + (when passphrase + (setenv "PGPPASSFD" "0")) + (as-binary-process + (setq process + (apply #'start-process-shell-command "*PGP*" output-buffer + program args))) + (set-process-sentinel process #'ignore) + (when passphrase + (process-send-string process (concat passphrase "\n"))) + (process-send-region process start end) + (process-send-eof process) + (while (eq 'run (process-status process)) + (accept-process-output process 5)) + (setq status (process-status process) + exit-status (process-exit-status process)) + (delete-process process) + (with-current-buffer output-buffer + (pgg-convert-lbt-region (point-min)(point-max) 'LF) + + (if (memq status '(stop signal)) + (error "%s exited abnormally: '%s'" program exit-status)) + (if (= 127 exit-status) + (error "%s could not be found" program)) + + (set-buffer (get-buffer-create errors-buffer)) + (buffer-disable-undo) + (erase-buffer) + (insert-file-contents errors-file-name) + (delete-file errors-file-name) + + (if (and process (eq 'run (process-status process))) + (interrupt-process process))))) + +(luna-define-method pgg-scheme-lookup-key ((scheme pgg-scheme-pgp) + string &optional type) + (let ((args (list "+batchmode" "+language=en" "-kv" string))) + (with-current-buffer (get-buffer-create pgg-output-buffer) + (buffer-disable-undo) + (erase-buffer) + (apply #'call-process pgg-pgp-program nil t nil args) + (goto-char (point-min)) + (cond + ((re-search-forward "^pub\\s +[0-9]+/" nil t);PGP 2.* + (buffer-substring (point)(+ 8 (point)))) + ((re-search-forward "^Type" nil t);PGP 6.* + (beginning-of-line 2) + (substring + (nth 2 (split-string + (buffer-substring (point)(progn (end-of-line) (point))))) + 2)))))) + +(luna-define-method pgg-scheme-encrypt-region ((scheme pgg-scheme-pgp) + start end recipients) + (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id)) + (args + `("+encrypttoself=off +verbose=1" "+batchmode" + "+language=us" "-fate" + ,@(if recipients + (mapcar (lambda (rcpt) (concat "\"" rcpt "\"")) + (append recipients + (if pgg-encrypt-for-me + (list pgg-pgp-user-id)))))))) + (pgg-pgp-process-region start end nil pgg-pgp-program args) + (pgg-process-when-success nil))) + +(luna-define-method pgg-scheme-decrypt-region ((scheme pgg-scheme-pgp) + start end) + (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id)) + (passphrase + (pgg-read-passphrase + (format "PGP passphrase for %s: " pgg-pgp-user-id) + (pgg-scheme-lookup-key scheme pgg-pgp-user-id 'encrypt))) + (args + '("+verbose=1" "+batchmode" "+language=us" "-f"))) + (pgg-pgp-process-region start end passphrase pgg-pgp-program args) + (pgg-process-when-success nil))) + +(luna-define-method pgg-scheme-sign-region ((scheme pgg-scheme-pgp) + start end &optional clearsign) + (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id)) + (passphrase + (pgg-read-passphrase + (format "PGP passphrase for %s: " pgg-pgp-user-id) + (pgg-scheme-lookup-key scheme pgg-pgp-user-id 'sign))) + (args + (list (if clearsign "-fast" "-fbast") + "+verbose=1" "+language=us" "+batchmode" + "-u" pgg-pgp-user-id))) + (pgg-pgp-process-region start end passphrase pgg-pgp-program args) + (pgg-process-when-success + (goto-char (point-min)) + (when (re-search-forward "^-+BEGIN PGP" nil t);XXX + (let ((packet + (cdr (assq 2 (pgg-parse-armor-region + (progn (beginning-of-line 2) + (point)) + (point-max)))))) + (if pgg-cache-passphrase + (pgg-add-passphrase-cache + (cdr (assq 'key-identifier packet)) + passphrase))))))) + +(luna-define-method pgg-scheme-verify-region ((scheme pgg-scheme-pgp) + start end &optional signature) + (let* ((basename (expand-file-name "pgg" temporary-file-directory)) + (orig-file (make-temp-name basename)) + (args '("+verbose=1" "+batchmode" "+language=us")) + (orig-mode (default-file-modes))) + (unwind-protect + (progn + (set-default-file-modes 448) + (write-region-as-binary start end orig-file)) + (set-default-file-modes orig-mode)) + (when (stringp signature) + (copy-file signature (setq signature (concat orig-file ".asc"))) + (setq args (append args (list signature orig-file)))) + (pgg-pgp-process-region (point)(point) nil pgg-pgp-program args) + (delete-file orig-file) + (if signature (delete-file signature)) + (pgg-process-when-success + (goto-char (point-min)) + (let ((case-fold-search t)) + (while (re-search-forward "^warning: " nil t) + (delete-region (match-beginning 0) + (progn (beginning-of-line 2) (point))))) + (goto-char (point-min)) + (when (re-search-forward "^\\.$" nil t) + (delete-region (point-min) + (progn (beginning-of-line 2) + (point))))))) + +(luna-define-method pgg-scheme-insert-key ((scheme pgg-scheme-pgp)) + (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id)) + (args + (list "+verbose=1" "+batchmode" "+language=us" "-kxaf" + (concat "\"" pgg-pgp-user-id "\"")))) + (pgg-pgp-process-region (point)(point) nil pgg-pgp-program args) + (insert-buffer-substring pgg-output-buffer))) + +(luna-define-method pgg-scheme-snarf-keys-region ((scheme pgg-scheme-pgp) + start end) + (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id)) + (basename (expand-file-name "pgg" temporary-file-directory)) + (key-file (make-temp-name basename)) + (args + (list "+verbose=1" "+batchmode" "+language=us" "-kaf" + key-file))) + (write-region-as-raw-text-CRLF start end key-file) + (pgg-pgp-process-region start end nil pgg-pgp-program args) + (delete-file key-file) + (pgg-process-when-success nil))) + +(provide 'pgg-pgp) + +;;; pgg-pgp.el ends here diff --git a/pgg-pgp5.el b/pgg-pgp5.el new file mode 100644 index 0000000..2b26a3f --- /dev/null +++ b/pgg-pgp5.el @@ -0,0 +1,244 @@ +;;; pgg-pgp5.el --- PGP 5.* support for PGG. + +;; Copyright (C) 1999,2000 Daiki Ueno + +;; Author: Daiki Ueno +;; Created: 1999/11/02 +;; Keywords: PGP, OpenPGP + +;; This file is part of SEMI (Secure Emacs MIME Interface). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(eval-when-compile (require 'pgg)) + +(defgroup pgg-pgp5 () + "PGP 5.* interface" + :group 'pgg) + +(defcustom pgg-pgp5-pgpe-program "pgpe" + "PGP 5.* 'pgpe' executable." + :group 'pgg-pgp5 + :type 'string) + +(defcustom pgg-pgp5-pgps-program "pgps" + "PGP 5.* 'pgps' executable." + :group 'pgg-pgp5 + :type 'string) + +(defcustom pgg-pgp5-pgpk-program "pgpk" + "PGP 5.* 'pgpk' executable." + :group 'pgg-pgp5 + :type 'string) + +(defcustom pgg-pgp5-pgpv-program "pgpv" + "PGP 5.* 'pgpv' executable." + :group 'pgg-pgp5 + :type 'string) + +(defcustom pgg-pgp5-shell-file-name "/bin/sh" + "File name to load inferior shells from. Bourne shell or its equivalent +\(not tcsh) is needed for \"2>\"." + :group 'pgg-pgp5 + :type 'string) + +(defcustom pgg-pgp5-shell-command-switch "-c" + "Switch used to have the shell execute its command line argument." + :group 'pgg-pgp5 + :type 'string) + +(defcustom pgg-pgp5-extra-args nil + "Extra arguments for every PGP invocation." + :group 'pgg-pgp5 + :type 'string) + +(eval-and-compile + (luna-define-class pgg-scheme-pgp5 (pgg-scheme))) + +(defvar pgg-pgp5-user-id nil + "GnuPG ID of your default identity.") + +(defvar pgg-scheme-pgp5-instance nil) + +;;;###autoload +(defun pgg-make-scheme-pgp5 () + (or pgg-scheme-pgp5-instance + (setq pgg-scheme-pgp5-instance + (luna-make-entity 'pgg-scheme-pgp5)))) + +(defun pgg-pgp5-process-region (start end passphrase program args) + (let* ((errors-file-name + (concat temporary-file-directory + (make-temp-name "pgg-errors"))) + (args + (append args + pgg-pgp5-extra-args + (list (concat "2>" errors-file-name)))) + (shell-file-name pgg-pgp5-shell-file-name) + (shell-command-switch pgg-pgp5-shell-command-switch) + (output-buffer pgg-output-buffer) + (errors-buffer pgg-errors-buffer) + (process-connection-type nil) + process status exit-status) + (with-current-buffer (get-buffer-create output-buffer) + (buffer-disable-undo) + (erase-buffer)) + (when passphrase + (setenv "PGPPASSFD" "0")) + (as-binary-process + (setq process + (apply #'start-process-shell-command "*PGP*" output-buffer + program args))) + (set-process-sentinel process #'ignore) + (when passphrase + (process-send-string process (concat passphrase "\n"))) + (process-send-region process start end) + (process-send-eof process) + (while (eq 'run (process-status process)) + (accept-process-output process 5)) + (setq status (process-status process) + exit-status (process-exit-status process)) + (delete-process process) + (with-current-buffer output-buffer + (pgg-convert-lbt-region (point-min)(point-max) 'LF) + + (if (memq status '(stop signal)) + (error "%s exited abnormally: '%s'" program exit-status)) + (if (= 127 exit-status) + (error "%s could not be found" program)) + + (set-buffer (get-buffer-create errors-buffer)) + (buffer-disable-undo) + (erase-buffer) + (insert-file-contents errors-file-name) + (delete-file errors-file-name) + + (if (and process (eq 'run (process-status process))) + (interrupt-process process))))) + +(luna-define-method pgg-scheme-lookup-key ((scheme pgg-scheme-pgp5) + string &optional type) + (let ((args (list "+language=en" "-l" string))) + (with-current-buffer (get-buffer-create pgg-output-buffer) + (buffer-disable-undo) + (erase-buffer) + (apply #'call-process pgg-pgp5-pgpk-program nil t nil args) + (goto-char (point-min)) + (when (re-search-forward "^sec" nil t) + (substring + (nth 2 (split-string + (buffer-substring (match-end 0)(progn (end-of-line)(point))))) + 2))))) + +(luna-define-method pgg-scheme-encrypt-region ((scheme pgg-scheme-pgp5) + start end recipients) + (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) + (args + `("+NoBatchInvalidKeys=off" "-fat" "+batchmode=1" + ,@(if recipients + (apply #'append + (mapcar (lambda (rcpt) + (list "-r" + (concat "\"" rcpt "\""))) + (append recipients + (if pgg-encrypt-for-me + (list pgg-pgp5-user-id))))))))) + (pgg-pgp5-process-region start end nil pgg-pgp5-pgpe-program args) + (pgg-process-when-success nil))) + +(luna-define-method pgg-scheme-decrypt-region ((scheme pgg-scheme-pgp5) + start end) + (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) + (passphrase + (pgg-read-passphrase + (format "PGP passphrase for %s: " pgg-pgp5-user-id) + (pgg-scheme-lookup-key scheme pgg-pgp5-user-id 'encrypt))) + (args + '("+verbose=1" "+batchmode=1" "+language=us" "-f"))) + (pgg-pgp5-process-region start end passphrase pgg-pgp5-pgpv-program args) + (pgg-process-when-success nil))) + +(luna-define-method pgg-scheme-sign-region ((scheme pgg-scheme-pgp5) + start end &optional clearsign) + (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) + (passphrase + (pgg-read-passphrase + (format "PGP passphrase for %s: " pgg-pgp5-user-id) + (pgg-scheme-lookup-key scheme pgg-pgp5-user-id 'sign))) + (args + (list (if clearsign "-fat" "-fbat") + "+verbose=1" "+language=us" "+batchmode=1" + "-u" pgg-pgp5-user-id))) + (pgg-pgp5-process-region start end passphrase pgg-pgp5-pgps-program args) + (pgg-process-when-success + (when (re-search-forward "^-+BEGIN PGP SIGNATURE" nil t);XXX + (let ((packet + (cdr (assq 2 (pgg-parse-armor-region + (progn (beginning-of-line 2) + (point)) + (point-max)))))) + (if pgg-cache-passphrase + (pgg-add-passphrase-cache + (cdr (assq 'key-identifier packet)) + passphrase))))))) + +(luna-define-method pgg-scheme-verify-region ((scheme pgg-scheme-pgp5) + start end &optional signature) + (let* ((basename (expand-file-name "pgg" temporary-file-directory)) + (orig-file (make-temp-name basename)) + (args '("+verbose=1" "+batchmode=1" "+language=us")) + (orig-mode (default-file-modes))) + (unwind-protect + (progn + (set-default-file-modes 448) + (write-region-as-binary start end orig-file)) + (set-default-file-modes orig-mode)) + (when (stringp signature) + (copy-file signature (setq signature (concat orig-file ".asc"))) + (setq args (append args (list signature)))) + (pgg-pgp5-process-region (point)(point) nil pgg-pgp5-pgpv-program args) + (delete-file orig-file) + (if signature (delete-file signature)) + (with-current-buffer pgg-errors-buffer + (goto-char (point-min)) + (re-search-forward "^Good signature" nil t)))) + +(luna-define-method pgg-scheme-insert-key ((scheme pgg-scheme-pgp5)) + (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) + (args + (list "+verbose=1" "+batchmode=1" "+language=us" "-x" + (concat "\"" pgg-pgp5-user-id "\"")))) + (pgg-pgp5-process-region (point)(point) nil pgg-pgp5-pgpk-program args) + (insert-buffer-substring pgg-output-buffer))) + +(luna-define-method pgg-scheme-snarf-keys-region ((scheme pgg-scheme-pgp5) + start end) + (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) + (basename (expand-file-name "pgg" temporary-file-directory)) + (key-file (make-temp-name basename)) + (args + (list "+verbose=1" "+batchmode=1" "+language=us" "-a" + key-file))) + (write-region-as-raw-text-CRLF start end key-file) + (pgg-pgp5-process-region start end nil pgg-pgp5-pgpk-program args) + (delete-file key-file) + (pgg-process-when-success nil))) + +(provide 'pgg-pgp5) + +;;; pgg-pgp5.el ends here diff --git a/pgg.el b/pgg.el new file mode 100644 index 0000000..cae8e27 --- /dev/null +++ b/pgg.el @@ -0,0 +1,424 @@ +;;; pgg.el --- glue for the various PGP implementations. + +;; Copyright (C) 1999,2000 Daiki Ueno + +;; Author: Daiki Ueno +;; Created: 1999/10/28 +;; Keywords: PGP + +;; This file is part of SEMI (Secure Emacs MIME Interface). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + + +;;; Commentary: +;; + +;;; Code: + +(require 'calist) + +(eval-and-compile (require 'luna)) + +(require 'pgg-def) +(require 'pgg-parse) + +(eval-when-compile + (ignore-errors + (require 'w3) + (require 'url))) + +(in-calist-package 'pgg) + +(defun pgg-field-match-method-with-containment + (calist field-type field-value) + (let ((s-field (assq field-type calist))) + (cond ((null s-field) + (cons (cons field-type field-value) calist)) + ((memq (cdr s-field) field-value) + calist)))) + +(define-calist-field-match-method 'signature-version + #'pgg-field-match-method-with-containment) + +(define-calist-field-match-method 'symmetric-key-algorithm + #'pgg-field-match-method-with-containment) + +(define-calist-field-match-method 'public-key-algorithm + #'pgg-field-match-method-with-containment) + +(define-calist-field-match-method 'hash-algorithm + #'pgg-field-match-method-with-containment) + +(defvar pgg-verify-condition nil + "Condition-tree about which PGP implementation is used for verifying.") + +(defvar pgg-decrypt-condition nil + "Condition-tree about which PGP implementation is used for decrypting.") + +(ctree-set-calist-strictly + 'pgg-verify-condition + '((signature-version 3)(public-key-algorithm RSA)(hash-algorithm MD5) + (scheme . pgp))) + +(ctree-set-calist-strictly + 'pgg-decrypt-condition + '((public-key-algorithm RSA)(symmetric-key-algorithm IDEA) + (scheme . pgp))) + +(ctree-set-calist-strictly + 'pgg-verify-condition + '((signature-version 3 4) + (public-key-algorithm RSA ELG DSA) + (hash-algorithm MD5 SHA1 RIPEMD160) + (scheme . pgp5))) + +(ctree-set-calist-strictly + 'pgg-decrypt-condition + '((public-key-algorithm RSA ELG DSA) + (symmetric-key-algorithm 3DES CAST5 IDEA) + (scheme . pgp5))) + +(ctree-set-calist-strictly + 'pgg-verify-condition + '((signature-version 3 4) + (public-key-algorithm ELG-E DSA ELG) + (hash-algorithm MD5 SHA1 RIPEMD160) + (scheme . gpg))) + +(ctree-set-calist-strictly + 'pgg-decrypt-condition + '((public-key-algorithm ELG-E DSA ELG) + (symmetric-key-algorithm 3DES CAST5 BLOWFISH TWOFISH) + (scheme . gpg))) + +;;; @ definition of the implementation scheme +;;; + +(eval-and-compile + (luna-define-class pgg-scheme ()) + + (luna-define-internal-accessors 'pgg-scheme)) + +(luna-define-generic pgg-scheme-lookup-key (scheme string &optional type) + "Search keys associated with STRING") + +(luna-define-generic pgg-scheme-encrypt-region (scheme start end recipients) + "Encrypt the current region between START and END.") + +(luna-define-generic pgg-scheme-decrypt-region (scheme start end) + "Decrypt the current region between START and END.") + +(luna-define-generic pgg-scheme-sign-region + (scheme start end &optional cleartext) + "Make detached signature from text between START and END.") + +(luna-define-generic pgg-scheme-verify-region + (scheme start end &optional signature) + "Verify region between START and END +as the detached signature SIGNATURE.") + +(luna-define-generic pgg-scheme-insert-key (scheme) + "Insert public key at point.") + +(luna-define-generic pgg-scheme-snarf-keys-region (scheme start end) + "Add all public keys in region between START +and END to the keyring.") + +;;; @ utility functions +;;; + +(defvar pgg-fetch-key-function (function pgg-fetch-key-with-w3)) + +(defmacro pgg-make-scheme (scheme) + `(progn + (require (intern (format "pgg-%s" ,scheme))) + (funcall (intern (format "pgg-make-scheme-%s" + ,scheme))))) + +(put 'pgg-save-coding-system 'lisp-indent-function 2) + +(defmacro pgg-save-coding-system (start end &rest body) + `(if (interactive-p) + (let ((buffer (current-buffer))) + (with-temp-buffer + (let (buffer-undo-list) + (insert-buffer-substring buffer ,start ,end) + (encode-coding-region (point-min)(point-max) + buffer-file-coding-system) + (prog1 (save-excursion ,@body) + (push nil buffer-undo-list) + (ignore-errors (undo)))))) + (save-restriction + (narrow-to-region ,start ,end) + ,@body))) + +(defun pgg-temp-buffer-show-function (buffer) + (let ((window (split-window-vertically + (- (window-height) + (/ (window-height) 5))))) + (set-window-buffer window buffer))) + +(defun pgg-display-output-buffer (start end status) + (if status + (progn + (delete-region start end) + (insert-buffer-substring pgg-output-buffer) + (decode-coding-region start (point) buffer-file-coding-system)) + (let ((temp-buffer-show-function + (function pgg-temp-buffer-show-function))) + (with-output-to-temp-buffer pgg-echo-buffer + (set-buffer standard-output) + (insert-buffer-substring pgg-errors-buffer))))) + +(defvar pgg-passphrase-cache-expiry 16) +(defvar pgg-passphrase-cache (make-vector 7 0)) + +(defvar pgg-read-passphrase nil) +(defun pgg-read-passphrase (prompt &optional key) + (if (not pgg-read-passphrase) + (if (functionp 'read-passwd) + (setq pgg-read-passphrase 'read-passwd) + (if (load "passwd" t) + (setq pgg-read-passphrase 'read-passwd) + (autoload 'ange-ftp-read-passwd "ange-ftp") + (setq pgg-read-passphrase 'ange-ftp-read-passwd)))) + (or (and pgg-cache-passphrase + key (setq key (pgg-truncate-key-identifier key)) + (symbol-value (intern-soft key pgg-passphrase-cache))) + (funcall pgg-read-passphrase prompt))) + +(defun pgg-add-passphrase-cache (key passphrase) + (setq key (pgg-truncate-key-identifier key)) + (set (intern key pgg-passphrase-cache) + passphrase) + (run-at-time pgg-passphrase-cache-expiry nil + #'pgg-remove-passphrase-cache + key)) + +(defun pgg-remove-passphrase-cache (key) + (let ((passphrase (symbol-value (intern-soft key pgg-passphrase-cache)))) + (when passphrase + (fillarray passphrase ?_) + (unintern key pgg-passphrase-cache)))) + +(defmacro pgg-convert-lbt-region (start end lbt) + `(let ((pgg-conversion-end (set-marker (make-marker) ,end))) + (goto-char ,start) + (case ,lbt + (CRLF + (while (progn + (end-of-line) + (> (marker-position pgg-conversion-end) (point))) + (insert "\r") + (forward-line 1))) + (LF + (while (re-search-forward "\r$" pgg-conversion-end t) + (replace-match "")))))) + +(put 'pgg-as-lbt 'lisp-indent-function 3) + +(defmacro pgg-as-lbt (start end lbt &rest body) + `(let ((inhibit-read-only t) + buffer-read-only + buffer-undo-list) + (pgg-convert-lbt-region ,start ,end ,lbt) + (let ((,end (point))) + ,@body) + (push nil buffer-undo-list) + (ignore-errors (undo)))) + +(put 'pgg-process-when-success 'lisp-indent-function 0) + +(defmacro pgg-process-when-success (&rest body) + `(with-current-buffer pgg-output-buffer + (if (zerop (buffer-size)) nil ,@body t))) + + +;;; @ interface functions +;;; + +;;;###autoload +(defun pgg-encrypt-region (start end rcpts) + "Encrypt the current region between START and END for RCPTS." + (interactive + (list (region-beginning)(region-end) + (split-string (read-string "Recipients: ") "[ \t,]+"))) + (let* ((entity (pgg-make-scheme pgg-default-scheme)) + (status + (pgg-save-coding-system start end + (pgg-scheme-encrypt-region entity (point-min)(point-max) rcpts)))) + (when (interactive-p) + (pgg-display-output-buffer start end status)) + status)) + +;;;###autoload +(defun pgg-decrypt-region (start end) + "Decrypt the current region between START and END." + (interactive "r") + (let* ((packet (cdr (assq 1 (pgg-parse-armor-region start end)))) + (scheme + (or pgg-scheme + (cdr (assq 'scheme + (progn + (in-calist-package 'pgg) + (ctree-match-calist pgg-decrypt-condition + packet)))) + pgg-default-scheme)) + (entity (pgg-make-scheme scheme)) + (status + (pgg-save-coding-system start end + (pgg-scheme-decrypt-region entity (point-min)(point-max))))) + (when (interactive-p) + (pgg-display-output-buffer start end status)) + status)) + +;;;###autoload +(defun pgg-sign-region (start end &optional cleartext) + "Make the signature from text between START and END. +If the optional 3rd argument CLEARTEXT is non-nil, it does not create +a detached signature." + (interactive "r") + (let* ((entity (pgg-make-scheme pgg-default-scheme)) + (status (pgg-save-coding-system start end + (pgg-scheme-sign-region entity (point-min)(point-max) + (or (interactive-p) cleartext))))) + (when (interactive-p) + (pgg-display-output-buffer start end status)) + status)) + +;;;###autoload +(defun pgg-verify-region (start end &optional signature fetch) + "Verify the current region between START and END. +If the optional 3rd argument SIGNATURE is non-nil, it is treated as +the detached signature of the current region. + +If the optional 4th argument FETCH is non-nil, we attempt to fetch the +signer's public key from `pgg-default-keyserver-address'." + (interactive "r") + (let* ((packet + (if (null signature) nil + (with-temp-buffer + (buffer-disable-undo) + (set-buffer-multibyte nil) + (insert-file-contents signature) + (cdr (assq 2 (pgg-decode-armor-region + (point-min)(point-max))))))) + (scheme + (or pgg-scheme + (cdr (assq 'scheme + (progn + (in-calist-package 'pgg) + (ctree-match-calist pgg-verify-condition + packet)))) + pgg-default-scheme)) + (entity (pgg-make-scheme scheme)) + (key (cdr (assq 'key-identifier packet))) + status keyserver) + (and (stringp key) + (setq key (concat "0x" (pgg-truncate-key-identifier key))) + (null (let ((pgg-scheme scheme)) + (pgg-lookup-key key))) + (or fetch (interactive-p)) + (y-or-n-p (format "Key %s not found; attempt to fetch? " key)) + (setq keyserver + (or (cdr (assq 'preferred-key-server packet)) + pgg-default-keyserver-address)) + (pgg-fetch-key keyserver key)) + (setq status (pgg-save-coding-system start end + (pgg-scheme-verify-region entity (point-min)(point-max) + signature))) + (when (interactive-p) + (let ((temp-buffer-show-function + (function pgg-temp-buffer-show-function))) + (with-output-to-temp-buffer pgg-echo-buffer + (set-buffer standard-output) + (insert-buffer-substring (if status pgg-output-buffer + pgg-errors-buffer))))) + status)) + +;;;###autoload +(defun pgg-insert-key () + "Insert the ASCII armored public key." + (interactive) + (let ((entity (pgg-make-scheme (or pgg-scheme pgg-default-scheme)))) + (pgg-scheme-insert-key entity))) + +;;;###autoload +(defun pgg-snarf-keys-region (start end) + "Import public keys in the current region between START and END." + (interactive "r") + (let ((entity (pgg-make-scheme (or pgg-scheme pgg-default-scheme)))) + (pgg-save-coding-system start end + (pgg-scheme-snarf-keys-region entity start end)))) + +(defun pgg-lookup-key (string &optional type) + (let ((entity (pgg-make-scheme (or pgg-scheme pgg-default-scheme)))) + (pgg-scheme-lookup-key entity string type))) + +(defvar pgg-insert-url-function (function pgg-insert-url-with-w3)) + +(defun pgg-insert-url-with-w3 (url) + (require 'w3) + (require 'url) + (let (buffer-file-name) + (url-insert-file-contents url))) + +(defvar pgg-insert-url-extra-arguments nil) +(defvar pgg-insert-url-program nil) + +(defun pgg-insert-url-with-program (url) + (let ((args (copy-sequence pgg-insert-url-extra-arguments)) + process) + (insert + (with-temp-buffer + (setq process + (apply #'start-process " *PGG url*" (current-buffer) + pgg-insert-url-program (nconc args (list url)))) + (set-process-sentinel process #'ignore) + (while (eq 'run (process-status process)) + (accept-process-output process 5)) + (delete-process process) + (if (and process (eq 'run (process-status process))) + (interrupt-process process)) + (buffer-string))))) + +(defun pgg-fetch-key (keyserver key) + "Attempt to fetch a KEY from KEYSERVER for addition to PGP or GnuPG keyring." + (with-current-buffer (get-buffer-create pgg-output-buffer) + (buffer-disable-undo) + (erase-buffer) + (let ((proto (if (string-match "^[a-zA-Z\\+\\.\\\\-]+:" keyserver) + (substring keyserver 0 (1- (match-end 0)))))) + (save-excursion + (funcall pgg-insert-url-function + (if proto keyserver + (format "http://%s:11371/pks/lookup?op=get&search=%s" + keyserver key)))) + (when (re-search-forward "^-+BEGIN" nil 'last) + (delete-region (point-min) (match-beginning 0)) + (when (re-search-forward "^-+END" nil t) + (delete-region (progn (end-of-line) (point)) + (point-max))) + (insert "\n") + (with-temp-buffer + (insert-buffer-substring pgg-output-buffer) + (pgg-snarf-keys-region (point-min)(point-max))))))) + + +(provide 'pgg) + +;;; pgg.el ends here diff --git a/semi-def.el b/semi-def.el index 2f35c2d..ac9aece 100644 --- a/semi-def.el +++ b/semi-def.el @@ -30,7 +30,7 @@ (require 'custom) -(defconst mime-user-interface-product ["EMY" (1 13 1) "Haste makes waste"] +(defconst mime-user-interface-product ["EMY" (1 13 2) "Better late than never"] "Product name, version number and code name of MIME-kernel package.") (autoload 'mule-caesar-region "mule-caesar" @@ -90,16 +90,14 @@ (setq buf (current-buffer) point (point) func (get-text-property (point) 'mime-button-callback) - data (get-text-property (point) 'mime-button-data) - )) + data (get-text-property (point) 'mime-button-data))) (save-excursion (set-buffer buf) (goto-char point) (if func (apply func data) (if (fboundp mime-button-mother-dispatcher) - (funcall mime-button-mother-dispatcher event) - ))))) + (funcall mime-button-mother-dispatcher event)))))) ;;; @ for URL @@ -143,65 +141,19 @@ (vector (car cell) `(progn (setq ret ',(cdr cell)) - (throw 'exit nil) - ) - t) - )) - menu-alist) - )) + (throw 'exit nil)) + t))) + menu-alist))) (recursive-edit) ret)) (defun select-menu-alist (title menu-alist) (x-popup-menu (list '(1 1) (selected-window)) - (list title (cons title menu-alist)) - )) - ) + (list title (cons title menu-alist))))) (defun select-menu-alist (title menu-alist) (cdr (assoc (completing-read (concat title " : ") menu-alist) - menu-alist) - )) - ) - - -;;; @ PGP -;;; - -(defvar pgp-function-alist - '( - ;; for mime-pgp - (verify mc-verify "mc-toplev") - (decrypt mc-decrypt "mc-toplev") - (fetch-key mc-pgp-fetch-key "mc-pgp") - (snarf-keys mc-snarf-keys "mc-toplev") - ;; for mime-edit - (mime-sign mime-mc-pgp-sign-region "mime-mc") - (traditional-sign mc-pgp-sign-region "mc-pgp") - (encrypt mime-mc-pgp-encrypt-region "mime-mc") - (insert-key mc-insert-public-key "mc-toplev") - ) - "Alist of service names vs. corresponding functions and its filenames. -Each element looks like (SERVICE FUNCTION FILE). - -SERVICE is a symbol of PGP processing. It allows `verify', `decrypt', -`fetch-key', `snarf-keys', `mime-sign', `traditional-sign', `encrypt' -or `insert-key'. - -Function is a symbol of function to do specified SERVICE. - -FILE is string of filename which has definition of corresponding -FUNCTION.") - -(defmacro pgp-function (method) - "Return function to do service METHOD." - `(cadr (assq ,method (symbol-value 'pgp-function-alist)))) - -(mapcar (function - (lambda (method) - (autoload (cadr method)(nth 2 method)) - )) - pgp-function-alist) + menu-alist)))) ;;; @ Other Utility @@ -233,13 +185,9 @@ activate." (funcall func sym condition) (if file (let ((method (cdr (assq 'method condition)))) - (autoload method file) - )) - ) - (error "Function for mode `%s' is not found." mode) - )) - (error "Variable for target-type `%s' is not found." target-type) - ))) + (autoload method file)))) + (error "Function for mode `%s' is not found." mode))) + (error "Variable for target-type `%s' is not found." target-type)))) ;;; @ end diff --git a/semi-setup.el b/semi-setup.el index 9928d1e..7623830 100644 --- a/semi-setup.el +++ b/semi-setup.el @@ -35,27 +35,22 @@ it is used as hook to set." (if (featurep module) (funcall func) (or hook-name - (setq hook-name (intern (concat (symbol-name module) "-load-hook"))) - ) - (add-hook hook-name func) - )) + (setq hook-name (intern (concat (symbol-name module) "-load-hook")))) + (add-hook hook-name func))) ;; for image/* and X-Face (defvar mime-setup-enable-inline-image (and window-system (or (featurep 'xemacs) - (and (featurep 'mule)(module-installed-p 'bitmap)) - )) + (and (featurep 'mule)(module-installed-p 'bitmap)))) "*If it is non-nil, semi-setup sets up to use mime-image.") (if mime-setup-enable-inline-image (call-after-loaded 'mime-view (function (lambda () - (require 'mime-image) - ))) - ) + (require 'mime-image))))) ;; for text/html @@ -77,15 +72,12 @@ it is used as hook to set." (body-presentation-method . mime-preview-text/html))) (set-alist 'mime-view-type-subtype-score-alist - '(text . html) 3) - ))) - ) + '(text . html) 3))))) ;; for PGP -(defvar mime-setup-enable-pgp - (module-installed-p 'mailcrypt) - "*If it is non-nil, semi-setup sets uf to use mime-pgp.") +(defvar mime-setup-enable-pgp t + "*If it is non-nil, semi-setup sets up to use mime-pgp.") (if mime-setup-enable-pgp (eval-after-load "mime-view" @@ -123,8 +115,30 @@ it is used as hook to set." '((type . application)(subtype . pgp-keys) (method . mime-add-application/pgp-keys)) 'strict "mime-pgp") - )) - ) + + (mime-add-condition + 'action + '((type . application)(subtype . pkcs7-signature) + (method . mime-verify-application/pkcs7-signature)) + 'strict "mime-pgp") + + (mime-add-condition + 'action + '((type . application)(subtype . x-pkcs7-signature) + (method . mime-verify-application/pkcs7-signature)) + 'strict "mime-pgp") + + (mime-add-condition + 'action + '((type . application)(subtype . pkcs7-mime) + (method . mime-view-application/pkcs7-mime)) + 'strict "mime-pgp") + + (mime-add-condition + 'action + '((type . application)(subtype . x-pkcs7-mime) + (method . mime-view-application/pkcs7-mime)) + 'strict "mime-pgp")))) ;;; @ for mime-edit @@ -140,11 +154,9 @@ it is used as hook to set." (concat "^" (regexp-quote mail-header-separator) "$") nil t) (match-beginning 0) - (point-max) - )) + (point-max))) (mime-decode-header-in-buffer) - (set-buffer-modified-p nil) - ))) + (set-buffer-modified-p nil)))) (add-hook 'mime-edit-mode-hook 'mime-setup-decode-message-header) @@ -171,8 +183,7 @@ it is used as hook to set." (let ((key (or (cdr (assq major-mode mime-setup-signature-key-alist)) mime-setup-default-signature-key))) - (define-key keymap key (function insert-signature)) - )))) + (define-key keymap key (function insert-signature)))))) (when mime-setup-use-signature (autoload 'insert-signature "signature" "Insert signature" t) diff --git a/signature.el b/signature.el index f06f53c..bd5114a 100644 --- a/signature.el +++ b/signature.el @@ -85,8 +85,7 @@ FIELD, the contents of FILENAME is inserted.") (concat "^" (regexp-quote mail-header-separator) "$") nil t) (match-beginning 0) - (point-max) - )) + (point-max))) (catch 'found (let ((alist signature-file-alist) cell field value) (while alist @@ -97,8 +96,7 @@ FIELD, the contents of FILENAME is inserted.") (let ((name (apply value field (cdr cell)))) (if name (throw 'found - (concat signature-file-prefix name)) - ))) + (concat signature-file-prefix name))))) ((stringp field) (cond ((consp value) (while value @@ -106,16 +104,13 @@ FIELD, the contents of FILENAME is inserted.") (throw 'found (concat signature-file-prefix (cdr cell))) - (setq value (cdr value)) - ))) + (setq value (cdr value))))) ((stringp value) (if (string-match value field) (throw 'found (concat - signature-file-prefix (cdr cell))) - ))))) - (setq alist (cdr alist)) - )) + signature-file-prefix (cdr cell)))))))) + (setq alist (cdr alist)))) signature-file-name)))) (defun insert-signature (&optional arg) @@ -130,20 +125,17 @@ specify a file named -DISTRIBUTION interactively." (signature/get-sigtype-from-bbdb arg)) (and arg (signature/get-sigtype-interactively)) - (signature/get-signature-file-name)) - ))) + (signature/get-signature-file-name))))) (or (file-readable-p signature-file-name) (error "Cannot open signature file: %s" signature-file-name)) (if signature-insert-at-eof (progn (goto-char (point-max)) (or (bolp) (insert "\n")) - (if signature-delete-blank-lines-at-eof (delete-blank-lines)) - )) + (if signature-delete-blank-lines-at-eof (delete-blank-lines)))) (run-hooks 'signature-insert-hook) (if (= (point)(point-max)) - (insert signature-separator) - ) + (insert signature-separator)) (insert-file-contents signature-file-name) (force-mode-line-update) signature-file-name)) diff --git a/smime.el b/smime.el new file mode 100644 index 0000000..bb4717d --- /dev/null +++ b/smime.el @@ -0,0 +1,334 @@ +;;; smime.el --- S/MIME interface. + +;; Copyright (C) 1999 Daiki Ueno + +;; Author: Daiki Ueno +;; Created: 1999/12/08 +;; Keywords: S/MIME, OpenSSL + +;; This file is part of SEMI (Secure Emacs MIME Interface). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + + +;;; Commentary: + +;; This module is based on + +;; [SMIMEV3] RFC 2633: "S/MIME Version 3 Message Specification" +;; by Crocker, D., Flanigan, B., Hoffman, P., Housley, R., +;; Pawling, J. and Schaad, J. (1999/06) + +;; [SMIMEV2] RFC 2311: "S/MIME Version 2 Message Specification" +;; by Dusse, S., Hoffman, P., Ramsdell, B., Lundblade, L. +;; and L. Repka. (1998/03) + +;;; Code: + +(require 'path-util) +(eval-when-compile (require 'static)) + +(defgroup smime () + "S/MIME interface" + :group 'mime) + +(defcustom smime-program "smime" + "The S/MIME executable." + :group 'smime + :type 'string) + +(defcustom smime-shell-file-name "/bin/sh" + "File name to load inferior shells from. Bourne shell or its equivalent +\(not tcsh) is needed for \"2>\"." + :group 'smime + :type 'string) + +(defcustom smime-shell-command-switch "-c" + "Switch used to have the shell execute its command line argument." + :group 'smime + :type 'string) + +(defcustom smime-x509-program + (let ((file (exec-installed-p "openssl"))) + (and file (list file "x509" "-noout"))) + "External program for x509 parser." + :group 'smime + :type 'string) + +(defcustom smime-cache-passphrase t + "Cache passphrase." + :group 'smime + :type 'boolean) + +(defcustom smime-certificate-directory "~/.w3/certs" + "Certificate directory." + :group 'smime + :type 'directory) + +(defcustom smime-public-key-file nil + "Public key file." + :group 'smime + :type 'boolean) + +(defcustom smime-private-key-file nil + "Private key file." + :group 'smime + :type 'boolean) + +(defvar smime-errors-buffer " *S/MIME errors*") +(defvar smime-output-buffer " *S/MIME output*") + +;;; @ utility functions +;;; +(put 'smime-process-when-success 'lisp-indent-function 0) + +(defmacro smime-process-when-success (&rest body) + `(with-current-buffer smime-output-buffer + (if (zerop (buffer-size)) nil ,@body t))) + +(defvar smime-passphrase-cache-expiry 16) +(defvar smime-passphrase-cache (make-vector 7 0)) + +(defvar smime-read-passphrase nil) +(defun smime-read-passphrase (prompt &optional key) + (if (not smime-read-passphrase) + (if (functionp 'read-passwd) + (setq smime-read-passphrase 'read-passwd) + (if (load "passwd" t) + (setq smime-read-passphrase 'read-passwd) + (autoload 'ange-ftp-read-passwd "ange-ftp") + (setq smime-read-passphrase 'ange-ftp-read-passwd)))) + (or (and smime-cache-passphrase + (symbol-value (intern-soft key smime-passphrase-cache))) + (funcall smime-read-passphrase prompt))) + +(defun smime-add-passphrase-cache (key passphrase) + (set (intern key smime-passphrase-cache) + passphrase) + (run-at-time smime-passphrase-cache-expiry nil + #'smime-remove-passphrase-cache + key)) + +(defun smime-remove-passphrase-cache (key) + (let ((passphrase (symbol-value (intern-soft key smime-passphrase-cache)))) + (when passphrase + (fillarray passphrase ?_) + (unintern key smime-passphrase-cache)))) + +(defsubst smime-parse-attribute (string) + (delq nil (mapcar + (lambda (attr) + (if (string-match "=" attr) + (cons (intern (substring attr 0 (match-beginning 0))) + (substring attr (match-end 0))) + nil)) + (split-string string "/")))) + +(defsubst smime-query-signer (start end) + (smime-process-region start end smime-program (list "-qs")) + (with-current-buffer smime-output-buffer + (if (zerop (buffer-size)) nil + (goto-char (point-min)) + (when (re-search-forward "^/" nil t) + (smime-parse-attribute + (buffer-substring (point) (progn (end-of-line)(point)))))))) + +(defsubst smime-x509-hash (cert-file) + (with-current-buffer (get-buffer-create smime-output-buffer) + (buffer-disable-undo) + (erase-buffer) + (apply #'call-process (car smime-x509-program) nil t nil + (append (cdr smime-x509-program) + (list "-hash" "-in" cert-file))) + (if (zerop (buffer-size)) nil + (buffer-substring (point-min) (1- (point-max)))))) + +(defsubst smime-x509-subject (cert-file) + (with-current-buffer (get-buffer-create smime-output-buffer) + (buffer-disable-undo) + (erase-buffer) + (apply #'call-process (car smime-x509-program) nil t nil + (append (cdr smime-x509-program) + (list "-subject" "-in" cert-file))) + (if (zerop (buffer-size)) nil + (goto-char (point-min)) + (when (re-search-forward "^subject=" nil t) + (smime-parse-attribute + (buffer-substring (point)(progn (end-of-line)(point)))))))) + +(static-condition-case nil + (directory-files nil nil nil nil nil) + (wrong-number-of-arguments + (defmacro smime-directory-files + (directory &optional full match nosort files-only) + (if files-only + `(delq nil (mapcar + (lambda (file) + ,(if (eq files-only t) + `(if (file-directory-p file) nil file) + `(if (file-directory-p file) file nil))) + (directory-files ,directory ,full ,match ,nosort))) + `(directory-files ,directory ,full ,match ,nosort)))) + (error + (defalias 'smime-directory-files 'directory-files))) + +(defsubst smime-find-certificate (attr) + (let ((files (if (file-directory-p smime-certificate-directory) + (delq nil (mapcar (lambda (file) + (if (file-directory-p file) nil + file)) + (directory-files + smime-certificate-directory + 'full))) + nil))) + (catch 'found + (while files + (if (or (string-equal + (cdr (assq 'CN (smime-x509-subject (car files)))) + (cdr (assq 'CN attr))) + (string-equal + (cdr (assq 'Email (smime-x509-subject (car files)))) + (cdr (assq 'Email attr)))) + (throw 'found (car files))) + (pop files))))) + +(defun smime-process-region (start end program args) + (let* ((errors-file-name + (concat temporary-file-directory + (make-temp-name "smime-errors"))) + (args (append args (list (concat "2>" errors-file-name)))) + (shell-file-name smime-shell-file-name) + (shell-command-switch smime-shell-command-switch) + (process-connection-type nil) + process status exit-status) + (with-current-buffer (get-buffer-create smime-output-buffer) + (buffer-disable-undo) + (erase-buffer)) + (as-binary-process + (setq process + (apply #'start-process-shell-command "*S/MIME*" + smime-output-buffer program args))) + (set-process-sentinel process 'ignore) + (process-send-region process start end) + (process-send-eof process) + (while (eq 'run (process-status process)) + (accept-process-output process 5)) + (setq status (process-status process) + exit-status (process-exit-status process)) + (delete-process process) + (with-current-buffer smime-output-buffer + (goto-char (point-min)) + (while (re-search-forward "\r$" (point-max) t) + (replace-match "")) + + (if (memq status '(stop signal)) + (error "%s exited abnormally: '%s'" program exit-status)) + (if (= 127 exit-status) + (error "%s could not be found" program)) + + (set-buffer (get-buffer-create smime-errors-buffer)) + (buffer-disable-undo) + (erase-buffer) + (insert-file-contents errors-file-name) + (delete-file errors-file-name) + + (if (and process (eq 'run (process-status process))) + (interrupt-process process))))) + +;;; @ interface functions +;;; + +;;;###autoload +(defun smime-encrypt-region (start end) + "Encrypt the current region between START and END." + (let* ((key-file + (or smime-private-key-file + (expand-file-name (read-file-name "Public key file: ")))) + (args (list "-e" key-file))) + (smime-process-region start end smime-program args) + (smime-process-when-success + (goto-char (point-min)) + (delete-region (point-min) (progn + (re-search-forward "^$" nil t) + (1+ (point))))))) + +;;;###autoload +(defun smime-decrypt-region (start end) + "Decrypt the current region between START and END." + (let* ((key-file + (or smime-private-key-file + (expand-file-name (read-file-name "Private key file: ")))) + (hash (smime-x509-hash key-file)) + (passphrase (smime-read-passphrase + (format "S/MIME passphrase for %s: " hash) + hash)) + (args (list "-d" key-file passphrase))) + (smime-process-region start end smime-program args) + (smime-process-when-success + (when smime-cache-passphrase + (smime-add-passphrase-cache hash passphrase))))) + +;;;###autoload +(defun smime-sign-region (start end &optional cleartext) + "Make the signature from text between START and END. +If the optional 3rd argument CLEARTEXT is non-nil, it does not create +a detached signature." + (let* ((key-file + (or smime-private-key-file + (expand-file-name (read-file-name "Private key file: ")))) + (hash (smime-x509-hash key-file)) + (passphrase (smime-read-passphrase + (format "S/MIME passphrase for %s: " hash) + hash)) + (args (list "-ds" key-file passphrase))) + (smime-process-region start end smime-program args) + (smime-process-when-success + (goto-char (point-min)) + (delete-region (point-min) (progn + (re-search-forward "^$" nil t) + (1+ (point)))) + (when smime-cache-passphrase + (smime-add-passphrase-cache hash passphrase))))) + +;;;###autoload +(defun smime-verify-region (start end signature) + "Verify the current region between START and END. +If the optional 3rd argument SIGNATURE is non-nil, it is treated as +the detached signature of the current region." + (let* ((basename (expand-file-name "smime" temporary-file-directory)) + (orig-file (make-temp-name basename)) + (args (list "-qs" signature)) + (orig-mode (default-file-modes))) + (unwind-protect + (progn + (set-default-file-modes 448) + (write-region-as-binary start end orig-file)) + (set-default-file-modes orig-mode)) + (with-temp-buffer + (insert-file-contents-as-binary signature) + (goto-char (point-max)) + (insert-file-contents-as-binary + (or (smime-find-certificate + (smime-query-signer (point-min)(point-max))) + (expand-file-name + (read-file-name "Certificate file: ")))) + (smime-process-region (point-min)(point-max) smime-program + (list "-dv" orig-file))) + (smime-process-when-success nil))) + +(provide 'smime) + +;;; smime.el ends here -- 1.7.10.4