--- /dev/null
+2000-11-16 Simon Josefsson <sj@extundo.com>
+
+ * gpg.el (gpg-command-verify-cleartext): New variable.
+ (gpg-verify-cleartext): New function.
;; Keywords: crypto
;; Created: 2000-04-15
-;; $Id: gpg.el,v 1.1.2.1 2000-11-05 05:21:26 ueno Exp $
-
;; This file is NOT (yet?) part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
(string :format "%v"))))
:group 'gpg-commands)
+(defcustom gpg-command-verify-cleartext
+ '(gpg . ("--batch" "--verbose" "--verify" message-file))
+ "Command to verify a message.
+The invoked program has to read the signed message from the given
+file. It should write human-readable information to standard output
+and/or standard error. The program shall not convert charsets or line
+endings; the input data shall be treated as binary."
+ :tag "Cleartext Verify Command"
+ :type '(cons
+ gpg-command-program
+ (repeat
+ :tag "Arguments"
+ (choice
+ :format "%[Type%] %v"
+ (const :tag "Insert name of file containing the message here."
+ :value message-file)
+ (string :format "%v"))))
+ :group 'gpg-commands)
+
(defcustom gpg-command-decrypt
'(gpg . ("--decrypt" "--batch" "--passphrase-fd=0"))
"Command to decrypt a message.
t))))
;;;###autoload
+(defun gpg-verify-cleartext (message result)
+ "Verify message in buffer MESSAGE.
+Returns t if everything worked out well, nil otherwise. Consult
+buffer RESULT for details.
+
+NOTE: Use of this function is deprecated."
+ (interactive "bBuffer containing message: \nbBuffor for result: ")
+ (gpg-with-temp-files 1
+ (let* ((msg-file (nth 0 gpg-temp-files))
+ (cmd (gpg-exec-path gpg-command-verify-cleartext))
+ (args (gpg-build-arg-list (cdr gpg-command-verify-cleartext)
+ `((message-file . ,msg-file))))
+ res)
+ (with-temp-file msg-file
+ (buffer-disable-undo)
+ (apply 'insert-buffer-substring (if (listp message)
+ message
+ (list message))))
+ (setq res (apply 'call-process-region
+ (point-min) (point-min) ; no data
+ cmd
+ nil ; don't delete
+ result
+ nil ; don't display
+ args))
+ (if (or (stringp res) (> res 0))
+ ;; Signal or abnormal exit.
+ (with-current-buffer result
+ (insert (format "\nCommand exit status: %s\n" res))
+ nil)
+ t))))
+
+;;;###autoload
(defun gpg-decrypt (ciphertext plaintext result &optional passphrase)
"Decrypt buffer CIPHERTEXT to buffer PLAINTEXT.
Returns t if everything worked out well, nil otherwise. Consult
+2000-11-19 12:00:00 ShengHuo ZHU <zsh@cs.rochester.edu>
+
+ * gnus-art.el (article-verify-x-pgp-sig): Check whether
+ original-article-buffer exists.
+
+ * rfc2047.el (rfc2047-q-encoding-alist): Match Resent-.
+ (rfc2047-header-encoding-alist): Addresses are different from text.
+ (rfc2047-encode-message-header): Ditto.
+ (rfc2047-dissect-region): Extra parameter.
+ (rfc2047-encode-region): Ditto.
+ (rfc2047-encode-string): Ditto.
+
+2000-11-19 00:00:00 ShengHuo ZHU <zsh@cs.rochester.edu>
+
+ * mm-uu.el (mm-uu-pgp-encrypted-extract-1): New function.
+ (mm-uu-pgp-encrypted-extract): Use it.
+ (mm-uu-pgp-signed-extract-1): New function.
+ (mm-uu-pgp-signed-extract): Use it.
+
+ * gnus-art.el (gnus-mime-display-security): New function.
+ (gnus-mime-display-part): Use it.
+ (gnus-mime-security-verify-or-decrypt): New function.
+ (gnus-mime-security-press-button): New function.
+ (gnus-insert-mime-security-button): Use it.
+
+ * mm-decode.el (mm-possibly-verify-or-decrypt): Use mm-h-m-c-p.
+ (mm-find-raw-part-by-type): Ditto.
+ (mm-verify-function-alist): Add x-gnus-pgp-signature handle.
+ (mm-decrypt-function-alist): Add x-gnus-pgp-encrypted handle.
+ (mm-destroy-parts): Kill nested multibyte buffer.
+
+ * mml2015.el (mml2015-mailcrypt-verify): Use mm-h-m-c-p.
+ (mml2015-gpg-verify): Ditto.
+
+2000-11-18 Simon Josefsson <sj@extundo.com>
+
+ * mml2015.el (mml2015-mailcrypt-clear-verify): New function.
+ (mml2015-function-alist): Use it.
+
+ * mml-sec.el (mml-sign-alist): Update names.
+ (mml-encrypt-alist): Ditto.
+ (mml-secure-part-smime-sign): Moved to mml-smime.el
+ as `mml-smime-sign-query'.
+ (mml-secure-part-smime-encrypt-by-file): Moved to mml-smime.el as
+ `mml-smime-get-file-cert'.
+ (mml-secure-part-smime-encrypt-by-dns): Moved to mml-smime.el as
+ `mml-smime-get-dns-cert'.
+ (mml-secure-part-smime-encrypt): Moved to mml-smime.el as
+ `mml-smime-encrypt-query'.
+ (mml-smime-sign-buffer): Use mml-smime-sign.
+ (mml-smime-encrypt-buffer): Use mml-smime-encrypt.
+
+ * mml-smime.el (mml-smime-sign): New function.
+ (mml-smime-encrypt):
+ (mml-smime-sign-query):
+ (mml-smime-get-file-cert):
+ (mml-smime-get-dns-cert):
+ (mml-smime-encrypt-query): Moved from mml-sec.el.
+
+2000-11-16 Simon Josefsson <sj@extundo.com>
+
+ * mml2015.el (mml2015-gpg-clear-verify): New function.
+ (mml2015-function-alist): Add it.
+
+2000-11-17 14:21 ShengHuo ZHU <zsh@cs.rochester.edu>
+
+ * message.el (message-setup-fill-variables): Use
+ message-cite-prefix-regexp.
+ (message-newline-and-reformat): Check the end of citation, leading
+ WSP, break in the cite prefix.
+ (message-fill-paragraph): New function.
+
+2000-11-17 13:44 ShengHuo ZHU <zsh@cs.rochester.edu>
+
+ * lpath.el: Shut up.
+
+2000-11-17 Per Abrahamsen <abraham@dina.kvl.dk>
+
+ * gnus-msg.el (gnus-group-posting-charset-alist): No longer allow
+ raw 8-bit in headers in dk.* newsgroups.
+
+2000-11-17 08:02 ShengHuo ZHU <zsh@cs.rochester.edu>
+
+ * message.el (message-newline-and-reformat): Match extra WSPs.
+
2000-11-16 23:31 ShengHuo ZHU <zsh@cs.rochester.edu>
* mml.el (mml-generate-mime-1): Ignore ascii.
(defun article-verify-x-pgp-sig ()
"Verify X-PGP-Sig."
(interactive)
- (let ((sig (with-current-buffer gnus-original-article-buffer
- (gnus-fetch-field "X-PGP-Sig")))
- items info headers)
- (when (and sig (mm-uu-pgp-signed-test))
- (with-temp-buffer
- (insert-buffer gnus-original-article-buffer)
- (setq items (split-string sig))
- (message-narrow-to-head)
- (let ((inhibit-point-motion-hooks t)
- (case-fold-search t))
- ;; Don't verify multiple headers.
- (setq headers (mapconcat (lambda (header)
- (concat header ": "
- (mail-fetch-field header) "\n"))
- (split-string (nth 1 items) ",") "")))
- (delete-region (point-min) (point-max))
- (insert "-----BEGIN PGP SIGNED MESSAGE-----\n\n")
- (insert "X-Signed-Headers: " (nth 1 items) "\n")
- (insert headers)
- (widen)
- (forward-line)
- (while (not (eobp))
- (if (looking-at "^-")
- (insert "- "))
- (forward-line))
- (insert "\n-----BEGIN PGP SIGNATURE-----\n")
- (insert "Version: " (car items) "\n\n")
- (insert (mapconcat 'identity (cddr items) "\n"))
- (insert "\n-----END PGP SIGNATURE-----\n")
- (let ((mm-security-handle (list (format "multipart/signed"))))
- (mml2015-clean-buffer)
- (let ((coding-system-for-write (or gnus-newsgroup-charset
- 'iso-8859-1)))
- (funcall (mml2015-clear-verify-function)))
- (setq info
- (or (mm-handle-multipart-ctl-parameter
- mm-security-handle 'gnus-details)
- (mm-handle-multipart-ctl-parameter
- mm-security-handle 'gnus-info)))))
- (when info
- (let (buffer-read-only bface eface)
- (save-restriction
+ (if (gnus-buffer-live-p gnus-original-article-buffer)
+ (let ((sig (with-current-buffer gnus-original-article-buffer
+ (gnus-fetch-field "X-PGP-Sig")))
+ items info headers)
+ (when (and sig (mm-uu-pgp-signed-test))
+ (with-temp-buffer
+ (insert-buffer gnus-original-article-buffer)
+ (setq items (split-string sig))
(message-narrow-to-head)
- (goto-char (point-max))
- (forward-line -1)
- (setq bface (get-text-property (gnus-point-at-bol) 'face)
- eface (get-text-property (1- (gnus-point-at-eol)) 'face))
- (message-remove-header "X-Gnus-PGP-Verify")
- (if (re-search-forward "^X-PGP-Sig:" nil t)
- (forward-line)
- (goto-char (point-max)))
- (narrow-to-region (point) (point))
- (insert "X-Gnus-PGP-Verify: " info "\n")
- (goto-char (point-min))
+ (let ((inhibit-point-motion-hooks t)
+ (case-fold-search t))
+ ;; Don't verify multiple headers.
+ (setq headers (mapconcat (lambda (header)
+ (concat header ": "
+ (mail-fetch-field header) "\n"))
+ (split-string (nth 1 items) ",") "")))
+ (delete-region (point-min) (point-max))
+ (insert "-----BEGIN PGP SIGNED MESSAGE-----\n\n")
+ (insert "X-Signed-Headers: " (nth 1 items) "\n")
+ (insert headers)
+ (widen)
(forward-line)
(while (not (eobp))
- (if (not (looking-at "^[ \t]"))
- (insert " "))
+ (if (looking-at "^-")
+ (insert "- "))
(forward-line))
- ;; Do highlighting.
- (goto-char (point-min))
- (when (looking-at "\\([^:]+\\): *")
- (put-text-property (match-beginning 1) (1+ (match-end 1))
- 'face bface)
- (put-text-property (match-end 0) (point-max)
- 'face eface))))))))
+ (insert "\n-----BEGIN PGP SIGNATURE-----\n")
+ (insert "Version: " (car items) "\n\n")
+ (insert (mapconcat 'identity (cddr items) "\n"))
+ (insert "\n-----END PGP SIGNATURE-----\n")
+ (let ((mm-security-handle (list (format "multipart/signed"))))
+ (mml2015-clean-buffer)
+ (let ((coding-system-for-write (or gnus-newsgroup-charset
+ 'iso-8859-1)))
+ (funcall (mml2015-clear-verify-function)))
+ (setq info
+ (or (mm-handle-multipart-ctl-parameter
+ mm-security-handle 'gnus-details)
+ (mm-handle-multipart-ctl-parameter
+ mm-security-handle 'gnus-info)))))
+ (when info
+ (let (buffer-read-only bface eface)
+ (save-restriction
+ (message-narrow-to-head)
+ (goto-char (point-max))
+ (forward-line -1)
+ (setq bface (get-text-property (gnus-point-at-bol) 'face)
+ eface (get-text-property (1- (gnus-point-at-eol)) 'face))
+ (message-remove-header "X-Gnus-PGP-Verify")
+ (if (re-search-forward "^X-PGP-Sig:" nil t)
+ (forward-line)
+ (goto-char (point-max)))
+ (narrow-to-region (point) (point))
+ (insert "X-Gnus-PGP-Verify: " info "\n")
+ (goto-char (point-min))
+ (forward-line)
+ (while (not (eobp))
+ (if (not (looking-at "^[ \t]"))
+ (insert " "))
+ (forward-line))
+ ;; Do highlighting.
+ (goto-char (point-min))
+ (when (looking-at "\\([^:]+\\): *")
+ (put-text-property (match-beginning 1) (1+ (match-end 1))
+ 'face bface)
+ (put-text-property (match-end 0) (point-max)
+ 'face eface)))))))))
(eval-and-compile
(mapcar
((equal (car handle) "multipart/signed")
(or (memq 'signed gnus-article-wash-types)
(push 'signed gnus-article-wash-types))
- (gnus-insert-mime-security-button handle)
- (gnus-mime-display-mixed (cdr handle)))
+ (gnus-mime-display-security handle))
((equal (car handle) "multipart/encrypted")
(or (memq 'encrypted gnus-article-wash-types)
(push 'encrypted gnus-article-wash-types))
- (gnus-insert-mime-security-button handle)
- (gnus-mime-display-mixed (cdr handle)))
+ (gnus-mime-display-security handle))
;; Other multiparts are handled like multipart/mixed.
(t
(gnus-mime-display-mixed (cdr handle)))))
%t The security MIME type
%i Additional info")
+(defvar gnus-mime-security-button-end-line-format "%{%([[End of %t]]%)%}\n"
+ "The following specs can be used:
+%t The security MIME type
+%i Additional info")
+
(defvar gnus-mime-security-button-line-format-alist
'((?t gnus-tmp-type ?s)
(?i gnus-tmp-info ?s)))
(defvar gnus-mime-security-details-buffer nil)
+(defun gnus-mime-security-verify-or-decrypt (handle)
+ (mm-remove-parts (cdr handle))
+ (let ((region (mm-handle-multipart-ctl-parameter handle 'gnus-region))
+ buffer-read-only)
+ (when region
+ (delete-region (car region) (cdr region))
+ (set-marker (car region) nil)
+ (set-marker (cdr region) nil)))
+ (with-current-buffer (mm-handle-multipart-original-buffer handle)
+ (let* ((mm-verify-option 'known)
+ (mm-decrypt-option 'known)
+ (nparts (mm-possibly-verify-or-decrypt (cdr handle) handle)))
+ (unless (eq nparts (cdr handle))
+ (mm-destroy-parts (cdr handle))
+ (setcdr handle nparts))))
+ (let ((point (point))
+ buffer-read-only)
+ (gnus-mime-display-security handle)
+ (goto-char point)))
+
(defun gnus-mime-security-show-details (handle)
(let ((details (mm-handle-multipart-ctl-parameter handle 'gnus-details)))
(if details
(pop-to-buffer gnus-mime-security-details-buffer))
(gnus-message 5 "No details."))))
+(defun gnus-mime-security-press-button (handle)
+ (if (mm-handle-multipart-ctl-parameter handle 'gnus-info)
+ (gnus-mime-security-show-details handle)
+ (gnus-mime-security-verify-or-decrypt handle)))
+
(defun gnus-insert-mime-security-button (handle &optional displayed)
(let* ((protocol (mm-handle-multipart-ctl-parameter handle 'protocol))
(gnus-tmp-type
(nth 2 (assoc protocol mm-decrypt-function-alist))
"Unknown")
(if (equal (car handle) "multipart/signed")
- " Signed" " Encrypted")))
+ " Signed" " Encrypted")
+ " Part"))
(gnus-tmp-info
(or (mm-handle-multipart-ctl-parameter handle 'gnus-info)
"Undecided"))
gnus-mime-security-button-line-format-alist
`(local-map ,gnus-mime-security-button-map
keymap ,gnus-mime-security-button-map
- gnus-callback gnus-mime-security-show-details
+ gnus-callback gnus-mime-security-press-button
article-type annotation
gnus-data ,handle))
(setq e (point))
"%S: show detail"
(aref gnus-mouse-2 0))))))
+(defun gnus-mime-display-security (handle)
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (gnus-insert-mime-security-button handle)
+ (gnus-mime-display-mixed (cdr handle))
+ (unless (bolp)
+ (insert "\n"))
+ (let ((gnus-mime-security-button-line-format
+ gnus-mime-security-button-end-line-format))
+ (gnus-insert-mime-security-button handle))
+ (mm-set-handle-multipart-parameter handle 'gnus-region
+ (cons (set-marker (make-marker)
+ (point-min))
+ (set-marker (make-marker)
+ (point-max))))))
+
;;; @ for mime-view
;;;
"If non-nil, automatically mark Gcc articles as read.")
(defcustom gnus-group-posting-charset-alist
- '(("^\\(no\\|fr\\|dk\\)\\.[^,]*\\(,[ \t\n]*\\(no\\|fr\\|dk\\)\\.[^,]*\\)*$" iso-8859-1 (iso-8859-1))
+ '(("^\\(no\\|fr\\)\\.[^,]*\\(,[ \t\n]*\\(no\\|fr\\)\\.[^,]*\\)*$" iso-8859-1 (iso-8859-1))
("^\\(fido7\\|relcom\\)\\.[^,]*\\(,[ \t\n]*\\(fido7\\|relcom\\)\\.[^,]*\\)*$" koi8-r (koi8-r))
(message-this-is-mail nil nil)
(message-this-is-news nil t))
rmail-select-summary rmail-summary-exists rmail-update-summary
sc-cite-regexp set-font-family set-font-size temp-directory
url-view-url vcard-pretty-print
+ url-insert-file-contents
w3-coding-system-for-mime-charset w3-prepare-buffer w3-region
widget-make-intangible x-defined-colors))
(maybe-bind '(adaptive-fill-first-line-regexp
adaptive-fill-regexp babel-history babel-translations
display-time-mail-function imap-password mail-mode-hook
+ mc-pgp-always-sign
url-current-callback-func url-be-asynchronous
url-current-callback-data url-working-buffer
url-current-mime-headers w3-meta-charset-content-type-regexp
(maybe-bind '(mh-lib-progs)))
;; FSFmacs
(maybe-fbind '(charsetp
- function-max-args propertize smiley-encode-buffer
- url-insert-file-contents))
+ function-max-args propertize smiley-encode-buffer))
(if (boundp 'MULE)
(progn
(maybe-fbind '(coding-system-get
;;;###autoload
(defcustom message-yank-prefix "> "
- "*Prefix inserted on the lines of yanked messages."
+ "*Prefix inserted on the lines of yanked messages.
+Fix `message-cite-prefix-regexp' if it is set to an abnormal value."
:type 'string
:group 'message-insertion)
(define-key message-mode-map "\C-c\C-v" 'message-delete-not-region)
(define-key message-mode-map "\C-c\C-z" 'message-kill-to-signature)
(define-key message-mode-map "\M-\r" 'message-newline-and-reformat)
+ (define-key message-mode-map "\M-q" 'message-fill-paragraph)
(define-key message-mode-map "\t" 'message-tab)
(make-local-variable 'adaptive-fill-first-line-regexp)
(make-local-variable 'auto-fill-inhibit-regexp)
(let ((quote-prefix-regexp
- (concat
- "[ \t]*" ; possible initial space
- "\\(\\(" (regexp-quote message-yank-prefix) "\\|" ; user's prefix
- "\\(\\w\\|[-_.]\\)+>\\|" ; supercite-style prefix
- "[|:>]" ; standard prefix
- "\\)[ \t]*\\)+"))) ; possible space after each prefix
+ ;; User should change message-cite-prefix-regexp if
+ ;; message-yank-prefix is set to an abnormal value.
+ (concat "\\(" message-cite-prefix-regexp "\\)[ \t]*")))
(setq paragraph-start
(concat
(regexp-quote mail-header-separator) "$\\|"
(unless (bolp)
(insert "\n"))))
-(defun message-newline-and-reformat ()
+(defun message-newline-and-reformat (&optional not-break)
"Insert four newlines, and then reformat if inside quoted text."
(interactive)
- (let (quoted point)
- (unless (bolp)
- (save-excursion
- (beginning-of-line)
- (when (looking-at message-cite-prefix-regexp)
- (setq quoted (match-string 0))))
- (insert "\n"))
+ (let (quoted point beg end leading-space)
(setq point (point))
- (insert "\n\n\n")
- (delete-region (point) (re-search-forward "[ \t]*"))
- (when quoted
- (insert quoted))
- (fill-paragraph nil)
+ (beginning-of-line)
+ (setq beg (point))
+ ;; Find first line of the paragraph.
+ (if not-break
+ (while (and (not (eobp))
+ (not (looking-at message-cite-prefix-regexp))
+ (looking-at paragraph-start))
+ (forward-line 1)))
+ ;; Find the prefix
+ (when (looking-at message-cite-prefix-regexp)
+ (setq quoted (match-string 0))
+ (goto-char (match-end 0))
+ (looking-at "[ \t]*")
+ (setq leading-space (match-string 0)))
+ (if (and quoted
+ (not not-break)
+ (< (- point beg) (length quoted)))
+ ;; break in the cite prefix.
+ (setq quoted nil
+ end nil))
+ (if quoted
+ (progn
+ (forward-line 1)
+ (while (and (not (eobp))
+ (not (looking-at paragraph-separate))
+ (looking-at message-cite-prefix-regexp)
+ (equal quoted (match-string 0)))
+ (goto-char (match-end 0))
+ (looking-at "[ \t]*")
+ (if (> (length leading-space) (length (match-string 0)))
+ (setq leading-space (match-string 0)))
+ (forward-line 1))
+ (setq end (point))
+ (goto-char beg)
+ (while (and (if (bobp) nil (forward-line -1) t)
+ (not (looking-at paragraph-start))
+ (looking-at message-cite-prefix-regexp)
+ (equal quoted (match-string 0)))
+ (setq beg (point))
+ (goto-char (match-end 0))
+ (looking-at "[ \t]*")
+ (if (> (length leading-space) (length (match-string 0)))
+ (setq leading-space (match-string 0)))))
+ (while (and (not (eobp))
+ (not (looking-at paragraph-separate))
+ (not (looking-at message-cite-prefix-regexp)))
+ (forward-line 1))
+ (setq end (point))
+ (goto-char beg)
+ (while (and (if (bobp) nil (forward-line -1) t)
+ (not (looking-at paragraph-start))
+ (not (looking-at message-cite-prefix-regexp))
+ (equal quoted (match-string 0)))
+ (setq beg (point))))
(goto-char point)
- (forward-line 1)))
+ (save-restriction
+ (narrow-to-region beg end)
+ (if not-break
+ (setq point nil)
+ (insert "\n\n")
+ (setq point (point))
+ (insert "\n\n")
+ (delete-region (point) (re-search-forward "[ \t]*"))
+ (when quoted
+ (insert quoted leading-space)))
+ (if quoted
+ (let* ((adaptive-fill-regexp
+ (regexp-quote (concat quoted leading-space)))
+ (adaptive-fill-first-line-regexp
+ adaptive-fill-regexp ))
+ (fill-paragraph nil))
+ (fill-paragraph nil))
+ (if point (goto-char point)))))
+
+(defun message-fill-paragraph ()
+ "Like `fill-paragraph'."
+ (interactive)
+ (message-newline-and-reformat t))
(defun message-insert-signature (&optional force)
"Insert a signature. See documentation for the `message-signature' variable."
(defvar mm-verify-function-alist
'(("application/pgp-signature" mml2015-verify "PGP" mml2015-verify-test)
+ ("application/x-gnus-pgp-signature" mm-uu-pgp-signed-extract-1 "PGP"
+ mm-uu-pgp-signed-test)
("application/pkcs7-signature" mml-smime-verify "S/MIME"
mml-smime-verify-test)
("application/x-pkcs7-signature" mml-smime-verify "S/MIME"
(autoload 'mml2015-decrypt-test "mml2015")
(defvar mm-decrypt-function-alist
- '(("application/pgp-encrypted" mml2015-decrypt "PGP" mml2015-decrypt-test)))
+ '(("application/pgp-encrypted" mml2015-decrypt "PGP" mml2015-decrypt-test)
+ ("application/x-gnus-pgp-encrypted" mm-uu-pgp-encrypted-extract-1 "PGP"
+ mm-uu-pgp-encrypted-test)))
(defcustom mm-decrypt-option nil
"Option of decrypting signed parts.
(kill-buffer (get-text-property 0 'buffer handle))))
((and (listp handle)
(stringp (car handle)))
- (mm-destroy-parts (cdr handle)))
+ (mm-destroy-parts handle))
(t
(mm-destroy-part handle)))))))
(defun mm-find-raw-part-by-type (ctl type &optional notp)
(goto-char (point-min))
- (let* ((boundary (concat "\n--" (mail-content-type-get ctl 'boundary)))
- (close-delimiter (concat (regexp-quote boundary) "--[ \t]*$"))
+ (let* ((boundary (concat "--" (mm-handle-multipart-ctl-parameter ctl
+ 'boundary)))
+ (close-delimiter (concat "^" (regexp-quote boundary) "--[ \t]*$"))
start
(end (save-excursion
(goto-char (point-max))
(match-beginning 0)
(point-max))))
result)
- (setq boundary (concat (regexp-quote boundary) "[ \t]*$"))
+ (setq boundary (concat "^" (regexp-quote boundary) "[ \t]*$"))
(while (and (not result)
(re-search-forward boundary end t))
(goto-char (match-beginning 0))
(when start
(save-excursion
(save-restriction
- (narrow-to-region start (point))
+ (narrow-to-region start (1- (point)))
(when (let ((ctl (ignore-errors
(mail-header-parse-content-type
(mail-fetch-field "content-type")))))
(not (equal (car ctl) type))
(equal (car ctl) type)))
(setq result (buffer-substring (point-min) (point-max)))))))
- (forward-line 2)
+ (forward-line 1)
(setq start (point)))
(when (and (not result) start)
(save-excursion
protocol func functest)
(cond
((equal subtype "signed")
- (unless (and (setq protocol (mail-content-type-get ctl 'protocol))
+ (unless (and (setq protocol
+ (mm-handle-multipart-ctl-parameter ctl 'protocol))
(not (equal protocol "multipart/mixed")))
;; The message is broken or draft-ietf-openpgp-multsig-01.
(let ((protocols mm-verify-function-alist))
mm-security-handle 'gnus-details
(format "Unknown sign protocol (%s)" protocol))))))
((equal subtype "encrypted")
- (unless (setq protocol (mail-content-type-get ctl 'protocol))
+ (unless (setq protocol
+ (mm-handle-multipart-ctl-parameter ctl 'protocol))
;; The message is broken.
(let ((parts parts))
(while parts
(defsubst mm-uu-function-2 (entry)
(nth 5 entry))
-(defun mm-uu-copy-to-buffer (from to)
+(defun mm-uu-copy-to-buffer (&optional from to)
"Copy the contents of the current buffer to a fresh buffer."
(save-excursion
(let ((obuf (current-buffer)))
(narrow-to-region (point) end-point)
(mm-dissect-buffer t)))
-(defun mm-uu-pgp-signed-test ()
+(defun mm-uu-pgp-signed-test (&rest rest)
(and
mml2015-use
(mml2015-clear-verify-function)
((eq mm-verify-option 'known) t)
(t (y-or-n-p "Verify pgp signed part?")))))
-(defun mm-uu-pgp-signed-extract ()
- (let ((buf (mm-uu-copy-to-buffer start-point end-point))
- (mm-security-handle (list (format "multipart/signed"))))
- (mm-set-handle-multipart-parameter
- mm-security-handle 'protocol "application/pgp-signature")
+(defun mm-uu-pgp-signed-extract-1 (handles ctl)
+ (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max))))
(with-current-buffer buf
(if (mm-uu-pgp-signed-test)
(progn
(delete-region (point-min) (point)))
(if (re-search-forward mm-uu-pgp-beginning-signature nil t)
(delete-region (match-beginning 0) (point-max))))
- (setcdr mm-security-handle
- (list
- (mm-make-handle buf
- '("text/plain" (charset . gnus-decoded)))))
+ (list
+ (mm-make-handle buf
+ '("text/plain" (charset . gnus-decoded))))))
+
+(defun mm-uu-pgp-signed-extract ()
+ (let ((mm-security-handle (list (format "multipart/signed"))))
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'protocol "application/x-gnus-pgp-signature")
+ (save-restriction
+ (narrow-to-region start-point end-point)
+ (add-text-properties 0 (length (car mm-security-handle))
+ (list 'buffer (mm-uu-copy-to-buffer))
+ (car mm-security-handle))
+ (setcdr mm-security-handle
+ (mm-uu-pgp-signed-extract-1 nil
+ mm-security-handle)))
mm-security-handle))
-(defun mm-uu-pgp-encrypted-test ()
+(defun mm-uu-pgp-encrypted-test (&rest rest)
(and
mml2015-use
(mml2015-clear-decrypt-function)
((eq mm-decrypt-option 'known) t)
(t (y-or-n-p "Decrypt pgp encrypted part?")))))
-(defun mm-uu-pgp-encrypted-extract ()
- (let ((buf (mm-uu-copy-to-buffer start-point end-point))
- (mm-security-handle (list (format "multipart/encrypted"))))
- (mm-set-handle-multipart-parameter
- mm-security-handle 'protocol "application/pgp-encrypted")
+(defun mm-uu-pgp-encrypted-extract-1 (handles ctl)
+ (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max))))
(if (mm-uu-pgp-encrypted-test)
(with-current-buffer buf
(mml2015-clean-buffer)
(funcall (mml2015-clear-decrypt-function))))
- (setcdr mm-security-handle
- (list
- (mm-make-handle buf
- '("text/plain" (charset . gnus-decoded)))))
+ (list
+ (mm-make-handle buf
+ '("text/plain" (charset . gnus-decoded))))))
+
+(defun mm-uu-pgp-encrypted-extract ()
+ (let ((mm-security-handle (list (format "multipart/encrypted"))))
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'protocol "application/x-gnus-pgp-encrypted")
+ (save-restriction
+ (narrow-to-region start-point end-point)
+ (add-text-properties 0 (length (car mm-security-handle))
+ (list 'buffer (mm-uu-copy-to-buffer))
+ (car mm-security-handle))
+ (setcdr mm-security-handle
+ (mm-uu-pgp-encrypted-extract-1 nil
+ mm-security-handle)))
mm-security-handle))
(defun mm-uu-gpg-key-skip-to-last ()
(require 'smime)
(require 'mml2015)
+(require 'mml-smime)
(eval-when-compile (require 'cl))
(defvar mml-sign-alist
- '(("smime" mml-smime-sign-buffer mml-secure-part-smime-sign)
+ '(("smime" mml-smime-sign-buffer mml-smime-sign-query)
("pgpmime" mml-pgpmime-sign-buffer list))
"Alist of MIME signer functions.")
"Default sign method.")
(defvar mml-encrypt-alist
- '(("smime" mml-smime-encrypt-buffer mml-secure-part-smime-encrypt)
+ '(("smime" mml-smime-encrypt-buffer mml-smime-encrypt-query)
("pgpmime" mml-pgpmime-encrypt-buffer list))
"Alist of MIME encryption functions.")
;;; Security functions
(defun mml-smime-sign-buffer (cont)
- (or (smime-sign-buffer (cdr (assq 'keyfile cont)))
+ (or (mml-smime-sign cont)
(error "Signing failed... inspect message logs for errors")))
(defun mml-smime-encrypt-buffer (cont)
- (let (certnames certfiles tmp file tmpfiles)
- (while (setq tmp (pop cont))
- (if (and (consp tmp) (eq (car tmp) 'certfile))
- (push (cdr tmp) certnames)))
- (while (setq tmp (pop certnames))
- (if (not (and (not (file-exists-p tmp))
- (get-buffer tmp)))
- (push tmp certfiles)
- (setq file (make-temp-name mm-tmp-directory))
- (with-current-buffer tmp
- (write-region (point-min) (point-max) file))
- (push file certfiles)
- (push file tmpfiles)))
- (if (smime-encrypt-buffer certfiles)
- (while (setq tmp (pop tmpfiles))
- (delete-file tmp))
- (while (setq tmp (pop tmpfiles))
- (delete-file tmp))
- (error "Encryption failed... inspect message logs for errors"))))
+ (or (mml-smime-encrypt cont)
+ (error "Encryption failed... inspect message logs for errors")))
(defun mml-pgpmime-sign-buffer (cont)
(or (mml2015-sign cont)
(or (mml2015-encrypt cont)
(error "Encryption failed... inspect message logs for errors")))
-(defun mml-secure-part-smime-sign ()
- (when (null smime-keys)
- (customize-variable 'smime-keys)
- (error "No S/MIME keys configured, use customize to add your key"))
- (list 'keyfile
- (if (= (length smime-keys) 1)
- (cadar smime-keys)
- (or (let ((from (cadr (funcall gnus-extract-address-components
- (or (save-excursion
- (save-restriction
- (message-narrow-to-headers)
- (message-fetch-field "from")))
- "")))))
- (and from (smime-get-key-by-email from)))
- (smime-get-key-by-email
- (completing-read "Sign this part with what signature? "
- smime-keys nil nil
- (and (listp (car-safe smime-keys))
- (caar smime-keys))))))))
-
-(defun mml-secure-part-smime-encrypt-by-file ()
- (ignore-errors
- (list 'certfile (read-file-name
- "File with recipient's S/MIME certificate: "
- smime-certificate-directory nil t ""))))
-
-
-(defun mml-secure-part-smime-encrypt-by-dns ()
- ;; todo: deal with comma separated multiple recipients
- (let (result who bad cert)
- (condition-case ()
- (while (not result)
- (setq who (read-from-minibuffer
- (format "%sLookup certificate for: " (or bad ""))
- (cadr (funcall gnus-extract-address-components
- (or (save-excursion
- (save-restriction
- (message-narrow-to-headers)
- (message-fetch-field "to")))
- "")))))
- (if (setq cert (smime-cert-by-dns who))
- (setq result (list 'certfile (buffer-name cert)))
- (setq bad (format "`%s' not found. " who))))
- (quit))
- result))
-
-(defun mml-secure-part-smime-encrypt ()
- ;; todo: add ldap support (xemacs ldap api?)
- ;; todo: try dns/ldap automatically first, before prompting user
- (let (certs done)
- (while (not done)
- (ecase (read (gnus-completing-read "dns" "Fetch certificate from"
- '(("dns") ("file")) nil t))
- (dns (setq certs (append certs
- (mml-secure-part-smime-encrypt-by-dns))))
- (file (setq certs (append certs
- (mml-secure-part-smime-encrypt-by-file)))))
- (setq done (not (y-or-n-p "Add more recipients? "))))
- certs))
-
(defun mml-secure-part (method &optional sign)
(save-excursion
(let ((tags (funcall (nth 2 (assoc method (if sign mml-sign-alist
;; Copyright (c) 2000 Free Software Foundation, Inc.
;; Author: Simon Josefsson <simon@josefsson.org>
-;; Keywords: Gnus, MIME, SMIME, MML
+;; Keywords: Gnus, MIME, S/MIME, MML
;; This file is a part of GNU Emacs.
;;; Commentary:
-;; todo: move s/mime code from mml-sec.el here.
-
;;; Code:
(require 'smime)
(require 'mm-decode)
+(defun mml-smime-sign (cont)
+ (smime-sign-buffer (cdr (assq 'keyfile cont))))
+
+(defun mml-smime-encrypt (cont)
+ (let (certnames certfiles tmp file tmpfiles)
+ ;; xxx tmp files are always an security issue
+ (while (setq tmp (pop cont))
+ (if (and (consp tmp) (eq (car tmp) 'certfile))
+ (push (cdr tmp) certnames)))
+ (while (setq tmp (pop certnames))
+ (if (not (and (not (file-exists-p tmp))
+ (get-buffer tmp)))
+ (push tmp certfiles)
+ (setq file (make-temp-name mm-tmp-directory))
+ (with-current-buffer tmp
+ (write-region (point-min) (point-max) file))
+ (push file certfiles)
+ (push file tmpfiles)))
+ (if (smime-encrypt-buffer certfiles)
+ (progn
+ (while (setq tmp (pop tmpfiles))
+ (delete-file tmp))
+ t)
+ (while (setq tmp (pop tmpfiles))
+ (delete-file tmp))
+ nil)))
+
+(defun mml-smime-sign-query ()
+ ;; query information (what certificate) from user when MML tag is
+ ;; added, for use later by the signing process
+ (when (null smime-keys)
+ (customize-variable 'smime-keys)
+ (error "No S/MIME keys configured, use customize to add your key"))
+ (list 'keyfile
+ (if (= (length smime-keys) 1)
+ (cadar smime-keys)
+ (or (let ((from (cadr (funcall gnus-extract-address-components
+ (or (save-excursion
+ (save-restriction
+ (message-narrow-to-headers)
+ (message-fetch-field "from")))
+ "")))))
+ (and from (smime-get-key-by-email from)))
+ (smime-get-key-by-email
+ (completing-read "Sign this part with what signature? "
+ smime-keys nil nil
+ (and (listp (car-safe smime-keys))
+ (caar smime-keys))))))))
+
+(defun mml-smime-get-file-cert ()
+ (ignore-errors
+ (list 'certfile (read-file-name
+ "File with recipient's S/MIME certificate: "
+ smime-certificate-directory nil t ""))))
+
+(defun mml-smime-get-dns-cert ()
+ ;; todo: deal with comma separated multiple recipients
+ (let (result who bad cert)
+ (condition-case ()
+ (while (not result)
+ (setq who (read-from-minibuffer
+ (format "%sLookup certificate for: " (or bad ""))
+ (cadr (funcall gnus-extract-address-components
+ (or (save-excursion
+ (save-restriction
+ (message-narrow-to-headers)
+ (message-fetch-field "to")))
+ "")))))
+ (if (setq cert (smime-cert-by-dns who))
+ (setq result (list 'certfile (buffer-name cert)))
+ (setq bad (format "`%s' not found. " who))))
+ (quit))
+ result))
+
+(defun mml-smime-encrypt-query ()
+ ;; todo: add ldap support (xemacs ldap api?)
+ ;; todo: try dns/ldap automatically first, before prompting user
+ (let (certs done)
+ (while (not done)
+ (ecase (read (gnus-completing-read "dns" "Fetch certificate from"
+ '(("dns") ("file")) nil t))
+ (dns (setq certs (append certs
+ (mml-smime-get-dns-cert))))
+ (file (setq certs (append certs
+ (mml-smime-get-file-cert)))))
+ (setq done (not (y-or-n-p "Add more recipients? "))))
+ certs))
+
(defun mml-smime-verify (handle ctl)
(with-current-buffer (mm-handle-multipart-original-buffer ctl)
;; xxx modifies buffer -- noone else uses the buffer, so what the heck
(mm-set-handle-multipart-parameter
mm-security-handle 'gnus-info "Failed")
(mm-set-handle-multipart-parameter
- mm-security-handle 'gnus-details (with-current-buffer smime-details-buffer
- (buffer-string))))
+ mm-security-handle 'gnus-details
+ (with-current-buffer smime-details-buffer
+ (buffer-string))))
handle))
(defun mml-smime-verify-test (handle ctl)
mml2015-gpg-encrypt
mml2015-gpg-verify
mml2015-gpg-decrypt
- nil
+ mml2015-gpg-clear-verify
mml2015-gpg-clear-decrypt))
"Alist of PGP/MIME functions.")
(catch 'error
(let (part)
(unless (setq part (mm-find-raw-part-by-type
- ctl (or (mail-content-type-get ctl 'protocol)
+ ctl (or (mm-handle-multipart-ctl-parameter
+ ctl 'protocol)
"application/pgp-signature")
t))
(mm-set-handle-multipart-parameter
(insert "-----BEGIN PGP SIGNED MESSAGE-----\n")
(insert (format "Hash: %s\n\n"
(or (mml2015-fix-micalg
- (mail-content-type-get ctl 'micalg))
+ (mm-handle-multipart-ctl-parameter
+ ctl 'micalg))
"SHA1")))
(save-restriction
(narrow-to-region (point) (point))
(catch 'error
(let (part message signature)
(unless (setq part (mm-find-raw-part-by-type
- ctl (or (mail-content-type-get ctl 'protocol)
+ ctl (or (mm-handle-multipart-ctl-parameter
+ ctl 'protocol)
"application/pgp-signature")
t))
(mm-set-handle-multipart-parameter
mm-security-handle 'gnus-info "OK"))
handle)))
+(defun mml2015-gpg-clear-verify ()
+ (if (condition-case err
+ (funcall mml2015-verify-function)
+ (error
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details (cadr err))
+ nil)
+ (quit
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details "Quit.")
+ nil))
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "OK")
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "Failed")))
+
(defun mml2015-gpg-sign (cont)
(let ((boundary
(funcall mml-boundary-function (incf mml-multipart-number)))
(defvar rfc2047-header-encoding-alist
'(("Newsgroups" . nil)
("Message-ID" . nil)
+ ("\\(Resent-\\)?\\(From\\|Cc\\|To\\|Bcc\\|Reply-To\\|Sender\\)" .
+ "-A-Za-z0-9!*+/=_")
(t . mime))
"*Header/encoding method alist.
The list is traversed sequentially. The keys can either be
2) `mime', in which case the header will be encoded according to RFC2047;
3) a charset, in which case it will be encoded as that charset;
4) `default', in which case the field will be encoded as the rest
- of the article.")
+ of the article.
+5) a string, like `mime', expect for using it as word-chars.")
(defvar rfc2047-charset-encoding-alist
'((us-ascii . nil)
"Alist of RFC2047 encodings to encoding functions.")
(defvar rfc2047-q-encoding-alist
- '(("\\(From\\|Cc\\|To\\|Bcc\||Reply-To\\):" . "-A-Za-z0-9!*+/")
+ '(("\\(Resent-\\)?\\(From\\|Cc\\|To\\|Bcc\\|Reply-To\\|Sender\\):"
+ . "-A-Za-z0-9!*+/" )
;; = (\075), _ (\137), ? (\077) are used in the encoded word.
;; Avoid using 8bit characters. Some versions of Emacs has bug!
;; Equivalent to "^\000-\007\011\013\015-\037\200-\377=_?"
(setq alist nil
method (cdr elem))))
(cond
+ ((stringp method)
+ (rfc2047-encode-region (point-min) (point-max) method))
((eq method 'mime)
(rfc2047-encode-region (point-min) (point-max)))
((eq method 'default)
(setq found t)))
found))
-(defun rfc2047-dissect-region (b e)
+(defun rfc2047-dissect-region (b e &optional word-chars)
"Dissect the region between B and E into words."
- (let ((word-chars "-A-Za-z0-9!*+/")
- ;; Not using ietf-drums-specials-token makes life simple.
- mail-parse-mule-charset
+ (unless word-chars
+ ;; Anything except most CTLs, WSP
+ (setq word-chars "\010\012\014\041-\177"))
+ (let (mail-parse-mule-charset
words point current
result word)
(save-restriction
(setq word (pop words))))
result))
-(defun rfc2047-encode-region (b e)
+(defun rfc2047-encode-region (b e &optional word-chars)
"Encode all encodable words in REGION."
- (let ((words (rfc2047-dissect-region b e)) word)
+ (let ((words (rfc2047-dissect-region b e word-chars)) word)
(save-restriction
(narrow-to-region b e)
(delete-region (point-min) (point-max))
(cdr word))))
(rfc2047-fold-region (point-min) (point-max)))))
-(defun rfc2047-encode-string (string)
+(defun rfc2047-encode-string (string &optional word-chars)
"Encode words in STRING."
(with-temp-buffer
(insert string)
- (rfc2047-encode-region (point-min) (point-max))
+ (rfc2047-encode-region (point-min) (point-max) word-chars)
(buffer-string)))
(defun rfc2047-encode (b e charset)
projects / elisp / gnus.git- / commitdiff