From: ueno Date: Tue, 28 Sep 1999 12:25:16 +0000 (+0000) Subject: Sync up to flim-1_13_2 from flim-1_12_7. X-Git-Url: http://git.chise.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=8781c16c86108f9a03060dcd91e5487cad04a66c;p=elisp%2Fflim.git Sync up to flim-1_13_2 from flim-1_12_7. --- diff --git a/FLIM-CFG b/FLIM-CFG index e4fbd65..05736ce 100644 --- a/FLIM-CFG +++ b/FLIM-CFG @@ -25,10 +25,10 @@ (add-path default-directory) -(or (fboundp 'write-region-as-binary) - (error "Please install latest APEL 7.3 or later.")) -(or (fboundp 'insert-file-contents-as-binary) - (error "Please install latest APEL 7.3 or later.")) +;; (or (fboundp 'write-region-as-binary) +;; (error "Please install latest APEL 7.3 or later.")) +;; (or (fboundp 'insert-file-contents-as-binary) +;; (error "Please install latest APEL 7.3 or later.")) ;;; @ Please specify prefix of install directory. diff --git a/FLIM-ELS b/FLIM-ELS index 7debfc9..732cc82 100644 --- a/FLIM-ELS +++ b/FLIM-ELS @@ -5,7 +5,7 @@ ;;; Code: (setq flim-modules '(std11 - mime-def + luna mime-def mel mel-q mel-u mel-g closure natset @@ -27,12 +27,13 @@ ew-dec eword-decode eword-encode ew-compat - mime mime-parse mmgeneric mmbuffer mmcooked + mime mime-parse mmbuffer mmcooked mmdbuffer mailcap smtp smtpmail)) -(unless (and (fboundp 'base64-encode-string) - (subrp (symbol-function 'base64-encode-string))) +(if (and (fboundp 'base64-encode-string) + (subrp (symbol-function 'base64-encode-string))) + nil (if (fboundp 'dynamic-link) (setq flim-modules (cons 'mel-b-dl flim-modules)) ) diff --git a/VERSION b/VERSION index a4dbc84..173b421 100644 --- a/VERSION +++ b/VERSION @@ -45,9 +45,9 @@ 1.12.5 Hirahata $(BJ?C<(B ; = $(B6aE4(B $(BE7M}@~(B 1.12.6 Family-K-Dòenmae-A $(B%U%!%_%j!<8x1`A0(B 1.12.7 Y-Dþzaki-A $(B7k:j(B ------- Iwami $(B@P8+(B ------- Tawaramoto $(BED86K\(B ; <=> $(B6aE4(B $(B@>ED86K\(B ------- Kasanui $(B3^K%(B +1.13.0 Iwami $(B@P8+(B +1.13.1 Tawaramoto $(BED86K\(B ; <=> $(B6aE4(B $(B@>ED86K\(B +1.13.2 Kasanui $(B3^K%(B ------ Ninokuchi $(B?7%N8}(B ------ Yagi $(BH,LZ(B ; = $(B6aE4(B $(BBg:e@~(B ------ Yagi-Nishiguchi $(BH,LZ@>8}(B @@ -86,3 +86,4 @@ 1.12.0 [JR] Ky-Dòto-A $(B5~ET(B ; <=> $(B6aE4(B, $(B5~ET;T8rDL6I(B 1.12.1 T-Dòfukuji-A $(BElJ!;{(B ; <=> $(B5~:e(B 1.12.2 Inari $(B0p2Y(B +1.13.0 JR Fujinomori JR $(BF#?9(B diff --git a/ftp.in b/ftp.in index 0949088..1d17d2a 100644 --- a/ftp.in +++ b/ftp.in @@ -2,16 +2,20 @@ It is available from + ftp://ftp.m17n.org/pub/mule/flim/flim-API + +or + ftp://ftp.etl.go.jp/pub/mule/flim/flim-API --[[message/external-body; access-type=anon-ftp; - site="ftp.etl.go.jp"; + site="ftp.m17n.org"; directory="/pub/mule/flim/flim-API"; - name="flim-VERSION.tar.gz"; + name="PACKAGE-VERSION.tar.gz"; mode=image]] Content-Type: application/octet-stream; - name="flim-VERSION.tar.gz"; + name="PACKAGE-VERSION.tar.gz"; type=tar; conversions=gzip --}-<> diff --git a/luna.el b/luna.el new file mode 100644 index 0000000..e66d265 --- /dev/null +++ b/luna.el @@ -0,0 +1,360 @@ +;;; luna.el --- tiny OOP system kernel + +;; Copyright (C) 1999 Electrotechnical Laboratory, JAPAN. +;; Licensed to the Free Software Foundation. + +;; Author: MORIOKA Tomohiko +;; Keywords: OOP + +;; 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: + +(eval-when-compile (require 'cl)) + +(eval-when-compile (require 'static)) + +(static-condition-case nil + :symbol-for-testing-whether-colon-keyword-is-available-or-not + (void-variable + (defconst :before ':before) + (defconst :after ':after) + (defconst :around ':around))) + +(defmacro luna-find-class (name) + "Return the luna-class of the given NAME." + `(get ,name 'luna-class)) + +(defmacro luna-set-class (name class) + `(put ,name 'luna-class ,class)) + +(defmacro luna-class-obarray (class) + `(aref ,class 1)) + +(defmacro luna-class-parents (class) + `(aref ,class 2)) + +(defmacro luna-class-number-of-slots (class) + `(aref ,class 3)) + +(defmacro luna-define-class (type &optional parents slots) + "Define TYPE as a luna-class. +If PARENTS is specified, TYPE inherits PARENTS. +Each parent must be name of luna-class (symbol). +If SLOTS is specified, TYPE will be defined to have them." + `(luna-define-class-function ',type ',(append parents '(standard-object)) + ',slots)) + +(defun luna-define-class-function (type &optional parents slots) + (static-condition-case nil + :symbol-for-testing-whether-colon-keyword-is-available-or-not + (void-variable + (let (key) + (dolist (slot slots) + (setq key (intern (format ":%s" slot))) + (set key key))))) + (let ((oa (make-vector 31 0)) + (rest parents) + parent name + (i 2) + b j) + (while rest + (setq parent (pop rest) + b (- i 2)) + (mapatoms (lambda (sym) + (when (setq j (get sym 'luna-slot-index)) + (setq name (symbol-name sym)) + (unless (intern-soft name oa) + (put (intern name oa) 'luna-slot-index (+ j b)) + (setq i (1+ i)) + ))) + (luna-class-obarray (luna-find-class parent))) + ) + (setq rest slots) + (while rest + (setq name (symbol-name (pop rest))) + (unless (intern-soft name oa) + (put (intern name oa) 'luna-slot-index i) + (setq i (1+ i)) + )) + (luna-set-class type (vector 'class oa parents i)) + )) + +(defun luna-class-find-member (class member-name) + (or (stringp member-name) + (setq member-name (symbol-name member-name))) + (or (intern-soft member-name (luna-class-obarray class)) + (let ((parents (luna-class-parents class)) + ret) + (while (and parents + (null + (setq ret (luna-class-find-member + (luna-find-class (pop parents)) + member-name))))) + ret))) + +(defsubst luna-class-find-or-make-member (class member-name) + (or (stringp member-name) + (setq member-name (symbol-name member-name))) + (intern member-name (luna-class-obarray class))) + +(defmacro luna-class-slot-index (class slot-name) + `(get (luna-class-find-member ,class ,slot-name) 'luna-slot-index)) + +(defmacro luna-slot-index (entity slot-name) + `(luna-class-slot-index (luna-find-class (luna-class-name ,entity)) + ,slot-name)) + +(defsubst luna-slot-value (entity slot) + "Return the value of SLOT of ENTITY." + (aref entity (luna-slot-index entity slot))) + +(defsubst luna-set-slot-value (entity slot value) + "Store VALUE into SLOT of ENTITY." + (aset entity (luna-slot-index entity slot) value)) + +(defmacro luna-define-method (name &rest definition) + "Define NAME as a method function of a class. + +Usage of this macro follows: + + (luna-define-method NAME [METHOD-QUALIFIER] ARGLIST [DOCSTRING] BODY...) + +NAME is the name of method. + +Optional argument METHOD-QUALIFIER must be :before, :after or :around. +If it is :before / :after, the method is called before / after a +method of parent class is finished. ARGLIST is like an argument list +of lambda, but (car ARGLIST) must be specialized parameter. (car (car +ARGLIST)) is name of variable and \(nth 1 (car ARGLIST)) is name of +class. + +Optional argument DOCSTRING is the documentation of method. + +BODY is the body of method." + (let ((method-qualifier (pop definition)) + args specializer class self) + (if (memq method-qualifier '(:before :after :around)) + (setq args (pop definition)) + (setq args method-qualifier + method-qualifier nil) + ) + (setq specializer (car args) + class (nth 1 specializer) + self (car specializer)) + `(let ((func (lambda ,(if self + (cons self (cdr args)) + (cdr args)) + ,@definition)) + (sym (luna-class-find-or-make-member + (luna-find-class ',class) ',name))) + (fset sym func) + (put sym 'luna-method-qualifier ,method-qualifier) + ))) + +(put 'luna-define-method 'lisp-indent-function 'defun) + +(def-edebug-spec luna-define-method + (&define name [&optional &or ":before" ":after" ":around"] + ((arg symbolp) + [&rest arg] + [&optional ["&optional" arg &rest arg]] + &optional ["&rest" arg] + ) + def-body)) + +(defun luna-class-find-parents-functions (class service) + (let ((parents (luna-class-parents class)) + ret) + (while (and parents + (null + (setq ret (luna-class-find-functions + (luna-find-class (pop parents)) + service))))) + ret)) + +(defun luna-class-find-functions (class service) + (let ((sym (luna-class-find-member class service))) + (if (fboundp sym) + (cond ((eq (get sym 'luna-method-qualifier) :before) + (cons (symbol-function sym) + (luna-class-find-parents-functions class service)) + ) + ((eq (get sym 'luna-method-qualifier) :after) + (nconc (luna-class-find-parents-functions class service) + (list (symbol-function sym))) + ) + ((eq (get sym 'luna-method-qualifier) :around) + (cons sym (luna-class-find-parents-functions class service)) + ) + (t + (list (symbol-function sym)) + )) + (luna-class-find-parents-functions class service) + ))) + +(defmacro luna-find-functions (entity service) + `(luna-class-find-functions (luna-find-class (luna-class-name ,entity)) + ,service)) + +(defsubst luna-send (entity message &rest luna-current-method-arguments) + "Send MESSAGE to ENTITY, and return the result. +LUNA-CURRENT-METHOD-ARGUMENTS is arguments of the MESSAGE." + (let ((luna-next-methods (luna-find-functions entity message)) + luna-current-method + luna-previous-return-value) + (while (and luna-next-methods + (progn + (setq luna-current-method (pop luna-next-methods) + luna-previous-return-value + (apply luna-current-method + luna-current-method-arguments)) + (if (symbolp luna-current-method) + (not (eq (get luna-current-method + 'luna-method-qualifier) :around)) + t)))) + luna-previous-return-value)) + +(eval-when-compile + (defvar luna-next-methods nil) + (defvar luna-current-method-arguments nil) + ) + +(defun luna-call-next-method () + "Call the next method in a method with :around qualifier." + (let (luna-current-method + luna-previous-return-value) + (while (and luna-next-methods + (progn + (setq luna-current-method (pop luna-next-methods) + luna-previous-return-value + (apply luna-current-method + luna-current-method-arguments)) + (if (symbolp luna-current-method) + (not (eq (get luna-current-method + 'luna-method-qualifier) :around)) + t)))) + luna-previous-return-value)) + +(defmacro luna-class-name (entity) + "Return class-name of the ENTITY." + `(aref ,entity 0)) + +(defmacro luna-set-class-name (entity name) + `(aset ,entity 0 ,name)) + +(defmacro luna-get-obarray (entity) + `(aref ,entity 1)) + +(defmacro luna-set-obarray (entity obarray) + `(aset ,entity 1 ,obarray)) + +(defun luna-make-entity (type &rest init-args) + "Make instance of luna-class TYPE and return it. +If INIT-ARGS is specified, it is used as initial values of the slots. +It must be plist and each slot name must have prefix `:'." + (let* ((c (get type 'luna-class)) + (v (make-vector (luna-class-number-of-slots c) nil))) + (luna-set-class-name v type) + (luna-set-obarray v (make-vector 7 0)) + (apply #'luna-send v 'initialize-instance v init-args) + )) + +(defsubst luna-arglist-to-arguments (arglist) + (let (dest) + (while arglist + (let ((arg (car arglist))) + (or (memq arg '(&optional &rest)) + (setq dest (cons arg dest))) + ) + (setq arglist (cdr arglist))) + (nreverse dest))) + +(defmacro luna-define-generic (name args &optional doc) + "Define generic-function NAME. +ARGS is argument of and DOC is DOC-string." + (if doc + `(defun ,(intern (symbol-name name)) ,args + ,doc + (luna-send ,(car args) ',name + ,@(luna-arglist-to-arguments args)) + ) + `(defun ,(intern (symbol-name name)) ,args + (luna-send ,(car args) ',name + ,@(luna-arglist-to-arguments args)) + ))) + +(put 'luna-define-generic 'lisp-indent-function 'defun) + +(defun luna-define-internal-accessors (class-name) + "Define internal accessors for an entity of CLASS-NAME." + (let ((entity-class (luna-find-class class-name)) + parents parent-class) + (mapatoms + (lambda (slot) + (if (luna-class-slot-index entity-class slot) + (catch 'derived + (setq parents (luna-class-parents entity-class)) + (while parents + (setq parent-class (luna-find-class (car parents))) + (if (luna-class-slot-index parent-class slot) + (throw 'derived nil)) + (setq parents (cdr parents)) + ) + (eval + `(progn + (defmacro ,(intern (format "%s-%s-internal" + class-name slot)) + (entity) + (list 'aref entity + ,(luna-class-slot-index entity-class + (intern (symbol-name slot))) + )) + (defmacro ,(intern (format "%s-set-%s-internal" + class-name slot)) + (entity value) + (list 'aset entity + ,(luna-class-slot-index + entity-class (intern (symbol-name slot))) + value)) + )) + ))) + (luna-class-obarray entity-class)))) + +(luna-define-class-function 'standard-object) + +(luna-define-method initialize-instance ((entity standard-object) + &rest init-args) + (let* ((c (luna-find-class (luna-class-name entity))) + (oa (luna-class-obarray c)) + s i) + (while init-args + (setq s (intern-soft (substring (symbol-name (pop init-args)) 1) oa) + i (pop init-args)) + (if s + (aset entity (get s 'luna-slot-index) i) + )) + entity)) + + +;;; @ end +;;; + +(provide 'luna) + +;; luna.el ends here diff --git a/mailcap.el b/mailcap.el index b3b7d90..eb1c093 100644 --- a/mailcap.el +++ b/mailcap.el @@ -105,7 +105,8 @@ (let ((beg (point))) (while (or (mailcap-look-at-qchar) (mailcap-look-at-schar))) - (buffer-substring beg (point)))) + (buffer-substring beg (point)) + )) ;;; @ field diff --git a/mel-b-ccl.el b/mel-b-ccl.el index e0426b8..fa12483 100644 --- a/mel-b-ccl.el +++ b/mel-b-ccl.el @@ -1,6 +1,6 @@ ;;; mel-b-ccl.el --- Base64 encoder/decoder using CCL. -;; Copyright (C) 1998 Tanaka Akira +;; Copyright (C) 1998,1999 Tanaka Akira ;; Author: Tanaka Akira ;; Created: 1998/9/17 diff --git a/mel-b-dl.el b/mel-b-dl.el index 59bff29..47b1b81 100644 --- a/mel-b-dl.el +++ b/mel-b-dl.el @@ -1,8 +1,8 @@ ;;; mel-b-dl.el --- Base64 encoder/decoder using DL module. -;; Copyright (C) 1998 Free Software Foundation, Inc. +;; Copyright (C) 1998,1999 Free Software Foundation, Inc. -;; Author: MORIOKA Tomohiko +;; Author: MORIOKA Tomohiko ;; Keywords: MIME, Base64 ;; This file is part of FLIM (Faithful Library about Internet Message). diff --git a/mel-b-el.el b/mel-b-el.el index 076f2f6..f661853 100644 --- a/mel-b-el.el +++ b/mel-b-el.el @@ -1,9 +1,9 @@ ;;; mel-b-el.el --- Base64 encoder/decoder. -;; Copyright (C) 1992,1995,1996,1997,1998 Free Software Foundation, Inc. +;; Copyright (C) 1992,1995,1996,1997,1998,1999 Free Software Foundation, Inc. ;; Author: ENAMI Tsugutomo -;; MORIOKA Tomohiko +;; MORIOKA Tomohiko ;; Created: 1995/6/24 ;; Keywords: MIME, Base64 diff --git a/mel-g.el b/mel-g.el index c0f3577..16a37fd 100644 --- a/mel-g.el +++ b/mel-g.el @@ -4,7 +4,8 @@ ;; Copyright (C) 1996,1997,1999 Shuhei KOBAYASHI ;; Author: Shuhei KOBAYASHI -;; MORIOKA Tomohiko +;; MORIOKA Tomohiko +;; Maintainer: Shuhei KOBAYASHI ;; Created: 1995/10/25 ;; Keywords: Gzip64, base64, gzip, MIME diff --git a/mel-q-ccl.el b/mel-q-ccl.el index 04e09b0..c71fab6 100644 --- a/mel-q-ccl.el +++ b/mel-q-ccl.el @@ -1,6 +1,6 @@ ;;; mel-q-ccl.el --- Quoted-Printable encoder/decoder using CCL. -;; Copyright (C) 1998 Tanaka Akira +;; Copyright (C) 1998,1999 Tanaka Akira ;; Author: Tanaka Akira ;; Created: 1998/9/17 diff --git a/mel-q.el b/mel-q.el index 6200a74..44b83c9 100644 --- a/mel-q.el +++ b/mel-q.el @@ -2,7 +2,7 @@ ;; Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc. -;; Author: MORIOKA Tomohiko +;; Author: MORIOKA Tomohiko ;; Created: 1995/6/25 ;; Keywords: MIME, Quoted-Printable, Q-encoding diff --git a/mel-u.el b/mel-u.el index 94ede06..49d5733 100644 --- a/mel-u.el +++ b/mel-u.el @@ -2,7 +2,7 @@ ;; Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc. -;; Author: MORIOKA Tomohiko +;; Author: MORIOKA Tomohiko ;; Created: 1995/10/25 ;; Keywords: uuencode diff --git a/mel.el b/mel.el index f128321..12fff86 100644 --- a/mel.el +++ b/mel.el @@ -2,7 +2,7 @@ ;; Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc. -;; Author: MORIOKA Tomohiko +;; Author: MORIOKA Tomohiko ;; Created: 1995/6/25 ;; Keywords: MIME, Base64, Quoted-Printable, uuencode, gzip64 @@ -26,6 +26,8 @@ ;;; Code: (require 'mime-def) +(require 'poem) +(require 'alist) (require 'path-util) (defcustom mime-encoding-list @@ -222,8 +224,9 @@ the STRING by its value." (defun Q-encoded-text-length (string &optional mode) (let ((l 0)(i 0)(len (length string)) chr) (while (< i len) - (setq chr (elt string i)) - (if (Q-encoding-printable-char-p chr mode) + (setq chr (aref string i)) + (if (or (Q-encoding-printable-char-p chr mode) + (eq chr ? )) (setq l (+ l 1)) (setq l (+ l 3))) (setq i (+ i 1))) diff --git a/mime-parse.el b/mime-parse.el index 7d760c4..5442896 100644 --- a/mime-parse.el +++ b/mime-parse.el @@ -27,6 +27,10 @@ (require 'mime-def) (require 'std11) +(autoload 'mime-entity-body-buffer "mime") +(autoload 'mime-entity-body-start-point "mime") +(autoload 'mime-entity-body-end-point "mime") + ;;; @ lexical analyzer ;;; @@ -213,70 +217,74 @@ If is is not found, return DEFAULT-ENCODING." ;;; (defun mime-parse-multipart (entity) - (goto-char (point-min)) - (let* ((representation-type - (mime-entity-representation-type-internal entity)) - (content-type (mime-entity-content-type-internal entity)) - (dash-boundary - (concat "--" (mime-content-type-parameter content-type "boundary"))) - (delimiter (concat "\n" (regexp-quote dash-boundary))) - (close-delimiter (concat delimiter "--[ \t]*$")) - (rsep (concat delimiter "[ \t]*\n")) - (dc-ctl - (if (eq (mime-content-type-subtype content-type) 'digest) - (make-mime-content-type 'message 'rfc822) - (make-mime-content-type 'text 'plain) - )) - (header-end (mime-entity-header-end-internal entity)) - (body-end (mime-entity-body-end-internal entity))) - (save-restriction - (goto-char body-end) - (narrow-to-region header-end - (if (re-search-backward close-delimiter nil t) - (match-beginning 0) - body-end)) - (goto-char header-end) - (if (re-search-forward rsep nil t) - (let ((cb (match-end 0)) - ce ncb ret children - (node-id (mime-entity-node-id-internal entity)) - (i 0)) - (while (re-search-forward rsep nil t) - (setq ce (match-beginning 0)) - (setq ncb (match-end 0)) + (with-current-buffer (mime-entity-body-buffer entity) + (let* ((representation-type + (mime-entity-representation-type-internal entity)) + (content-type (mime-entity-content-type-internal entity)) + (dash-boundary + (concat "--" + (mime-content-type-parameter content-type "boundary"))) + (delimiter (concat "\n" (regexp-quote dash-boundary))) + (close-delimiter (concat delimiter "--[ \t]*$")) + (rsep (concat delimiter "[ \t]*\n")) + (dc-ctl + (if (eq (mime-content-type-subtype content-type) 'digest) + (make-mime-content-type 'message 'rfc822) + (make-mime-content-type 'text 'plain) + )) + (body-start (mime-entity-body-start-point entity)) + (body-end (mime-entity-body-end-point entity))) + (save-restriction + (goto-char body-end) + (narrow-to-region body-start + (if (re-search-backward close-delimiter nil t) + (match-beginning 0) + body-end)) + (goto-char body-start) + (if (re-search-forward + (concat "^" (regexp-quote dash-boundary) "[ \t]*\n") + nil t) + (let ((cb (match-end 0)) + ce ncb ret children + (node-id (mime-entity-node-id-internal entity)) + (i 0)) + (while (re-search-forward rsep nil t) + (setq ce (match-beginning 0)) + (setq ncb (match-end 0)) + (save-restriction + (narrow-to-region cb ce) + (setq ret (mime-parse-message representation-type dc-ctl + entity (cons i node-id))) + ) + (setq children (cons ret children)) + (goto-char (setq cb ncb)) + (setq i (1+ i)) + ) + (setq ce (point-max)) (save-restriction (narrow-to-region cb ce) (setq ret (mime-parse-message representation-type dc-ctl entity (cons i node-id))) ) (setq children (cons ret children)) - (goto-char (setq cb ncb)) - (setq i (1+ i)) + (mime-entity-set-children-internal entity (nreverse children)) ) - (setq ce (point-max)) - (save-restriction - (narrow-to-region cb ce) - (setq ret (mime-parse-message representation-type dc-ctl - entity (cons i node-id))) - ) - (setq children (cons ret children)) - (mime-entity-set-children-internal entity (nreverse children)) - ) - (mime-entity-set-content-type-internal - entity (make-mime-content-type 'message 'x-broken)) - nil) - ))) + (mime-entity-set-content-type-internal + entity (make-mime-content-type 'message 'x-broken)) + nil) + )))) (defun mime-parse-encapsulated (entity) (mime-entity-set-children-internal entity - (save-restriction - (narrow-to-region (mime-entity-body-start-internal entity) - (mime-entity-body-end-internal entity)) - (list (mime-parse-message - (mime-entity-representation-type-internal entity) nil - entity (cons 0 (mime-entity-node-id-internal entity)))) - ))) + (with-current-buffer (mime-entity-body-buffer entity) + (save-restriction + (narrow-to-region (mime-entity-body-start-point entity) + (mime-entity-body-end-point entity)) + (list (mime-parse-message + (mime-entity-representation-type-internal entity) nil + entity (cons 0 (mime-entity-node-id-internal entity)))) + )))) (defun mime-parse-message (representation-type &optional default-ctl parent node-id) @@ -301,15 +309,16 @@ If is is not found, return DEFAULT-ENCODING." )) default-ctl)) ) - (make-mime-entity-internal representation-type - (current-buffer) - content-type nil parent node-id - nil nil nil nil - nil nil nil nil - nil nil - (current-buffer) - header-start header-end - body-start body-end) + (luna-make-entity representation-type + :location (current-buffer) + :content-type content-type + :parent parent + :node-id node-id + :buffer (current-buffer) + :header-start header-start + :header-end header-end + :body-start body-start + :body-end body-end) )) @@ -323,7 +332,8 @@ If buffer is omitted, it parses current-buffer." (save-excursion (if buffer (set-buffer buffer)) (setq mime-message-structure - (mime-parse-message (or representation-type 'buffer) nil)) + (mime-parse-message (or representation-type + 'mime-buffer-entity) nil)) )) diff --git a/mime.el b/mime.el index ce23631..63af880 100644 --- a/mime.el +++ b/mime.el @@ -1,8 +1,10 @@ ;;; mime.el --- MIME library module ;; Copyright (C) 1998,1999 Free Software Foundation, Inc. +;; Copyright (C) 1999 Electrotechnical Laboratory, JAPAN. +;; Licensed to the Free Software Foundation. -;; Author: MORIOKA Tomohiko +;; Author: MORIOKA Tomohiko ;; Keywords: MIME, multimedia, mail, news ;; This file is part of FLIM (Faithful Library about Internet Message). @@ -66,50 +68,18 @@ current-buffer, and return it.") ;;; @ Entity Representation and Implementation ;;; -(defsubst mime-find-function (service type) - (let ((imps (cdr (assq type mime-entity-implementation-alist)))) - (if imps - (cdr (assq service imps)) - (require (intern (format "mm%s" type))) - (cdr (assq service - (cdr (assq type mime-entity-implementation-alist)))) - ))) - -(defsubst mime-entity-function (entity service) - (mime-find-function service - (mime-entity-representation-type-internal entity))) - -(defsubst mime-entity-send (entity message &rest args) - "Send MESSAGE to ENTITY with ARGS, and return the result." - (apply (mime-find-function - message (mime-entity-representation-type-internal entity)) - entity - args)) - -(defmacro mm-define-generic (name args &optional doc) - (if doc - `(defun ,(intern (format "mime-%s" name)) ,args - ,doc - (mime-entity-send ,(car args) ',name - ,@(mm-arglist-to-arguments (cdr args))) - ) - `(defun ,(intern (format "mime-%s" name)) ,args - (mime-entity-send ,(car args) ',name - ,@(mm-arglist-to-arguments (cdr args))) - ))) - -(put 'mm-define-generic 'lisp-indent-function 'defun) +(defmacro mime-entity-send (entity message &rest args) + `(luna-send ,entity ',(intern (format "mime-%s" (eval message))) ,@args)) (defun mime-open-entity (type location) "Open an entity and return it. TYPE is representation-type. LOCATION is location of entity. Specification of it is depended on representation-type." - (let ((entity (make-mime-entity-internal type location))) - (mime-entity-send entity 'initialize-instance) - entity)) + (require (intern (format "mm%s" type))) + (luna-make-entity (mm-expand-class-name type) :location location)) -(mm-define-generic entity-cooked-p (entity) +(luna-define-generic mime-entity-cooked-p (entity) "Return non-nil if contents of ENTITY has been already code-converted.") @@ -118,7 +88,7 @@ representation-type." (defun mime-entity-children (entity) (or (mime-entity-children-internal entity) - (mime-entity-send entity 'entity-children))) + (luna-send entity 'mime-entity-children entity))) (defalias 'mime-entity-node-id 'mime-entity-node-id-internal) @@ -150,7 +120,7 @@ If MESSAGE is not specified, `mime-message-structure' is used." If MESSAGE is not specified, `mime-message-structure' is used." (or message (setq message mime-message-structure)) - (if (equal cid (mime-read-field 'Content-Id message)) + (if (equal cid (mime-entity-read-field message "Content-Id")) message (let ((children (mime-entity-children message)) ret) @@ -173,76 +143,79 @@ If MESSAGE is specified, it is regarded as root entity." (null (mime-entity-parent entity message))) -;;; @ Entity Buffer +;;; @ Header buffer ;;; -(defun mime-entity-buffer (entity) - (or (mime-entity-buffer-internal entity) - (mime-entity-send entity 'entity-buffer))) +(luna-define-generic mime-entity-header-buffer (entity)) -(mm-define-generic entity-point-min (entity) - "Return the start point of ENTITY in the buffer which contains ENTITY.") +(luna-define-generic mime-goto-header-start-point (entity) + "Set buffer and point to header-start-position of ENTITY.") -(mm-define-generic entity-point-max (entity) - "Return the end point of ENTITY in the buffer which contains ENTITY.") +(luna-define-generic mime-entity-header-start-point (entity) + "Return header-start-position of ENTITY.") -(defun mime-entity-header-start (entity) - (or (mime-entity-header-start-internal entity) - (mime-entity-send entity 'entity-header-start))) +(luna-define-generic mime-entity-header-end-point (entity) + "Return header-end-position of ENTITY.") + + +;;; @ Body buffer +;;; -(defun mime-entity-header-end (entity) - (or (mime-entity-header-end-internal entity) - (mime-entity-send entity 'entity-header-end))) +(luna-define-generic mime-entity-body-buffer (entity)) -(defun mime-entity-body-start (entity) - (or (mime-entity-body-start-internal entity) - (mime-entity-send entity 'entity-body-start))) +(luna-define-generic mime-goto-body-start-point (entity) + "Set buffer and point to body-start-position of ENTITY.") -(defun mime-entity-body-end (entity) - (or (mime-entity-body-end-internal entity) - (mime-entity-send entity 'entity-body-end))) +(luna-define-generic mime-goto-body-end-point (entity) + "Set buffer and point to body-end-position of ENTITY.") + +(luna-define-generic mime-entity-body-start-point (entity) + "Return body-start-position of ENTITY.") + +(define-obsolete-function-alias + 'mime-entity-body-start 'mime-entity-body-start-point) + +(luna-define-generic mime-entity-body-end-point (entity) + "Return body-end-position of ENTITY.") + +(define-obsolete-function-alias + 'mime-entity-body-end 'mime-entity-body-end-point) + + +;;; @ Entity buffer (obsolete) +;;; + +(luna-define-generic mime-entity-buffer (entity)) +(make-obsolete 'mime-entity-buffer + "use mime-entity-header-buffer or mime-entity-body-buffer instead.") + +(luna-define-generic mime-entity-point-min (entity)) +(make-obsolete 'mime-entity-point-min 'mime-entity-header-start-point) + +(luna-define-generic mime-entity-point-max (entity)) +(make-obsolete 'mime-entity-point-max 'mime-entity-body-end-point) ;;; @ Entity Header ;;; +(luna-define-generic mime-entity-fetch-field (entity field-name) + "Return the value of the ENTITY's header field whose type is FIELD-NAME.") + (defun mime-fetch-field (field-name &optional entity) - (or (symbolp field-name) - (setq field-name (intern (capitalize (capitalize field-name))))) + "Return the value of the ENTITY's header field whose type is FIELD-NAME." + (if (symbolp field-name) + (setq field-name (symbol-name field-name)) + ) (or entity (setq entity mime-message-structure)) - (cond ((eq field-name 'Date) - (or (mime-entity-date-internal entity) - (mime-entity-set-date-internal - entity (mime-entity-send entity 'fetch-field "Date")) - )) - ((eq field-name 'Message-Id) - (or (mime-entity-message-id-internal entity) - (mime-entity-set-message-id-internal - entity (mime-entity-send entity 'fetch-field "Message-Id")) - )) - ((eq field-name 'References) - (or (mime-entity-references-internal entity) - (mime-entity-set-references-internal - entity (mime-entity-send entity 'fetch-field "References")) - )) - (t - (let* ((header (mime-entity-original-header-internal entity)) - (field-body (cdr (assq field-name header)))) - (or field-body - (progn - (if (setq field-body - (mime-entity-send entity 'fetch-field - (symbol-name field-name))) - (mime-entity-set-original-header-internal - entity (put-alist field-name field-body header)) - ) - field-body)) - )))) + (mime-entity-fetch-field entity field-name) + ) +(make-obsolete 'mime-fetch-field 'mime-entity-fetch-field) (defun mime-entity-content-type (entity) (or (mime-entity-content-type-internal entity) - (let ((ret (mime-fetch-field 'Content-Type entity))) + (let ((ret (mime-entity-fetch-field entity "Content-Type"))) (if ret (mime-entity-set-content-type-internal entity (mime-parse-Content-Type ret)) @@ -250,7 +223,7 @@ If MESSAGE is specified, it is regarded as root entity." (defun mime-entity-content-disposition (entity) (or (mime-entity-content-disposition-internal entity) - (let ((ret (mime-fetch-field 'Content-Disposition entity))) + (let ((ret (mime-entity-fetch-field entity "Content-Disposition"))) (if ret (mime-entity-set-content-disposition-internal entity (mime-parse-Content-Disposition ret)) @@ -258,7 +231,7 @@ If MESSAGE is specified, it is regarded as root entity." (defun mime-entity-encoding (entity &optional default-encoding) (or (mime-entity-encoding-internal entity) - (let ((ret (mime-fetch-field 'Content-Transfer-Encoding entity))) + (let ((ret (mime-entity-fetch-field entity "Content-Transfer-Encoding"))) (mime-entity-set-encoding-internal entity (or (and ret (mime-parse-Content-Transfer-Encoding ret)) @@ -294,58 +267,64 @@ If MESSAGE is specified, it is regarded as root entity." (Content-Id . mime-parse-msg-id) )) +(defun mime-entity-read-field (entity field-name) + (let ((sym (if (symbolp field-name) + (prog1 + field-name + (setq field-name (symbol-name field-name))) + (capitalize (capitalize field-name))))) + (cond ((eq sym 'Content-Type) + (mime-entity-content-type entity) + ) + ((eq sym 'Content-Disposition) + (mime-entity-content-disposition entity) + ) + ((eq sym 'Content-Transfer-Encoding) + (mime-entity-encoding entity) + ) + (t + (let* ((header (mime-entity-parsed-header-internal entity)) + (field (cdr (assq sym header)))) + (or field + (let ((field-body (mime-entity-fetch-field entity field-name)) + parser) + (when field-body + (setq parser + (cdr (assq sym mime-field-parser-alist))) + (setq field + (if parser + (funcall parser + (eword-lexical-analyze field-body)) + (mime-decode-field-body field-body sym 'plain) + )) + (mime-entity-set-parsed-header-internal + entity (put-alist sym field header)) + field)))))))) + (defun mime-read-field (field-name &optional entity) - (or (symbolp field-name) - (setq field-name (capitalize (capitalize field-name)))) (or entity (setq entity mime-message-structure)) - (cond ((eq field-name 'Content-Type) - (mime-entity-content-type entity) - ) - ((eq field-name 'Content-Disposition) - (mime-entity-content-disposition entity) - ) - ((eq field-name 'Content-Transfer-Encoding) - (mime-entity-encoding entity) - ) - (t - (let* ((header (mime-entity-parsed-header-internal entity)) - (field (cdr (assq field-name header)))) - (or field - (let ((field-body (mime-fetch-field field-name entity)) - parser) - (when field-body - (setq parser - (cdr (assq field-name mime-field-parser-alist))) - (setq field - (if parser - (funcall parser - (eword-lexical-analyze field-body)) - (mime-decode-field-body - field-body field-name 'plain) - )) - (mime-entity-set-parsed-header-internal - entity (put-alist field-name field header)) - field))))))) - -(mm-define-generic insert-header (entity &optional invisible-fields - visible-fields) - "Insert before point a decoded header of ENTITY.") + (mime-entity-read-field entity field-name) + ) +(make-obsolete 'mime-read-field 'mime-entity-read-field) -(define-obsolete-function-alias - 'mime-insert-decoded-header 'mime-insert-header) +(luna-define-generic mime-insert-header (entity &optional invisible-fields + visible-fields) + "Insert before point a decoded header of ENTITY.") ;;; @ Entity Attributes ;;; +(luna-define-generic mime-entity-name (entity) + "Return name of the ENTITY.") + (defun mime-entity-uu-filename (entity) (if (member (mime-entity-encoding entity) mime-uuencode-encoding-name-list) (save-excursion - (set-buffer (mime-entity-buffer entity)) - (goto-char (mime-entity-body-start entity)) + (mime-goto-body-start-point entity) (if (re-search-forward "^begin [0-9]+ " - (mime-entity-body-end entity) t) + (mime-entity-body-end-point entity) t) (if (looking-at ".+$") (buffer-substring (match-beginning 0)(match-end 0)) ))))) @@ -376,25 +355,25 @@ If MESSAGE is specified, it is regarded as root entity." ;;; @ Entity Content ;;; -(mm-define-generic entity-content (entity) +(luna-define-generic mime-entity-content (entity) "Return content of ENTITY as byte sequence (string).") -(mm-define-generic insert-entity-content (entity) +(luna-define-generic mime-insert-entity-content (entity) "Insert content of ENTITY at point.") -(mm-define-generic write-entity-content (entity filename) +(luna-define-generic mime-write-entity-content (entity filename) "Write content of ENTITY into FILENAME.") -(mm-define-generic insert-text-content (entity) +(luna-define-generic mime-insert-text-content (entity) "Insert decoded text body of ENTITY.") -(mm-define-generic insert-entity (entity) +(luna-define-generic mime-insert-entity (entity) "Insert header and body of ENTITY at point.") -(mm-define-generic write-entity (entity filename) +(luna-define-generic mime-write-entity (entity filename) "Write header and body of ENTITY into FILENAME.") -(mm-define-generic write-entity-body (entity filename) +(luna-define-generic mime-write-entity-body (entity filename) "Write body of ENTITY into FILENAME.") diff --git a/mmbuffer.el b/mmbuffer.el index 38432fb..f014aec 100644 --- a/mmbuffer.el +++ b/mmbuffer.el @@ -1,8 +1,10 @@ ;;; mmbuffer.el --- MIME entity module for binary buffer ;; Copyright (C) 1998,1999 Free Software Foundation, Inc. +;; Copyright (C) 1999 Electrotechnical Laboratory, JAPAN. +;; Licensed to the Free Software Foundation. -;; Author: MORIOKA Tomohiko +;; Author: MORIOKA Tomohiko ;; Keywords: MIME, multimedia, mail, news ;; This file is part of FLIM (Faithful Library about Internet Message). @@ -24,107 +26,262 @@ ;;; Code: -(require 'mmgeneric) +(require 'mime) -(mm-define-backend buffer (generic)) +(eval-and-compile + (luna-define-class mime-buffer-entity (mime-entity) + (buffer + header-start + header-end + body-start + body-end)) -(mm-define-method initialize-instance ((entity buffer)) - (mime-entity-set-buffer-internal - entity (mime-entity-location-internal entity)) + (luna-define-internal-accessors 'mime-buffer-entity) + ) + +(luna-define-method initialize-instance :after ((entity mime-buffer-entity) + &rest init-args) + (or (mime-buffer-entity-buffer-internal entity) + (mime-buffer-entity-set-buffer-internal + entity (mime-entity-location-internal entity))) (save-excursion - (set-buffer (mime-entity-buffer-internal entity)) - (setq mime-message-structure entity) - (let ((header-start (point-min)) - header-end - body-start - (body-end (point-max))) + (set-buffer (mime-buffer-entity-buffer-internal entity)) + (if (mime-root-entity-p entity) + (setq mime-message-structure entity)) + (let ((header-start + (or (mime-buffer-entity-header-start-internal entity) + (mime-buffer-entity-set-header-start-internal + entity (point-min)))) + (header-end (mime-buffer-entity-header-end-internal entity)) + (body-start (mime-buffer-entity-body-start-internal entity)) + (body-end + (or (mime-buffer-entity-body-end-internal entity) + (mime-buffer-entity-set-body-end-internal entity (point-max))))) (goto-char header-start) - (if (re-search-forward "^$" nil t) - (setq header-end (match-end 0) - body-start (if (= header-end body-end) - body-end - (1+ header-end))) - (setq header-end (point-min) - body-start (point-min))) - (save-restriction - (narrow-to-region header-start header-end) - (mime-entity-set-content-type-internal - entity - (let ((str (std11-fetch-field "Content-Type"))) - (if str - (mime-parse-Content-Type str) - ))) + (unless (and header-end body-start) + (if (re-search-forward "^$" body-end t) + (setq header-end (match-end 0) + body-start (if (= header-end body-end) + body-end + (1+ header-end))) + (setq header-end (point-min) + body-start (point-min))) + (mime-buffer-entity-set-header-end-internal entity header-end) + (mime-buffer-entity-set-body-start-internal entity body-start) ) - (mime-entity-set-header-start-internal entity header-start) - (mime-entity-set-header-end-internal entity header-end) - (mime-entity-set-body-start-internal entity body-start) - (mime-entity-set-body-end-internal entity body-end) - ))) + (or (mime-entity-content-type-internal entity) + (save-restriction + (narrow-to-region header-start header-end) + (mime-entity-set-content-type-internal + entity + (let ((str (std11-fetch-field "Content-Type"))) + (if str + (mime-parse-Content-Type str) + ))) + )) + )) + entity) -;;; redefine to speed up +(luna-define-method mime-entity-name ((entity mime-buffer-entity)) + (buffer-name (mime-buffer-entity-buffer-internal entity)) + ) -(mm-define-method entity-point-min ((entity buffer)) - (mime-entity-header-start-internal entity)) -(mm-define-method entity-point-max ((entity buffer)) - (mime-entity-body-end-internal entity)) +(defun mime-visible-field-p (field-name visible-fields invisible-fields) + (or (catch 'found + (while visible-fields + (let ((regexp (car visible-fields))) + (if (string-match regexp field-name) + (throw 'found t) + )) + (setq visible-fields (cdr visible-fields)) + )) + (catch 'found + (while invisible-fields + (let ((regexp (car invisible-fields))) + (if (string-match regexp field-name) + (throw 'found nil) + )) + (setq invisible-fields (cdr invisible-fields)) + ) + t))) -(mm-define-method fetch-field ((entity buffer) field-name) - (save-excursion - (set-buffer (mime-entity-buffer-internal entity)) - (save-restriction - (narrow-to-region (mime-entity-header-start-internal entity) - (mime-entity-header-end-internal entity)) - (std11-fetch-field field-name) - ))) - -(mm-define-method entity-content ((entity buffer)) +(defun mime-insert-header-from-buffer (buffer start end + &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) + (save-restriction + (narrow-to-region start end) + (goto-char start) + (while (re-search-forward std11-field-head-regexp nil t) + (setq f-b (match-beginning 0) + p (match-end 0) + field-name (buffer-substring f-b p) + len (string-width field-name) + f-e (std11-field-end)) + (when (mime-visible-field-p field-name + visible-fields invisible-fields) + (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 + (insert field-name) + (insert (if field-decoder + (funcall field-decoder field-body len) + ;; Don't decode + field-body)) + (insert "\n") + ))))))) + +(luna-define-method mime-insert-header ((entity mime-buffer-entity) + &optional invisible-fields + visible-fields) + (mime-insert-header-from-buffer + (mime-buffer-entity-buffer-internal entity) + (mime-buffer-entity-header-start-internal entity) + (mime-buffer-entity-header-end-internal entity) + invisible-fields visible-fields) + ) + +(luna-define-method mime-entity-content ((entity mime-buffer-entity)) (save-excursion - (set-buffer (mime-entity-buffer-internal entity)) + (set-buffer (mime-buffer-entity-buffer-internal entity)) (mime-decode-string - (buffer-substring (mime-entity-body-start-internal entity) - (mime-entity-body-end-internal entity)) + (buffer-substring (mime-buffer-entity-body-start-internal entity) + (mime-buffer-entity-body-end-internal entity)) (mime-entity-encoding entity)))) +(luna-define-method mime-entity-fetch-field :around + ((entity mime-buffer-entity) field-name) + (or (luna-call-next-method) + (save-excursion + (set-buffer (mime-buffer-entity-buffer-internal entity)) + (save-restriction + (narrow-to-region (mime-buffer-entity-header-start-internal entity) + (mime-buffer-entity-header-end-internal entity)) + (let ((ret (std11-fetch-field field-name))) + (when ret + (or (symbolp field-name) + (setq field-name + (intern (capitalize (capitalize field-name))))) + (mime-entity-set-original-header-internal + entity + (put-alist field-name ret + (mime-entity-original-header-internal entity))) + ret)))))) + (mm-define-method insert-entity-content ((entity buffer)) - (insert (with-current-buffer (mime-entity-buffer-internal entity) + (insert (with-current-buffer (mime-buffer-entity-buffer-internal entity) (mime-decode-string - (buffer-substring (mime-entity-body-start-internal entity) - (mime-entity-body-end-internal entity)) + (buffer-substring (mime-buffer-entity-body-start-internal entity) + (mime-buffer-entity-body-end-internal entity)) (mime-entity-encoding entity))))) (mm-define-method write-entity-content ((entity buffer) filename) (save-excursion - (set-buffer (mime-entity-buffer-internal entity)) - (mime-write-decoded-region (mime-entity-body-start-internal entity) - (mime-entity-body-end-internal entity) + (set-buffer (mime-buffer-entity-buffer-internal entity)) + (mime-write-decoded-region (mime-buffer-entity-body-start-internal entity) + (mime-buffer-entity-body-end-internal entity) filename (or (mime-entity-encoding entity) "7bit")) )) (mm-define-method insert-entity ((entity buffer)) - (insert-buffer-substring (mime-entity-buffer-internal entity) - (mime-entity-header-start-internal entity) - (mime-entity-body-end-internal entity)) + (insert-buffer-substring (mime-buffer-entity-buffer-internal entity) + (mime-buffer-entity-header-start-internal entity) + (mime-buffer-entity-body-end-internal entity)) ) (mm-define-method write-entity ((entity buffer) filename) (save-excursion - (set-buffer (mime-entity-buffer-internal entity)) - (write-region-as-raw-text-CRLF (mime-entity-header-start-internal entity) - (mime-entity-body-end-internal entity) - filename) + (set-buffer (mime-buffer-entity-buffer-internal entity)) + (write-region-as-raw-text-CRLF + (mime-buffer-entity-header-start-internal entity) + (mime-buffer-entity-body-end-internal entity) + filename) )) (mm-define-method write-entity-body ((entity buffer) filename) (save-excursion - (set-buffer (mime-entity-buffer-internal entity)) - (write-region-as-binary (mime-entity-body-start-internal entity) - (mime-entity-body-end-internal entity) + (set-buffer (mime-buffer-entity-buffer-internal entity)) + (write-region-as-binary (mime-buffer-entity-body-start-internal entity) + (mime-buffer-entity-body-end-internal entity) filename) )) +;;; @ header buffer +;;; + +(luna-define-method mime-entity-header-buffer ((entity mime-buffer-entity)) + (mime-buffer-entity-buffer-internal entity) + ) + +(luna-define-method mime-goto-header-start-point ((entity mime-buffer-entity)) + (set-buffer (mime-buffer-entity-buffer-internal entity)) + (goto-char (mime-buffer-entity-header-start-internal entity)) + ) + +(luna-define-method mime-entity-header-start-point ((entity + mime-buffer-entity)) + (mime-buffer-entity-header-start-internal entity) + ) + +(luna-define-method mime-entity-header-end-point ((entity + mime-buffer-entity)) + (mime-buffer-entity-header-end-internal entity) + ) + + +;;; @ body buffer +;;; + +(luna-define-method mime-entity-body-buffer ((entity mime-buffer-entity)) + (mime-buffer-entity-buffer-internal entity) + ) + +(luna-define-method mime-goto-body-start-point ((entity mime-buffer-entity)) + (set-buffer (mime-buffer-entity-buffer-internal entity)) + (goto-char (mime-buffer-entity-body-start-internal entity)) + ) + +(luna-define-method mime-goto-body-end-point ((entity mime-buffer-entity)) + (set-buffer (mime-buffer-entity-buffer-internal entity)) + (goto-char (mime-buffer-entity-body-end-internal entity)) + ) + +(luna-define-method mime-entity-body-start-point ((entity mime-buffer-entity)) + (mime-buffer-entity-body-start-internal entity) + ) + +(luna-define-method mime-entity-body-end-point ((entity mime-buffer-entity)) + (mime-buffer-entity-body-end-internal entity) + ) + + +;;; @ buffer (obsolete) +;;; + +(luna-define-method mime-entity-buffer ((entity mime-buffer-entity)) + (mime-buffer-entity-buffer-internal entity) + ) + +(luna-define-method mime-entity-point-min ((entity mime-buffer-entity)) + (mime-buffer-entity-header-start-internal entity) + ) + +(luna-define-method mime-entity-point-max ((entity mime-buffer-entity)) + (mime-buffer-entity-body-end-internal entity) + ) + + ;;; @ end ;;; diff --git a/mmcooked.el b/mmcooked.el index 6995469..f55a34a 100644 --- a/mmcooked.el +++ b/mmcooked.el @@ -1,6 +1,6 @@ ;;; mmcooked.el --- MIME entity implementation for binary buffer -;; Copyright (C) 1998 Free Software Foundation, Inc. +;; Copyright (C) 1998,1999 Free Software Foundation, Inc. ;; Author: MORIOKA Tomohiko ;; Keywords: MIME, multimedia, mail, news @@ -32,36 +32,40 @@ (mm-define-method write-entity-content ((entity cooked) filename) (save-excursion - (set-buffer (mime-entity-buffer-internal entity)) + (set-buffer (mime-buffer-entity-buffer-internal entity)) (let ((encoding (or (mime-entity-encoding entity) "7bit"))) (if (member encoding '("7bit" "8bit" "binary")) - (write-region (mime-entity-body-start-internal entity) - (mime-entity-body-end-internal entity) filename) - (mime-write-decoded-region (mime-entity-body-start-internal entity) - (mime-entity-body-end-internal entity) - filename encoding) + (write-region (mime-buffer-entity-body-start-internal entity) + (mime-buffer-entity-body-end-internal entity) filename) + (mime-write-decoded-region + (mime-buffer-entity-body-start-internal entity) + (mime-buffer-entity-body-end-internal entity) + filename encoding) )))) (mm-define-method write-entity ((entity cooked) filename) (save-excursion - (set-buffer (mime-entity-buffer-internal entity)) - (write-region (mime-entity-header-start-internal entity) - (mime-entity-body-end-internal entity) + (set-buffer (mime-buffer-entity-buffer-internal entity)) + (write-region (mime-buffer-entity-header-start-internal entity) + (mime-buffer-entity-body-end-internal entity) filename) )) (mm-define-method write-entity-body ((entity cooked) filename) (save-excursion - (set-buffer (mime-entity-buffer-internal entity)) - (write-region (mime-entity-body-start-internal entity) - (mime-entity-body-end-internal entity) + (set-buffer (mime-buffer-entity-buffer-internal entity)) + (write-region (mime-buffer-entity-body-start-internal entity) + (mime-buffer-entity-body-end-internal entity) filename) )) -(mm-define-method insert-header ((entity cooked) - &optional invisible-fields visible-fields) +(luna-define-method mime-insert-header ((entity mime-cooked-entity) + &optional invisible-fields + visible-fields) (let (default-mime-charset) - (funcall (mime-find-function 'insert-decoded-header 'buffer) + (funcall (car (luna-class-find-functions + (luna-find-class 'mime-buffer-entity) + 'mime-insert-header)) entity invisible-fields visible-fields) )) diff --git a/mmdbuffer.el b/mmdbuffer.el new file mode 100644 index 0000000..637eab3 --- /dev/null +++ b/mmdbuffer.el @@ -0,0 +1,250 @@ +;;; mmdual.el --- MIME entity module for dual buffers + +;; Copyright (C) 1998,1999 Free Software Foundation, Inc. +;; Copyright (C) 1999 Electrotechnical Laboratory, JAPAN. +;; Licensed to the Free Software Foundation. + +;; Author: MORIOKA Tomohiko +;; Keywords: MIME, multimedia, mail, news + +;; 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 'mime) + +(eval-and-compile + (luna-define-class mime-dual-entity (mime-entity) + (header-buffer + body-buffer)) + + (luna-define-internal-accessors 'mime-dual-entity) + ) + +(luna-define-method initialize-instance :after ((entity mime-dual-entity) + &rest init-args) + (let (buf) + (setq buf (mime-dual-entity-header-buffer-internal entity)) + (if buf + (with-current-buffer buf + (if (mime-root-entity-p entity) + (setq mime-message-structure entity)) + (or (mime-entity-content-type-internal entity) + (mime-entity-set-content-type-internal + entity + (let ((str (std11-fetch-field "Content-Type"))) + (if str + (mime-parse-Content-Type str) + )))))) + (setq buf (mime-dual-entity-body-buffer-internal entity)) + (if buf + (with-current-buffer buf + (if (mime-root-entity-p entity) + (setq mime-message-structure entity)))) + ) entity) + +(luna-define-method mime-entity-name ((entity mime-dual-entity)) + (buffer-name (mime-dual-entity-header-buffer-internal entity)) + ) + + +(defun mime-visible-field-p (field-name visible-fields invisible-fields) + (or (catch 'found + (while visible-fields + (let ((regexp (car visible-fields))) + (if (string-match regexp field-name) + (throw 'found t) + )) + (setq visible-fields (cdr visible-fields)) + )) + (catch 'found + (while invisible-fields + (let ((regexp (car invisible-fields))) + (if (string-match regexp field-name) + (throw 'found nil) + )) + (setq invisible-fields (cdr invisible-fields)) + ) + t))) + +(defun mime-insert-header-from-buffer (buffer start end + &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) + (save-restriction + (narrow-to-region start end) + (goto-char start) + (while (re-search-forward std11-field-head-regexp nil t) + (setq f-b (match-beginning 0) + p (match-end 0) + field-name (buffer-substring f-b p) + len (string-width field-name) + f-e (std11-field-end)) + (when (mime-visible-field-p field-name + visible-fields invisible-fields) + (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 + (insert field-name) + (insert (if field-decoder + (funcall field-decoder field-body len) + ;; Don't decode + field-body)) + (insert "\n") + ))))))) + +(luna-define-method mime-insert-header ((entity mime-dual-entity) + &optional invisible-fields + visible-fields) + (let* ((buf (mime-dual-entity-header-buffer-internal entity)) + header-start header-end) + (with-current-buffer buf + (setq header-start (point-min) + header-end (point-max))) + (mime-insert-header-from-buffer buf header-start header-end + invisible-fields visible-fields) + )) + +(luna-define-method mime-entity-content ((entity mime-dual-entity)) + (mime-decode-string + (with-current-buffer (mime-dual-entity-body-buffer-internal entity) + (buffer-string)) + (mime-entity-encoding entity))) + +(luna-define-method mime-entity-fetch-field :around + ((entity mime-dual-entity) field-name) + (or (luna-call-next-method) + (with-current-buffer (mime-dual-entity-header-buffer-internal entity) + (let ((ret (std11-fetch-field field-name))) + (when ret + (or (symbolp field-name) + (setq field-name + (intern (capitalize (capitalize field-name))))) + (mime-entity-set-original-header-internal + entity + (put-alist field-name ret + (mime-entity-original-header-internal entity))) + ret))))) + +(luna-define-method mime-insert-entity-content ((entity mime-dual-entity)) + (insert + (mime-decode-string + (with-current-buffer (mime-dual-entity-body-buffer-internal entity) + (buffer-substring (point-min)(point-max))) + (mime-entity-encoding entity)))) + +(luna-define-method mime-write-entity-content ((entity mime-dual-entity) + filename) + (with-current-buffer (mime-dual-entity-body-buffer-internal entity) + (mime-write-decoded-region (point-min) + (point-max) + filename + (or (mime-entity-encoding entity) "7bit")))) + +(luna-define-method mime-insert-entity ((entity mime-dual-entity)) + (let (buf) + (setq buf (mime-dual-entity-header-buffer-internal entity)) + (when buf + (insert-buffer (mime-dual-entity-header-buffer-internal entity)) + (setq buf (mime-dual-entity-body-buffer-internal entity)) + (when buf + (insert "\n") + (insert-buffer buf))))) + +(luna-define-method mime-write-entity ((entity mime-dual-entity) filename) + (let (buf) + (setq buf (mime-dual-entity-header-buffer-internal entity)) + (if (null buf) + (error "No header buffer.") + (with-current-buffer buf + (write-region-as-raw-text-CRLF + (point-min)(point-max) filename)) + (setq buf (mime-dual-entity-body-buffer-internal entity)) + (when buf + (with-temp-buffer + (insert "\n") + (write-region-as-raw-text-CRLF + (point-min)(point-max) + filename 'append)) + (with-current-buffer buf + (write-region-as-raw-text-CRLF + (point-min)(point-max) + filename 'append)))))) + +(luna-define-method mime-write-entity-body ((entity mime-dual-entity) filename) + (with-current-buffer (mime-dual-entity-body-buffer-internal entity) + (write-region-as-binary (point-min)(point-max) + filename))) + + +;;; @ buffer +;;; + +(luna-define-method mime-entity-header-buffer ((entity mime-dual-entity)) + (mime-dual-entity-header-buffer-internal entity)) + +(luna-define-method mime-entity-body-buffer ((entity mime-dual-entity)) + (mime-dual-entity-body-buffer-internal entity)) + +(luna-define-method mime-entity-buffer ((entity mime-dual-entity)) + (message "mime-dual-entity does not have mime-entity-buffer.") + nil) + +(luna-define-method mime-entity-body-start-point ((entity mime-dual-entity)) + (with-current-buffer (mime-entity-body-buffer entity) + (point-min))) + +(luna-define-method mime-entity-body-end-point ((entity mime-dual-entity)) + (with-current-buffer (mime-entity-body-buffer entity) + (point-max))) + +(luna-define-method mime-entity-point-min ((entity mime-dual-entity)) + (message "mime-dual-entity does not have mime-entity-point-min.") + nil) + +(luna-define-method mime-entity-point-max ((entity mime-dual-entity)) + (message "mime-dual-entity does not have mime-entity-point-max.") + nil) + +(luna-define-method mime-goto-header-start-point ((entity mime-dual-entity)) + (set-buffer (mime-dual-entity-header-buffer-internal entity)) + (goto-char (point-min))) + +(luna-define-method mime-goto-body-start-point ((entity mime-dual-entity)) + (set-buffer (mime-dual-entity-body-buffer-internal entity)) + (goto-char (point-min))) + +(luna-define-method mime-goto-body-end-point ((entity mime-dual-entity)) + (set-buffer (mime-dual-entity-body-buffer-internal entity)) + (goto-char (point-max))) + + +;;; @ end +;;; + +(provide 'mmdual) + +;;; mmdual.el ends here diff --git a/smtp.el b/smtp.el index baef1ec..532bb14 100644 --- a/smtp.el +++ b/smtp.el @@ -1,11 +1,10 @@ ;;; smtp.el --- basic functions to send mail with SMTP server -;; Copyright (C) 1995, 1996, 1998 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1996, 1998, 1999 Free Software Foundation, Inc. ;; Author: Tomoji Kagatani -;; Simon Leinen (ESMTP support) -;; MORIOKA Tomohiko (separate smtp.el from smtpmail.el) -;; Shuhei KOBAYASHI +;; Simon Leinen (ESMTP support) +;; Shuhei KOBAYASHI ;; Keywords: SMTP, mail ;; This file is part of FLIM (Faithful Library about Internet Message). @@ -73,6 +72,12 @@ don't define this value." :type 'boolean :group 'smtp) +(defcustom smtp-notify-success nil + "*If non-nil, notification for successful mail delivery is returned + to user (RFC1891)." + :type 'boolean + :group 'smtp) + (defvar smtp-read-point nil) (defun smtp-make-fqdn () @@ -203,7 +208,11 @@ don't define this value." ;; RCPT TO: (while recipients (smtp-send-command process - (format "RCPT TO:<%s>" (car recipients))) + (format + (if smtp-notify-success + "RCPT TO:<%s> NOTIFY=SUCCESS" + "RCPT TO:<%s>") + (car recipients))) (setq recipients (cdr recipients)) (setq response (smtp-read-response process)) (if (or (null (car response)) diff --git a/smtpmail.el b/smtpmail.el index 1cb7a1f..e5fbe5a 100644 --- a/smtpmail.el +++ b/smtpmail.el @@ -1,6 +1,6 @@ ;;; smtpmail.el --- SMTP interface for mail-mode -;; Copyright (C) 1995, 1996, 1998 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1996, 1998, 1999 Free Software Foundation, Inc. ;; Author: Tomoji Kagatani ;; Keywords: mail @@ -130,7 +130,9 @@ This is relative to `smtpmail-queue-dir'.") (save-restriction (narrow-to-region (point) (save-excursion - (end-of-line) + (forward-line 1) + (while (looking-at "^[ \t]") + (forward-line 1)) (point))) (append (mail-parse-comma-list) resend-to-addresses)))) @@ -230,8 +232,9 @@ This is relative to `smtpmail-queue-dir'.") (error "Sending failed; no recipients")) (let* ((file-data (concat smtpmail-queue-dir - (time-stamp-strftime - "%02y%02m%02d-%02H%02M%02S"))) + (mapconcat + (lambda (arg) (format "%x" arg)) + (current-time) ""))) (file-elisp (concat file-data ".el")) (buffer-data (create-file-buffer file-data)) (buffer-elisp (create-file-buffer file-elisp)) @@ -240,7 +243,7 @@ This is relative to `smtpmail-queue-dir'.") (set-buffer buffer-data) (erase-buffer) (insert-buffer tembuf) - (write-file file-data) + (write-region-as-binary (point-min) (point-max) file-data) (set-buffer buffer-elisp) (erase-buffer) (insert (concat @@ -276,7 +279,7 @@ This is relative to `smtpmail-queue-dir'.") (end-of-line) (point)))) (load file-msg) - (setq tembuf (find-file-noselect file-msg)) + (setq tembuf (find-file-noselect-as-binary file-msg)) (if smtpmail-recipient-address-list (if (not (smtp-via-smtp user-mail-address smtpmail-recipient-address-list tembuf))