;;;; -*- mode:emacs-lisp;coding:utf-8 -*- ;;;;***************************************************************************** ;;;;FILE: pjb-mail.el ;;;;LANGUAGE: emacs lisp ;;;;SYSTEM: emacs ;;;;USER-INTERFACE: emacs ;;;;DESCRIPTION ;;;; ;;;; This module exports various functions related to mail handling. ;;;; ;;;;AUTHORS ;;;; Pascal J. Bourguignon ;;;;MODIFICATIONS ;;;; 2002-10-01 Created. ;;;; ;;;;BUGS ;;;;LEGAL ;;;; LGPL ;;;; ;;;; Copyright Pascal J. Bourguignon 2002 - 2011 ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either ;;;; version 2 of the License, or (at your option) any later version. ;;;; ;;;; This library 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 ;;;; Lesser General Public License for more details. ;;;; ;;;; You should have received a copy of the GNU Lesser General Public ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ;;;; ;;;;****************************************************************************** (require 'pjb-cl) (require 'pjb-list) (require 'pjb-strings) (require 'pjb-emacs) (require 'pjb-pgp) (require 'mailheader) (require 'mm nil t) (require 'sendmail) (defun slist-get (slist prop &rest options) " DO: Extract a value from a property list. PLIST: is a property list, which is a list of the form (PROP1 VALUE1 PROP2 VALUE2...). RETURN: the value corresponding to the given PROP, or nil if PROP is not one of the properties on the list. NOTE: The difference with plist-get is that this function works with strings properties. OPTIONS can contain :ignore-case in which case the case string and prefix are matched case insensitively. " (let ((ignore-case (member :ignore-case options)) ) (when ignore-case (setq prop (upcase prop))) (loop for clist = slist then (cddr clist) while clist for sprop = (if ignore-case (upcase (car clist)) (car clist)) while (string/= sprop prop) finally return (cadr clist)) )) ;;slist-get (defun pjb-mail-narrow-to-headers () "Narrow the buffer to the head of the message." ;; Taken from message-narrow-to-headers (interactive) (widen) (narrow-to-region (goto-char (point-min)) (if (re-search-forward (concat "^" (regexp-quote mail-header-separator) "\n") nil t) (match-beginning 0) (point-max))) (goto-char (point-min))) ;;pjb-mail-narrow-to-headers (defun pjb-mail-remove-header (header &optional is-regexp first reverse) " PRE: (pjb-mail-narrow-to-header) DO: Remove HEADER in the narrowed buffer. If IS-REGEXP, HEADER is a regular expression. If FIRST, only remove the first instance of the header. If REVERSE, remove the header not matching HEADER (regexp). RETURN: the number of headers removed. NOTE: See original code: message-remove-header " (goto-char (point-min)) (let ((regexp (if is-regexp header (concat "^" (regexp-quote header) ":"))) (number 0) (case-fold-search t) last) (while (and (not (eobp)) (not last)) (if (let ((case-fold-search t)) ;; case is not significant in headers whatever what. (if reverse (not (looking-at regexp)) (looking-at regexp))) (progn (incf number) (when first (setq last t)) (delete-region (point) ;; There might be a continuation header, so we have to search ;; until we find a new non-continuation line. (progn (forward-line 1) (if (re-search-forward "^[^ \t]" nil t) (goto-char (match-beginning 0)) (point-max))))) (forward-line 1) (if (re-search-forward "^[^ \t]" nil t) (goto-char (match-beginning 0)) (point-max)))) number)) (defun pjb-mail-make-boundary () " RETURN: A unique string that can be used as a boundary. " (let ((ut (decode-time))) (format "%s.%08d.%04d-%02d-%02d-%02d-%02d-%02d/%02d" (system-name) (random 100000000) (elt ut 5) (elt ut 4) (elt ut 3) (elt ut 2) (elt ut 1) (elt ut 0) (or (elt ut 8) 0)))) (defun pjb-mail$$insert-content-headers (&rest headers-k-v) " DO: Inserts at point 'Content-' MIME headers as directed by headers-k-v which should be of the form: :key1 value1 :key2 value2 --> Content-Key1: value1 Content-Key2: value2 " ;;(message "headers-k-v=%S\n" headers-k-v) (loop for current = headers-k-v then (cddr current) while current for key = (car current) for value = (cadr current) do (insert (format "Content-%s: %s\n" (capitalize (subseq (symbol-name key) 1)) value)) ) ;;loop ) ;;pjb-mail$$insert-content-headers (defun pjb-mail$$select (indicator list) " RETURN: The sublist of the elements from LIST for which the indicator function does not return nil. " (let ( (result nil) ) (dolist (element list) (when (funcall indicator element) (setq result (cons element result)))) result) ) ;;pjb-mail$$select (defun pjb-mail-make-mime () " PRE: the current buffer contains a RFC822 message. DO: If the mail is not already a MIME message, then makes it a MIME message. POST: the current buffer contains a MIME multipart/mixed message, either the original one, or a new one with the old message contents as the first MIME section. " (let ((headers (progn (widen) (goto-char (point-min)) (mail-header-extract))) boundary) (unless (mail-header 'mime-version headers) ;; not already a MIME message. ;; let's encapusulate the existing body into the first section before ;; adding a new section for the attached file. (setq boundary (pjb-mail-make-boundary)) (pjb-mail-narrow-to-headers) (goto-char (point-max)) (insert "MIME-Version: 1\n") (pjb-mail$$insert-content-headers :transfer-encoding "8bit" :type (format "multipart/mixed; boundary=\"%s\"" boundary) :disposition "inline") (widen) (mail-text) (insert "\n") (insert "This is a MIME formated message.\n\n") (insert (format "--%s\n" boundary)) (pjb-mail$$insert-content-headers :encoding "8bit" :type "text/plain; charset=iso-8859-1" :language "fr,en" :disposition "inline" :description "Cover letter.") (goto-char (point-max)) (insert "\n\n") (insert (format "--%s--\n" boundary)) (insert "\n") (widen) ) ;;unless not already a MIME message. )) ;;pjb-mail-make-mime (defun pjb-mail-make-multipart/mixed () " PRE: the current buffer contains a MIME message. DO: if it's not already a multipart/mixed message, then makes it multipart/mixed. POST: the current buffer contains a MIME multipart/mixed message, either the original one, or a new one with the old message contents as the first MIME section. " (let ((headers (progn (widen) (goto-char (point-min)) (mail-header-extract))) boundary) (unless (pjb-string-prefix-p (mail-header 'content-type headers) "multipart/mixed" :ignore-case) ;; already a MIME, but not a mixed ;; let's move the content- headers to the existing body and ;; encapusulate it into the first section before ;; adding a new section for the attached file. (setq boundary (pjb-mail-make-boundary)) ;; since it's not a multipart/mixed, there's no boundary yet. ;; first, let's report the current "Content-" headers into the body. (widen) (mail-text) (insert "\n") (insert "This is a MIME formated message.\n\n") (insert (format "--%s\n" boundary)) (apply 'pjb-mail$$insert-content-headers (flatten (mapcar (lambda (item) (list (intern (concat ":" (chop-prefix (symbol-name (car item)) "content-" :ignore-case))) (cdr item))) (pjb-mail$$select (lambda (item) (pjb-string-prefix-p (symbol-name (car item)) "content-" :ignore-case)) headers) ))) (insert "\n") ;; (sleep 0.001) ;; to display the changes... (goto-char (point-max)) ;; end of message text (insert "\n\n") (insert (format "--%s--\n" boundary)) (insert "\n") ;; next, let's remove the current "Content-" headers (pjb-mail-narrow-to-headers) (pjb-mail-remove-header "^Content-.*" t nil nil) ;; finally, let's add the new "Content-" headers. (goto-char (point-max)) ;; end of headers ;; no need to insert MIME-Version, it's aready a MIME message. (pjb-mail$$insert-content-headers :transfer-encoding "8bit" :type (format "multipart/mixed; boundary=\"%s\"" boundary) :disposition "inline") (widen) ))) (defun pjb-mail-get-multipart/mixed-boundary (headers) " RETURN: the boundary attribute of the multipart/mixed content-type header in headers. " (replace-regexp-in-string "^\"\\(.*\\)\"$" "\\1" (slist-get (delete "" (flatten (mapcar (lambda (s) (split-string s "=")) (split-string (chop-prefix (mail-header 'content-type headers) "multipart/mixed" :ignore-case) "[\n ]*;[\n ]*")))) "boundary" :ignore-case) nil nil)) (defun pjb-mail-attach-file (file-name &optional compress) " DO: Ask for the path of a file to attach to the message being edited in the current buffer. " (interactive "*fFile to attach: P") ;; (unless (eq major-mode 'mail-mode) ;; (error "I can attach a file only to a mail buffer.")) (pjb-mail-make-mime) (pjb-mail-make-multipart/mixed) (let ((headers (progn (widen) (goto-char (point-min)) (mail-header-extract)))) (unless (mail-header 'content-type headers) (error "Can't get Content-Type: header!")) ;; already a MIME and already a mixed ;; let's just recover the boundary and add a section. (let ((boundary (pjb-mail-get-multipart/mixed-boundary headers))) (when (or (null boundary) (= 0 (length boundary))) (error "Invalid multipart/mixed boundary. Please fix.")) (widen) (goto-char (point-max)) (if (re-search-backward (format "^--%s\\(--\\)?\n" (regexp-quote boundary)) (point-min) t) (progn ;; found (goto-char (match-beginning 0)) (insert (concat "--" boundary "\n")) ;; TODO: handle errors in case insert-attachment-here fails. (pjb-mail-insert-attachment-here file-name compress)) (error "No boundary in a multipart/mixed. Please fix."))))) (defun parse-address-list-string (adlist-string) " DO: parse the adlist-string and extract from it the email addresses. RETURN: a list of strings containing each one address. " (let ((i 0) (len (length adlist-string)) (result nil) (curaddr nil) (state :unknown) ;; ( :unknown :in-address ;; :in-comment-paren :in-escape-quote :in-comment-angle ) (prevstate nil) (escape nil) ;; ?\ (start 0) curchar (dbl-quote (character "\"" )) (left-paren (character "(" )) (right-paren (character ")" )) (left-angle (character "<" )) (right-angle (character ">" )) (anti-slash (character "\\" )) (comma (character "," )) ) (while (<= i len) (if (< i len) (setq curchar (aref adlist-string i)) (setq curchar nil)) (cond ((eq state :unknown) (if (and escape curchar) (progn (push curchar curaddr) (setq escape nil)) (cond ((or (null curchar) (= curchar comma)) (let ((address (list-to-string (nreverse curaddr)))) (when (< 0 (length address)) (push (chop-spaces address) result)) (setq curaddr nil))) ((= curchar dbl-quote) (push curchar curaddr) (setq prevstate state state :in-escape-quote)) ((= curchar left-paren) (setq state :in-comment-paren)) ((= curchar left-angle) (setq state :in-address curaddr nil)) ((= curchar anti-slash) (push curchar curaddr) (setq escape t)) (t (push curchar curaddr)) ))) ;;state :unknown ((eq state :in-address) (if (and escape curchar) (progn (push curchar curaddr) (setq escape nil)) (cond ((or (null curchar) (= curchar right-angle)) (let ((address (list-to-string (nreverse curaddr)))) (when (< 0 (length address)) (push (chop-spaces address) result)) (setq curaddr nil)) (setq state :in-comment-angle)) ((= curchar anti-slash) (push curchar curaddr) (setq escape t)) (t (push curchar curaddr)) ))) ;;state :in-address ((eq state :in-comment-paren) (if escape (setq escape nil) (cond ((null curchar)) ((= curchar right-paren) (setq state :unknown)) ((= curchar anti-slash) (setq escape t)) ))) ;;state :in-comment-paren ((eq state :in-escape-quote) (if escape (progn (push curchar curaddr) (setq escape nil)) (cond ((null curchar)) ((= curchar dbl-quote) (setq state prevstate)) ((= curchar anti-slash) (push curchar curaddr) (setq escape t)) (t (push curchar curaddr)) ))) ;;state :in-escape-quote ((eq state :in-comment-angle) (if escape (setq escape nil) (cond ((null curchar)) ((= curchar anti-slash) (setq escape t)) ((= curchar comma) (setq state :unknown)) ))) ;;state :in-comment-angle ) (setq i (1+ i)) ) ;;while result)) ;;parse-address-list-string ;;; (mapc (lambda (adls) ;;; (printf "%S\n %S\n\n" adls (parse-address-list-string adls))) ;;; ;; -------------------------------------------------- ;;; '("Bernard ,Agathe " ;;; "ber\\" ;;; "pjb@informatimago.com" ;;; "(comment) pjb@informatimago.com" ;;; "pjb@informatimago.com (comment)" ;;; "(comment) pjb@informatimago.com (comment)" ;;; "pjb@(comment)informatimago.com" ;;; "" ;;; "<(comment) pjb@informatimago.com>" ;;; "" ;;; "<(comment) pjb@informatimago.com (comment)>" ;;; "" ;;; "a,b,c" ;;; "," ;;; "" ;;; "a,,b" ;;; "(abc),(def)" ;;; "(abc)" ;;; "a\\,b,c" ;;; "\\\\," ;;; "\\," ;;; "\"" ;;; "a\\,,b" ;;; "\\a,,b" ;;; "\\(abc)\\,(def)" ;;; "\\(abc)" ;;; "\"Toto Duchnock\" " ;;; "<\"toto duchnock\"@dot.com> haha ,(toto@dot.com) toto" ;;; )) (defun pjb-mail-sign (pass-phrase) " Content-Type: multipart/signed; micalg=pgp-sha1; protocol=\"application/pgp-signature\"; boundary=\"5mCyUwZo2JvN/JJP\" --5mCyUwZo2JvN/JJP Content-Type: text/plain; charset=us-ascii Content-Disposition: inline --5mCyUwZo2JvN/JJP Content-Type: application/pgp-signature Content-Disposition: inline -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.0.6 (GNU/Linux) Comment: w00t! iD8DBQE9xuYI76uNUzjDrRQRAmiHAJ9rPkgxJBK6TdIaiaalc7U5JxLX+wCfU/IG 4KOwAyGYpBr18qA4av8qMjA= =WfP3 -----END PGP SIGNATURE----- --5mCyUwZo2JvN/JJP-- " ) ;;pjb-mail-sign (defun pjb-mail-encrypt (pass-phrase recipients &optional conv-utf-8) " DO: Encrypt the current mail and put it into a multipart/encrypted MIME. Sign and encrypt the buffer, with pgp-signer key, unlocked by the PASS-PHRASE, for the given RECIPIENTS. " (interactive (list ;; pass-phrase (progn (unless (eq major-mode 'mail-mode) (error "I can encrypt a message only in a mail buffer.")) (let ((pass-phrase (read-string "Pass phrase: "))) (pgp-remove-key-from-history pass-phrase) pass-phrase)) ;; recipients (let ((recipients (unsplit-string (remove-duplicates (flatten (mapcar ;; extract only the email addresses (lambda (item) (parse-address-list-string (cdr item))) (pjb-mail$$select ;; select only To: Cc: and Bcc: headers. (lambda (item) (member (car item) '(to cc bcc))) (progn ;; get the headers. (widen) (expand-mail-aliases (point-min) (progn (mail-text) (point))) (goto-char (point-min)) (mail-header-extract))))))))) (if recipients recipients (read-string "Recipients: "))) ;; conv-utf-8 current-prefix-arg )) (unless (eq major-mode 'mail-mode) (error "I can encrypt a message only in a mail buffer.")) (pjb-mail-make-mime) (let ((headers (progn (widen) (goto-char (point-min)) (mail-header-extract))) (boundary (pjb-mail-make-boundary)) (text-beg (make-marker)) (text-end (make-marker)) ) ;; copy the Content-* headers to the message body, ready to be encrypted. (mail-text) (apply 'pjb-mail$$insert-content-headers (flatten (mapcar (lambda (item) (list (intern (concat ":" (chop-prefix (symbol-name (car item)) "content-" :ignore-case))) (cdr item))) (pjb-mail$$select (lambda (item) (pjb-string-prefix-p (symbol-name (car item)) "content-" :ignore-case)) headers) ))) (insert "\n") ;; next, let's remove the current "Content-" headers (pjb-mail-narrow-to-headers) (pjb-mail-remove-header "^Content-.*" t nil nil) ;; let's add the new "Content-" headers. (goto-char (point-max)) ;; end of headers ;; no need to insert MIME-Version, it's aready a MIME message. (pjb-mail$$insert-content-headers :transfer-encoding "7bit" ;; encrypted is pure ASCII :type (format (concat "multipart/encrypted; " "protocol=\"application/pgp-encrypted\"; " "boundary=\"%s\"") boundary) :disposition "inline") (widen) (mail-text) (set-marker text-beg (point)) (set-marker text-end (point-max)) (insert-before-markers (format (concat "Beginning of MIME encrypted message.\n" "\n" "--%s\n" "Content-Type: application/pgp-encrypted\n" "Content-Disposition: inline; filename=\"msg.asc\"\n" "\n" "Version: 1\n" "\n" "--%s\n" "Content-Type: application/octet-stream\n" "Content-Disposition: inline\n" "\n") boundary boundary)) (goto-char text-end) (insert (format (concat "\n" "--%s--\n" "\n" "End of MIME encrypted message.\n" "\n") boundary)) (condition-case exception (progn (when conv-utf-8 (pgp-convert-to-utf-8 text-beg text-end) ) (pgp-encrypt-pk-range pass-phrase recipients text-beg text-end) ) (error (message "PGP encryption raised an exception: %S" exception))) (set-marker text-beg nil) (set-marker text-end nil) (if (< 0 (buffer-size (buffer-named "*PGP*"))) (save-selected-window (switch-to-buffer-other-window "*PGP*") (fit-window-to-buffer) )) )) (defun old-pjb-mail-attach-file (file-name &optional compress) " " (interactive "*fFile to attach: P") (unless (eq major-mode 'mail-mode) (error "I can attach a file only to a mail buffer.")) (let (headers boundary ) (setq headers (progn (widen) (goto-char (point-min)) (mail-header-extract))) ;;(pjb-mail-narrow-to-headers) (unless (mail-header 'mime-version headers) ;; not already a MIME message. ;; let's encapusulate the existing body into the first section before ;; adding a new section for the attached file. (setq boundary (pjb-mail-make-boundary)) (pjb-mail-narrow-to-headers) (goto-char (point-max)) (insert "MIME-Version: 1\n") (pjb-mail$$insert-content-headers :transfer-encoding "8bit" :type (format "multipart/mixed; boundary=\"%s\"" boundary) :disposition "inline") (widen) (mail-text) (insert "\n") (insert "This is a MIME formated message.\n\n") (insert (format "--%s\n" boundary)) (pjb-mail$$insert-content-headers :encoding "8bit" :type "text/plain; charset=iso-8859-1" :language "fr,en" :disposition "inline" :description "Cover letter.") (goto-char (point-max)) (insert "\n\n") (insert (format "--%s--\n" boundary)) (insert "\n") (setq headers (progn (widen) (goto-char (point-min)) (mail-header-extract))) ) ;;unless not already a MIME message. (unless (pjb-string-prefix-p (mail-header 'content-type headers) "multipart/mixed" :ignore-case) ;; already a MIME, but not a mixed ;; let's move the content- headers to the existing body and ;; encapusulate it into the first section before ;; adding a new section for the attached file. (setq boundary (pjb-mail-make-boundary)) ;; since it's not a multipart/mixed, there's no boundary yet. ;; first, let's report the current "Content-" headers into the body. (widen) (mail-text) (insert "\n") (insert "This is a MIME formated message.\n\n") (insert (format "--%s\n" boundary)) (apply 'pjb-mail$$insert-content-headers (flatten (mapcar (lambda (item) (list (intern (concat ":" (chop-prefix (symbol-name (car item)) "content-" :ignore-case))) (cdr item))) (pjb-mail$$select (lambda (item) (pjb-string-prefix-p (symbol-name (car item)) "content-" :ignore-case)) headers) ))) (sleep 0.001) (goto-char (point-max)) ;; end of message text (insert "\n\n") (insert (format "--%s--\n" boundary)) (insert "\n") ;; next, let's remove the current "Content-" headers (pjb-mail-narrow-to-headers) (pjb-mail-remove-header "^Content-.*" t nil nil) ;; finally, let's add the new "Content-" headers. (goto-char (point-max)) ;; end of headers ;; no need to insert MIME-Version, it's aready a MIME message. (pjb-mail$$insert-content-headers :transfer-encoding "8bit" :type (format "multipart/mixed; boundary=\"%s\"" boundary) :disposition "inline") (setq headers (progn (widen) (goto-char (point-min)) (mail-header-extract))) ) ;;unless not already a multipart/mixed (unless (mail-header 'content-type headers) (error "Can't get Content-Type: header!")) ;; already a MIME and already a mixed ;; let's just recover the boundary and add a section. (setq boundary (replace-regexp-in-string "^\"\\(.*\\)\"$" "\\1" (slist-get (flatten (mapcar (lambda (s) (split-string s "=")) (split-string (chop-prefix (mail-header (quote content-type) headers) "multipart/mixed" :ignore-case) "[\n ]*;[\n ]*"))) "boundary" :ignore-case) nil nil)) (when (or (null boundary) (= 0 (length boundary))) (error "Invalid multipart/mixed boundary. Please fix.")) (widen) (goto-char (point-max)) (if (re-search-backward (format "^--%s\\(--\\)?\n" (regexp-quote boundary)) (point-min) t) (progn ;; found (goto-char (match-beginning 0)) (insert (concat "--" boundary "\n")) ;; TODO: handle errors in case insert-attachment-here fails. (pjb-mail-insert-attachment-here file-name compress) ) (error "No boundary in a multipart/mixed. Please fix.")) ) ;;progn ) ;;old-pjb-mail-attach-file (defvar *pjb-mail-inline-types* '("image/.*")) (defvar *pjb-mail-mime-type-as-8bit* '( "application/ghostview" "application/mac-binhex40" "application/pgp" "application/pgp-signature" "application/postscript" "application/rtf" "application/x-csh" "application/x-httpd-php" "application/x-perl" "application/x-sh" "application/x-shar" "application/x-tcl" "application/x-tex" "application/x-texinfo" "application/x-troff" "application/x-troff-man" "application/x-troff-me" "application/x-troff-ms" "application/octetstream" "message/external-body" "message/news" "message/partial" "message/rfc822" "multipart/alternative" "multipart/appledouble" "multipart/digest" "multipart/mixed" "multipart/parallel" "text/css" "text/html" "text/plain" "text/richtext" "text/tab-separated-values" "text/x-setext" "text/x-sgml" "text/x-vCalendar" "text/x-vCard" "text/xml" "text/vnd.rn-realtext" ) "List of mime type that can be sent with transport-encoding: 8bit. Others will be sent as base64.") (defun pjb-mail-insert-attachment-here (file-name &optional compress) " DO: Insert a file attachment at the point, prefixed with Content- headers and possibly encoded. May ask the user for further attributes. " (setq file-name (expand-file-name file-name)) (unless (file-exists-p file-name) (error "File '%s' does not exist." file-name)) (when (file-directory-p file-name) (error "Can't attach a directory!")) (let ((out-fname (basename file-name)) (type nil) transfer-encoding description (disposition "attachment")) ; may be "inline" (if compress (setq type "application/x-gzip" transfer-encoding "base64") (progn ;; (mm-parse-mimetypes) ;; (when (string-match "\\(\\.[^\\.]+\\)$" file-name) ;; (setq type (mm-extension-to-mime (match-string 0 file-name)))) (unless type (setq type (replace-regexp-in-string ", English" "" (car (split-string ;; TODO: handle errors (shell-command-to-string (format "file -L -b -i %s 2>/dev/null" (shell-quote-argument file-name))) "\n")) t t))) (when (or (null type) (= 0 (length type)) (string= "data" type)) (setq type (read-string "Can't determine mime-type. Please tell me: " "application/octetstream"))) (when (= 0 (length type)) (setq type "application/octetstream")) (if (member* (car (split-string type " *; *")) *pjb-mail-mime-type-as-8bit* :test (function cl:string-equal)) (setq transfer-encoding "8bit") (setq transfer-encoding "base64")) (when (member* (car (split-string type " *; *")) *pjb-mail-inline-types* :test (lambda (s r) ;; (message "(%S %S) -> %S" s r (string-match r s)) (string-match r s))) (setf disposition "inline")))) (setq description (read-string "Please enter attachment description: ")) (when (= 0 (length description)) (setq description (format "Attachment %s" (shell-quote-argument out-fname)))) (pjb-mail$$insert-content-headers :transfer-encoding transfer-encoding :type type :disposition (format "%s; filename=\"%s\"" disposition (shell-quote-argument out-fname)) :description description) (insert "\n\n") (previous-line 1) (if (string= "8bit" transfer-encoding) (insert-file-contents file-name) (if compress (shell-command (format "gzip<%s|base64-encode" (shell-quote-argument file-name)) t nil) (shell-command (format "base64<%s" (shell-quote-argument file-name)) t nil))))) (when (require 'vm nil t) (require 'vm-vars) ;;---------------------------------------------------------------------- ;; Create auto-folders ;;---------------------------------------------------------------------- (defstruct (afr (:type list)) label slot regexp) (defvar *auto-folder-regexps* '(("Subject" vm-subject-of "^Subject:") ("To" vm-to-of "^To:") ("From" vm-from-of "^From:") ("FromToCc" vm-from-of "^\\(From:\\|To:\\|Cc:\\)"))) (defun vm-current-message () (car vm-message-pointer)) ;; (defun pjb-vm-create-auto-folder-and-save-message (selector) ;; (interactive ;; (list ;; (completing-read ;; "Selector: " (mapcar (afr-label) *auto-folder-regexps*) nil t "From"))) ;; (let (( ;; ;; (vm-subject-of message) ;; (vm-from-of message) ;; (vm-to-of message) ;; (vm-cc-of message) ;; ;; (vm-auto-select-folder vm-message-pointer vm-auto-folder-alist) );; when require (provide 'pjb-mail) ;;;; THE END ;;;;