1999-01-04 Tanaka Akira <akr@jaist.ac.jp>
+ * Sync up to flim-1_12_1 from flim-1_11_3.
+
+ * mime-def.el (mime-library-product): Bump up to FLAM-DOODLE
+ 1.12.0.
+
+1999-01-04 Tanaka Akira <akr@jaist.ac.jp>
+
* ew-var.el (ew-decode-field-syntax-alist): Add `x-face-version',
`x-pgp-sig-version', `x-pgp-key-info' and `x-info'.
* eword-decode.el: Copied from AKEMI branch of SEMI.
\f
-1998-10-27 Tanaka Akira <akr@jaist.ac.jp>
+1998-12-02 MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+ * FLIM: Version 1.12.1 (Nishinoky\e-Dò)\e-A released.
+
+1998-11-30 MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+ * smtpmail.el (smtpmail-send-it): Add autoload cookie; use
+ `smtpmail-do-bcc' instead of `smtp-do-bcc'; modify for interface
+ change of `smtp-via-smtp'.
+ (smtpmail-do-bcc): New function (moved and renamed from
+ `smtp-do-bcc' of smtp.el).
+
+1998-08-06 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * lisp/smtp.el: Do not insert empty line at the end of message.
+
+1998-06-18 Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp>
+
+ * lisp/smtp.el (smtp-use-8bitmime): New variable.
+ (smtp-debug-info): Internal variable, now.
+ (smtp-make-fqdn): Renamed from `smtp-fqdn'.
+ (smtp-via-smtp): New implementation.
+ (smtp-send-command): Treat "PASS" as usual.
+ (smtp-do-bcc): Removed.
+
+1998-11-30 MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+ * smtpmail.el: New module (copied from Semi-gnus 6.8).
+
+ * smtp.el: New module (copied from Semi-gnus 6.8).
+
+ * FLIM-ELS: Add smtp.el and smtpmail.el.
+
+1998-11-30 MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+ * mime-def.el: Abolish function `eliminate-top-spaces' because it
+ is not used in FLIM.
+
+1998-11-29 MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+ * eword-encode.el (eword-encode-mailbox-to-rword-list): Fix
+ problem in `eword-encode-addresses-to-rword-list'.
+
+1998-11-26 MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+ * std11.el (std11-full-name-string): fixed.
+
+ * std11.el (std11-comment-value-to-string): fixed.
+
+1998-11-25 MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+ * NEWS (Changes in FLIM 1.12): New section.
+
+1998-11-25 MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+ * std11.el (std11-comment-value-to-string): New function.
+ (std11-full-name-string): Use `std11-comment-value-to-string'.
+
+ * eword-decode.el (eword-parse-comment): New function.
+ (eword-analyze-comment): New implementation; use
+ `eword-parse-comment'; change representation.
+ (eword-decode-token): Modify for representation change of comment.
+
+\f
+1998-11-16 MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+ * FLIM: Version 1.12.0 (Amagatsuji) was released.
+
+1998-11-14 Tanaka Akira <akr@jaist.ac.jp>
+
+ * mel-b-ccl.el (ccl-cascading-read): Check consistency.
+
+1998-11-13 MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+ * eword-decode.el (eword-decode-structured-field-body): Abolish
+ non-used local variable.
+
+1998-11-12 Tanaka Akira <akr@jaist.ac.jp>
+
+ * mel-b-ccl.el (mel-ccl-decode-b): Check `ccl-cascading-read' to
+ select implementation.
+
+1998-11-12 Tanaka Akira <akr@jaist.ac.jp>
+
+ * mel-q-ccl.el (mel-ccl-encode-quoted-printable-generic): workaround
+ for mule-2.3@19.34.
+
+1998-11-12 Tanaka Akira <akr@jaist.ac.jp>
+
+ * mel.el (mel-b-builtin): New variable.
+
+1998-11-10 Tanaka Akira <akr@jaist.ac.jp>
+
+ * FLIM-ELS: require 'pccl.
+ (flim-modules): Check CCL availability by broken facility.
+
+1998-11-08 MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+ * eword-decode.el (eword-decode-structured-field-body): New
+ implementation; abolish optional argument `must-unfold'; delete
+ DOC-string.
+ (eword-decode-and-unfold-structured-field-body): Renamed from
+ `eword-decode-and-unfold-structured-field'; delete DOC-string.
+ (eword-decode-and-fold-structured-field-body): Renamed from
+ `eword-decode-and-fold-structured-field'; abolish optional
+ argument `must-unfold'; delete DOC-string.
+ (eword-decode-unstructured-field-body): Abolish optional argument
+ `must-unfold'; delete DOC-string.
+ (eword-decode-and-unfold-unstructured-field-body): Renamed from
+ `eword-decode-and-unfold-unstructured-field'; delete DOC-string.
+ (eword-decode-unfolded-unstructured-field-body): New function.
+
+1998-11-08 MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+ * mmgeneric.el (mime-insert-header-from-buffer): Use
+ `mime-find-field-presentation-method' and
+ `mime-find-field-decoder-internal'.
+
+ * eword-decode.el (mime-find-field-presentation-method): New
+ macro.
+ (mime-find-field-decoder-internal): New function.
+ (mime-find-field-decoder): New implementation (use
+ mime-find-field-decoder-internal).
+ (mime-decode-header-in-region): Use
+ `mime-find-field-presentation-method' and
+ `mime-find-field-decoder-internal'.
+
+1998-11-08 MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+ * mmgeneric.el (mime-insert-header-from-buffer): Rename
+ field-presentation-mode `folding' to `wide'.
+
+ * eword-decode.el: Rename field-presentation-modes from `native',
+ `folding', `unfolding', `unfolding-xover' to `plain', `wide',
+ `summary', `nov'.
+
+1998-11-07 Tanaka Akira <akr@jaist.ac.jp>
+
+ * eword-decode.el (mime-set-field-decoder): Add mode `unfolding-xover'.
+ (mime-find-field-decoder): Ditto.
+
+1998-11-04 MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+ * eword-encode.el (eword-encode-phrase-route-addr-to-rword-list):
+ Don't delete the front spaces.
+ (eword-encode-addresses-to-rword-list): Don't supplement space;
+ use `nconc' instead of `append'.
+ (eword-encode-msg-id-to-rword-list): Supplement the front space;
+ use `nconc' instead of `append'.
+
+1998-11-02 Tanaka Akira <akr@jaist.ac.jp>
+
+ * eword-decode.el (mime-field-decoder-cache): New variable.
+ (mime-find-field-decoder): Use `mime-field-decoder-cache'.
+ (mime-update-field-decoder-cache): New variable.
+ (mime-update-field-decoder-cache): New function.
+ (mime-decode-header-in-region): Use `mime-field-decoder-cache'.
+
+ * mmgeneric.el (mime-insert-header-from-buffer): Use
+ `mime-field-decoder-cache'.
+
+1998-11-02 MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+ * eword-decode.el (mime-decode-header-in-region): New function.
+ (mime-decode-header-in-buffer): Use function
+ `mime-decode-header-in-region'.
+
+1998-10-28 MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+ * mmgeneric.el (mime-insert-header-from-buffer): Refer
+ `mime-field-decoder-alist' instead of hard-coding.
+
+ * mime.el (mime-read-field): Use `mime-decode-field-body'.
+
+ * eword-decode.el (eword-decode-and-unfold-structured-field): Add
+ optional dummy argument `start-column' and `max-column'.
+ (eword-decode-structured-field-body): Change interface.
+ (eword-decode-unstructured-field-body): Change interface to add
+ optional dummy argument `start-column' and `max-column'.
+ (eword-decode-and-unfold-unstructured-field): Add optional dummy
+ argument `start-column' and `max-column'.
+ (mime-field-decoder-alist): New variable; abolish user option
+ `eword-decode-ignored-field-list' and
+ `eword-decode-structured-field-list'.
+ (mime-set-field-decoder): New function.
+ (mime-find-field-decoder): New function.
+ (mime-decode-field-body): New function; abolish function
+ `eword-decode-field-body'.
+ (mime-decode-header-in-buffer): Renamed from
+ `eword-decode-header'; refer `mime-field-decoder-alist' instead of
+ hard-coding; add obsolete alias `eword-decode-header'.
+
+1998-10-28 MORIOKA Tomohiko <morioka@jaist.ac.jp>
- * eword-encode.el (eword-encode-field-body): Unfold `field-body'.
+ * mime-def.el: Avoid compile error when edebug is missing.
\f
1998-10-28 MORIOKA Tomohiko <morioka@jaist.ac.jp>
19 \e$B>.F&\e(B \e$B$"$:$-\e(B 2.5R3.5/5.0 FLAM-DOODLE 1.11.0
20 \e$BIrF:Cc\e(B \e$B$($S$A$c\e(B 5.0R4.0/11.0 FLAM-DOODLE 1.11.1
21 \e$B??<k\e(B \e$B$7$s$7$e\e(B 2.5R4.5/10.0 FLAM-DOODLE 1.11.2
- 22 \e$B[XHi\e(B \e$B$R$O$@\e(B 2.0YR3.5/4.0
+ 22 \e$B[XHi\e(B \e$B$R$O$@\e(B 2.0YR3.5/4.0 FLAM-DOODLE 1.12.0
23 \e$B%Y%s%,%i\e(B \e$B$Y$s$,$i\e(B 7.5R4.0/7.0
24 \e$BBel`\e(B \e$B$?$$$7$c\e(B 10R4.5/8.0
25 \e$B>GCc\e(B \e$B$3$2$A$c\e(B 10R3.0/2.0
ew-compat
mime mime-parse mmgeneric mmbuffer mmcooked
mailcap
- ))
+ smtp smtpmail))
(unless (and (fboundp 'base64-encode-string)
(subrp (symbol-function 'base64-encode-string)))
(setq flim-modules (cons 'mel-b-el flim-modules))
)
-(if (and (featurep 'mule)
- (not (or (and (boundp 'MULE) MULE)
- (and (featurep 'xemacs) (< emacs-major-version 21))
- )))
- (setq flim-modules (cons 'mel-b-ccl (cons 'mel-q-ccl flim-modules)))
- )
+(require 'pccl)
+(unless-broken ccl-usable
+ (setq flim-modules (cons 'mel-b-ccl (cons 'mel-q-ccl flim-modules))))
;;; FLIM-ELS ends here
#
PACKAGE = flim
-VERSION = 1.11.3
+API = 1.12
+RELEASE = 1
TAR = tar
RM = /bin/rm -f
*.pg *.pgs *.tp *.tps *.toc *.aux *.log
FILES = README.?? Makefile FLIM-MK FLIM-CFG FLIM-ELS *.el ChangeLog
+VERSION = $(API).$(RELEASE)
+ARC_DIR = /pub/GNU/elisp/flim/$(PACKAGE)-$(API)
+SEMI_ARC_DIR = /pub/GNU/elisp/semi/semi-1.12-for-flim-$(API)
elc: ew-parse.el
$(EMACS) $(FLAGS) -l FLIM-MK -f compile-flim $(PREFIX) $(LISPDIR) \
tar:
cvs commit
- sh -c 'cvs tag -RF $(PACKAGE)-`echo $(VERSION) \
- | sed s/\\\\./_/ | sed s/\\\\./_/`; \
+ sh -c 'cvs tag -RF $(PACKAGE)-`echo $(VERSION) | tr . _`; \
cd /tmp; \
cvs -d :pserver:anonymous@chamonix.jaist.ac.jp:/hare/cvs/root \
export -d $(PACKAGE)-$(VERSION) \
- -r $(PACKAGE)-`echo $(VERSION) | sed s/\\\\./_/ | sed s/\\\\./_/` \
+ -r $(PACKAGE)-`echo $(VERSION) | tr . _` \
flim'
cd /tmp; $(RM) $(PACKAGE)-$(VERSION)/ftp.in ; \
$(TAR) cvzf $(PACKAGE)-$(VERSION).tar.gz $(PACKAGE)-$(VERSION)
cd /tmp; $(RM) -r $(PACKAGE)-$(VERSION)
- sed "s/VERSION/$(VERSION)/" < ftp.in > ftp
+ sed "s/VERSION/$(VERSION)/" < ftp.in | sed "s/API/$(API)/" > ftp
release:
- -$(RM) /pub/GNU/elisp/flim/$(PACKAGE)-$(VERSION).tar.gz
- mv /tmp/$(PACKAGE)-$(VERSION).tar.gz /pub/GNU/elisp/flim/
- cd /pub/GNU/elisp/semi/ ; \
- ln -s ../flim/$(PACKAGE)-$(VERSION).tar.gz .
+ -$(RM) $(ARC_DIR)/$(PACKAGE)-$(VERSION).tar.gz
+ mv /tmp/$(PACKAGE)-$(VERSION).tar.gz $(ARC_DIR)
+ cd $(SEMI_ARC_DIR) ; \
+ ln -s ../../flim/flim-$(API)/$(PACKAGE)-$(VERSION).tar.gz .
ew-parse.el: ew-parse.scm lalr-el.scm
-scm -f lalr-el.scm -f ew-parse.scm > ew-parse.out
# The file BENCHMARK is not a part of FLAM-DOODLE because it is so large.
benchmark:
$(EMACS) $(FLAGS_CURDIR) -l ./BENCHMARK -eval '(report)'
-
FLIM NEWS --- history of major-changes.
Copyright (C) 1998 Free Software Foundation, Inc.
+* Changes in FLIM 1.12
+
+** Restructure of field decoding features
+
+Introduce backend mechanism of field-decoder and
+field-presentation-method to restructure field decoding features.
+
+Field-decoder is registered into variable `mime-field-decoder-alist'.
+Each decoding function uses decoding method found from variable
+`mime-field-decoder-alist'.
+
+New function `mime-set-field-decoder' is added to register field
+decoding method.
+
+New function `mime-find-field-presentation-method' is added to get
+`field-presentation-method' object corresponding with specified
+field-presentation-mode. Field-presentation-mode must be `plain',
+`wide', `summary' or `nov'.
+
+New function `mime-find-field-decoder' is added to find field decoding
+method corresponding with field-name and field-presentation-mode.
+
+New function `mime-decode-field-body' is added. It is general field
+decoder.
+
+
+** Function `mime-decode-header-in-buffer'
+
+Renamed from `eword-decode-header'. `eword-decode-header' is defined
+as obsolete alias.
+
+
+** New function `mime-decode-header-in-region'
+
+\f
* Changes in FLIM 1.11
** New function `mime-insert-text-content'
(require 'ew-dec)
(require 'eword-decode)
+(require 'ew-line)
+(eval-when-compile (require 'cl))
+
(defun ew-gnus-structured-field-decoder (string)
(if (fboundp 'ew-decode-field)
(let ((ew-ignore-76bytes-limit t)
(error
(message "gnus-structured-field-decoder error: %s" string)
(decode-mime-charset-string string 'x-ctext))))
- (eword-decode-and-unfold-structured-field string)))
+ (eword-decode-and-unfold-structured-field-body string)))
(defun ew-gnus-unstructured-field-decoder (string)
(if (fboundp 'ew-decode-field)
(decode-mime-charset-string string 'x-ctext))))
(eword-decode-unstructured-field-body (std11-unfold-string string) 'must-unfold)))
+(defun ew-mime-update-field-decoder-cache (field mode)
+ (let ((fun (cond
+ ((eq mode 'plain)
+ (lexical-let ((field-name (symbol-name field)))
+ (lambda (field-body &optional start-column max-column must-unfold)
+ (setq field-body (ew-lf-to-crlf field-body))
+ (let ((res (ew-crlf-to-lf
+ (ew-decode-field field-name field-body))))
+ (add-text-properties
+ 0 (length res)
+ (list 'original-field-name field-name
+ 'original-field-body field-body)
+ res)
+ res))))
+ ((eq mode 'wide)
+ (lexical-let ((field-name (symbol-name field)))
+ (lambda (field-body &optional start-column max-column must-unfold)
+ (setq field-body (ew-lf-to-crlf field-body))
+ (let ((res (ew-crlf-to-lf
+ (ew-crlf-refold
+ (ew-decode-field field-name field-body)
+ (length field-name)
+ (or max-column fill-column)))))
+ (add-text-properties
+ 0 (length res)
+ (list 'original-field-name field-name
+ 'original-field-body field-body)
+ res)
+ res))))
+ ((eq mode 'summary)
+ (lexical-let ((field-name (symbol-name field)))
+ (lambda (field-body &optional start-column max-column must-unfold)
+ (setq field-body (ew-lf-to-crlf field-body))
+ (let ((res (ew-crlf-to-lf
+ (ew-crlf-unfold
+ (ew-decode-field field-name field-body)))))
+ (add-text-properties
+ 0 (length res)
+ (list 'original-field-name field-name
+ 'original-field-body field-body)
+ res)
+ res))))
+ ((eq mode 'nov)
+ (lexical-let ((field-name (symbol-name field)))
+ (lambda (field-body &optional start-column max-column must-unfold)
+ (setq field-body (ew-lf-to-crlf field-body))
+ (require 'ew-var)
+ (let ((ew-ignore-76bytes-limit t))
+ (let ((res (ew-crlf-to-lf
+ (ew-crlf-unfold
+ (ew-decode-field field-name field-body)))))
+ (add-text-properties
+ 0 (length res)
+ (list 'original-field-name field-name
+ 'original-field-body field-body)
+ res)
+ res)))))
+ (t
+ nil))))
+ (mime-update-field-decoder-cache field mode fun)))
+
+(setq mime-update-field-decoder-cache 'ew-mime-update-field-decoder-cache)
(require 'mime-def)
(require 'ew-dec)
+(require 'ew-line)
+
+(eval-when-compile (require 'cl))
(defgroup eword-decode nil
"Encoded-word decoding"
code-conversion
must-unfold))
-(defun eword-decode-and-fold-structured-field
- (string start-column &optional max-column must-unfold)
- "Decode and fold (fill) STRING as structured field body.
+(defun eword-decode-structured-field-body (string
+ &optional
+ start-column max-column)
+ (let* ((ew-decode-field-default-syntax '(ew-scan-unibyte-std11))
+ (decoded (ew-decode-field "" (ew-lf-crlf-to-crlf string))))
+ (ew-crlf-to-lf decoded)))
+
+(defun eword-decode-and-unfold-structured-field-body (string
+ &optional
+ start-column
+ max-column)
+ "Decode and unfold STRING as structured field body.
It decodes non us-ascii characters in FULL-NAME encoded as
encoded-words or invalid \"raw\" string. \"Raw\" non us-ascii
characters are regarded as variable `default-mime-charset'.
If an encoded-word is broken or your emacs implementation can not
-decode the charset included in it, it is not decoded.
-
-If MAX-COLUMN is omitted, `fill-column' is used.
+decode the charset included in it, it is not decoded."
+ (let* ((decoded (ew-decode-field "" (ew-lf-crlf-to-crlf string))))
+ (ew-crlf-to-lf (ew-crlf-unfold decoded))))
-If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
-if there are in decoded encoded-words (generated by bad manner MUA
-such as a version of Net$cape)."
- (rotate-memo args-eword-decode-and-fold-structured-field
- (list string start-column max-column must-unfold))
+(defun eword-decode-and-fold-structured-field-body (string
+ start-column
+ &optional max-column)
(or max-column
(setq max-column fill-column))
(let* ((field-name (make-string (1- start-column) ?X))
(setq decoded (ew-crlf-refold decoded start-column max-column)))
(ew-crlf-to-lf decoded)))
-(defun eword-decode-and-unfold-structured-field (string)
- "Decode and unfold STRING as structured field body.
-It decodes non us-ascii characters in FULL-NAME encoded as
-encoded-words or invalid \"raw\" string. \"Raw\" non us-ascii
-characters are regarded as variable `default-mime-charset'.
-
-If an encoded-word is broken or your emacs implementation can not
-decode the charset included in it, it is not decoded."
- (rotate-memo args-eword-decode-and-unfold-structured-field (list string))
- (let* ((ew-decode-field-default-syntax '(ew-scan-unibyte-std11))
- (decoded (ew-decode-field "" (ew-lf-crlf-to-crlf string))))
- (ew-crlf-to-lf (ew-crlf-unfold decoded))))
-
-(defun eword-decode-structured-field-body (string &optional must-unfold
- start-column max-column)
- "Decode non us-ascii characters in STRING as structured field body.
-STRING is unfolded before decoding.
-
-It decodes non us-ascii characters in FULL-NAME encoded as
-encoded-words or invalid \"raw\" string. \"Raw\" non us-ascii
-characters are regarded as variable `default-mime-charset'.
-
-If an encoded-word is broken or your emacs implementation can not
-decode the charset included in it, it is not decoded.
-
-If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
-if there are in decoded encoded-words (generated by bad manner MUA
-such as a version of Net$cape)."
- (rotate-memo args-eword-decode-structured-field-body
- (list string must-unfold start-column max-column))
- (if start-column
- ;; fold with max-column
- (eword-decode-and-fold-structured-field
- string start-column max-column must-unfold)
- ;; Don't fold
- (let* ((ew-decode-field-default-syntax '(ew-scan-unibyte-std11))
- (decoded (ew-decode-field "" (ew-lf-crlf-to-crlf string))))
- (ew-crlf-to-lf decoded))))
-
-(defun eword-decode-unstructured-field-body (string &optional must-unfold)
- "Decode non us-ascii characters in STRING as unstructured field body.
-STRING is unfolded before decoding.
-
-It decodes non us-ascii characters in FULL-NAME encoded as
-encoded-words or invalid \"raw\" string. \"Raw\" non us-ascii
-characters are regarded as variable `default-mime-charset'.
-
-If an encoded-word is broken or your emacs implementation can not
-decode the charset included in it, it is not decoded.
+(defun eword-decode-unstructured-field-body (string &optional start-column
+ max-column)
+ (let ((decoded (ew-decode-field "" (ew-lf-crlf-to-crlf string))))
+ (ew-crlf-to-lf decoded)))
-If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
-if there are in decoded encoded-words (generated by bad manner MUA
-such as a version of Net$cape)."
- (rotate-memo args-eword-decode-unstructured-field-body
- (list string must-unfold))
+(defun eword-decode-and-unfold-unstructured-field-body (string
+ &optional start-column
+ max-column)
(let ((decoded (ew-decode-field "" (ew-lf-crlf-to-crlf string))))
(ew-crlf-to-lf (ew-crlf-unfold decoded))))
-(defun eword-decode-and-unfold-unstructured-field (string)
- "Decode and unfold STRING as unstructured field body.
-It decodes non us-ascii characters in FULL-NAME encoded as
-encoded-words or invalid \"raw\" string. \"Raw\" non us-ascii
-characters are regarded as variable `default-mime-charset'.
-
-If an encoded-word is broken or your emacs implementation can not
-decode the charset included in it, it is not decoded."
- (rotate-memo args-eword-decode-and-unfold-unstructured-field
- (list string))
+(defun eword-decode-unfolded-unstructured-field-body (string
+ &optional start-column
+ max-column)
(let ((decoded (ew-decode-field "" (ew-lf-crlf-to-crlf string))))
- (ew-crlf-to-lf (ew-crlf-unfold decoded))))
+ (ew-crlf-to-lf decoded)))
;;; @ for region
(delete-region (point-min) (point-max))
(insert str)))))
+(defun eword-decode-unfold ()
+ (goto-char (point-min))
+ (let (field beg end)
+ (while (re-search-forward std11-field-head-regexp nil t)
+ (setq beg (match-beginning 0)
+ end (std11-field-end))
+ (setq field (buffer-substring beg end))
+ (if (string-match eword-encoded-word-regexp field)
+ (save-restriction
+ (narrow-to-region (goto-char beg) end)
+ (while (re-search-forward "\n\\([ \t]\\)" nil t)
+ (replace-match (match-string 1))
+ )
+ (goto-char (point-max))
+ ))
+ )))
;;; @ for message header
;;;
-(defcustom eword-decode-ignored-field-list
- '(Newsgroups Path Lines Nntp-Posting-Host Received Message-Id Date)
- "*List of field-names to be ignored when decoding.
-Each field name must be symbol."
- :group 'eword-decode
- :type '(repeat symbol))
-
-(defcustom eword-decode-structured-field-list
- '(Reply-To Resent-Reply-To From Resent-From Sender Resent-Sender
- To Resent-To Cc Resent-Cc Bcc Resent-Bcc Dcc
- Mail-Followup-To
- Mime-Version Content-Type Content-Transfer-Encoding
- Content-Disposition User-Agent)
- "*List of field-names to decode as structured field.
-Each field name must be symbol."
- :group 'eword-decode
- :type '(repeat symbol))
+(defvar mime-field-decoder-alist nil)
+
+(defvar mime-field-decoder-cache nil)
-(defun eword-decode-field-body
- (field-body field-name &optional unfolded max-column)
- "Decode FIELD-BODY as FIELD-NAME, and return the result.
+(defvar mime-update-field-decoder-cache 'ew-mime-update-field-decoder-cache
+ "*Field decoder cache update function.")
+
+;;;###autoload
+(defun mime-set-field-decoder (field &rest specs)
+ "Set decoder of FILED.
+SPECS must be like `MODE1 DECODER1 MODE2 DECODER2 ...'.
+Each mode must be `nil', `plain', `wide', `summary' or `nov'.
+If mode is `nil', corresponding decoder is set up for every modes."
+ (when specs
+ (let ((mode (pop specs))
+ (function (pop specs)))
+ (if mode
+ (progn
+ (let ((cell (assq mode mime-field-decoder-alist)))
+ (if cell
+ (setcdr cell (put-alist field function (cdr cell)))
+ (setq mime-field-decoder-alist
+ (cons (cons mode (list (cons field function)))
+ mime-field-decoder-alist))
+ ))
+ (apply (function mime-set-field-decoder) field specs)
+ )
+ (mime-set-field-decoder field
+ 'plain function
+ 'wide function
+ 'summary function
+ 'nov function)
+ ))))
-If UNFOLDED is non-nil, it is assumed that FIELD-BODY is
-already unfolded.
+;;;###autoload
+(defmacro mime-find-field-presentation-method (name)
+ "Return field-presentation-method from NAME.
+NAME must be `plain', `wide', `summary' or `nov'."
+ (cond ((eq name nil)
+ `(or (assq 'summary mime-field-decoder-cache)
+ '(summary))
+ )
+ ((and (consp name)
+ (car name)
+ (consp (cdr name))
+ (symbolp (car (cdr name)))
+ (null (cdr (cdr name))))
+ `(or (assq ,name mime-field-decoder-cache)
+ (cons ,name nil))
+ )
+ (t
+ `(or (assq (or ,name 'summary) mime-field-decoder-cache)
+ (cons (or ,name 'summary) nil))
+ )))
+
+(defun mime-find-field-decoder-internal (field &optional mode)
+ "Return function to decode field-body of FIELD in MODE.
+Optional argument MODE must be object of field-presentation-method."
+ (cdr (or (assq field (cdr mode))
+ (prog1
+ (funcall mime-update-field-decoder-cache
+ field (car mode))
+ (setcdr mode
+ (cdr (assq (car mode) mime-field-decoder-cache)))
+ ))))
+
+;;;###autoload
+(defun mime-find-field-decoder (field &optional mode)
+ "Return function to decode field-body of FIELD in MODE.
+Optional argument MODE must be object or name of
+field-presentation-method. Name of field-presentation-method must be
+`plain', `wide', `summary' or `nov'.
+Default value of MODE is `summary'."
+ (if (symbolp mode)
+ (let ((p (cdr (mime-find-field-presentation-method mode))))
+ (if (and p (setq p (assq field p)))
+ (cdr p)
+ (cdr (funcall mime-update-field-decoder-cache
+ field (or mode 'summary)))))
+ (inline (mime-find-field-decoder-internal field mode))
+ ))
-If MAX-COLUMN is non-nil, the result is folded with MAX-COLUMN
-or `fill-column' if MAX-COLUMN is t.
-Otherwise, the result is unfolded.
+;;;###autoload
+(defun mime-update-field-decoder-cache (field mode &optional function)
+ "Update field decoder cache `mime-field-decoder-cache'."
+ (cond ((eq function 'identity)
+ (setq function nil)
+ )
+ ((null function)
+ (let ((decoder-alist
+ (cdr (assq (or mode 'summary) mime-field-decoder-alist))))
+ (setq function (cdr (or (assq field decoder-alist)
+ (assq t decoder-alist)))))
+ ))
+ (let ((cell (assq mode mime-field-decoder-cache))
+ ret)
+ (if cell
+ (if (setq ret (assq field (cdr cell)))
+ (setcdr ret function)
+ (setcdr cell (cons (setq ret (cons field function)) (cdr cell))))
+ (setq mime-field-decoder-cache
+ (cons (cons mode (list (setq ret (cons field function))))
+ mime-field-decoder-cache)))
+ ret))
+
+;; ignored fields
+(mime-set-field-decoder 'Archive nil nil)
+(mime-set-field-decoder 'Content-Md5 nil nil)
+(mime-set-field-decoder 'Control nil nil)
+(mime-set-field-decoder 'Date nil nil)
+(mime-set-field-decoder 'Distribution nil nil)
+(mime-set-field-decoder 'Followup-Host nil nil)
+(mime-set-field-decoder 'Followup-To nil nil)
+(mime-set-field-decoder 'Lines nil nil)
+(mime-set-field-decoder 'Message-Id nil nil)
+(mime-set-field-decoder 'Newsgroups nil nil)
+(mime-set-field-decoder 'Nntp-Posting-Host nil nil)
+(mime-set-field-decoder 'Path nil nil)
+(mime-set-field-decoder 'Posted-And-Mailed nil nil)
+(mime-set-field-decoder 'Received nil nil)
+(mime-set-field-decoder 'Status nil nil)
+(mime-set-field-decoder 'X-Face nil nil)
+(mime-set-field-decoder 'X-Face-Version nil nil)
+(mime-set-field-decoder 'X-Info nil nil)
+(mime-set-field-decoder 'X-Pgp-Key-Info nil nil)
+(mime-set-field-decoder 'X-Pgp-Sig nil nil)
+(mime-set-field-decoder 'X-Pgp-Sig-Version nil nil)
+(mime-set-field-decoder 'Xref nil nil)
+
+;; structured fields
+(let ((fields
+ '(Reply-To Resent-Reply-To From Resent-From Sender Resent-Sender
+ To Resent-To Cc Resent-Cc Bcc Resent-Bcc Dcc
+ Mail-Followup-To
+ Mime-Version Content-Type Content-Transfer-Encoding
+ Content-Disposition User-Agent))
+ field)
+ (while fields
+ (setq field (pop fields))
+ (mime-set-field-decoder
+ field
+ 'plain #'eword-decode-structured-field-body
+ 'wide #'eword-decode-and-fold-structured-field-body
+ 'summary #'eword-decode-and-unfold-structured-field-body
+ 'nov #'eword-decode-and-unfold-structured-field-body)
+ ))
-MIME encoded-word in FIELD-BODY is recognized according to
-`eword-decode-ignored-field-list',
-`eword-decode-structured-field-list' and FIELD-NAME.
+;; unstructured fields (default)
+(mime-set-field-decoder
+ t
+ 'plain #'eword-decode-unstructured-field-body
+ 'wide #'eword-decode-unstructured-field-body
+ 'summary #'eword-decode-and-unfold-unstructured-field-body
+ 'nov #'eword-decode-unfolded-unstructured-field-body)
+
+;;;###autoload
+(defun ew-mime-update-field-decoder-cache (field mode)
+ (let ((fun (cond
+ ((eq mode 'plain)
+ (lexical-let ((field-name (symbol-name field)))
+ (lambda (field-body &optional start-column max-column must-unfold)
+ (setq field-body (ew-lf-to-crlf field-body))
+ (let ((res (ew-crlf-to-lf
+ (ew-decode-field field-name field-body))))
+ (add-text-properties
+ 0 (length res)
+ (list 'original-field-name field-name
+ 'original-field-body field-body)
+ res)
+ res))))
+ ((eq mode 'wide)
+ (lexical-let ((field-name (symbol-name field)))
+ (lambda (field-body &optional start-column max-column must-unfold)
+ (setq field-body (ew-lf-to-crlf field-body))
+ (let ((res (ew-crlf-to-lf
+ (ew-crlf-refold
+ (ew-decode-field field-name field-body)
+ (length field-name)
+ (or max-column fill-column)))))
+ (add-text-properties
+ 0 (length res)
+ (list 'original-field-name field-name
+ 'original-field-body field-body)
+ res)
+ res))))
+ ((eq mode 'summary)
+ (lexical-let ((field-name (symbol-name field)))
+ (lambda (field-body &optional start-column max-column must-unfold)
+ (setq field-body (ew-lf-to-crlf field-body))
+ (let ((res (ew-crlf-to-lf
+ (ew-crlf-unfold
+ (ew-decode-field field-name field-body)))))
+ (add-text-properties
+ 0 (length res)
+ (list 'original-field-name field-name
+ 'original-field-body field-body)
+ res)
+ res))))
+ ((eq mode 'nov)
+ (lexical-let ((field-name (symbol-name field)))
+ (lambda (field-body &optional start-column max-column must-unfold)
+ (setq field-body (ew-lf-to-crlf field-body))
+ (require 'ew-var)
+ (let ((ew-ignore-76bytes-limit t))
+ (let ((res (ew-crlf-to-lf
+ (ew-crlf-unfold
+ (ew-decode-field field-name field-body)))))
+ (add-text-properties
+ 0 (length res)
+ (list 'original-field-name field-name
+ 'original-field-body field-body)
+ res)
+ res)))))
+ (t
+ nil))))
+ (mime-update-field-decoder-cache field mode fun)))
+
+;;;###autoload
+(defun mime-decode-field-body (field-body field-name
+ &optional mode max-column)
+ "Decode FIELD-BODY as FIELD-NAME in MODE, and return the result.
+Optional argument MODE must be `plain', `wide', `summary' or `nov'.
+Default mode is `summary'.
+
+If MODE is `wide' and MAX-COLUMN is non-nil, the result is folded with
+MAX-COLUMN.
Non MIME encoded-word part in FILED-BODY is decoded with
`default-mime-charset'."
+ (unless mode (setq mode 'summary))
(if (symbolp field-name) (setq field-name (symbol-name field-name)))
(let ((decoded
- (if unfolded
+ (if (eq mode 'nov)
(let ((ew-ignore-76bytes-limit t))
(ew-decode-field
field-name (ew-lf-crlf-to-crlf field-body)))
(ew-decode-field
field-name (ew-lf-crlf-to-crlf field-body)))))
- (if max-column
+ (if (and (eq mode 'wide) max-column)
(setq decoded (ew-crlf-refold
decoded
(1+ (string-width field-name))
- (if (eq max-column t) fill-column max-column)))
- (setq decoded (ew-crlf-unfold decoded)))
+ max-column))
+ (if (not (eq mode 'plain))
+ (setq decoded (ew-crlf-unfold decoded))))
(setq decoded (ew-crlf-to-lf decoded))
(add-text-properties 0 (length decoded)
(list 'original-field-name field-name
decoded)
decoded))
-(defun eword-decode-header (&optional code-conversion separator)
+;;;###autoload
+(defun mime-decode-header-in-region (start end
+ &optional code-conversion)
+ "Decode MIME encoded-words in region between START and END.
+If CODE-CONVERSION is nil, it decodes only encoded-words. If it is
+mime-charset, it decodes non-ASCII bit patterns as the mime-charset.
+Otherwise it decodes non-ASCII bit patterns as the
+default-mime-charset."
+ (interactive "*r")
+ (save-excursion
+ (save-restriction
+ (narrow-to-region start end)
+ (let ((default-charset
+ (if code-conversion
+ (if (mime-charset-to-coding-system code-conversion)
+ code-conversion
+ default-mime-charset))))
+ (if default-charset
+ (let ((mode-obj (mime-find-field-presentation-method 'wide))
+ beg p end field-name-sym len field-decoder
+ field-name field-body)
+ (goto-char (point-min))
+ (while (re-search-forward std11-field-head-regexp nil t)
+ (setq beg (match-beginning 0)
+ p (match-end 0)
+ field-name (buffer-substring beg (1- p))
+ len (string-width field-name)
+ field-name-sym (intern (capitalize field-name))
+ field-decoder (inline
+ (mime-find-field-decoder-internal
+ field-name-sm mode-obj)))
+ (when field-decoder
+ (setq end (std11-field-end)
+ field-body (buffer-substring p end))
+ (let ((default-mime-charset default-charset))
+ (delete-region p end)
+ (insert (funcall field-decoder field-body (1+ len)))
+ ))
+ (add-text-properties beg (min (1+ (point)) (point-max))
+ (list 'original-field-name field-name
+ 'original-field-body field-body))
+ ))
+ (eword-decode-region (point-min) (point-max) t)
+ )))))
+
+;;;###autoload
+(defun mime-decode-header-in-buffer (&optional code-conversion separator)
"Decode MIME encoded-words in header fields.
If CODE-CONVERSION is nil, it decodes only encoded-words. If it is
mime-charset, it decodes non-ASCII bit patterns as the mime-charset.
default-mime-charset.
If SEPARATOR is not nil, it is used as header separator."
(interactive "*")
- (rotate-memo args-eword-decode-header (list code-conversion))
- (unless code-conversion
- (message "eword-decode-header is called without code-conversion")
- (sit-for 2))
- (if (and code-conversion
- (not (mime-charset-to-coding-system code-conversion)))
- (setq code-conversion default-mime-charset))
- (save-excursion
- (save-restriction
- (std11-narrow-to-header separator)
- (rotate-memo args-h-eword-decode-header (buffer-substring (point-min) (point-max)))
- (if code-conversion
- (let (beg p end field-name field-body decoded)
- (goto-char (point-min))
- (while (re-search-forward std11-field-head-regexp nil t)
- (setq beg (match-beginning 0)
- p (match-end 0)
- field-name (buffer-substring beg (1- p))
- end (std11-field-end)
- field-body (ew-lf-crlf-to-crlf
- (buffer-substring p end))
- decoded (ew-decode-field
- field-name field-body))
- (unless (equal field-body decoded)
- (setq decoded (ew-crlf-refold
- decoded
- (1+ (string-width field-name))
- fill-column)))
- (delete-region p end)
- (insert (ew-crlf-to-lf decoded))
- (add-text-properties beg (min (1+ (point)) (point-max))
- (list 'original-field-name field-name
- 'original-field-body field-body))
- ))
- (eword-decode-region (point-min) (point-max) t nil nil)
- ))))
-
-(defun eword-decode-unfold ()
- (goto-char (point-min))
- (let (field beg end)
- (while (re-search-forward std11-field-head-regexp nil t)
- (setq beg (match-beginning 0)
- end (std11-field-end))
- (setq field (buffer-substring beg end))
- (if (string-match eword-encoded-word-regexp field)
- (save-restriction
- (narrow-to-region (goto-char beg) end)
- (while (re-search-forward "\n\\([ \t]\\)" nil t)
- (replace-match (match-string 1))
- )
- (goto-char (point-max))
- ))
- )))
+ (mime-decode-header-in-region
+ (point-min)
+ (save-excursion
+ (goto-char (point-min))
+ (if (re-search-forward
+ (concat "^\\(" (regexp-quote (or separator "")) "\\)?$")
+ nil t)
+ (match-beginning 0)
+ (point-max)
+ ))
+ code-conversion))
+
+(define-obsolete-function-alias 'eword-decode-header
+ 'mime-decode-header-in-buffer)
;;; @ encoded-word decoder
(substring string p)))
nil)))
+
(defun eword-analyze-spaces (string &optional must-unfold)
(std11-analyze-spaces string))
(let ((phrase (nth 1 phrase-route-addr))
(route (nth 2 phrase-route-addr))
dest)
- (if (eq (car (car phrase)) 'spaces)
- (setq phrase (cdr phrase))
- )
+ ;; (if (eq (car (car phrase)) 'spaces)
+ ;; (setq phrase (cdr phrase))
+ ;; )
(setq dest (eword-encode-phrase-to-rword-list phrase))
(if dest
(setq dest (append dest '((" " nil nil))))
'((" " nil nil)
("(" nil nil))
(eword-encode-split-string comment 'comment)
- '((")" nil nil))
+ (list '(")" nil nil))
)))
dest))
(if dest
(while (setq addresses (cdr addresses))
(setq dest
- (append dest
- '(("," nil nil))
- '((" " nil nil))
- (eword-encode-mailbox-to-rword-list (car addresses))
- ))
+ (nconc dest
+ (list '("," nil nil))
+ ;; (list '(" " nil nil))
+ (eword-encode-mailbox-to-rword-list (car addresses))
+ ))
))
dest))
(defsubst eword-encode-msg-id-to-rword-list (msg-id)
- (cons '("<" nil nil)
- (append (eword-encode-addr-seq-to-rword-list (cdr msg-id))
- '((">" nil nil)))))
+ (cons '(" " nil nil)
+ (cons '("<" nil nil)
+ (nconc (eword-encode-addr-seq-to-rword-list (cdr msg-id))
+ '((">" nil nil))))))
(defsubst eword-encode-in-reply-to-to-rword-list (in-reply-to)
(let (dest)
It is available from
- ftp://ftp.jaist.ac.jp/pub/GNU/elisp/flim/
+ ftp://ftp.jaist.ac.jp/pub/GNU/elisp/flim/flim-API
--[[message/external-body;
access-type=anon-ftp;
site="ftp.jaist.ac.jp";
- directory="/pub/GNU/elisp/flim";
+ directory="/pub/GNU/elisp/flim/flim-API";
name="flim-VERSION.tar.gz";
mode=image]]
Content-Type: application/octet-stream;
)
-(define-ccl-program mel-ccl-decode-b
- `(1
- (loop
- (read r0 r1 r2 r3)
- (r4 = r0 ,mel-ccl-decode-b-0-table)
- (r5 = r1 ,mel-ccl-decode-b-1-table)
- (r4 |= r5)
- (r5 = r2 ,mel-ccl-decode-b-2-table)
- (r4 |= r5)
- (r5 = r3 ,mel-ccl-decode-b-3-table)
- (r4 |= r5)
- (if (r4 & ,(lognot (1- (lsh 1 24))))
- ((loop
- (if (r4 & ,(lsh 1 24))
- ((r0 = r1) (r1 = r2) (r2 = r3) (read r3)
- (r4 >>= 1) (r4 &= ,(logior (lsh 7 24)))
- (r5 = r3 ,mel-ccl-decode-b-3-table)
- (r4 |= r5)
- (repeat))
- (break)))
- (loop
- (if (r4 & ,(lsh 1 25))
- ((r1 = r2) (r2 = r3) (read r3)
- (r4 >>= 1) (r4 &= ,(logior (lsh 7 24)))
- (r5 = r3 ,mel-ccl-decode-b-3-table)
- (r4 |= r5)
- (repeat))
- (break)))
- (loop
- (if (r2 != ?=)
- (if (r4 & ,(lsh 1 26))
- ((r2 = r3) (read r3)
- (r4 >>= 1) (r4 &= ,(logior (lsh 7 24)))
- (r5 = r3 ,mel-ccl-decode-b-3-table)
- (r4 |= r5)
- (repeat))
- ((r6 = 0)
- (break)))
- ((r6 = 1)
- (break))))
- (loop
- (if (r3 != ?=)
- (if (r4 & ,(lsh 1 27))
- ((read r3)
- (r4 = r3 ,mel-ccl-decode-b-3-table)
- (repeat))
- (break))
- ((r6 |= 2)
- (break))))
- (r4 = r0 ,mel-ccl-decode-b-0-table)
- (r5 = r1 ,mel-ccl-decode-b-1-table)
- (r4 |= r5)
- (branch
- r6
- ;; BBBB
- ((r5 = r2 ,mel-ccl-decode-b-2-table)
+(check-broken-facility ccl-cascading-read)
+
+(if-broken ccl-cascading-read
+ (define-ccl-program mel-ccl-decode-b
+ `(1
+ (loop
+ (loop
+ (read-branch
+ r1
+ ,@(mapcar
+ (lambda (v)
+ (cond
+ ((or (eq v nil) (eq v t)) '(repeat))
+ (t `((r0 = ,(lsh v 2)) (break)))))
+ mel-ccl-256-to-64-table)))
+ (loop
+ (read-branch
+ r1
+ ,@(mapcar
+ (lambda (v)
+ (cond
+ ((or (eq v nil) (eq v t)) '(repeat))
+ ((= (lsh v -4) 0) `((write r0) (r0 = ,(lsh (logand v 15) 4)) (break)))
+ (t `((r0 |= ,(lsh v -4)) (write r0) (r0 = ,(lsh (logand v 15) 4)) (break)))))
+ mel-ccl-256-to-64-table)))
+ (loop
+ (read-branch
+ r1
+ ,@(mapcar
+ (lambda (v)
+ (cond
+ ((eq v nil) '(repeat))
+ ((eq v t) '(end))
+ ((= (lsh v -2) 0) `((write r0) (r0 = ,(lsh (logand v 3) 6)) (break)))
+ (t `((r0 |= ,(lsh v -2)) (write r0) (r0 = ,(lsh (logand v 3) 6)) (break)))))
+ mel-ccl-256-to-64-table)))
+ (loop
+ (read-branch
+ r1
+ ,@(mapcar
+ (lambda (v)
+ (cond
+ ((eq v nil) '(repeat))
+ ((eq v t) '(end))
+ (t `((r0 |= ,v) (write r0) (break)))))
+ mel-ccl-256-to-64-table)))
+ (repeat))))
+ (define-ccl-program mel-ccl-decode-b
+ `(1
+ (loop
+ (read r0 r1 r2 r3)
+ (r4 = r0 ,mel-ccl-decode-b-0-table)
+ (r5 = r1 ,mel-ccl-decode-b-1-table)
+ (r4 |= r5)
+ (r5 = r2 ,mel-ccl-decode-b-2-table)
+ (r4 |= r5)
+ (r5 = r3 ,mel-ccl-decode-b-3-table)
+ (r4 |= r5)
+ (if (r4 & ,(lognot (1- (lsh 1 24))))
+ ((loop
+ (if (r4 & ,(lsh 1 24))
+ ((r0 = r1) (r1 = r2) (r2 = r3) (read r3)
+ (r4 >>= 1) (r4 &= ,(logior (lsh 7 24)))
+ (r5 = r3 ,mel-ccl-decode-b-3-table)
+ (r4 |= r5)
+ (repeat))
+ (break)))
+ (loop
+ (if (r4 & ,(lsh 1 25))
+ ((r1 = r2) (r2 = r3) (read r3)
+ (r4 >>= 1) (r4 &= ,(logior (lsh 7 24)))
+ (r5 = r3 ,mel-ccl-decode-b-3-table)
+ (r4 |= r5)
+ (repeat))
+ (break)))
+ (loop
+ (if (r2 != ?=)
+ (if (r4 & ,(lsh 1 26))
+ ((r2 = r3) (read r3)
+ (r4 >>= 1) (r4 &= ,(logior (lsh 7 24)))
+ (r5 = r3 ,mel-ccl-decode-b-3-table)
+ (r4 |= r5)
+ (repeat))
+ ((r6 = 0)
+ (break)))
+ ((r6 = 1)
+ (break))))
+ (loop
+ (if (r3 != ?=)
+ (if (r4 & ,(lsh 1 27))
+ ((read r3)
+ (r4 = r3 ,mel-ccl-decode-b-3-table)
+ (repeat))
+ (break))
+ ((r6 |= 2)
+ (break))))
+ (r4 = r0 ,mel-ccl-decode-b-0-table)
+ (r5 = r1 ,mel-ccl-decode-b-1-table)
(r4 |= r5)
- (r5 = r3 ,mel-ccl-decode-b-3-table)
- (r4 |= r5)
- (r4 >8= 0)
- (write r7)
- (r4 >8= 0)
- (write r7)
- (write-repeat r4))
- ;; error: BB=B
- ((write (r4 & 255))
- (end))
- ;; BBB=
- ((r5 = r2 ,mel-ccl-decode-b-2-table)
- (r4 |= r5)
- (r4 >8= 0)
- (write r7)
- (write (r4 & 255))
- (end) ; Excessive (end) is workaround for XEmacs 21.0.
+ (branch
+ r6
+ ;; BBBB
+ ((r5 = r2 ,mel-ccl-decode-b-2-table)
+ (r4 |= r5)
+ (r5 = r3 ,mel-ccl-decode-b-3-table)
+ (r4 |= r5)
+ (r4 >8= 0)
+ (write r7)
+ (r4 >8= 0)
+ (write r7)
+ (write-repeat r4))
+ ;; error: BB=B
+ ((write (r4 & 255))
+ (end))
+ ;; BBB=
+ ((r5 = r2 ,mel-ccl-decode-b-2-table)
+ (r4 |= r5)
+ (r4 >8= 0)
+ (write r7)
+ (write (r4 & 255))
+ (end) ; Excessive (end) is workaround for XEmacs 21.0.
; Without this, "AAA=" is converted to "^@^@^@".
- (end))
- ;; BB==
- ((write (r4 & 255))
- (end))))
- ((r4 >8= 0)
- (write r7)
- (r4 >8= 0)
- (write r7)
- (write-repeat r4))))))
+ (end))
+ ;; BB==
+ ((write (r4 & 255))
+ (end))))
+ ((r4 >8= 0)
+ (write r7)
+ (r4 >8= 0)
+ (write r7)
+ (write-repeat r4))))))
+ )
(eval-when-compile
;; Generated CCL program works not properly on 20.2 because CCL_EOF_BLOCK
;; is not executed.
-(defun mel-ccl-encode-base64-generic (&optional quantums-per-line output-crlf terminate-with-newline)
+(defun mel-ccl-encode-base64-generic
+ (&optional quantums-per-line output-crlf terminate-with-newline)
`(2
((r3 = 0)
(loop
(write ,(if output-crlf "=\r\n" "=\n"))
(write r0)
(write "=0D")
- (r0 = r1)
+ (r0 = (r1 + 0)) ; "+ 0" is workaround for mule 2.3@19.34.
(break))
;; r0:r3=ENC CR r1:noLF
((r6 = 6)
(write r0 ,mel-ccl-high-table)
(write r0 ,mel-ccl-low-table)
(write "=0D")
- (r0 = r1)
+ (r0 = (r1 + 0))
(break))))
;; r0:r3={RAW,ENC} r1:noCR
;; r0:r3={RAW,ENC} r1:noCRLF
(r5 = 0)
(write ,(if output-crlf "=\r\n" "=\n"))
(write r0)
- (r0 = r1)
+ (r0 = (r1 + 0))
(break))
;; r0:r3=ENC r1:noCR
;; r0:r3=ENC r1:noCRLF
(write ,(if output-crlf "=\r\n=" "=\n="))
(write r0 ,mel-ccl-high-table)
(write r0 ,mel-ccl-low-table)
- (r0 = r1)
+ (r0 = (r1 + 0))
(break)))))))
(repeat)))
;; EOF
((setq tmp (nth r0 mel-ccl-256-to-16-table))
;; '=' [\t ]* r0:[0-9A-F]
;; upper nibble of hexadecimal digit found.
- `((r1 = r0)
+ `((r1 = (r0 + 0))
(r0 = ,tmp)))
(t
;; '=' [\t ]* r0:[^\r0-9A-F]
;; invalid input ->
;; output "=" with hex digit and rescan from r2.
(write ?=)
- (r0 = r2)
+ (r0 = (r2 + 0))
(write-repeat r1)))
(t
;; r0:[^\t\r -~]
(mel-define-backend "binary" ("8bit"))
-(when (and (fboundp 'base64-encode-string)
- (subrp (symbol-function 'base64-encode-string)))
+(defvar mel-b-builtin
+ (and (fboundp 'base64-encode-string)
+ (subrp (symbol-function 'base64-encode-string))))
+
+(when mel-b-builtin
(mel-define-backend "base64")
(mel-define-method-function (mime-encode-string string (nil "base64"))
'base64-encode-string)
(require 'mcharset)
(eval-and-compile
- (defconst mime-library-product ["FLAM-DOODLE" (1 11 2) "\e$B??<k\e(B 2.5R4.5/10.0"]
+ (defconst mime-library-product ["FLAM-DOODLE" (1 12 0) "\e$B[XHi\e(B 2.0YR3.5/4.0"]
"Product name, version number and code name of MIME-library package.")
)
;;; @ required functions
;;;
-(defsubst eliminate-top-spaces (string)
- "Eliminate top sequence of space or tab in STRING."
- (if (string-match "^[ \t]+" string)
- (substring string (match-end 0))
- string))
-
(defsubst regexp-* (regexp)
(concat regexp "*"))
))))
(put 'mm-define-method 'lisp-indent-function 'defun)
-(def-edebug-spec mm-define-method
- (&define name ((arg symbolp)
- [&rest arg]
- [&optional ["&optional" arg &rest arg]]
- &optional ["&rest" arg]
- )
- def-body))
+
+(eval-when-compile
+ (defmacro eval-module-depended-macro (module definition)
+ (condition-case nil
+ (progn
+ (require (eval module))
+ definition)
+ (error `(eval-after-load ,(symbol-name (eval module)) ',definition))
+ ))
+ )
+
+(eval-module-depended-macro
+ 'edebug
+ (def-edebug-spec mm-define-method
+ (&define name ((arg symbolp)
+ [&rest arg]
+ [&optional ["&optional" arg &rest arg]]
+ &optional ["&rest" arg]
+ )
+ def-body))
+ )
(defsubst mm-arglist-to-arguments (arglist)
(let (dest)
(setq field (std11-parse-address
(eword-lexical-analyze field-body)))
)
- ((memq field-name eword-decode-ignored-field-list)
- (setq field field-body))
- ((memq field-name eword-decode-structured-field-list)
- (setq field (eword-decode-structured-field-body
- field-body)))
(t
- (setq field (ew-decode-field (symbol-name field-name)
- field-body))
+ (setq field (mime-decode-field-body
+ field-body field-name 'plain))
))
(mime-entity-set-parsed-header-internal
entity (put-alist field-name field header))
&optional invisible-fields
visible-fields)
(let ((the-buf (current-buffer))
+ (mode-obj (mime-find-field-presentation-method 'wide))
+ field-decoder
f-b p f-e field-name len field field-body)
(save-excursion
(set-buffer buffer)
f-e (std11-field-end))
(when (mime-visible-field-p field-name
visible-fields invisible-fields)
- (setq field (buffer-substring f-b (1- p))
- field-body (buffer-substring p f-e))
+ (setq field (intern
+ (capitalize (buffer-substring f-b (1- p))))
+ field-body (buffer-substring p f-e)
+ field-decoder (inline (mime-find-field-decoder-internal
+ field mode-obj)))
(with-current-buffer the-buf
- (setq p (point))
- (insert
- field-name
- (eword-decode-field-body field-body field nil t)
- "\n")
+ (setq p (point))
+ (insert field-name)
+ (insert (if field-decoder
+ (funcall field-decoder field-body len)
+ ;; Don't decode
+ field-body))
+ (insert "\n")
(add-text-properties p (point)
- (list 'original-field-name field
+ (list 'original-field-name field-name
'original-field-body field-body))
)))))))
--- /dev/null
+;;; smtp.el --- basic functions to send mail with SMTP server
+
+;; Copyright (C) 1995, 1996, 1998 Free Software Foundation, Inc.
+
+;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp>
+;; Simon Leinen <simon@switch.ch> (ESMTP support)
+;; Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp>
+;; Keywords: SMTP, mail
+
+;; This file is part of FLIM (Faithful Library about Internet Message).
+
+;; 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 'mail-utils) ; pick up mail-strip-quoted-names
+
+(defgroup smtp nil
+ "SMTP protocol for sending mail."
+ :group 'mail)
+
+(defcustom smtp-default-server nil
+ "*Specify default SMTP server."
+ :type '(choice (const nil) string)
+ :group 'smtp)
+
+(defcustom smtp-server (or (getenv "SMTPSERVER") smtp-default-server)
+ "*The name of the host running SMTP server."
+ :type '(choice (const nil) string)
+ :group 'smtp)
+
+(defcustom smtp-service "smtp"
+ "*SMTP service port number. \"smtp\" or 25."
+ :type '(choice (integer :tag "25" 25)
+ (string :tag "smtp" "smtp"))
+ :group 'smtp)
+
+(defcustom smtp-use-8bitmime t
+ "*If non-nil, use ESMTP 8BITMIME if available."
+ :type 'boolean
+ :group 'smtp)
+
+(defcustom smtp-local-domain nil
+ "*Local domain name without a host name.
+If the function (system-name) returns the full internet address,
+don't define this value."
+ :type '(choice (const nil) string)
+ :group 'smtp)
+
+(defcustom smtp-coding-system 'binary
+ "*Coding-system for SMTP output."
+ :type 'coding-system
+ :group 'smtp)
+
+(defvar smtp-debug-info nil)
+(defvar smtp-read-point nil)
+
+(defun smtp-make-fqdn ()
+ "Return user's fully qualified domain name."
+ (let ((system-name (system-name)))
+ (cond
+ (smtp-local-domain
+ (concat system-name "." smtp-local-domain))
+ ((string-match "[^.]\\.[^.]" system-name)
+ system-name)
+ (t
+ (error "Cannot generate valid FQDN. Set `smtp-local-domain' correctly.")))))
+
+(defun smtp-via-smtp (sender recipients smtp-text-buffer)
+ (let ((coding-system-for-read smtp-coding-system)
+ (coding-system-for-write smtp-coding-system)
+ process response extensions)
+ (save-excursion
+ (set-buffer
+ (get-buffer-create
+ (format "*trace of SMTP session to %s*" smtp-server)))
+ (erase-buffer)
+ (make-local-variable 'smtp-read-point)
+ (setq smtp-read-point (point-min))
+
+ (unwind-protect
+ (catch 'done
+ (setq process (open-network-stream "SMTP"
+ (current-buffer)
+ smtp-server smtp-service))
+ (or process (throw 'done nil))
+
+ (set-process-filter process 'smtp-process-filter)
+
+ ;; Greeting
+ (setq response (smtp-read-response process))
+ (if (or (null (car response))
+ (not (integerp (car response)))
+ (>= (car response) 400))
+ (throw 'done (car (cdr response))))
+
+ ;; EHLO
+ (smtp-send-command process
+ (format "EHLO %s" (smtp-make-fqdn)))
+ (setq response (smtp-read-response process))
+ (if (or (null (car response))
+ (not (integerp (car response)))
+ (>= (car response) 400))
+ (progn
+ ;; HELO
+ (smtp-send-command process
+ (format "HELO %s" (smtp-make-fqdn)))
+ (setq response (smtp-read-response process))
+ (if (or (null (car response))
+ (not (integerp (car response)))
+ (>= (car response) 400))
+ (throw 'done (car (cdr response)))))
+ (let ((extension-lines (cdr (cdr response))))
+ (while extension-lines
+ (push (intern (downcase (substring (car extension-lines) 4)))
+ extensions)
+ (setq extension-lines (cdr extension-lines)))))
+
+ ;; ONEX --- One message transaction only (sendmail extension?)
+ (if (or (memq 'onex extensions)
+ (memq 'xone extensions))
+ (progn
+ (smtp-send-command process "ONEX")
+ (setq response (smtp-read-response process))
+ (if (or (null (car response))
+ (not (integerp (car response)))
+ (>= (car response) 400))
+ (throw 'done (car (cdr response))))))
+
+ ;; VERB --- Verbose (sendmail extension?)
+ (if (and smtp-debug-info
+ (or (memq 'verb extensions)
+ (memq 'xvrb extensions)))
+ (progn
+ (smtp-send-command process "VERB")
+ (setq response (smtp-read-response process))
+ (if (or (null (car response))
+ (not (integerp (car response)))
+ (>= (car response) 400))
+ (throw 'done (car (cdr response))))))
+
+ ;; XUSR --- Initial (user) submission (sendmail extension?)
+ (if (memq 'xusr extensions)
+ (progn
+ (smtp-send-command process "XUSR")
+ (setq response (smtp-read-response process))
+ (if (or (null (car response))
+ (not (integerp (car response)))
+ (>= (car response) 400))
+ (throw 'done (car (cdr response))))))
+
+ ;; MAIL FROM:<sender>
+ (smtp-send-command
+ process
+ (format "MAIL FROM:<%s>%s%s"
+ sender
+ ;; SIZE --- Message Size Declaration (RFC1870)
+ (if (memq 'size extensions)
+ (format " SIZE=%d"
+ (save-excursion
+ (set-buffer smtp-text-buffer)
+ (+ (- (point-max) (point-min))
+ ;; Add one byte for each change-of-line
+ ;; because or CR-LF representation:
+ (count-lines (point-min) (point-max))
+ ;; For some reason, an empty line is
+ ;; added to the message. Maybe this
+ ;; is a bug, but it can't hurt to add
+ ;; those two bytes anyway:
+ 2)))
+ "")
+ ;; 8BITMIME --- 8bit-MIMEtransport (RFC1652)
+ (if (and (memq '8bitmime extensions)
+ smtp-use-8bitmime)
+ " BODY=8BITMIME"
+ "")))
+ (setq response (smtp-read-response process))
+ (if (or (null (car response))
+ (not (integerp (car response)))
+ (>= (car response) 400))
+ (throw 'done (car (cdr response))))
+
+ ;; RCPT TO:<recipient>
+ (while recipients
+ (smtp-send-command process
+ (format "RCPT TO:<%s>" (car recipients)))
+ (setq recipients (cdr recipients))
+ (setq response (smtp-read-response process))
+ (if (or (null (car response))
+ (not (integerp (car response)))
+ (>= (car response) 400))
+ (throw 'done (car (cdr response)))))
+
+ ;; DATA
+ (smtp-send-command process "DATA")
+ (setq response (smtp-read-response process))
+ (if (or (null (car response))
+ (not (integerp (car response)))
+ (>= (car response) 400))
+ (throw 'done (car (cdr response))))
+
+ ;; Mail contents
+ (smtp-send-data process smtp-text-buffer)
+
+ ;; DATA end "."
+ (smtp-send-command process ".")
+ (setq response (smtp-read-response process))
+ (if (or (null (car response))
+ (not (integerp (car response)))
+ (>= (car response) 400))
+ (throw 'done (car (cdr response))))
+
+ t)
+
+ (if (and process
+ (eq (process-status process) 'open))
+ (progn
+ ;; QUIT
+ (smtp-send-command process "QUIT")
+ (smtp-read-response process)
+ (delete-process process)))))))
+
+(defun smtp-process-filter (process output)
+ (save-excursion
+ (set-buffer (process-buffer process))
+ (goto-char (point-max))
+ (insert output)))
+
+(defun smtp-read-response (process)
+ (let ((case-fold-search nil)
+ (response-strings nil)
+ (response-continue t)
+ (return-value '(nil ()))
+ match-end)
+
+ (while response-continue
+ (goto-char smtp-read-point)
+ (while (not (search-forward "\r\n" nil t))
+ (accept-process-output process)
+ (goto-char smtp-read-point))
+
+ (setq match-end (point))
+ (setq response-strings
+ (cons (buffer-substring smtp-read-point (- match-end 2))
+ response-strings))
+
+ (goto-char smtp-read-point)
+ (if (looking-at "[0-9]+ ")
+ (let ((begin (match-beginning 0))
+ (end (match-end 0)))
+ (if smtp-debug-info
+ (message "%s" (car response-strings)))
+
+ (setq smtp-read-point match-end)
+
+ ;; ignore lines that start with "0"
+ (if (looking-at "0[0-9]+ ")
+ nil
+ (setq response-continue nil)
+ (setq return-value
+ (cons (string-to-int
+ (buffer-substring begin end))
+ (nreverse response-strings)))))
+
+ (if (looking-at "[0-9]+-")
+ (progn (if smtp-debug-info
+ (message "%s" (car response-strings)))
+ (setq smtp-read-point match-end)
+ (setq response-continue t))
+ (progn
+ (setq smtp-read-point match-end)
+ (setq response-continue nil)
+ (setq return-value
+ (cons nil (nreverse response-strings)))))))
+ (setq smtp-read-point match-end)
+ return-value))
+
+(defun smtp-send-command (process command)
+ (goto-char (point-max))
+ (insert command "\r\n")
+ (setq smtp-read-point (point))
+ (process-send-string process command)
+ (process-send-string process "\r\n"))
+
+(defun smtp-send-data-1 (process data)
+ (goto-char (point-max))
+ (if smtp-debug-info
+ (insert data "\r\n"))
+ (setq smtp-read-point (point))
+ ;; Escape "." at start of a line.
+ (if (eq (string-to-char data) ?.)
+ (process-send-string process "."))
+ (process-send-string process data)
+ (process-send-string process "\r\n"))
+
+(defun smtp-send-data (process buffer)
+ (let ((data-continue t)
+ (sending-data nil)
+ this-line
+ this-line-end)
+
+ (save-excursion
+ (set-buffer buffer)
+ (goto-char (point-min)))
+
+ (while data-continue
+ (save-excursion
+ (set-buffer buffer)
+ (beginning-of-line)
+ (setq this-line (point))
+ (end-of-line)
+ (setq this-line-end (point))
+ (setq sending-data nil)
+ (setq sending-data (buffer-substring this-line this-line-end))
+ (if (or (/= (forward-line 1) 0) (eobp))
+ (setq data-continue nil)))
+
+ (smtp-send-data-1 process sending-data))))
+
+(defun smtp-deduce-address-list (smtp-text-buffer header-start header-end)
+ "Get address list suitable for smtp RCPT TO:<address>."
+ (let ((case-fold-search t)
+ (simple-address-list "")
+ this-line
+ this-line-end
+ addr-regexp
+ (smtp-address-buffer (generate-new-buffer " *smtp-mail*")))
+ (unwind-protect
+ (save-excursion
+ ;;
+ (set-buffer smtp-address-buffer)
+ (erase-buffer)
+ (insert (save-excursion
+ (set-buffer smtp-text-buffer)
+ (buffer-substring-no-properties header-start header-end)))
+ (goto-char (point-min))
+ ;; RESENT-* fields should stop processing of regular fields.
+ (save-excursion
+ (if (re-search-forward "^RESENT-TO:" header-end t)
+ (setq addr-regexp
+ "^\\(RESENT-TO:\\|RESENT-CC:\\|RESENT-BCC:\\)")
+ (setq addr-regexp "^\\(TO:\\|CC:\\|BCC:\\)")))
+
+ (while (re-search-forward addr-regexp header-end t)
+ (replace-match "")
+ (setq this-line (match-beginning 0))
+ (forward-line 1)
+ ;; get any continuation lines.
+ (while (and (looking-at "^[ \t]+") (< (point) header-end))
+ (forward-line 1))
+ (setq this-line-end (point-marker))
+ (setq simple-address-list
+ (concat simple-address-list " "
+ (mail-strip-quoted-names
+ (buffer-substring this-line this-line-end)))))
+ (erase-buffer)
+ (insert-string " ")
+ (insert-string simple-address-list)
+ (insert-string "\n")
+ ;; newline --> blank
+ (subst-char-in-region (point-min) (point-max) 10 ? t)
+ ;; comma --> blank
+ (subst-char-in-region (point-min) (point-max) ?, ? t)
+ ;; tab --> blank
+ (subst-char-in-region (point-min) (point-max) 9 ? t)
+
+ (goto-char (point-min))
+ ;; tidyness in case hook is not robust when it looks at this
+ (while (re-search-forward "[ \t]+" header-end t) (replace-match " "))
+
+ (goto-char (point-min))
+ (let (recipient-address-list)
+ (while (re-search-forward " \\([^ ]+\\) " (point-max) t)
+ (backward-char 1)
+ (setq recipient-address-list
+ (cons (buffer-substring (match-beginning 1) (match-end 1))
+ recipient-address-list)))
+ recipient-address-list))
+ (kill-buffer smtp-address-buffer))))
+
+(provide 'smtp)
+
+;;; smtp.el ends here
--- /dev/null
+;;; smtpmail.el --- SMTP interface for mail-mode
+
+;; Copyright (C) 1995, 1996, 1998 Free Software Foundation, Inc.
+
+;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp>
+;; Keywords: mail
+
+;; This file is part of FLIM (Faithful Library about Internet Message).
+
+;; 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:
+
+;; Send Mail to smtp host from smtpmail temp buffer.
+
+;; Please add these lines in your .emacs(_emacs).
+;;
+;;(setq send-mail-function 'smtpmail-send-it)
+;;(setq smtp-default-server "YOUR SMTP HOST")
+;;(setq smtp-service "smtp")
+;;(setq smtp-local-domain "YOUR DOMAIN NAME")
+;;(setq smtp-debug-info t)
+;;(autoload 'smtpmail-send-it "smtpmail")
+;;(setq user-full-name "YOUR NAME HERE")
+
+;; To queue mail, set smtpmail-queue-mail to t and use
+;; smtpmail-send-queued-mail to send.
+
+
+;;; Code:
+
+(require 'smtp)
+(require 'sendmail)
+(require 'time-stamp)
+
+;;;
+
+(defcustom smtpmail-queue-mail nil
+ "*Specify if mail is queued (if t) or sent immediately (if nil).
+If queued, it is stored in the directory `smtpmail-queue-dir'
+and sent with `smtpmail-send-queued-mail'."
+ :type 'boolean
+ :group 'smtp)
+
+(defcustom smtpmail-queue-dir "~/Mail/queued-mail/"
+ "*Directory where `smtpmail.el' stores queued mail."
+ :type 'directory
+ :group 'smtp)
+
+(defvar smtpmail-queue-index-file "index"
+ "File name of queued mail index,
+This is relative to `smtpmail-queue-dir'.")
+
+(defvar smtpmail-queue-index (concat smtpmail-queue-dir
+ smtpmail-queue-index-file))
+
+(defvar smtpmail-recipient-address-list nil)
+
+
+;;;
+;;;
+;;;
+
+;;;###autoload
+(defun smtpmail-send-it ()
+ (require 'mail-utils)
+ (let ((errbuf (if mail-interactive
+ (generate-new-buffer " smtpmail errors")
+ 0))
+ (tembuf (generate-new-buffer " smtpmail temp"))
+ (case-fold-search nil)
+ resend-to-addresses
+ delimline
+ (mailbuf (current-buffer)))
+ (unwind-protect
+ (save-excursion
+ (set-buffer tembuf)
+ (erase-buffer)
+ (insert-buffer-substring mailbuf)
+ (goto-char (point-max))
+ ;; require one newline at the end.
+ (or (= (preceding-char) ?\n)
+ (insert ?\n))
+ ;; Change header-delimiter to be what sendmail expects.
+ (goto-char (point-min))
+ (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "\n"))
+ (replace-match "\n")
+ (backward-char 1)
+ (setq delimline (point-marker))
+;; (sendmail-synch-aliases)
+ (if mail-aliases
+ (expand-mail-aliases (point-min) delimline))
+ (goto-char (point-min))
+ ;; ignore any blank lines in the header
+ (while (and (re-search-forward "\n\n\n*" delimline t)
+ (< (point) delimline))
+ (replace-match "\n"))
+ (let ((case-fold-search t))
+ (goto-char (point-min))
+ (goto-char (point-min))
+ (while (re-search-forward "^Resent-to:" delimline t)
+ (setq resend-to-addresses
+ (save-restriction
+ (narrow-to-region (point)
+ (save-excursion
+ (end-of-line)
+ (point)))
+ (append (mail-parse-comma-list)
+ resend-to-addresses))))
+;;; Apparently this causes a duplicate Sender.
+;;; ;; If the From is different than current user, insert Sender.
+;;; (goto-char (point-min))
+;;; (and (re-search-forward "^From:" delimline t)
+;;; (progn
+;;; (require 'mail-utils)
+;;; (not (string-equal
+;;; (mail-strip-quoted-names
+;;; (save-restriction
+;;; (narrow-to-region (point-min) delimline)
+;;; (mail-fetch-field "From")))
+;;; (user-login-name))))
+;;; (progn
+;;; (forward-line 1)
+;;; (insert "Sender: " (user-login-name) "\n")))
+ ;; Don't send out a blank subject line
+ (goto-char (point-min))
+ (if (re-search-forward "^Subject:[ \t]*\n" delimline t)
+ (replace-match ""))
+ ;; Put the "From:" field in unless for some odd reason
+ ;; they put one in themselves.
+ (goto-char (point-min))
+ (if (not (re-search-forward "^From:" delimline t))
+ (let* ((login user-mail-address)
+ (fullname (user-full-name)))
+ (cond ((eq mail-from-style 'angles)
+ (insert "From: " fullname)
+ (let ((fullname-start (+ (point-min) 6))
+ (fullname-end (point-marker)))
+ (goto-char fullname-start)
+ ;; Look for a character that cannot appear unquoted
+ ;; according to RFC 822.
+ (if (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]"
+ fullname-end 1)
+ (progn
+ ;; Quote fullname, escaping specials.
+ (goto-char fullname-start)
+ (insert "\"")
+ (while (re-search-forward "[\"\\]"
+ fullname-end 1)
+ (replace-match "\\\\\\&" t))
+ (insert "\""))))
+ (insert " <" login ">\n"))
+ ((eq mail-from-style 'parens)
+ (insert "From: " login " (")
+ (let ((fullname-start (point)))
+ (insert fullname)
+ (let ((fullname-end (point-marker)))
+ (goto-char fullname-start)
+ ;; RFC 822 says \ and nonmatching parentheses
+ ;; must be escaped in comments.
+ ;; Escape every instance of ()\ ...
+ (while (re-search-forward "[()\\]" fullname-end 1)
+ (replace-match "\\\\\\&" t))
+ ;; ... then undo escaping of matching parentheses,
+ ;; including matching nested parentheses.
+ (goto-char fullname-start)
+ (while (re-search-forward
+ "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)"
+ fullname-end 1)
+ (replace-match "\\1(\\3)" t)
+ (goto-char fullname-start))))
+ (insert ")\n"))
+ ((null mail-from-style)
+ (insert "From: " login "\n")))))
+ ;; Insert an extra newline if we need it to work around
+ ;; Sun's bug that swallows newlines.
+ (goto-char (1+ delimline))
+ (if (eval mail-mailer-swallows-blank-line)
+ (newline))
+ ;; Find and handle any FCC fields.
+ (goto-char (point-min))
+ (if (re-search-forward "^FCC:" delimline t)
+ (mail-do-fcc delimline))
+ (if mail-interactive
+ (save-excursion
+ (set-buffer errbuf)
+ (erase-buffer))))
+ ;;
+ ;;
+ ;;
+ (setq smtpmail-recipient-address-list
+ (or resend-to-addresses
+ (smtp-deduce-address-list tembuf (point-min) delimline)))
+
+ (smtpmail-do-bcc delimline)
+ ; Send or queue
+ (if (not smtpmail-queue-mail)
+ (if smtpmail-recipient-address-list
+ (if (not (smtp-via-smtp user-mail-address
+ smtpmail-recipient-address-list
+ tembuf))
+ (error "Sending failed; SMTP protocol error"))
+ (error "Sending failed; no recipients"))
+ (let* ((file-data (concat
+ smtpmail-queue-dir
+ (time-stamp-strftime
+ "%02y%02m%02d-%02H%02M%02S")))
+ (file-elisp (concat file-data ".el"))
+ (buffer-data (create-file-buffer file-data))
+ (buffer-elisp (create-file-buffer file-elisp))
+ (buffer-scratch "*queue-mail*"))
+ (save-excursion
+ (set-buffer buffer-data)
+ (erase-buffer)
+ (insert-buffer tembuf)
+ (write-file file-data)
+ (set-buffer buffer-elisp)
+ (erase-buffer)
+ (insert (concat
+ "(setq smtpmail-recipient-address-list '"
+ (prin1-to-string smtpmail-recipient-address-list)
+ ")\n"))
+ (write-file file-elisp)
+ (set-buffer (generate-new-buffer buffer-scratch))
+ (insert (concat file-data "\n"))
+ (append-to-file (point-min)
+ (point-max)
+ smtpmail-queue-index)
+ )
+ (kill-buffer buffer-scratch)
+ (kill-buffer buffer-data)
+ (kill-buffer buffer-elisp))))
+ (kill-buffer tembuf)
+ (if (bufferp errbuf)
+ (kill-buffer errbuf)))))
+
+(defun smtpmail-send-queued-mail ()
+ "Send mail that was queued as a result of setting `smtpmail-queue-mail'."
+ (interactive)
+ ;;; Get index, get first mail, send it, get second mail, etc...
+ (let ((buffer-index (find-file-noselect smtpmail-queue-index))
+ (file-msg "")
+ (tembuf nil))
+ (save-excursion
+ (set-buffer buffer-index)
+ (beginning-of-buffer)
+ (while (not (eobp))
+ (setq file-msg (buffer-substring (point) (save-excursion
+ (end-of-line)
+ (point))))
+ (load file-msg)
+ (setq tembuf (find-file-noselect file-msg))
+ (if smtpmail-recipient-address-list
+ (if (not (smtp-via-smtp user-mail-address
+ smtpmail-recipient-address-list tembuf))
+ (error "Sending failed; SMTP protocol error"))
+ (error "Sending failed; no recipients"))
+ (delete-file file-msg)
+ (delete-file (concat file-msg ".el"))
+ (kill-buffer tembuf)
+ (kill-line 1))
+ (set-buffer buffer-index)
+ (save-buffer smtpmail-queue-index)
+ (kill-buffer buffer-index)
+ )))
+
+
+(defun smtpmail-do-bcc (header-end)
+ "Delete BCC: and their continuation lines from the header area.
+There may be multiple BCC: lines, and each may have arbitrarily
+many continuation lines."
+ (let ((case-fold-search t))
+ (save-excursion
+ (goto-char (point-min))
+ ;; iterate over all BCC: lines
+ (while (re-search-forward "^BCC:" header-end t)
+ (delete-region (match-beginning 0) (progn (forward-line 1) (point)))
+ ;; get rid of any continuation lines
+ (while (and (looking-at "^[ \t].*\n") (< (point) header-end))
+ (replace-match ""))
+ )
+ ) ;; save-excursion
+ ) ;; let
+ )
+
+
+;;;
+
+(provide 'smtpmail)
+
+;;; smtpmail.el ends here
;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
;; Keywords: mail, news, RFC 822, STD 11
-;; This file is part of MU (Message Utilities).
+;; This file is part of FLIM (Faithful Library about Internet Message).
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;;; Code:
-(autoload 'buffer-substring-no-properties "emu")
-(autoload 'member "emu")
+(or (fboundp 'buffer-substring-no-properties)
+ (require 'poe))
;;; @ field
)
)))))
+(defun std11-comment-value-to-string (value)
+ (if (stringp value)
+ (std11-strip-quoted-pair value)
+ (let ((dest ""))
+ (while value
+ (setq dest
+ (concat dest
+ (if (stringp (car value))
+ (car value)
+ (concat "("
+ (std11-comment-value-to-string
+ (cdr (car value)))
+ ")")
+ ))
+ value (cdr value))
+ )
+ dest)))
+
(defun std11-full-name-string (address)
- "Return string of full-name part from parsed ADDRESS of RFC 822.
-\[std11.el]"
+ "Return string of full-name part from parsed ADDRESS of RFC 822."
(cond ((eq (car address) 'group)
(mapconcat (function
(lambda (token)
(std11-strip-quoted-pair (cdr token))
)
((eq type 'comment)
- (concat
- "("
- (std11-strip-quoted-pair (cdr token))
- ")")
+ (concat "("
+ (std11-comment-value-to-string
+ (cdr token))
+ ")")
)
(t
(cdr token)
(nth 1 addr) ""))
)
(cond ((> (length phrase) 0) phrase)
- (comment (std11-strip-quoted-pair comment))
+ (comment (std11-comment-value-to-string comment))
)
))))
projects / elisp / flim.git / commitdiff