From 95539eb34d47f5434055c634da1fe6b145f2359d Mon Sep 17 00:00:00 2001 From: morioka Date: Tue, 1 Jun 1999 09:12:46 +0000 Subject: [PATCH] Merge chao-1_13_0. --- ChangeLog | 267 ++++++++++++++++++++++++++++++++++++++++++++ FLIM-ELS | 4 +- Makefile | 11 +- VERSION | 1 + ftp.in | 4 +- luna.el | 344 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ mailcap.el | 3 +- mel-b-ccl.el | 2 +- mel-b-dl.el | 4 +- mel-b-el.el | 4 +- mel-g.el | 3 +- mel-q-ccl.el | 2 +- mel-q.el | 2 +- mel-u.el | 2 +- mel.el | 9 +- mime-def.el | 267 +++++++++++--------------------------------- mime-parse.el | 129 +++++++++++----------- mime.el | 251 +++++++++++++++++++---------------------- mmbuffer.el | 304 +++++++++++++++++++++++++++++++++++++++----------- mmcooked.el | 36 +++--- mmgeneric.el | 219 ------------------------------------ smtp.el | 7 +- smtpmail.el | 2 +- 23 files changed, 1146 insertions(+), 731 deletions(-) create mode 100644 luna.el delete mode 100644 mmgeneric.el diff --git a/ChangeLog b/ChangeLog index c5598ef..d01613f 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,270 @@ +1999-06-01 MORIOKA Tomohiko + + * Chao: Version 1.13.0 (JR Fujinomori) released. + +1999-05-29 MORIOKA Tomohiko + + * mmbuffer.el (mime-entity-fetch-field): New implementation. + + * mime-def.el (mime-entity-fetch-field): New method of luna-class + `mime-entity'. + + * luna.el (luna-define-method): Allow `:around' qualifier. + (luna-class-find-functions): Likewise. + (luna-send): Likewise. + (luna-call-next-method): New function. + +1999-05-26 MORIOKA Tomohiko + + * mime-def.el (eval-module-depended-macro): Abolished. + Use `def-edebug-spec' directly. + + * luna.el (luna-define-method): Allow `:before' qualifier. + (luna-class-find-functions): Likewise. + + * mime-def.el (mime-message-structure): Define as obsolete + variable. + +1999-05-26 MORIOKA Tomohiko + + * mime-parse.el (mime-parse-encapsulated): Use + `mime-entity-body-start-point' and `mime-entity-body-end-point'. + + * mime.el (mime-parse-buffer): Revert to auto-load from + "mime-parse". + + * mime-parse.el (mime-parse-multipart): Move from mime-parse.el + again. + (mime-parse-encapsulated): Likewise. + (mime-parse-message): Likewise. + (mime-parse-buffer): Likewise. + + * mmbuffer.el (mime-parse-multipart): Move to mime-parse.el again. + (mime-parse-encapsulated): Likewise. + (mime-parse-message): Likewise. + (mime-parse-buffer): Likewise. + + * mmbuffer.el (mime-parse-encapsulated): Run in body-buffer of an + entity. + +1999-05-26 MORIOKA Tomohiko + + * mmbuffer.el (initialize-instance): Don't initialize slots if + they are initialized. + (mime-parse-multipart): Run in body-buffer of an entity. + (mime-entity-body-start-point): New method. + +1999-05-25 MORIOKA Tomohiko + + * mmbuffer.el (mime-entity-body-end-point): New method. + (mime-goto-header-start-point): New method. + (mime-goto-body-start-point): New method. + (mime-goto-body-end-point): New method. + + * mime.el (mime-goto-body-end-point): New generic function. + + * mel.el (Q-encoded-text-length): Fixed. + +1999-05-24 MORIOKA Tomohiko + + * mmbuffer.el (mime-parse-multipart): Refer body-start instead of + header-end. + + * mmcooked.el (mime-insert-header): Fix typo. + +1999-05-23 MORIOKA Tomohiko + + * mmcooked.el (mime-insert-header): Use + `luna-class-find-functions'. + + * mime.el (mime-entity-buffer): Define as obsolete function. + (mime-entity-body-end-point): New generic function; define + `mime-entity-body-end' as obsolete function. + (mime-goto-body-start-point): New generic function. + (mime-entity-uu-filename): Use `mime-goto-body-start-point' and + `mime-entity-body-end-point'. + + * mmbuffer.el (initialize-instance): Define as after method; + return initialized instance. + + * luna.el (luna-define-class): Add `standard-object' as a parent. + (luna-define-method): Allow `:after' qualifier. + (luna-class-find-parents-functions): New function. + (luna-class-find-functions): New function [abolish + `luna-class-find-function']. + (luna-find-functions): New function [abolish + `luna-find-function']. + (luna-send): Modify for new method dispatch mechanism. + (luna-make-entity): New implementation. + (standard-object): New class. + (initialize-instance): New method. + +1999-05-22 MORIOKA Tomohiko + + * Delete mmgeneric.el. + + * mmcooked.el: Modify for mmbuffer.el. + + * mmbuffer.el: + - Don't require `mmgeneric' and `mime-parse'. + - Require mime. + - Use `luna'. + (mime-buffer-entity-buffer-internal): Renamed from + `mime-entity-set-buffer-internal'. + (mime-buffer-entity-set-buffer-internal): Likewise. + (mime-buffer-entity-header-start-internal): Likewise. + (mime-buffer-entity-set-header-start-internal): Likewise. + (mime-buffer-entity-header-end-internal): Likewise. + (mime-buffer-entity-set-header-end-internal): Likewise. + (mime-buffer-entity-body-start-internal): Likewise. + (mime-buffer-entity-set-body-start-internal): Likewise. + (mime-buffer-entity-body-end-internal): Likewise. + (mime-buffer-entity-set-body-end-internal): Likewise. + (mime-entity-name): New method. + (mime-parse-multipart): New function [moved from mime-parse.el]. + (mime-parse-encapsulated): Likewise. + (mime-parse-message): Likewise. + (mime-entity-children): New method. + (mime-goto-header-start-point): New method. + (mime-visible-field-p): New function [moved from mmgeneric.el]. + (mime-insert-header-from-buffer): Likewise. + (mime-insert-header): New method. + (mime-entity-content): Use `luna-define-method'. + (mime-insert-text-content): New method. + ((mime-entity-fetch-field): Use `luna-define-method'. + (mime-entity-header-buffer): New method. + (mime-entity-body-buffer): Likewise. + (mime-entity-buffer): Likewise. + (mime-entity-point-min): Use `luna-define-method'. + (mime-entity-point-max): Use `luna-define-method'. + (mime-parse-buffer): New function [moved from mmgeneric.el]. + + * mime-parse.el (mime-parse-multipart): Moved to mmbuffer.el. + (mime-parse-encapsulated): Likewise. + (mime-parse-message): Likewise. + (mime-parse-buffer): Likewise. + + * mime.el (mime-parse-buffer): Auto-loaded from "mmbufer". + (mime-find-function): Abolished. + (mime-entity-function): Abolished. + (mime-entity-send): Use `luna-send'. + (mime-open-entity): Use `luna-make-entity' and + `mm-expand-class-name'. + (mime-entity-cooked-p): Use `luna-define-generic'. + (mime-entity-children): Use `luna-send'. + (mime-find-entity-from-content-id): Use `mime-entity-read-field'. + (mime-entity-buffer): Change to generic function. + (mime-entity-header-buffer): New generic function. + (mime-entity-body-buffer): Likewise. + (mime-entity-point-min): Use `luna-define-generic'. + (mime-entity-point-max): Likewise. + (mime-entity-header-start): Abolished. + (mime-entity-header-end): Abolished. + (mime-entity-body-start): Abolished. + (mime-entity-body-end): Abolished. + (mime-goto-header-start-point): New generic function. + (mime-entity-fetch-field): New generic function. + (mime-fetch-field): Use `mime-entity-fetch-field'; declare as + obsolete function. + (mime-entity-content-type): Use `mime-entity-fetch-field'. + (mime-entity-content-disposition): Likewise. + (mime-entity-encoding): Likewise. + (mime-entity-read-field): New function. + (mime-read-field): Use `mime-entity-read-field'; declare as + obsolete function. + (mime-insert-header): Use `luna-define-generic'; abolish obsolete + alias `mime-insert-decoded-header'. + (mime-entity-name): New generic function. + (mime-entity-content): Use `luna-define-generic'. + (mime-insert-entity-content): Likewise. + (mime-write-entity-content): Likewise. + (mime-insert-text-content): Likewise. + (mime-insert-entity): Likewise. + (mime-write-entity): Likewise. + (mime-write-entity-body): Likewise. + + * mime-def.el: + - Use `luna'. + (make-mime-entity-internal): Abolished. + (mime-entity-representation-type-internal): Change to alias for + `luna-class-name'. + (mime-entity-set-representation-type-internal): Change to alias + for `luna-set-class-name'. + (mime-entity-location-internal): Defined by + `luna-define-internal-accessors'. + (mime-entity-set-location-internal): Likewise. + (mime-entity-content-type-internal): Likewise. + (mime-entity-set-content-type-internal): Likewise. + (mime-entity-content-disposition-internal): Likewise. + (mime-entity-set-content-disposition-internal): Likewise. + (mime-entity-encoding-internal): Likewise. + (mime-entity-set-encoding-internal): Likewise. + (mime-entity-children-internal): Likewise. + (mime-entity-set-children-internal): Likewise. + (mime-entity-parent-internal): Likewise. + (mime-entity-set-parent-internal): Likewise. + (mime-entity-node-id-internal): Likewise. + (mime-entity-decoded-subject-internal): Abolished. + (mime-entity-set-decoded-subject-internal): Abolished. + (mime-entity-decoded-from-internal): Abolished. + (mime-entity-set-decoded-from-internal): Abolished. + (mime-entity-date-internal): Abolished. + (mime-entity-set-date-internal): Abolished. + (mime-entity-message-id-internal): Abolished. + (mime-entity-set-message-id-internal): Abolished. + (mime-entity-references-internal): Abolished. + (mime-entity-set-references-internal): Abolished. + (mime-entity-chars-internal): Abolished. + (mime-entity-set-chars-internal): Abolished. + (mime-entity-lines-internal): Abolished. + (mime-entity-set-lines-internal): Abolished. + (mime-entity-xref-internal): Abolished. + (mime-entity-set-xref-internal): Abolished. + (mime-entity-original-header-internal): Defined by + `luna-define-internal-accessors'. + (mime-entity-set-original-header-internal): Likewise. + (mime-entity-parsed-header-internal): Likewise. + (mime-entity-set-parsed-header-internal): Likewise. + (mime-entity-buffer-internal): Abolished. + (mime-entity-set-buffer-internal): Abolished. + (mime-entity-header-start-internal): Abolished. + (mime-entity-set-header-start-internal): Abolished. + (mime-entity-header-end-internal): Abolished. + (mime-entity-set-header-end-internal): Abolished. + (mime-entity-body-start-internal): Abolished. + (mime-entity-set-body-start-internal): Abolished. + (mime-entity-body-end-internal): Abolished. + (mime-entity-set-body-end-internal): Abolished. + (mm-expand-class-name): New macro. + (mm-define-backend): Use `luna-define-class' and + `mm-expand-class-name'. + (mm-define-method): Use `luna-define-method' and + `mm-expand-class-name'. + (mm-arglist-to-arguments): Abolished. + (mel-define-service): Use `luna-arglist-to-arguments' instead of + `mm-arglist-to-arguments'. + + * mel.el: Require `alist'. + + * FLIM-ELS (flim-modules): Add `luna' and delete `mmgeneric'. + + * luna.el: + - Rename property `luna-member-index' to `luna-slot-index'. + - Rearrangement to avoid byte-compiling problem. + (luna-define-class-function): New function. + (luna-define-class): Use `luna-define-class-function'. + (luna-define-generic): Fixed. + (luna-define-internal-accessors): New function. + +1999-05-15 MORIOKA Tomohiko + + * luna.el (luna-make-entity-function): Send `initialize-instance'. + +1999-05-14 MORIOKA Tomohiko + + * luna.el: New module. + + 1999-05-31 MORIOKA Tomohiko * FLIM: Version 1.12.7 (Y-Dþzaki)-A released. diff --git a/FLIM-ELS b/FLIM-ELS index d389fa4..418c328 100644 --- a/FLIM-ELS +++ b/FLIM-ELS @@ -5,10 +5,10 @@ ;;; Code: (setq flim-modules '(std11 - mime-def + luna mime-def mel mel-q mel-u mel-g eword-decode eword-encode - mime mime-parse mmgeneric mmbuffer mmcooked + mime mime-parse mmbuffer mmcooked mailcap smtp smtpmail)) diff --git a/Makefile b/Makefile index 56f1304..5a78811 100644 --- a/Makefile +++ b/Makefile @@ -2,9 +2,9 @@ # Makefile for FLIM. # -PACKAGE = flim -API = 1.12 -RELEASE = 7 +PACKAGE = chao +API = 1.13 +RELEASE = 0 TAR = tar RM = /bin/rm -f @@ -25,7 +25,7 @@ GOMI = *.elc \ FILES = README.?? Makefile FLIM-MK FLIM-CFG FLIM-ELS *.el ChangeLog VERSION = $(API).$(RELEASE) -ARC_DIR = /pub/mule/flim/$(PACKAGE)-$(API) +ARC_DIR = /pub/mule/flim/flim-$(API) SEMI_ARC_DIR = /pub/mule/semi/semi-1.13-for-flim-$(API) elc: @@ -58,7 +58,8 @@ tar: 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 | sed "s/API/$(API)/" > ftp + sed "s/VERSION/$(VERSION)/" < ftp.in | sed "s/API/$(API)/" \ + | sed "s/PACKAGE/$(PACKAGE)/" > ftp release: -$(RM) $(ARC_DIR)/$(PACKAGE)-$(VERSION).tar.gz diff --git a/VERSION b/VERSION index a4dbc84..6e4ed5b 100644 --- a/VERSION +++ b/VERSION @@ -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..39ff790 100644 --- a/ftp.in +++ b/ftp.in @@ -8,10 +8,10 @@ access-type=anon-ftp; site="ftp.etl.go.jp"; 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..65c647a --- /dev/null +++ b/luna.el @@ -0,0 +1,344 @@ +;;; 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)) + +(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) + (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-def.el b/mime-def.el index 75375f4..88e788e 100644 --- a/mime-def.el +++ b/mime-def.el @@ -1,8 +1,10 @@ ;;; mime-def.el --- definition module about MIME ;; Copyright (C) 1995,1996,1997,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: definition, MIME, multimedia, mail, news ;; This file is part of FLIM (Faithful Library about Internet Message). @@ -33,7 +35,7 @@ (eval-when-compile (require 'cl)) ; list* (eval-and-compile - (defconst mime-library-product ["FLIM" (1 12 7) "Y.DŽþzaki"] + (defconst mime-library-product ["Chao" (1 13 0) "JR Fujinomori"] "Product name, version number and code name of MIME-library package.") ) @@ -57,6 +59,8 @@ ;;; @ variables ;;; +(require 'custom) + (defgroup mime '((default-mime-charset custom-variable)) "Emacs MIME Interfaces" :group 'news @@ -206,125 +210,63 @@ ;;; @ MIME entity ;;; -(defmacro make-mime-entity-internal (representation-type location - &optional content-type - children parent node-id - ;; for NOV - decoded-subject decoded-from - date message-id references - chars lines - xref - ;; for other fields - original-header parsed-header - ;; for buffer representation - buffer - header-start header-end - body-start body-end) - `(vector ,representation-type ,location - ,content-type nil nil ,children ,parent ,node-id - ;; for NOV - ,decoded-subject ,decoded-from - ,date ,message-id ,references - ,chars ,lines - ,xref - ;; for other fields - ,original-header ,parsed-header - ;; for buffer representation - ,buffer ,header-start ,header-end ,body-start ,body-end)) - -(defmacro mime-entity-representation-type-internal (entity) - `(aref ,entity 0)) -(defmacro mime-entity-set-representation-type-internal (entity type) - `(aset ,entity 0 ,type)) -(defmacro mime-entity-location-internal (entity) - `(aref ,entity 1)) -(defmacro mime-entity-set-location-internal (entity location) - `(aset ,entity 1 ,location)) - -(defmacro mime-entity-content-type-internal (entity) - `(aref ,entity 2)) -(defmacro mime-entity-set-content-type-internal (entity type) - `(aset ,entity 2 ,type)) -(defmacro mime-entity-content-disposition-internal (entity) - `(aref ,entity 3)) -(defmacro mime-entity-set-content-disposition-internal (entity disposition) - `(aset ,entity 3 ,disposition)) -(defmacro mime-entity-encoding-internal (entity) - `(aref ,entity 4)) -(defmacro mime-entity-set-encoding-internal (entity encoding) - `(aset ,entity 4 ,encoding)) - -(defmacro mime-entity-children-internal (entity) - `(aref ,entity 5)) -(defmacro mime-entity-set-children-internal (entity children) - `(aset ,entity 5 ,children)) -(defmacro mime-entity-parent-internal (entity) - `(aref ,entity 6)) -(defmacro mime-entity-node-id-internal (entity) - `(aref ,entity 7)) - -(defmacro mime-entity-decoded-subject-internal (entity) - `(aref ,entity 8)) -(defmacro mime-entity-set-decoded-subject-internal (entity subject) - `(aset ,entity 8 ,subject)) -(defmacro mime-entity-decoded-from-internal (entity) - `(aref ,entity 9)) -(defmacro mime-entity-set-decoded-from-internal (entity from) - `(aset ,entity 9 ,from)) -(defmacro mime-entity-date-internal (entity) - `(aref ,entity 10)) -(defmacro mime-entity-set-date-internal (entity date) - `(aset ,entity 10 ,date)) -(defmacro mime-entity-message-id-internal (entity) - `(aref ,entity 11)) -(defmacro mime-entity-set-message-id-internal (entity message-id) - `(aset ,entity 11 ,message-id)) -(defmacro mime-entity-references-internal (entity) - `(aref ,entity 12)) -(defmacro mime-entity-set-references-internal (entity references) - `(aset ,entity 12 ,references)) -(defmacro mime-entity-chars-internal (entity) - `(aref ,entity 13)) -(defmacro mime-entity-set-chars-internal (entity chars) - `(aset ,entity 13 ,chars)) -(defmacro mime-entity-lines-internal (entity) - `(aref ,entity 14)) -(defmacro mime-entity-set-lines-internal (entity lines) - `(aset ,entity 14 ,lines)) -(defmacro mime-entity-xref-internal (entity) - `(aref ,entity 15)) -(defmacro mime-entity-set-xref-internal (entity xref) - `(aset ,entity 15 ,xref)) - -(defmacro mime-entity-original-header-internal (entity) - `(aref ,entity 16)) -(defmacro mime-entity-set-original-header-internal (entity header) - `(aset ,entity 16 ,header)) -(defmacro mime-entity-parsed-header-internal (entity) - `(aref ,entity 17)) -(defmacro mime-entity-set-parsed-header-internal (entity header) - `(aset ,entity 17 ,header)) - -(defmacro mime-entity-buffer-internal (entity) - `(aref ,entity 18)) -(defmacro mime-entity-set-buffer-internal (entity buffer) - `(aset ,entity 18 ,buffer)) -(defmacro mime-entity-header-start-internal (entity) - `(aref ,entity 19)) -(defmacro mime-entity-set-header-start-internal (entity point) - `(aset ,entity 19 ,point)) -(defmacro mime-entity-header-end-internal (entity) - `(aref ,entity 20)) -(defmacro mime-entity-set-header-end-internal (entity point) - `(aset ,entity 20 ,point)) -(defmacro mime-entity-body-start-internal (entity) - `(aref ,entity 21)) -(defmacro mime-entity-set-body-start-internal (entity point) - `(aset ,entity 21 ,point)) -(defmacro mime-entity-body-end-internal (entity) - `(aref ,entity 22)) -(defmacro mime-entity-set-body-end-internal (entity point) - `(aset ,entity 22 ,point)) +(require 'luna) + +(luna-define-class mime-entity () + (location + content-type children parent + node-id + content-disposition encoding + ;; for other fields + original-header parsed-header)) + +(defalias 'mime-entity-representation-type-internal 'luna-class-name) +(defalias 'mime-entity-set-representation-type-internal 'luna-set-class-name) + +(luna-define-internal-accessors 'mime-entity) + +(luna-define-method mime-entity-fetch-field ((entity mime-entity) + field-name) + (or (symbolp field-name) + (setq field-name (intern (capitalize (capitalize field-name))))) + (cdr (assq field-name + (mime-entity-original-header-internal entity)))) + + +;;; @ for mm-backend +;;; + +(defmacro mm-expand-class-name (type) + `(intern (format "mime-%s-entity" ,type))) + +(defmacro mm-define-backend (type &optional parents) + `(luna-define-class ,(mm-expand-class-name type) + ,(nconc (mapcar (lambda (parent) + (mm-expand-class-name parent) + ) + parents) + '(mime-entity)))) + +(defmacro mm-define-method (name args &rest body) + (or (eq name 'initialize-instance) + (setq name (intern (format "mime-%s" name)))) + (let ((spec (car args))) + (setq args + (cons (list (car spec) + (mm-expand-class-name (nth 1 spec))) + (cdr args))) + `(luna-define-method ,name ,args ,@body) + )) + +(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)) ;;; @ message structure @@ -336,12 +278,7 @@ Please use reference function `mime-entity-SLOT' to get value of SLOT. Following is a list of slots of the structure: -buffer buffer includes this entity (buffer). node-id node-id (list of integers) -header-start minimum point of header in raw-buffer -header-end maximum point of header in raw-buffer -body-start minimum point of body in raw-buffer -body-end maximum point of body in raw-buffer content-type content-type (content-type) content-disposition content-disposition (content-disposition) encoding Content-Transfer-Encoding (string or nil) @@ -353,81 +290,7 @@ message/rfc822, `mime-entity' structures of them are included in (make-variable-buffer-local 'mime-message-structure) - -;;; @ for mm-backend -;;; - -(defvar mime-entity-implementation-alist nil) - -(defmacro mm-define-backend (type &optional parents) - "Define TYPE as a mm-backend. -If PARENTS is specified, TYPE inherits PARENTS. -Each parent must be backend name (symbol)." - (if parents - `(let ((rest ',(reverse parents))) - (while rest - (set-alist 'mime-entity-implementation-alist - ',type - (copy-alist - (cdr (assq (car rest) - mime-entity-implementation-alist)))) - (setq rest (cdr rest)) - )))) - -(defmacro mm-define-method (name args &rest body) - "Define NAME as a method function of (nth 1 (car ARGS)) backend. - -ARGS is like an argument list of lambda, but (car ARGS) must be -specialized parameter. (car (car ARGS)) is name of variable and (nth -1 (car ARGS)) is name of backend." - (let* ((specializer (car args)) - (class (nth 1 specializer)) - (self (car specializer))) - `(let ((imps (cdr (assq ',class mime-entity-implementation-alist))) - (func (lambda ,(if self - (cons self (cdr args)) - (cdr args)) - ,@body))) - (if imps - (set-alist 'mime-entity-implementation-alist - ',class (put-alist ',name func imps)) - (set-alist 'mime-entity-implementation-alist - ',class - (list (cons ',name func))) - )))) - -(put 'mm-define-method 'lisp-indent-function 'defun) - -(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) - (while arglist - (let ((arg (car arglist))) - (or (memq arg '(&optional &rest)) - (setq dest (cons arg dest))) - ) - (setq arglist (cdr arglist))) - (nreverse dest))) +(make-obsolete-variable 'mime-message-structure "should not use it.") ;;; @ for mel-backend @@ -446,7 +309,7 @@ service." `((defun ,name ,args ,@rest (funcall (mel-find-function ',name ,(car (last args))) - ,@(mm-arglist-to-arguments (butlast args))) + ,@(luna-arglist-to-arguments (butlast args))) ))) )) diff --git a/mime-parse.el b/mime-parse.el index 7d760c4..4a49855 100644 --- a/mime-parse.el +++ b/mime-parse.el @@ -213,70 +213,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 +305,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) )) diff --git a/mime.el b/mime.el index ce23631..57cd04f 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,73 @@ If MESSAGE is specified, it is regarded as root entity." (null (mime-entity-parent entity message))) -;;; @ Entity Buffer +;;; @ Header buffer +;;; + +(luna-define-generic mime-entity-header-buffer (entity)) + +(luna-define-generic mime-goto-header-start-point (entity) + "Set buffer and point to header-start-position of ENTITY.") + + +;;; @ Body buffer ;;; -(defun mime-entity-buffer (entity) - (or (mime-entity-buffer-internal entity) - (mime-entity-send entity 'entity-buffer))) +(luna-define-generic mime-entity-body-buffer (entity)) + +(luna-define-generic mime-entity-body-start-point (entity) + "Set buffer and point to 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) + "Set buffer and point to body-end-position of ENTITY.") + +(define-obsolete-function-alias + 'mime-entity-body-end 'mime-entity-body-end-point) + +(luna-define-generic mime-goto-body-start-point (entity) + "Set buffer and point to body-start-position of ENTITY.") + +(luna-define-generic mime-goto-body-end-point (entity) + "Set buffer and point to body-end-position of ENTITY.") -(mm-define-generic entity-point-min (entity) - "Return the start point of ENTITY in the buffer which contains ENTITY.") -(mm-define-generic entity-point-max (entity) - "Return the end point of ENTITY in the buffer which contains ENTITY.") +;;; @ Entity buffer (obsolete) +;;; -(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-buffer (entity)) -(defun mime-entity-header-end (entity) - (or (mime-entity-header-end-internal entity) - (mime-entity-send entity 'entity-header-end))) +(make-obsolete + 'mime-entity-buffer + "use mime-entity-header-buffer or mime-entity-body-buffer instead.") -(defun mime-entity-body-start (entity) - (or (mime-entity-body-start-internal entity) - (mime-entity-send entity 'entity-body-start))) +(luna-define-generic mime-entity-point-min (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-entity-point-max (entity)) ;;; @ 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 +217,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 +225,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 +261,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 +349,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..bb2a31c 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,277 @@ ;;; 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)) +(luna-define-method mime-entity-children ((entity mime-buffer-entity)) + (let* ((content-type (mime-entity-content-type entity)) + (primary-type (mime-content-type-primary-type content-type))) + (cond ((eq primary-type 'multipart) + (mime-parse-multipart entity) + ) + ((and (eq primary-type 'message) + (memq (mime-content-type-subtype content-type) + '(rfc822 news external-body) + )) + (mime-parse-encapsulated entity) + )) + )) -(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-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-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-insert-text-content ((entity mime-buffer-entity)) + (insert + (decode-mime-charset-string (mime-entity-content entity) + (or (mime-content-type-parameter + (mime-entity-content-type entity) + "charset") + default-mime-charset) + 'CRLF) + )) + +;;; redefine to speed up + +(mm-define-method entity-point-min ((entity buffer)) + (mime-buffer-entity-header-start-internal entity)) + +(mm-define-method entity-point-max ((entity buffer)) + (mime-buffer-entity-body-end-internal 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) )) +;;; @ buffer +;;; + +(luna-define-method mime-entity-header-buffer ((entity mime-buffer-entity)) + (mime-buffer-entity-buffer-internal entity) + ) + +(luna-define-method mime-entity-body-buffer ((entity mime-buffer-entity)) + (mime-buffer-entity-buffer-internal entity) + ) + +(luna-define-method mime-entity-buffer ((entity mime-buffer-entity)) + (mime-buffer-entity-buffer-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) + ) + +(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) + ) + +(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-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)) + ) + + ;;; @ 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/mmgeneric.el b/mmgeneric.el deleted file mode 100644 index df11185..0000000 --- a/mmgeneric.el +++ /dev/null @@ -1,219 +0,0 @@ -;;; mmgeneric.el --- MIME entity module for generic buffer - -;; Copyright (C) 1998,1999 Free Software Foundation, Inc. - -;; 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) -(require 'mime-parse) - -(mm-define-backend generic) - -(mm-define-method entity-header-start ((entity generic)) - (mime-entity-set-header-start-internal - entity - (save-excursion - (set-buffer (mime-entity-buffer entity)) - (point-min) - ))) - -(mm-define-method entity-header-end ((entity generic)) - (save-excursion - (set-buffer (mime-entity-buffer entity)) - (mime-entity-header-end-internal entity) - )) - -(mm-define-method entity-body-start ((entity generic)) - (mime-entity-set-body-start-internal - entity - (save-excursion - (set-buffer (mime-entity-buffer entity)) - (mime-entity-body-start-internal entity) - ))) - -(mm-define-method entity-body-end ((entity generic)) - (mime-entity-set-body-end-internal - entity - (save-excursion - (set-buffer (mime-entity-buffer entity)) - (point-max) - ))) - -(mm-define-method entity-point-min ((entity generic)) - (or (mime-entity-header-start-internal entity) - (mime-entity-send entity 'entity-header-start))) - -(mm-define-method entity-point-max ((entity generic)) - (or (mime-entity-body-end-internal entity) - (mime-entity-send entity 'entity-body-end))) - -(mm-define-method fetch-field ((entity generic) field-name) - (save-excursion - (set-buffer (mime-entity-buffer 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-cooked-p ((entity generic)) nil) - -(mm-define-method entity-children ((entity generic)) - (let* ((content-type (mime-entity-content-type entity)) - (primary-type (mime-content-type-primary-type content-type))) - (cond ((eq primary-type 'multipart) - (mime-parse-multipart entity) - ) - ((and (eq primary-type 'message) - (memq (mime-content-type-subtype content-type) - '(rfc822 news external-body) - )) - (mime-parse-encapsulated entity) - )) - )) - -(mm-define-method entity-content ((entity generic)) - (save-excursion - (set-buffer (mime-entity-buffer entity)) - (mime-decode-string - (buffer-substring (mime-entity-body-start-internal entity) - (mime-entity-body-end-internal entity)) - (mime-entity-encoding entity)))) - -(mm-define-method insert-entity-content ((entity generic)) - (insert (with-current-buffer (mime-entity-buffer entity) - (mime-decode-string - (buffer-substring (mime-entity-body-start-internal entity) - (mime-entity-body-end-internal entity)) - (mime-entity-encoding entity))))) - -(mm-define-method write-entity-content ((entity generic) filename) - (save-excursion - (set-buffer (mime-entity-buffer entity)) - (mime-write-decoded-region (mime-entity-body-start-internal entity) - (mime-entity-body-end-internal entity) - filename - (or (mime-entity-encoding entity) "7bit")) - )) - -(mm-define-method insert-entity ((entity generic)) - (insert-buffer-substring (mime-entity-buffer entity) - (mime-entity-header-start-internal entity) - (mime-entity-body-end-internal entity)) - ) - -(mm-define-method write-entity ((entity generic) filename) - (save-excursion - (set-buffer (mime-entity-buffer entity)) - (write-region-as-raw-text-CRLF (mime-entity-header-start-internal entity) - (mime-entity-body-end-internal entity) - filename) - )) - -(mm-define-method write-entity-body ((entity generic) filename) - (save-excursion - (set-buffer (mime-entity-buffer entity)) - (write-region-as-binary (mime-entity-body-start-internal entity) - (mime-entity-body-end-internal entity) - filename) - )) - -(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") - ))))))) - -(mm-define-method insert-header ((entity generic) - &optional invisible-fields visible-fields) - (mime-insert-header-from-buffer - (mime-entity-buffer entity) - (mime-entity-header-start-internal entity) - (mime-entity-header-end-internal entity) - invisible-fields visible-fields) - ) - -(mm-define-method insert-text-content ((entity generic)) - (insert - (decode-mime-charset-string (mime-entity-content entity) - (or (mime-content-type-parameter - (mime-entity-content-type entity) - "charset") - default-mime-charset) - 'CRLF) - )) - - -;;; @ end -;;; - -(provide 'mmgeneric) - -;;; mmgeneric.el ends here diff --git a/smtp.el b/smtp.el index baef1ec..47d082a 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). diff --git a/smtpmail.el b/smtpmail.el index 1cb7a1f..3d330ec 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 -- 1.7.10.4