+2000-02-07 Yoshiki Hayashi <t90553@mail.ecc.u-tokyo.ac.jp>
+
+ * EMY 1.13.2 is released.
+
+2000-02-07 Yoshiki Hayashi <yoshiki@xemacs.org>
+
+ * mime-view.el (mime-display-message): Add new local variable
+ line-move-ignore-invisible. Bind it to t.
+
+2000-02-06 Yoshiki Hayashi <yoshiki@xemacs.org>
+
+ * pgg-def.el (pgg-default-scheme): Improve custom options.
+
+2000-02-05 Yoshiki Hayashi <yoshiki@xemacs.org>
+
+ * Makefile: Format Info file.
+
+2000-02-04 Yoshiki Hayashi <yoshiki@xemacs.org>
+
+ * 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 <yoshiki@xemacs.org>
+
+ * 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 <t90553@mail.ecc.u-tokyo.ac.jp>
* EMY 1.13.1 is released.
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
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 \
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)
* 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
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
(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))
(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))
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
;; Copyright (C) 1993,94,95,96,97,98,99 Free Software Foundation, Inc.
;; Author: UMEDA Masanobu <umerin@mse.kyutech.ac.jp>
-;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; Daiki Ueno <ueno@ueda.info.waseda.ac.jp>
;; Created: 1994/08/21 renamed from mime.el
;; Renamed: 1997/2/21 from tm-edit.el
;; Keywords: MIME, multimedia, multilingual, mail, news
(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
("mail-server"
("server" "ftpmail@nic.karrn.ad.jp")
("subject"))
- ("url" ("url"))
- ))
+ ("url" ("url"))))
("rfc822")
- ("news")
- )
+ ("news"))
("application"
("octet-stream" ("type" "" "tar" "shar"))
("postscript")
("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
("\\.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
("\\.\\(rc\\|lst\\|log\\|sql\\|mak\\)$\\|\\..*rc$"
"text" "plain" nil
nil
- "attachment" (("filename" . file))
- )
+ "attachment" (("filename" . file)))
("\\.html$"
"text" "html" nil
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)
("\\.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
;; primary-type
(choice :tag "Primary-Type"
,@(nconc (mapcar (lambda (cell)
- (list 'item (car cell))
- )
+ (list 'item (car cell)))
mime-content-types)
'(string)))
;; subtype
(apply #'nconc
(mapcar (lambda (cell)
(mapcar (lambda (cell)
- (list 'item (car cell))
- )
+ (list 'item (car cell)))
(cdr cell)))
mime-content-types))
'(string)))
,@(cons
'(const nil)
(mapcar (lambda (cell)
- (list 'item cell)
- )
+ (list 'item cell))
(mime-encoding-list))))
;; disposition-type
(choice :tag "Disposition-Type"
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
(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.")
(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)
(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 ")")))))
(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)
(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 <steve@miranova.com>
;; 1995/12/6 (c.f. [tm-en:209])
(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
(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
;;;
(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)
'((" 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
;; Define menu for XEmacs.
(if (featurep 'xemacs)
- (mime-edit-define-menu-for-xemacs)
- )
+ (mime-edit-define-menu-for-xemacs))
(enable-invisible)
(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
(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)
(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."
(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."
(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)))
(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."
(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)))
\f
;; Insert a new tag around a point.
(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)))
(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
;; Restore previous point.
(goto-char current)
nil ;Nothing is created.
- )
- ))
+ )))
(defun mime-edit-insert-binary-file (file &optional encoding)
"Insert binary FILE at point.
(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)))))
\f
;; Commands work on a current message flagment.
(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."
(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."
;; 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."
(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."
(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.
(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."
(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]*\\("
(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."
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)
(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
(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)
(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)
;; 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."
(setq encoding
(completing-read
"What transfer encoding: "
- (mime-encoding-alist) nil t default)
- )
+ (mime-encoding-alist) nil t default))
""))
encoding))
(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))
(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))
(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
(insert
(format "--[[multipart/%s;
boundary=\"%s\"][7bit]]\n"
- type boundary))
- ))
+ type boundary))))
boundary))))
(defun mime-edit-enquote-region (beg end)
(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
(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"))
(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
(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\";
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
(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
(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
(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."
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
(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
;; 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))
(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."
(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)
(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))
(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."
(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
(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)
(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.
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
(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
(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."
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))
\f
;;; @ Other useful commands.
(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)
(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
;; 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
(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
(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.
(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
(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
(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
(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
(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
(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)
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)
(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)
(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
(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."
(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
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)
(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))
(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)
(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)
(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
(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)
(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
;; Copyright (C) 1996 Dan Rich
;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; Dan Rich <drich@morpheus.corp.sgi.com>
+;; Dan Rich <drich@morpheus.corp.sgi.com>
+;; Daiki Ueno <ueno@ueda.info.waseda.ac.jp>
+;; Katsumi Yamaoka <yamaoka@jpl.org>
;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp>
;; Created: 1995/12/15
;; Renamed: 1997/2/21 from tm-image.el
;;; 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
(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))
(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
;; Copyright (C) 1995,1996,1997,1998,1999 MORIOKA Tomohiko
;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; Daiki Ueno <ueno@ueda.info.waseda.ac.jp>
;; Created: 1995/12/7
;; Renamed: 1997/2/27 from tm-pgp.el
;; Keywords: PGP, security, MIME, multimedia, mail, news
;; by Kazuhiko Yamamoto <kazu@is.aist-nara.ac.jp> (1995/10;
;; expired)
+;; [OpenPGP/MIME] draft-yamamoto-openpgp-mime-00.txt: "MIME
+;; Security with OpenPGP (OpenPGP/MIME)" by Kazuhiko YAMAMOTO
+;; <kazu@iijlab.net> (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
(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)
(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)
(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."
(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))
(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
;;;
(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.
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
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)
(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
(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
(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)
(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))
(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)
(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
(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"
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)
;; )
(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
(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
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)))
(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.
(- (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
(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
("^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
(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)))
(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
(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
(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")))
(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))
(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))
(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)))
(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
(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)))
(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)
(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
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
(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
</dd>
<kt>C-c C-x C-k
<kd>
-Insert <dref>PGP</dref> public key. (It requires Mailcrypt package.)
+Insert <dref>PGP</dref> public key.
</kd>
<kt>C-c C-x t
<kd>
features based on <concept>PGP/MIME</concept> (RFC 2015) or
<concept>PGP-kazu</concept> (draft-kazu-pgp-mime-00.txt).
<p>
-This feature requires pgp command and pgp interface package, such as
-<a file="mailcrypt">Mailcrypt package</a>.
+This feature requires your pgp command.
-<defvar name="pgp-function-alist">
+<defvar name="pgg-default-scheme">
<p>
-Alist of service names vs. corresponding functions and its filenames.
-Each element looks like <code>(SERVICE FUNCTION FILE)</code>.
-<p>
-SERVICE is a symbol of PGP processing. It allows `verify', `decrypt',
-`fetch-key', `snarf-keys', `mime-sign', `traditional-sign', `encrypt'
-or `insert-key'.
-<p>
-Function is a symbol of function to do specified SERVICE.
-<p>
-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>,
+<code>pgp</code> or <code>pgp5</code>.
</defvar>
-<defun name="pgp-function">
- <args> method
+<defvar name="pgg-scheme">
<p>
-Return function to do service <var>method</var>.
-</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>,
+<code>pgp</code> or <code>pgp5</code>.
+</defvar>
<h2> Mouse button
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
<concept>PGP-kazu</concept> (draft-kazu-pgp-mime-00.txt) \e$B$K$h$k0E9f2=!&\e(B
\e$BEE;R=pL>!&8x3+80$NA^F~5!G=$rMxMQ$9$k$3$H$,$G$-$^$9!#\e(B
<p>
-
\e$BC"$7!"$3$N5!G=$rMxMQ$9$k$K$O
\e(B <a file="mailcrypt">Mailcrypt package</a>
-\e$B$H\e(B pgp command \e$B$,I,MW$G$9!#\e(B
+\e$BC"$7!"$3$N5!G=$rMxMQ$9$k$K$O3F<o\e(B pgp command \e$B$,I,MW$G$9!#\e(B
-<defvar name="pgp-function-alist">
+<defvar name="pgg-default-scheme">
<p>
-Alist of service names vs. corresponding functions and its filenames.
-Each element looks like <code>(SERVICE FUNCTION FILE)</code>.
-<p>
-SERVICE is a symbol of PGP processing. It allows `verify', `decrypt',
-`fetch-key', `snarf-keys', `mime-sign', `traditional-sign', `encrypt'
-or `insert-key'.
-<p>
-Function is a symbol of function to do specified SERVICE.
-<p>
-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>,
+<code>pgp</code> or <code>pgp5</code>.
</defvar>
-<defun name="pgp-function">
- <args> method
+<defvar name="pgg-scheme">
<p>
-Return function to do service <var>method</var>.
-</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>,
+<code>pgp</code> or <code>pgp5</code>.
+</defvar>
<h2> \e$B2!KU\e(B
(draft-kazu-pgp-mime-00.txt) \e$B$K$h$k0E9f2=!&EE;R=pL>!&8x3+80$NA^F~5!G=$r\e(B
\e$BMxMQ$9$k$3$H$,$G$-$^$9!#\e(B@refill
-\e$BC"$7!"$3$N5!G=$rMxMQ$9$k$K$O\e(B Mailcrypt package (@ref{(mailcrypt)}) \e$B$H\e(B
-pgp command \e$B$,I,MW$G$9!#\e(B
+\e$BC"$7!"$3$N5!G=$rMxMQ$9$k$K$O3F<o\e(B pgp command \e$B$,I,MW$G$9!#\e(B
-@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
(defvar mime-raw-representation-type-alist
'((mime-show-message-mode . binary)
(mime-temp-message-mode . binary)
- (t . cooked)
- )
+ (t . cooked))
"Alist of major-mode vs. representation-type of mime-raw-buffer.
Each element looks like (SYMBOL . REPRESENTATION-TYPE). SYMBOL is
major-mode or t. t means default. REPRESENTATION-TYPE must be
(if (and recursive mime-mother-buffer)
(save-excursion
(set-buffer mime-mother-buffer)
- (mime-preview-original-major-mode recursive)
- )
+ (mime-preview-original-major-mode recursive))
(cdr (assq 'major-mode
(get-text-property (or point
(if (> (point) (buffer-size))
(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)
(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))
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
(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")
(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)
(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
(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
(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
"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))))
\[[ 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))
(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))
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
(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"
(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
(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
(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
(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)
(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)
(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"
(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
[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
(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."
(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)
(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")
(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)
(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))
(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
(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
\"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).
\"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
(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)
'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)))
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
'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
(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)))
(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
(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
`(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)
'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
--- /dev/null
+;;; pgg-def.el --- functions/macros for defining PGG functions
+
+;; Copyright (C) 1999 Daiki Ueno
+
+;; Author: Daiki Ueno <ueno@ueda.info.waseda.ac.jp>
+;; 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
--- /dev/null
+;;; pgg-gpg.el --- GnuPG support for PGG.
+
+;; Copyright (C) 1999,2000 Daiki Ueno
+
+;; Author: Daiki Ueno <ueno@ueda.info.waseda.ac.jp>
+;; 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
--- /dev/null
+;;; pgg-parse.el --- OpenPGP packet parsing
+
+;; Copyright (C) 1999 Daiki Ueno
+
+;; Author: Daiki Ueno <ueno@ueda.info.waseda.ac.jp>
+;; 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 <jwn2@qualcomm.com>,
+;; Jon Callas <jon@pgp.com>, Lutz Donnerhacke <lutz@iks-jena.de>,
+;; Hal Finney <hal@pgp.com> and Rodney Thayer <rodney@unitran.com>
+;; (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
--- /dev/null
+;;; pgg-pgp.el --- PGP 2.* and 6.* support for PGG.
+
+;; Copyright (C) 1999,2000 Daiki Ueno
+
+;; Author: Daiki Ueno <ueno@ueda.info.waseda.ac.jp>
+;; 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
--- /dev/null
+;;; pgg-pgp5.el --- PGP 5.* support for PGG.
+
+;; Copyright (C) 1999,2000 Daiki Ueno
+
+;; Author: Daiki Ueno <ueno@ueda.info.waseda.ac.jp>
+;; 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
--- /dev/null
+;;; pgg.el --- glue for the various PGP implementations.
+
+;; Copyright (C) 1999,2000 Daiki Ueno
+
+;; Author: Daiki Ueno <ueno@ueda.info.waseda.ac.jp>
+;; 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
(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"
(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
(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
(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
(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
(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"
'((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
(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)
(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)
(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
(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
(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)
(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))
--- /dev/null
+;;; smime.el --- S/MIME interface.
+
+;; Copyright (C) 1999 Daiki Ueno
+
+;; Author: Daiki Ueno <ueno@ueda.info.waseda.ac.jp>
+;; 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
projects / elisp / semi.git / commitdiff