From fe69f909bed61a2cd79796b5b05940b2a83b0572 Mon Sep 17 00:00:00 2001 From: tomo Date: Thu, 29 Mar 2001 05:22:27 +0000 Subject: [PATCH] Merge semi21-D20010129. --- emacs-lisp/alist.el | 110 ++ emacs-lisp/broken.el | 113 ++ emacs-lisp/calist.el | 331 ++++++ emacs-lisp/filename.el | 164 +++ emacs-lisp/install.el | 200 ++++ emacs-lisp/luna.el | 437 +++++++ emacs-lisp/path-util.el | 201 ++++ emacs-lisp/static.el | 89 ++ mail/feedmail.el | 6 +- mail/hex-util.el | 73 ++ mail/hmac-def.el | 85 ++ mail/hmac-md5.el | 95 ++ mail/hmac-sha1.el | 80 ++ mail/qmtp.el | 143 +++ mail/sasl-cram.el | 51 + mail/sasl-digest.el | 156 +++ mail/sasl.el | 269 +++++ mail/sha1.el | 78 ++ mail/smtp.el | 614 ++++++++++ mail/smtpmail.el | 620 ++-------- mime/emh-comp.el | 527 ++++++++ mime/emh-def.el | 41 + mime/emh-face.el | 156 +++ mime/emh-setup.el | 97 ++ mime/emh.el | 355 ++++++ mime/eword-decode.el | 823 +++++++++++++ mime/eword-encode.el | 694 +++++++++++ mime/mail-mime-setup.el | 65 + mime/mcharset.el | 108 ++ mime/mcs-20.el | 167 +++ mime/mcs-e20.el | 157 +++ mime/mel-b-ccl.el | 477 ++++++++ mime/mel-g.el | 135 +++ mime/mel-q-ccl.el | 996 ++++++++++++++++ mime/mel-u.el | 163 +++ mime/mel.el | 334 ++++++ mime/mime-bbdb.el | 303 +++++ mime/mime-conf.el | 277 +++++ mime/mime-def.el | 402 +++++++ mime/mime-edit.el | 3040 +++++++++++++++++++++++++++++++++++++++++++++++ mime/mime-image.el | 206 ++++ mime/mime-parse.el | 358 ++++++ mime/mime-partial.el | 98 ++ mime/mime-pgp.el | 286 +++++ mime/mime-play.el | 517 ++++++++ mime/mime-setup.el | 47 + mime/mime-view.el | 1869 +++++++++++++++++++++++++++++ mime/mime-w3.el | 86 ++ mime/mime.el | 435 +++++++ mime/mmbabyl.el | 178 +++ mime/mmbuffer.el | 360 ++++++ mime/mmcooked.el | 92 ++ mime/mmexternal.el | 187 +++ mime/mmgeneric.el | 178 +++ mime/pgg-def.el | 78 ++ mime/pgg-gpg.el | 242 ++++ mime/pgg-parse.el | 500 ++++++++ mime/pgg-pgp.el | 246 ++++ mime/pgg-pgp5.el | 255 ++++ mime/pgg.el | 421 +++++++ mime/postpet.el | 153 +++ mime/semi-def.el | 208 ++++ mime/semi-setup.el | 208 ++++ mime/signature.el | 158 +++ mime/smime.el | 322 +++++ mime/std11.el | 925 ++++++++++++++ poe/apel-ver.el | 58 + poe/inv-19.el | 61 + poe/invisible.el | 42 + poe/pccl-20.el | 155 +++ poe/pccl.el | 77 ++ poe/product.el | 424 +++++++ richtext.el | 185 +++ 73 files changed, 22335 insertions(+), 512 deletions(-) create mode 100644 emacs-lisp/alist.el create mode 100644 emacs-lisp/broken.el create mode 100644 emacs-lisp/calist.el create mode 100644 emacs-lisp/filename.el create mode 100644 emacs-lisp/install.el create mode 100644 emacs-lisp/luna.el create mode 100644 emacs-lisp/path-util.el create mode 100644 emacs-lisp/static.el create mode 100644 mail/hex-util.el create mode 100644 mail/hmac-def.el create mode 100644 mail/hmac-md5.el create mode 100644 mail/hmac-sha1.el create mode 100644 mail/qmtp.el create mode 100644 mail/sasl-cram.el create mode 100644 mail/sasl-digest.el create mode 100644 mail/sasl.el create mode 100644 mail/sha1.el create mode 100644 mail/smtp.el create mode 100644 mime/emh-comp.el create mode 100644 mime/emh-def.el create mode 100644 mime/emh-face.el create mode 100644 mime/emh-setup.el create mode 100644 mime/emh.el create mode 100644 mime/eword-decode.el create mode 100644 mime/eword-encode.el create mode 100644 mime/mail-mime-setup.el create mode 100644 mime/mcharset.el create mode 100644 mime/mcs-20.el create mode 100644 mime/mcs-e20.el create mode 100644 mime/mel-b-ccl.el create mode 100644 mime/mel-g.el create mode 100644 mime/mel-q-ccl.el create mode 100644 mime/mel-u.el create mode 100644 mime/mel.el create mode 100644 mime/mime-bbdb.el create mode 100644 mime/mime-conf.el create mode 100644 mime/mime-def.el create mode 100644 mime/mime-edit.el create mode 100644 mime/mime-image.el create mode 100644 mime/mime-parse.el create mode 100644 mime/mime-partial.el create mode 100644 mime/mime-pgp.el create mode 100644 mime/mime-play.el create mode 100644 mime/mime-setup.el create mode 100644 mime/mime-view.el create mode 100644 mime/mime-w3.el create mode 100644 mime/mime.el create mode 100644 mime/mmbabyl.el create mode 100644 mime/mmbuffer.el create mode 100644 mime/mmcooked.el create mode 100644 mime/mmexternal.el create mode 100644 mime/mmgeneric.el create mode 100644 mime/pgg-def.el create mode 100644 mime/pgg-gpg.el create mode 100644 mime/pgg-parse.el create mode 100644 mime/pgg-pgp.el create mode 100644 mime/pgg-pgp5.el create mode 100644 mime/pgg.el create mode 100644 mime/postpet.el create mode 100644 mime/semi-def.el create mode 100644 mime/semi-setup.el create mode 100644 mime/signature.el create mode 100644 mime/smime.el create mode 100644 mime/std11.el create mode 100644 poe/apel-ver.el create mode 100644 poe/inv-19.el create mode 100644 poe/invisible.el create mode 100644 poe/pccl-20.el create mode 100644 poe/pccl.el create mode 100644 poe/product.el create mode 100644 richtext.el diff --git a/emacs-lisp/alist.el b/emacs-lisp/alist.el new file mode 100644 index 0000000..4b656de --- /dev/null +++ b/emacs-lisp/alist.el @@ -0,0 +1,110 @@ +;;; alist.el --- utility functions for association list + +;; Copyright (C) 1993,1994,1995,1996,1998,2000 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Keywords: alist + +;; This file is part of GNU Emacs. + +;; 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: + +;;;###autoload +(defun put-alist (key value alist) + "Set cdr of an element (KEY . ...) in ALIST to VALUE and return ALIST. +If there is no such element, create a new pair (KEY . VALUE) and +return a new alist whose car is the new pair and cdr is ALIST." + (let ((elm (assoc key alist))) + (if elm + (progn + (setcdr elm value) + alist) + (cons (cons key value) alist)))) + +;;;###autoload +(defun del-alist (key alist) + "Delete an element whose car equals KEY from ALIST. +Return the modified ALIST." + (if (equal key (car (car alist))) + (cdr alist) + (let ((pr alist) + (r (cdr alist))) + (catch 'tag + (while (not (null r)) + (if (equal key (car (car r))) + (progn + (rplacd pr (cdr r)) + (throw 'tag alist))) + (setq pr r) + (setq r (cdr r))) + alist)))) + +;;;###autoload +(defun set-alist (symbol key value) + "Set cdr of an element (KEY . ...) in the alist bound to SYMBOL to VALUE." + (or (boundp symbol) + (set symbol nil)) + (set symbol (put-alist key value (symbol-value symbol)))) + +;;;###autoload +(defun remove-alist (symbol key) + "Delete an element whose car equals KEY from the alist bound to SYMBOL." + (and (boundp symbol) + (set symbol (del-alist key (symbol-value symbol))))) + +;;;###autoload +(defun modify-alist (modifier default) + "Store elements in the alist MODIFIER in the alist DEFAULT. +Return the modified alist." + (mapcar (function + (lambda (as) + (setq default (put-alist (car as)(cdr as) default)))) + modifier) + default) + +;;;###autoload +(defun set-modified-alist (symbol modifier) + "Store elements in the alist MODIFIER in an alist bound to SYMBOL. +If SYMBOL is not bound, set it to nil at first." + (if (not (boundp symbol)) + (set symbol nil)) + (set symbol (modify-alist modifier (eval symbol)))) + + +;;; @ association-vector-list +;;; + +;;;###autoload +(defun vassoc (key avlist) + "Search AVLIST for an element whose first element equals KEY. +AVLIST is a list of vectors. +See also `assoc'." + (while (and avlist + (not (equal key (aref (car avlist) 0)))) + (setq avlist (cdr avlist))) + (and avlist + (car avlist))) + + +;;; @ end +;;; + +(require 'product) +(product-provide (provide 'alist) (require 'apel-ver)) + +;;; alist.el ends here diff --git a/emacs-lisp/broken.el b/emacs-lisp/broken.el new file mode 100644 index 0000000..d30d97c --- /dev/null +++ b/emacs-lisp/broken.el @@ -0,0 +1,113 @@ +;;; broken.el --- Emacs broken facility infomation registry. + +;; Copyright (C) 1998, 1999 Tanaka Akira + +;; Author: Tanaka Akira +;; Keywords: emulation, compatibility, incompatibility, Mule + +;; This file is part of APEL (A Portable Emacs Library). + +;; 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 'static) + +(eval-and-compile + + (defvar notice-non-obvious-broken-facility t + "If the value is t, non-obvious broken facility is noticed when +`broken-facility' macro is expanded.") + + (defun broken-facility-internal (facility &optional docstring assertion) + "Declare that FACILITY emulation is broken if ASSERTION is nil." + (when docstring + (put facility 'broken-docstring docstring)) + (put facility 'broken (not assertion))) + + (defun broken-p (facility) + "t if FACILITY emulation is broken." + (get facility 'broken)) + + (defun broken-facility-description (facility) + "Return description for FACILITY." + (get facility 'broken-docstring)) + + ) + +(put 'broken-facility 'lisp-indent-function 1) +(defmacro broken-facility (facility &optional docstring assertion no-notice) + "Declare that FACILITY emulation is broken if ASSERTION is nil. +ASSERTION is evaluated statically. + +FACILITY must be symbol. + +If ASSERTION is not ommited and evaluated to nil and NO-NOTICE is nil, +it is noticed." + (` (static-if (, assertion) + (eval-and-compile + (broken-facility-internal '(, facility) (, docstring) t)) + (eval-when-compile + (when (and '(, assertion) (not '(, no-notice)) + notice-non-obvious-broken-facility) + (message "BROKEN FACILITY DETECTED: %s" (, docstring))) + nil) + (eval-and-compile + (broken-facility-internal '(, facility) (, docstring) nil))))) + +(put 'if-broken 'lisp-indent-function 2) +(defmacro if-broken (facility then &rest else) + "If FACILITY is broken, expand to THEN, otherwise (progn . ELSE)." + (` (static-if (broken-p '(, facility)) + (, then) + (,@ else)))) + + +(put 'when-broken 'lisp-indent-function 1) +(defmacro when-broken (facility &rest body) + "If FACILITY is broken, expand to (progn . BODY), otherwise nil." + (` (static-when (broken-p '(, facility)) + (,@ body)))) + +(put 'unless-broken 'lisp-indent-function 1) +(defmacro unless-broken (facility &rest body) + "If FACILITY is not broken, expand to (progn . BODY), otherwise nil." + (` (static-unless (broken-p '(, facility)) + (,@ body)))) + +(defmacro check-broken-facility (facility) + "Check FACILITY is broken or not. If the status is different on +compile(macro expansion) time and run time, warn it." + (` (if-broken (, facility) + (unless (broken-p '(, facility)) + (message "COMPILE TIME ONLY BROKEN FACILITY DETECTED: %s" + (or + '(, (broken-facility-description facility)) + (broken-facility-description '(, facility))))) + (when (broken-p '(, facility)) + (message "RUN TIME ONLY BROKEN FACILITY DETECTED: %s" + (or + (broken-facility-description '(, facility)) + '(, (broken-facility-description facility)))))))) + + +;;; @ end +;;; + +(require 'product) +(product-provide (provide 'broken) (require 'apel-ver)) + +;;; broken.el ends here diff --git a/emacs-lisp/calist.el b/emacs-lisp/calist.el new file mode 100644 index 0000000..fbef680 --- /dev/null +++ b/emacs-lisp/calist.el @@ -0,0 +1,331 @@ +;;; calist.el --- Condition functions + +;; Copyright (C) 1998 Free Software Foundation, Inc. +;; Copyright (C) 1999 Electrotechnical Laboratory, JAPAN. +;; Licensed to the Free Software Foundation. + +;; Author: MORIOKA Tomohiko +;; Keywords: condition, alist, tree + +;; This file is part of APEL (A Portable Emacs Library). + +;; 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)) + +(require 'alist) + +(defvar calist-package-alist nil) +(defvar calist-field-match-method-obarray nil) + +(defun find-calist-package (name) + "Return a calist-package by NAME." + (cdr (assq name calist-package-alist))) + +(defun define-calist-field-match-method (field-type function) + "Set field-match-method for FIELD-TYPE to FUNCTION." + (fset (intern (symbol-name field-type) calist-field-match-method-obarray) + function)) + +(defun use-calist-package (name) + "Make the symbols of package NAME accessible in the current package." + (mapatoms (lambda (sym) + (if (intern-soft (symbol-name sym) + calist-field-match-method-obarray) + (signal 'conflict-of-calist-symbol + (list (format "Conflict of symbol %s"))) + (if (fboundp sym) + (define-calist-field-match-method + sym (symbol-function sym)) + ))) + (find-calist-package name))) + +(defun make-calist-package (name &optional use) + "Create a new calist-package." + (let ((calist-field-match-method-obarray (make-vector 7 0))) + (set-alist 'calist-package-alist name + calist-field-match-method-obarray) + (use-calist-package (or use 'standard)) + calist-field-match-method-obarray)) + +(defun in-calist-package (name) + "Set the current calist-package to a new or existing calist-package." + (setq calist-field-match-method-obarray + (or (find-calist-package name) + (make-calist-package name)))) + +(in-calist-package 'standard) + +(defun calist-default-field-match-method (calist field-type field-value) + (let ((s-field (assoc field-type calist))) + (cond ((null s-field) + (cons (cons field-type field-value) calist) + ) + ((eq field-value t) + calist) + ((equal (cdr s-field) field-value) + calist)))) + +(define-calist-field-match-method t (function calist-default-field-match-method)) + +(defsubst calist-field-match-method (field-type) + (symbol-function + (or (intern-soft (if (symbolp field-type) + (symbol-name field-type) + field-type) + calist-field-match-method-obarray) + (intern-soft "t" calist-field-match-method-obarray)))) + +(defsubst calist-field-match (calist field-type field-value) + (funcall (calist-field-match-method field-type) + calist field-type field-value)) + +(defun ctree-match-calist (rule-tree alist) + "Return matched condition-alist if ALIST matches RULE-TREE." + (if (null rule-tree) + alist + (let ((type (car rule-tree)) + (choices (cdr rule-tree)) + default) + (catch 'tag + (while choices + (let* ((choice (car choices)) + (choice-value (car choice))) + (if (eq choice-value t) + (setq default choice) + (let ((ret-alist (calist-field-match alist type (car choice)))) + (if ret-alist + (throw 'tag + (if (cdr choice) + (ctree-match-calist (cdr choice) ret-alist) + ret-alist)) + )))) + (setq choices (cdr choices))) + (if default + (let ((ret-alist (calist-field-match alist type t))) + (if ret-alist + (if (cdr default) + (ctree-match-calist (cdr default) ret-alist) + ret-alist)))) + )))) + +(defun ctree-match-calist-partially (rule-tree alist) + "Return matched condition-alist if ALIST matches RULE-TREE." + (if (null rule-tree) + alist + (let ((type (car rule-tree)) + (choices (cdr rule-tree)) + default) + (catch 'tag + (while choices + (let* ((choice (car choices)) + (choice-value (car choice))) + (if (eq choice-value t) + (setq default choice) + (let ((ret-alist (calist-field-match alist type (car choice)))) + (if ret-alist + (throw 'tag + (if (cdr choice) + (ctree-match-calist-partially + (cdr choice) ret-alist) + ret-alist)) + )))) + (setq choices (cdr choices))) + (if default + (let ((ret-alist (calist-field-match alist type t))) + (if ret-alist + (if (cdr default) + (ctree-match-calist-partially (cdr default) ret-alist) + ret-alist))) + (calist-field-match alist type t)) + )))) + +(defun ctree-find-calist (rule-tree alist &optional all) + "Return list of condition-alist which matches ALIST in RULE-TREE. +If optional argument ALL is specified, default rules are not ignored +even if other rules are matched for ALIST." + (if (null rule-tree) + (list alist) + (let ((type (car rule-tree)) + (choices (cdr rule-tree)) + default dest) + (while choices + (let* ((choice (car choices)) + (choice-value (car choice))) + (if (eq choice-value t) + (setq default choice) + (let ((ret-alist (calist-field-match alist type (car choice)))) + (if ret-alist + (if (cdr choice) + (let ((ret (ctree-find-calist + (cdr choice) ret-alist all))) + (while ret + (let ((elt (car ret))) + (or (member elt dest) + (setq dest (cons elt dest)) + )) + (setq ret (cdr ret)) + )) + (or (member ret-alist dest) + (setq dest (cons ret-alist dest))) + ))))) + (setq choices (cdr choices))) + (or (and (not all) dest) + (if default + (let ((ret-alist (calist-field-match alist type t))) + (if ret-alist + (if (cdr default) + (let ((ret (ctree-find-calist + (cdr default) ret-alist all))) + (while ret + (let ((elt (car ret))) + (or (member elt dest) + (setq dest (cons elt dest)) + )) + (setq ret (cdr ret)) + )) + (or (member ret-alist dest) + (setq dest (cons ret-alist dest))) + )))) + ) + dest))) + +(defun calist-to-ctree (calist) + "Convert condition-alist CALIST to condition-tree." + (if calist + (let* ((cell (car calist))) + (cons (car cell) + (list (cons (cdr cell) + (calist-to-ctree (cdr calist)) + )))))) + +(defun ctree-add-calist-strictly (ctree calist) + "Add condition CALIST to condition-tree CTREE without default clause." + (cond ((null calist) ctree) + ((null ctree) + (calist-to-ctree calist) + ) + (t + (let* ((type (car ctree)) + (values (cdr ctree)) + (ret (assoc type calist))) + (if ret + (catch 'tag + (while values + (let ((cell (car values))) + (if (equal (car cell)(cdr ret)) + (throw 'tag + (setcdr cell + (ctree-add-calist-strictly + (cdr cell) + (delete ret (copy-alist calist))) + )))) + (setq values (cdr values))) + (setcdr ctree (cons (cons (cdr ret) + (calist-to-ctree + (delete ret (copy-alist calist)))) + (cdr ctree))) + ) + (catch 'tag + (while values + (let ((cell (car values))) + (setcdr cell + (ctree-add-calist-strictly (cdr cell) calist)) + ) + (setq values (cdr values)))) + ) + ctree)))) + +(defun ctree-add-calist-with-default (ctree calist) + "Add condition CALIST to condition-tree CTREE with default clause." + (cond ((null calist) ctree) + ((null ctree) + (let* ((cell (car calist)) + (type (car cell)) + (value (cdr cell))) + (cons type + (list (list t) + (cons value (calist-to-ctree (cdr calist))))) + )) + (t + (let* ((type (car ctree)) + (values (cdr ctree)) + (ret (assoc type calist))) + (if ret + (catch 'tag + (while values + (let ((cell (car values))) + (if (equal (car cell)(cdr ret)) + (throw 'tag + (setcdr cell + (ctree-add-calist-with-default + (cdr cell) + (delete ret (copy-alist calist))) + )))) + (setq values (cdr values))) + (if (assq t (cdr ctree)) + (setcdr ctree + (cons (cons (cdr ret) + (calist-to-ctree + (delete ret (copy-alist calist)))) + (cdr ctree))) + (setcdr ctree + (list* (list t) + (cons (cdr ret) + (calist-to-ctree + (delete ret (copy-alist calist)))) + (cdr ctree))) + )) + (catch 'tag + (while values + (let ((cell (car values))) + (setcdr cell + (ctree-add-calist-with-default (cdr cell) calist)) + ) + (setq values (cdr values))) + (let ((cell (assq t (cdr ctree)))) + (if cell + (setcdr cell + (ctree-add-calist-with-default (cdr cell) + calist)) + (let ((elt (cons t (calist-to-ctree calist)))) + (or (member elt (cdr ctree)) + (setcdr ctree (cons elt (cdr ctree))) + )) + ))) + ) + ctree)))) + +(defun ctree-set-calist-strictly (ctree-var calist) + "Set condition CALIST in CTREE-VAR without default clause." + (set ctree-var + (ctree-add-calist-strictly (symbol-value ctree-var) calist))) + +(defun ctree-set-calist-with-default (ctree-var calist) + "Set condition CALIST to CTREE-VAR with default clause." + (set ctree-var + (ctree-add-calist-with-default (symbol-value ctree-var) calist))) + + +;;; @ end +;;; + +(require 'product) +(product-provide (provide 'calist) (require 'apel-ver)) + +;;; calist.el ends here diff --git a/emacs-lisp/filename.el b/emacs-lisp/filename.el new file mode 100644 index 0000000..2efdb09 --- /dev/null +++ b/emacs-lisp/filename.el @@ -0,0 +1,164 @@ +;;; filename.el --- file name filter + +;; Copyright (C) 1996,1997,2000 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Keywords: file name, string + +;; This file is part of APEL (A Portable Emacs Library). + +;; 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 'path-util) + +(or (fboundp 'char-int) + (defalias 'char-int 'identity)) + +;; Emacs 20.1/XEmacs 20.3 (but first appeared in Epoch?): (functionp OBJECT) +(or (fboundp 'functionp) + (defun functionp (object) + "Non-nil if OBJECT is a type of object that can be called as a function." + (or (subrp object) (byte-code-function-p object) + (eq (car-safe object) 'lambda) + (and (symbolp object) (fboundp object))))) + + +(defsubst poly-funcall (functions argument) + "Apply initial ARGUMENT to sequence of FUNCTIONS. +FUNCTIONS is list of functions. + +(poly-funcall '(f1 f2 .. fn) arg) is as same as +(fn .. (f2 (f1 arg)) ..). + +For example, (poly-funcall '(car number-to-string) '(100)) returns +\"100\"." + (while functions + (setq argument (funcall (car functions) argument) + functions (cdr functions))) + argument) + + +;;; @ variables +;;; + +(defvar filename-limit-length 21 "Limit size of file-name.") + +(defvar filename-replacement-alist + '(((?\ ?\t) . "_") + ((?! ?\" ?# ?$ ?% ?& ?' ?\( ?\) ?* ?/ + ?: ?\; ?< ?> ?? ?\[ ?\\ ?\] ?` ?{ ?| ?}) . "_") + (filename-control-p . "")) + "Alist list of characters vs. string as replacement. +List of characters represents characters not allowed as file-name.") + +(defvar filename-filters + (let ((filters '(filename-special-filter + filename-eliminate-top-low-lines + filename-canonicalize-low-lines + filename-maybe-truncate-by-size + filename-eliminate-bottom-low-lines + ))) + (if (exec-installed-p "kakasi") + (cons 'filename-japanese-to-roman-string filters) + filters)) + "List of functions for file-name filter.") + + +;;; @ filters +;;; + +(defun filename-japanese-to-roman-string (str) + (save-excursion + (set-buffer (get-buffer-create " *temp kakasi*")) + (erase-buffer) + (insert str) + (call-process-region + (point-min)(point-max) + "kakasi" t t t "-Ha" "-Ka" "-Ja" "-Ea" "-ka") + (buffer-string))) + +(defun filename-control-p (character) + (let ((code (char-int character))) + (or (< code 32)(= code 127)))) + +(defun filename-special-filter (string) + (let ((len (length string)) + (b 0)(i 0) + (dest "")) + (while (< i len) + (let ((chr (sref string i)) + (lst filename-replacement-alist) + ret) + (while (and lst (not ret)) + (if (if (functionp (car (car lst))) + (setq ret (funcall (car (car lst)) chr)) + (setq ret (memq chr (car (car lst))))) + t ; quit this loop. + (setq lst (cdr lst)))) + (if ret + (setq dest (concat dest (substring string b i)(cdr (car lst))) + i (1+ i) + ;; i (+ i (char-length chr)) + b i) + (setq i (1+ i)) + ;; (setq i (+ i (char-length chr))) + ))) + (concat dest (substring string b)))) + +(defun filename-eliminate-top-low-lines (string) + (if (string-match "^_+" string) + (substring string (match-end 0)) + string)) + +(defun filename-canonicalize-low-lines (string) + (let ((dest "")) + (while (string-match "__+" string) + (setq dest (concat dest (substring string 0 (1+ (match-beginning 0))))) + (setq string (substring string (match-end 0)))) + (concat dest string))) + +(defun filename-maybe-truncate-by-size (string) + (if (and (> (length string) filename-limit-length) + (string-match "_" string filename-limit-length)) + (substring string 0 (match-beginning 0)) + string)) + +(defun filename-eliminate-bottom-low-lines (string) + (if (string-match "_+$" string) + (substring string 0 (match-beginning 0)) + string)) + + +;;; @ interface +;;; + +(defun replace-as-filename (string) + "Return safety filename from STRING. +It refers variable `filename-filters' and default filters refers +`filename-limit-length', `filename-replacement-alist'." + (and string + (poly-funcall filename-filters string))) + + +;;; @ end +;;; + +(require 'product) +(product-provide (provide 'filename) (require 'apel-ver)) + +;;; filename.el ends here diff --git a/emacs-lisp/install.el b/emacs-lisp/install.el new file mode 100644 index 0000000..eb20781 --- /dev/null +++ b/emacs-lisp/install.el @@ -0,0 +1,200 @@ +;;; install.el --- Emacs Lisp package install utility + +;; Copyright (C) 1996,1997,1998,1999 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Created: 1996/08/18 +;; Keywords: install, byte-compile, directory detection + +;; This file is part of APEL (A Portable Emacs Library). + +;; 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 'poe) ; make-directory for v18 +(require 'path-util) ; default-load-path + + +;;; @ compile Emacs Lisp files +;;; + +(defun compile-elisp-module (module &optional path every-time) + (setq module (expand-file-name (symbol-name module) path)) + (let ((el-file (concat module ".el")) + (elc-file (concat module ".elc"))) + (if (or every-time + (file-newer-than-file-p el-file elc-file)) + (byte-compile-file el-file)))) + +(defun compile-elisp-modules (modules &optional path every-time) + (mapcar + (function + (lambda (module) + (compile-elisp-module module path every-time))) + modules)) + + +;;; @ install files +;;; + +(defvar install-overwritten-file-modes (+ (* 64 6)(* 8 4) 4)) ; 0644 + +(defun install-file (file src dest &optional move overwrite just-print) + (if just-print + (princ (format "%s -> %s\n" file dest)) + (let ((src-file (expand-file-name file src))) + (if (file-exists-p src-file) + (let ((full-path (expand-file-name file dest))) + (if (and (file-exists-p full-path) overwrite) + (delete-file full-path)) + (copy-file src-file full-path t t) + (if move + (catch 'tag + (while (and (file-exists-p src-file) + (file-writable-p src-file)) + (condition-case err + (progn + (delete-file src-file) + (throw 'tag nil)) + (error (princ (format "%s\n" (nth 1 err)))))))) + (princ (format "%s -> %s\n" file dest))))))) + +(defun install-files (files src dest &optional move overwrite just-print) + (or (file-exists-p dest) + (make-directory dest t)) + (mapcar + (function + (lambda (file) + (install-file file src dest move overwrite just-print))) + files)) + + +;;; @@ install Emacs Lisp files +;;; + +(defun install-elisp-module (module src dest &optional just-print) + (let (el-file elc-file) + (let ((name (symbol-name module))) + (setq el-file (concat name ".el")) + (setq elc-file (concat name ".elc"))) + (let ((src-file (expand-file-name el-file src))) + (if (not (file-exists-p src-file)) + nil + (if just-print + (princ (format "%s -> %s\n" el-file dest)) + (let ((full-path (expand-file-name el-file dest))) + (if (file-exists-p full-path) + (delete-file full-path)) + (copy-file src-file full-path t t) + (princ (format "%s -> %s\n" el-file dest))))) + (setq src-file (expand-file-name elc-file src)) + (if (not (file-exists-p src-file)) + nil + (if just-print + (princ (format "%s -> %s\n" elc-file dest)) + (let ((full-path (expand-file-name elc-file dest))) + (if (file-exists-p full-path) + (delete-file full-path)) + (copy-file src-file full-path t t) + (catch 'tag + (while (file-exists-p src-file) + (condition-case err + (progn + (delete-file src-file) + (throw 'tag nil)) + (error (princ (format "%s\n" (nth 1 err))))))) + (princ (format "%s -> %s\n" elc-file dest)))))))) + +(defun install-elisp-modules (modules src dest &optional just-print) + (or (file-exists-p dest) + (make-directory dest t)) + (mapcar + (function + (lambda (module) + (install-elisp-module module src dest just-print))) + modules)) + + +;;; @ detect install path +;;; + +;; install to shared directory (maybe "/usr/local") +(defvar install-prefix + (if (or (<= emacs-major-version 18) + (featurep 'xemacs) + (and (boundp 'system-configuration-options) ; 19.29 or later + (string= system-configuration-options "NT"))) ; for Meadow + (expand-file-name "../../.." exec-directory) + (expand-file-name "../../../.." data-directory))) + +(defvar install-elisp-prefix + (if (>= emacs-major-version 19) + "site-lisp" + ;; v18 does not have standard site directory. + "local.lisp")) + +(defun install-detect-elisp-directory (&optional prefix elisp-prefix + allow-version-specific) + (or prefix + (setq prefix install-prefix)) + (or elisp-prefix + (setq elisp-prefix install-elisp-prefix)) + (or (catch 'tag + (let ((rest default-load-path) + (regexp (concat "^" + (expand-file-name (concat ".*/" elisp-prefix) + prefix) + "/?$"))) + (while rest + (if (string-match regexp (car rest)) + (if (or allow-version-specific + (not (string-match (format "/%d\\.%d" + emacs-major-version + emacs-minor-version) + (car rest)))) + (throw 'tag (car rest)))) + (setq rest (cdr rest))))) + (expand-file-name (concat (if (and (not (featurep 'xemacs)) + (or (>= emacs-major-version 20) + (and (= emacs-major-version 19) + (> emacs-minor-version 28)))) + "share/" + "lib/") + (cond + ((featurep 'xemacs) + (if (featurep 'mule) + "xmule/" + "xemacs/")) + ;; unfortunately, unofficial mule based on + ;; 19.29 and later use "emacs/" by default. + ((boundp 'MULE) "mule/") + ((boundp 'NEMACS) "nemacs/") + (t "emacs/")) + elisp-prefix) + prefix))) + +(defvar install-default-elisp-directory + (install-detect-elisp-directory)) + + +;;; @ end +;;; + +(require 'product) +(product-provide (provide 'install) (require 'apel-ver)) + +;;; install.el ends here diff --git a/emacs-lisp/luna.el b/emacs-lisp/luna.el new file mode 100644 index 0000000..b307ad9 --- /dev/null +++ b/emacs-lisp/luna.el @@ -0,0 +1,437 @@ +;;; luna.el --- tiny OOP system kernel + +;; Copyright (C) 1999,2000 Free Software Foundation, Inc. + +;; 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)) + + +;;; @ class +;;; + +(defmacro luna-find-class (name) + "Return a luna-class that has NAME." + `(get ,name 'luna-class)) + +;; Give NAME (symbol) the luna-class CLASS. +(defmacro luna-set-class (name class) + `(put ,name 'luna-class ,class)) + +;; Return the obarray of luna-class CLASS. +(defmacro luna-class-obarray (class) + `(aref ,class 1)) + +;; Return the parents of luna-class CLASS. +(defmacro luna-class-parents (class) + `(aref ,class 2)) + +;; Return the number of slots of luna-class CLASS. +(defmacro luna-class-number-of-slots (class) + `(aref ,class 3)) + +(defmacro luna-define-class (class &optional parents slots) + "Define CLASS as a luna-class. +CLASS always inherits the luna-class `standard-object'. + +The optional 1st arg PARENTS is a list luna-class names. These +luna-classes are also inheritted by CLASS. + +The optional 2nd arg SLOTS is a list of slots CLASS will have." + `(luna-define-class-function ',class ',(append parents '(standard-object)) + ',slots)) + + +;; Define CLASS as a luna-class. PARENTS, if non-nil, is a list of +;; luna-class names inherited by CLASS. SLOTS, if non-nil, is a list +;; of slots belonging to CLASS. + +(defun luna-define-class-function (class &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 class (vector 'class oa parents i)))) + + +;; Return a member (slot or method) of CLASS that has name +;; MEMBER-NAME. + +(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))) + + +;; Return a member (slot or method) of CLASS that has name +;; MEMBER-NAME. If CLASS doesnt' have such a member, make it in +;; CLASS. + +(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))) + + +;; Return the index number of SLOT-NAME in CLASS. + +(defmacro luna-class-slot-index (class slot-name) + `(get (luna-class-find-member ,class ,slot-name) 'luna-slot-index)) + +(defmacro luna-define-method (name &rest definition) + "Define NAME as a method of a luna class. + +Usage of this macro follows: + + (luna-define-method NAME [METHOD-QUALIFIER] ARGLIST [DOCSTRING] BODY...) + +The optional 1st argument METHOD-QUALIFIER specifies when and how the +method is called. + +If it is :before, call the method before calling the parents' methods. + +If it is :after, call the method after calling the parents' methods. + +If it is :around, call the method only. The parents' methods can be +executed by calling the function `luna-call-next-method' in BODY. + +Otherwize, call the method only, and the parents' methods are never +executed. In this case, METHOD-QUALIFIER is treated as ARGLIST. + +ARGLIST has the form ((VAR CLASS) METHOD-ARG ...), where VAR is a +variable name that should be bound to an entity that receives the +message NAME, CLASS is a class name. The first argument to the method +is VAR, and the remaining arguments are METHOD-ARGs. + +If VAR is nil, arguments to the method are METHOD-ARGs. This kind of +methods can't be called from generic-function (see +`luna-define-generic'). + +The optional 4th argument DOCSTRING is the documentation of the +method. If it is not string, it is treated as BODY. + +The optional 5th BODY is the body of the 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)) + (cache (get ',name 'luna-method-cache))) + (if cache + (unintern ',class cache)) + (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)) + + +;; Return a list of method functions named SERVICE registered in the +;; parents of CLASS. + +(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)) + +;; Return a list of method functions named SERVICE registered in CLASS +;; and the parents.. + +(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)))) + + +;;; @ instance (entity) +;;; + +(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)) + +(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-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. +ENTITY is an instance of a luna class, and MESSAGE is a method name of +the luna class. +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 the current method function. +A method function that has :around qualifier should call this function +to execute the parents' methods." + (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)) + +(defun luna-make-entity (class &rest init-args) + "Make an entity (instance) of luna-class CLASS and return it. +INIT-ARGS is a plist of the form (:SLOT1 VAL1 :SLOT2 VAL2 ...), +where SLOTs are slots of CLASS and the VALs are initial values of +the corresponding SLOTs." + (let* ((c (get class 'luna-class)) + (v (make-vector (luna-class-number-of-slots c) nil))) + (luna-set-class-name v class) + (luna-set-obarray v (make-vector 7 0)) + (apply #'luna-send v 'initialize-instance v init-args))) + + +;;; @ interface (generic function) +;;; + +;; Find a method of ENTITY that handles MESSAGE, and call it with +;; arguments LUNA-CURRENT-METHOD-ARGUMENTS. + +(defun luna-apply-generic (entity message &rest luna-current-method-arguments) + (let* ((class (luna-class-name entity)) + (cache (get message 'luna-method-cache)) + (sym (intern-soft (symbol-name class) cache)) + luna-next-methods) + (if sym + (setq luna-next-methods (symbol-value sym)) + (setq luna-next-methods + (luna-find-functions entity message)) + (set (intern (symbol-name class) cache) + luna-next-methods)) + (luna-call-next-method))) + + +;; Convert ARGLIST (argument list spec for a method function) to the +;; actual list of arguments. + +(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 a function NAME that provides a generic interface to the method NAME. +ARGS is the argument list for NAME. The first element of ARGS is an +entity. + +The function handles a message sent to the entity by calling the +method with proper arguments. + +The optional 3rd argument DOC is the documentation string for NAME." + (if doc + `(progn + (defun ,(intern (symbol-name name)) ,args + ,doc + (luna-apply-generic ,(car args) ',name + ,@(luna-arglist-to-arguments args))) + (put ',name 'luna-method-cache (make-vector 31 0))) + `(progn + (defun ,(intern (symbol-name name)) ,args + (luna-apply-generic ,(car args) ',name + ,@(luna-arglist-to-arguments args))) + (put ',name 'luna-method-cache (make-vector 31 0))))) + +(put 'luna-define-generic 'lisp-indent-function 'defun) + + +;;; @ accessor +;;; + +(defun luna-define-internal-accessors (class-name) + "Define internal accessors for instances of the luna class CLASS-NAME. + +Internal accessors are macros to refer and set a slot value of the +instances. For instance, if the class has SLOT, macros +CLASS-NAME-SLOT-internal and CLASS-NAME-set-SLOT-internal are defined. + +CLASS-NAME-SLOT-internal accepts one argument INSTANCE, and returns +the value of SLOT. + +CLASS-NAME-set-SLOT-internal accepts two arguemnt INSTANCE and VALUE, +and sets SLOT to VALUE." + (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)))) + + +;;; @ standard object +;;; + +;; Define super class of all luna classes. +(luna-define-class-function 'standard-object) + +(luna-define-method initialize-instance ((entity standard-object) + &rest init-args) + "Initialize slots of ENTITY by 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/emacs-lisp/path-util.el b/emacs-lisp/path-util.el new file mode 100644 index 0000000..385aecd --- /dev/null +++ b/emacs-lisp/path-util.el @@ -0,0 +1,201 @@ +;;; path-util.el --- Emacs Lisp file detection utility + +;; Copyright (C) 1996,1997,1999 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Keywords: file detection, install, module + +;; This file is part of APEL (A Portable Emacs Library). + +;; 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: + +(defvar default-load-path load-path + "*Base of `load-path'. +It is used as default value of target path to search file or +subdirectory under load-path.") + +;;;###autoload +(defun add-path (path &rest options) + "Add PATH to `load-path' if it exists under `default-load-path' +directories and it does not exist in `load-path'. + +You can use following PATH styles: + load-path relative: \"PATH/\" + (it is searched from `defaul-load-path') + home directory relative: \"~/PATH/\" \"~USER/PATH/\" + absolute path: \"/HOO/BAR/BAZ/\" + +You can specify following OPTIONS: + 'all-paths search from `load-path' + instead of `default-load-path' + 'append add PATH to the last of `load-path'" + (let ((rest (if (memq 'all-paths options) + load-path + default-load-path)) + p) + (if (and (catch 'tag + (while rest + (setq p (expand-file-name path (car rest))) + (if (file-directory-p p) + (throw 'tag p) + ) + (setq rest (cdr rest)) + )) + (not (member p load-path)) + ) + (setq load-path + (if (memq 'append options) + (append load-path (list p)) + (cons p load-path) + )) + ))) + +;;;###autoload +(defun add-latest-path (pattern &optional all-paths) + "Add latest path matched by PATTERN to `load-path' +if it exists under `default-load-path' directories +and it does not exist in `load-path'. + +If optional argument ALL-PATHS is specified, it is searched from all +of load-path instead of default-load-path." + (let ((path (get-latest-path pattern all-paths))) + (if path + (add-to-list 'load-path path) + ))) + +;;;###autoload +(defun get-latest-path (pattern &optional all-paths) + "Return latest directory in default-load-path +which is matched to regexp PATTERN. +If optional argument ALL-PATHS is specified, +it is searched from all of load-path instead of default-load-path." + (catch 'tag + (let ((paths (if all-paths + load-path + default-load-path)) + dir) + (while (setq dir (car paths)) + (if (and (file-exists-p dir) + (file-directory-p dir) + ) + (let ((files (sort (directory-files dir t pattern t) + (function file-newer-than-file-p))) + file) + (while (setq file (car files)) + (if (file-directory-p file) + (throw 'tag file) + ) + (setq files (cdr files)) + ))) + (setq paths (cdr paths)) + )))) + +;;;###autoload +(defun file-installed-p (file &optional paths) + "Return absolute-path of FILE if FILE exists in PATHS. +If PATHS is omitted, `load-path' is used." + (if (null paths) + (setq paths load-path) + ) + (catch 'tag + (let (path) + (while paths + (setq path (expand-file-name file (car paths))) + (if (file-exists-p path) + (throw 'tag path) + ) + (setq paths (cdr paths)) + )))) + +;;;###autoload +(defvar exec-suffix-list '("") + "*List of suffixes for executable.") + +;;;###autoload +(defun exec-installed-p (file &optional paths suffixes) + "Return absolute-path of FILE if FILE exists in PATHS. +If PATHS is omitted, `exec-path' is used. +If suffixes is omitted, `exec-suffix-list' is used." + (or paths + (setq paths exec-path) + ) + (or suffixes + (setq suffixes exec-suffix-list) + ) + (let (files) + (catch 'tag + (while suffixes + (let ((suf (car suffixes))) + (if (and (not (string= suf "")) + (string-match (concat (regexp-quote suf) "$") file)) + (progn + (setq files (list file)) + (throw 'tag nil) + ) + (setq files (cons (concat file suf) files)) + ) + (setq suffixes (cdr suffixes)) + ))) + (setq files (nreverse files)) + (catch 'tag + (while paths + (let ((path (car paths)) + (files files) + ) + (while files + (setq file (expand-file-name (car files) path)) + (if (file-executable-p file) + (throw 'tag file) + ) + (setq files (cdr files)) + ) + (setq paths (cdr paths)) + ))))) + +;;;###autoload +(defun module-installed-p (module &optional paths) + "Return t if module is provided or exists in PATHS. +If PATHS is omitted, `load-path' is used." + (or (featurep module) + (let ((file (symbol-name module))) + (or paths + (setq paths load-path) + ) + (catch 'tag + (while paths + (let ((stem (expand-file-name file (car paths))) + (sufs '(".elc" ".el")) + ) + (while sufs + (let ((file (concat stem (car sufs)))) + (if (file-exists-p file) + (throw 'tag file) + )) + (setq sufs (cdr sufs)) + )) + (setq paths (cdr paths)) + ))))) + + +;;; @ end +;;; + +(require 'product) +(product-provide (provide 'path-util) (require 'apel-ver)) + +;;; path-util.el ends here diff --git a/emacs-lisp/static.el b/emacs-lisp/static.el new file mode 100644 index 0000000..a42d816 --- /dev/null +++ b/emacs-lisp/static.el @@ -0,0 +1,89 @@ +;;; static.el --- tools for static evaluation. + +;; Copyright (C) 1999 Tanaka Akira + +;; Author: Tanaka Akira +;; Keywords: byte compile, evaluation + +;; This file is part of APEL (A Portable Emacs Library). + +;; 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: + +(put 'static-if 'lisp-indent-function 2) +(defmacro static-if (cond then &rest else) + "Like `if', but evaluate COND at compile time." + (if (eval cond) + then + (` (progn (,@ else))))) + +(put 'static-when 'lisp-indent-function 1) +(defmacro static-when (cond &rest body) + "Like `when', but evaluate COND at compile time." + (if (eval cond) + (` (progn (,@ body))))) + +(put 'static-unless 'lisp-indent-function 1) +(defmacro static-unless (cond &rest body) + "Like `unless', but evaluate COND at compile time." + (if (eval cond) + nil + (` (progn (,@ body))))) + +(put 'static-condition-case 'lisp-indent-function 2) +(defmacro static-condition-case (var bodyform &rest handlers) + "Like `condition-case', but evaluate BODYFORM at compile time." + (eval (` (condition-case (, var) + (list (quote quote) (, bodyform)) + (,@ (mapcar + (if var + (function + (lambda (h) + (` ((, (car h)) + (list (quote funcall) + (function (lambda ((, var)) (,@ (cdr h)))) + (list (quote quote) (, var))))))) + (function + (lambda (h) + (` ((, (car h)) (quote (progn (,@ (cdr h))))))))) + handlers)))))) + +(put 'static-defconst 'lisp-indent-function 'defun) +(defmacro static-defconst (symbol initvalue &optional docstring) + "Like `defconst', but evaluate INITVALUE at compile time. + +The variable SYMBOL can be referred at both compile time and run time." + (let ((value (eval initvalue))) + (eval (` (defconst (, symbol) (quote (, value)) (, docstring)))) + (` (defconst (, symbol) (quote (, value)) (, docstring))))) + +(defmacro static-cond (&rest clauses) + "Like `cond', but evaluate CONDITION part of each clause at compile time." + (while (and clauses + (not (eval (car (car clauses))))) + (setq clauses (cdr clauses))) + (if clauses + (cons 'progn (cdr (car clauses))))) + + +;;; @ end +;;; + +(require 'product) +(product-provide (provide 'static) (require 'apel-ver)) + +;;; static.el ends here diff --git a/mail/feedmail.el b/mail/feedmail.el index 477a966..f864de3 100644 --- a/mail/feedmail.el +++ b/mail/feedmail.el @@ -1356,15 +1356,15 @@ complicated cases." ;; I'm not sure smtpmail.el is careful about the following ;; return value, but it also uses it internally, so I will fear ;; no evil. - (require 'smtpmail) - (if (not (smtpmail-via-smtp addr-listoid prepped)) + (require 'smtp) + (if (not (smtp-via-smtp user-mail-address addr-listoid prepped)) (progn (set-buffer errors-to) (insert "Send via smtpmail failed. Probable SMTP protocol error.\n") (insert "Look for details below or in the *Messages* buffer.\n\n") (let ((case-fold-search t) ;; don't be overconfident about the name of the trace buffer - (tracer (concat "trace.*smtp.*" (regexp-quote smtpmail-smtp-server)))) + (tracer (concat "trace.*smtp.*" (regexp-quote smtp-server)))) (mapcar '(lambda (buffy) (if (string-match tracer (buffer-name buffy)) diff --git a/mail/hex-util.el b/mail/hex-util.el new file mode 100644 index 0000000..92a09ff --- /dev/null +++ b/mail/hex-util.el @@ -0,0 +1,73 @@ +;;; hex-util.el --- Functions to encode/decode hexadecimal string. + +;; Copyright (C) 1999 Shuhei KOBAYASHI + +;; Author: Shuhei KOBAYASHI +;; Keywords: data + +;; 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 this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(eval-when-compile + (defmacro hex-char-to-num (chr) + (` (let ((chr (, chr))) + (cond + ((and (<= ?a chr)(<= chr ?f)) (+ (- chr ?a) 10)) + ((and (<= ?A chr)(<= chr ?F)) (+ (- chr ?A) 10)) + ((and (<= ?0 chr)(<= chr ?9)) (- chr ?0)) + (t (error "Invalid hexadecimal digit `%c'" chr)))))) + (defmacro num-to-hex-char (num) + (` (aref "0123456789abcdef" (, num))))) + +(defun decode-hex-string (string) + "Decode hexadecimal STRING to octet string." + (let* ((len (length string)) + (dst (make-string (/ len 2) 0)) + (idx 0)(pos 0)) + (while (< pos len) +;;; logior and lsh are not byte-coded. +;;; (aset dst idx (logior (lsh (hex-char-to-num (aref string pos)) 4) +;;; (hex-char-to-num (aref string (1+ pos))))) + (aset dst idx (+ (* (hex-char-to-num (aref string pos)) 16) + (hex-char-to-num (aref string (1+ pos))))) + (setq idx (1+ idx) + pos (+ 2 pos))) + dst)) + +(defun encode-hex-string (string) + "Encode octet STRING to hexadecimal string." + (let* ((len (length string)) + (dst (make-string (* len 2) 0)) + (idx 0)(pos 0)) + (while (< pos len) +;;; logand and lsh are not byte-coded. +;;; (aset dst idx (num-to-hex-char (logand (lsh (aref string pos) -4) 15))) + (aset dst idx (num-to-hex-char (/ (aref string pos) 16))) + (setq idx (1+ idx)) +;;; (aset dst idx (num-to-hex-char (logand (aref string pos) 15))) + (aset dst idx (num-to-hex-char (% (aref string pos) 16))) + (setq idx (1+ idx) + pos (1+ pos))) + dst)) + +(provide 'hex-util) + +;;; hex-util.el ends here diff --git a/mail/hmac-def.el b/mail/hmac-def.el new file mode 100644 index 0000000..7525c89 --- /dev/null +++ b/mail/hmac-def.el @@ -0,0 +1,85 @@ +;;; hmac-def.el --- A macro for defining HMAC functions. + +;; Copyright (C) 1999 Shuhei KOBAYASHI + +;; Author: Shuhei KOBAYASHI +;; Keywords: HMAC, RFC 2104 + +;; 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 this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This program is implemented from RFC 2104, +;; "HMAC: Keyed-Hashing for Message Authentication". + +;;; Code: + +(defmacro define-hmac-function (name H B L &optional bit) + "Define a function NAME(TEXT KEY) which computes HMAC with function H. + +HMAC function is H(KEY XOR opad, H(KEY XOR ipad, TEXT)): + +H is a cryptographic hash function, such as SHA1 and MD5, which takes +a string and return a digest of it (in binary form). +B is a byte-length of a block size of H. (B=64 for both SHA1 and MD5.) +L is a byte-length of hash outputs. (L=16 for MD5, L=20 for SHA1.) +If BIT is non-nil, truncate output to specified bits." + (` (defun (, name) (text key) + (, (concat "Compute " + (upcase (symbol-name name)) + " over TEXT with KEY.")) + (let ((key-xor-ipad (make-string (, B) ?\x36)) + (key-xor-opad (make-string (, B) ?\x5C)) + (len (length key)) + (pos 0)) + (unwind-protect + (progn + ;; if `key' is longer than the block size, apply hash function + ;; to `key' and use the result as a real `key'. + (if (> len (, B)) + (setq key ((, H) key) + len (, L))) + (while (< pos len) + (aset key-xor-ipad pos (logxor (aref key pos) ?\x36)) + (aset key-xor-opad pos (logxor (aref key pos) ?\x5C)) + (setq pos (1+ pos))) + (setq key-xor-ipad (unwind-protect + (concat key-xor-ipad text) + (fillarray key-xor-ipad 0)) + key-xor-ipad (unwind-protect + ((, H) key-xor-ipad) + (fillarray key-xor-ipad 0)) + key-xor-opad (unwind-protect + (concat key-xor-opad key-xor-ipad) + (fillarray key-xor-opad 0)) + key-xor-opad (unwind-protect + ((, H) key-xor-opad) + (fillarray key-xor-opad 0))) + ;; now `key-xor-opad' contains + ;; H(KEY XOR opad, H(KEY XOR ipad, TEXT)). + (, (if (and bit (< (/ bit 8) L)) + (` (substring key-xor-opad 0 (, (/ bit 8)))) + ;; return a copy of `key-xor-opad'. + (` (concat key-xor-opad))))) + ;; cleanup. + (fillarray key-xor-ipad 0) + (fillarray key-xor-opad 0)))))) + +(provide 'hmac-def) + +;;; hmac-def.el ends here diff --git a/mail/hmac-md5.el b/mail/hmac-md5.el new file mode 100644 index 0000000..9c936d0 --- /dev/null +++ b/mail/hmac-md5.el @@ -0,0 +1,95 @@ +;;; hmac-md5.el --- Compute HMAC-MD5. + +;; Copyright (C) 1999 Shuhei KOBAYASHI + +;; Author: Shuhei KOBAYASHI +;; Kenichi OKADA +;; Maintainer: Kenichi OKADA +;; Keywords: HMAC, RFC 2104, HMAC-MD5, MD5, KEYED-MD5, CRAM-MD5 + +;; 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 this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Test cases from RFC 2202, "Test Cases for HMAC-MD5 and HMAC-SHA-1". +;; +;; (encode-hex-string (hmac-md5 "Hi There" (make-string 16 ?\x0b))) +;; => "9294727a3638bb1c13f48ef8158bfc9d" +;; +;; (encode-hex-string (hmac-md5 "what do ya want for nothing?" "Jefe")) +;; => "750c783e6ab0b503eaa86e310a5db738" +;; +;; (encode-hex-string (hmac-md5 (make-string 50 ?\xdd) (make-string 16 ?\xaa))) +;; => "56be34521d144c88dbb8c733f0e8b3f6" +;; +;; (encode-hex-string +;; (hmac-md5 +;; (make-string 50 ?\xcd) +;; (decode-hex-string "0102030405060708090a0b0c0d0e0f10111213141516171819"))) +;; => "697eaf0aca3a3aea3a75164746ffaa79" +;; +;; (encode-hex-string +;; (hmac-md5 "Test With Truncation" (make-string 16 ?\x0c))) +;; => "56461ef2342edc00f9bab995690efd4c" +;; (encode-hex-string +;; (hmac-md5-96 "Test With Truncation" (make-string 16 ?\x0c))) +;; => "56461ef2342edc00f9bab995" +;; +;; (encode-hex-string +;; (hmac-md5 +;; "Test Using Larger Than Block-Size Key - Hash Key First" +;; (make-string 80 ?\xaa))) +;; => "6b1ab7fe4bd7bf8f0b62e6ce61b9d0cd" +;; +;; (encode-hex-string +;; (hmac-md5 +;; "Test Using Larger Than Block-Size Key and Larger Than One Block-Size Data" +;; (make-string 80 ?\xaa))) +;; => "6f630fad67cda0ee1fb1f562db3aa53e" + +;;; Code: + +(eval-when-compile (require 'hmac-def)) +(require 'hex-util) ; (decode-hex-string STRING) +(require 'md5) ; expects (md5 STRING) + +;; We cannot define this function in md5.el because recent XEmacs provides +;; built-in md5 function and provides feature 'md5 at startup. +(if (and (featurep 'xemacs) + (fboundp 'md5) + (subrp (symbol-function 'md5)) + (condition-case nil + ;; `md5' of XEmacs 21 takes 4th arg CODING (and 5th arg NOERROR). + (md5 "" nil nil 'binary) ; => "fb5d2156096fa1f254352f3cc3fada7e" + (error nil))) + ;; XEmacs 21. + (defun md5-binary (string &optional start end) + "Return the MD5 of STRING in binary form." + (decode-hex-string (md5 string start end 'binary))) + ;; not XEmacs 21 and not DL. + (if (not (fboundp 'md5-binary)) + (defun md5-binary (string) + "Return the MD5 of STRING in binary form." + (decode-hex-string (md5 string))))) + +(define-hmac-function hmac-md5 md5-binary 64 16) ; => (hmac-md5 TEXT KEY) +;; (define-hmac-function hmac-md5-96 md5-binary 64 16 96) + +(provide 'hmac-md5) + +;;; hmac-md5.el ends here diff --git a/mail/hmac-sha1.el b/mail/hmac-sha1.el new file mode 100644 index 0000000..6b2beea --- /dev/null +++ b/mail/hmac-sha1.el @@ -0,0 +1,80 @@ +;;; hmac-sha1.el --- Compute HMAC-SHA1. + +;; Copyright (C) 1999 Shuhei KOBAYASHI + +;; Author: Shuhei KOBAYASHI +;; Keywords: HMAC, RFC 2104, HMAC-SHA1, SHA1, Cancel-Lock + +;; 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 this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Test cases from RFC 2202, "Test Cases for HMAC-MD5 and HMAC-SHA-1". +;; +;; (encode-hex-string (hmac-sha1 "Hi There" (make-string 20 ?\x0b))) +;; => "b617318655057264e28bc0b6fb378c8ef146be00" +;; +;; (encode-hex-string (hmac-sha1 "what do ya want for nothing?" "Jefe")) +;; => "effcdf6ae5eb2fa2d27416d5f184df9c259a7c79" +;; +;; (encode-hex-string (hmac-sha1 (make-string 50 ?\xdd) (make-string 20 ?\xaa))) +;; => "125d7342b9ac11cd91a39af48aa17b4f63f175d3" +;; +;; (encode-hex-string +;; (hmac-sha1 +;; (make-string 50 ?\xcd) +;; (decode-hex-string "0102030405060708090a0b0c0d0e0f10111213141516171819"))) +;; => "4c9007f4026250c6bc8414f9bf50c86c2d7235da" +;; +;; (encode-hex-string +;; (hmac-sha1 "Test With Truncation" (make-string 20 ?\x0c))) +;; => "4c1a03424b55e07fe7f27be1d58bb9324a9a5a04" +;; (encode-hex-string +;; (hmac-sha1-96 "Test With Truncation" (make-string 20 ?\x0c))) +;; => "4c1a03424b55e07fe7f27be1" +;; +;; (encode-hex-string +;; (hmac-sha1 +;; "Test Using Larger Than Block-Size Key - Hash Key First" +;; (make-string 80 ?\xaa))) +;; => "aa4ae5e15272d00e95705637ce8a3b55ed402112" +;; +;; (encode-hex-string +;; (hmac-sha1 +;; "Test Using Larger Than Block-Size Key and Larger Than One Block-Size Data" +;; (make-string 80 ?\xaa))) +;; => "e8e99d0f45237d786d6bbaa7965c7808bbff1a91" + +;;; Code: + +(eval-when-compile (require 'hmac-def)) +(require 'hex-util) ; (decode-hex-string STRING) +(require 'sha1) ; expects (sha1 STRING) + +;;; For consintency with hmac-md5.el, we define this function here. +(or (fboundp 'sha1-binary) + (defun sha1-binary (string) + "Return the SHA1 of STRING in binary form." + (decode-hex-string (sha1 string)))) + +(define-hmac-function hmac-sha1 sha1-binary 64 20) ; => (hmac-sha1 TEXT KEY) +;; (define-hmac-function hmac-sha1-96 sha1-binary 64 20 96) + +(provide 'hmac-sha1) + +;;; hmac-sha1.el ends here diff --git a/mail/qmtp.el b/mail/qmtp.el new file mode 100644 index 0000000..e74f798 --- /dev/null +++ b/mail/qmtp.el @@ -0,0 +1,143 @@ +;;; qmtp.el --- basic functions to send mail with QMTP server + +;; Copyright (C) 2000 Free Software Foundation, Inc. + +;; Author: Daiki Ueno +;; Keywords: QMTP, qmail + +;; 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 this program; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + + +;;; Commentary: + +;; Installation: + +;; To send mail using QMTP instead of SMTP, do + +;; (fset 'smtp-send-buffer 'qmtp-send-buffer) + +;;; Code: + +(require 'custom) +(require 'mel) ; binary-funcall + +(defgroup qmtp nil + "QMTP protocol for sending mail." + :group 'mail) + +(defcustom qmtp-default-server nil + "Specify default QMTP server." + :type '(choice (const nil) string) + :group 'qmtp) + +(defvar qmtp-server qmtp-default-server + "The name of the host running QMTP server. +It can also be a function +called from `qmtp-via-qmtp' with arguments SENDER and RECIPIENTS.") + +(defcustom qmtp-service "qmtp" + "QMTP service port number. \"qmtp\" or 209." + :type '(choice (integer :tag "209" 209) + (string :tag "qmtp" "qmtp")) + :group 'qmtp) + +(defcustom qmtp-timeout 30 + "Timeout for each QMTP session." + :type 'integer + :group 'qmtp) + +;;;###autoload +(defvar qmtp-open-connection-function (function open-network-stream)) + +(defvar qmtp-error-response-alist + '((?Z "Temporary failure") + (?D "Permanent failure"))) + +(defvar qmtp-read-point nil) + +(defun qmtp-encode-netstring-string (string) + (format "%d:%s," (length string) string)) + +(defun qmtp-send-package (process sender recipients buffer) + (with-temp-buffer + (buffer-disable-undo) + (erase-buffer) + (set-buffer-multibyte nil) + (insert + (format "%d:\n" + (with-current-buffer buffer + (1+ (point-max));; for the "\n" + ))) + (insert-buffer-substring buffer) + (insert + "\n," + (qmtp-encode-netstring-string sender) + (qmtp-encode-netstring-string + (mapconcat #'qmtp-encode-netstring-string + recipients ""))) + (process-send-region process (point-min)(point-max))) + (goto-char qmtp-read-point) + (while (and (memq (process-status process) '(open run)) + (not (re-search-forward "^[0-9]+:" nil 'noerror))) + (unless (accept-process-output process qmtp-timeout) + (error "timeout expired: %d" qmtp-timeout)) + (goto-char qmtp-read-point)) + (let ((response (char-after (match-end 0)))) + (unless (eq response ?K) + (error (nth 1 (assq response qmtp-error-response-alist)))) + (setq recipients (cdr recipients)) + (beginning-of-line 2) + (setq qmtp-read-point (point)))) + +;;;###autoload +(defun qmtp-via-qmtp (sender recipients buffer) + (condition-case nil + (progn + (qmtp-send-buffer sender recipients buffer) + t) + (error))) + +(make-obsolete 'qmtp-via-qmtp "It's old API.") + +;;;###autoload +(defun qmtp-send-buffer (sender recipients buffer) + (save-excursion + (set-buffer + (get-buffer-create + (format "*trace of QMTP session to %s*" qmtp-server))) + (buffer-disable-undo) + (erase-buffer) + (make-local-variable 'qmtp-read-point) + (setq qmtp-read-point (point-min)) + (let (process) + (unwind-protect + (progn + (setq process + (binary-funcall qmtp-open-connection-function + "QMTP" (current-buffer) + qmtp-server qmtp-service)) + (qmtp-send-package process sender recipients buffer)) + (when (and process + (memq (process-status process) '(open run))) + ;; QUIT + (process-send-eof process) + (delete-process process)))))) + +(provide 'qmtp) + +;;; qmtp.el ends here diff --git a/mail/sasl-cram.el b/mail/sasl-cram.el new file mode 100644 index 0000000..25d1082 --- /dev/null +++ b/mail/sasl-cram.el @@ -0,0 +1,51 @@ +;;; sasl-cram.el --- CRAM-MD5 module for the SASL client framework + +;; Copyright (C) 2000 Free Software Foundation, Inc. + +;; Author: Daiki Ueno +;; Kenichi OKADA +;; Keywords: SASL, CRAM-MD5 + +;; 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 this program; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +(require 'sasl) +(require 'hmac-md5) + +(defconst sasl-cram-md5-steps + '(ignore ;no initial response + sasl-cram-md5-response)) + +(defun sasl-cram-md5-response (client step) + (let ((passphrase + (sasl-read-passphrase + (format "CRAM-MD5 passphrase for %s: " + (sasl-client-name client))))) + (unwind-protect + (concat (sasl-client-name client) " " + (encode-hex-string + (hmac-md5 (sasl-step-data step) passphrase))) + (fillarray passphrase 0)))) + +(put 'sasl-cram 'sasl-mechanism + (sasl-make-mechanism "CRAM-MD5" sasl-cram-md5-steps)) + +(provide 'sasl-cram) + +;;; sasl-cram.el ends here diff --git a/mail/sasl-digest.el b/mail/sasl-digest.el new file mode 100644 index 0000000..9e061b7 --- /dev/null +++ b/mail/sasl-digest.el @@ -0,0 +1,156 @@ +;;; sasl-digest.el --- DIGEST-MD5 module for the SASL client framework + +;; Copyright (C) 2000 Free Software Foundation, Inc. + +;; Author: Daiki Ueno +;; Kenichi OKADA +;; Keywords: SASL, DIGEST-MD5 + +;; 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 this program; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;; This program is implemented from draft-leach-digest-sasl-05.txt. +;; +;; It is caller's responsibility to base64-decode challenges and +;; base64-encode responses in IMAP4 AUTHENTICATE command. +;; +;; Passphrase should be longer than 16 bytes. (See RFC 2195) + +;;; Commentary: + +(require 'sasl) +(require 'hmac-md5) + +(defvar sasl-digest-md5-nonce-count 1) +(defvar sasl-digest-md5-unique-id-function + sasl-unique-id-function) + +(defvar sasl-digest-md5-syntax-table + (let ((table (make-syntax-table))) + (modify-syntax-entry ?= "." table) + (modify-syntax-entry ?, "." table) + table) + "A syntax table for parsing digest-challenge attributes.") + +(defconst sasl-digest-md5-steps + '(ignore ;no initial response + sasl-digest-md5-response + ignore)) ;"" + +(defun sasl-digest-md5-parse-string (string) + "Parse STRING and return a property list. +The value is a cons cell of the form \(realm nonce qop-options stale maxbuf +charset algorithm cipher-opts auth-param)." + (with-temp-buffer + (set-syntax-table sasl-digest-md5-syntax-table) + (save-excursion + (insert string) + (goto-char (point-min)) + (insert "(") + (while (progn (forward-sexp) (not (eobp))) + (delete-char 1) + (insert " ")) + (insert ")") + (read (point-min-marker))))) + +(defun sasl-digest-md5-digest-uri (serv-type host &optional serv-name) + (concat serv-type "/" host + (if (and serv-name + (not (string= host serv-name))) + (concat "/" serv-name)))) + +(defun sasl-digest-md5-cnonce () + (let ((sasl-unique-id-function sasl-digest-md5-unique-id-function)) + (sasl-unique-id))) + +(defun sasl-digest-md5-response-value (username + realm + nonce + cnonce + nonce-count + qop + digest-uri + authzid) + (let ((passphrase + (sasl-read-passphrase + (format "DIGEST-MD5 passphrase for %s: " + username)))) + (unwind-protect + (encode-hex-string + (md5-binary + (concat + (encode-hex-string + (md5-binary (concat (md5-binary + (concat username ":" realm ":" passphrase)) + ":" nonce ":" cnonce + (if authzid + (concat ":" authzid))))) + ":" nonce + ":" (format "%08x" nonce-count) ":" cnonce ":" qop ":" + (encode-hex-string + (md5-binary + (concat "AUTHENTICATE:" digest-uri + (if (member qop '("auth-int" "auth-conf")) + ":00000000000000000000000000000000"))))))) + (fillarray passphrase 0)))) + +(defun sasl-digest-md5-response (client step) + (let* ((plist + (sasl-digest-md5-parse-string (sasl-step-data step))) + (realm + (or (sasl-client-property client 'realm) + (plist-get plist 'realm))) ;need to check + (nonce-count + (or (sasl-client-property client 'nonce-count) + sasl-digest-md5-nonce-count)) + (qop + (or (sasl-client-property client 'qop) + "auth")) + (digest-uri + (sasl-digest-md5-digest-uri + (sasl-client-service client)(sasl-client-server client))) + (cnonce + (or (sasl-client-property client 'cnonce) + (sasl-digest-md5-cnonce)))) + (sasl-client-set-property client 'nonce-count (1+ nonce-count)) + (unless (string= qop "auth") + (sasl-error (format "Unsupported \"qop-value\": %s" qop))) + (concat + "username=\"" (sasl-client-name client) "\"," + "realm=\"" realm "\"," + "nonce=\"" (plist-get plist 'nonce) "\"," + "cnonce=\"" cnonce "\"," + (format "nc=%08x," nonce-count) + "digest-uri=\"" digest-uri "\"," + "qop=" qop "," + "response=" + (sasl-digest-md5-response-value + (sasl-client-name client) + realm + (plist-get plist 'nonce) + cnonce + nonce-count + qop + digest-uri + (plist-get plist 'authzid))))) + +(put 'sasl-digest 'sasl-mechanism + (sasl-make-mechanism "DIGEST-MD5" sasl-digest-md5-steps)) + +(provide 'sasl-digest) + +;;; sasl-digest.el ends here diff --git a/mail/sasl.el b/mail/sasl.el new file mode 100644 index 0000000..8528898 --- /dev/null +++ b/mail/sasl.el @@ -0,0 +1,269 @@ +;;; sasl.el --- SASL client framework + +;; Copyright (C) 2000 Free Software Foundation, Inc. + +;; Author: Daiki Ueno +;; Keywords: SASL + +;; 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 this program; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This module provides common interface functions to share several +;; SASL mechanism drivers. The toplevel is designed to be mostly +;; compatible with [Java-SASL]. +;; +;; [SASL] J. Myers, "Simple Authentication and Security Layer (SASL)", +;; RFC 2222, October 1997. +;; +;; [Java-SASL] R. Weltman & R. Lee, "The Java SASL Application Program +;; Interface", draft-weltman-java-sasl-03.txt, March 2000. + +;;; Code: + +(defvar sasl-mechanisms + '("CRAM-MD5" "DIGEST-MD5" "PLAIN" "LOGIN" "ANONYMOUS")) + +(defvar sasl-mechanism-alist + '(("CRAM-MD5" sasl-cram) + ("DIGEST-MD5" sasl-digest) + ("PLAIN" sasl-plain) + ("LOGIN" sasl-login) + ("ANONYMOUS" sasl-anonymous))) + +(defvar sasl-unique-id-function #'sasl-unique-id-function) + +(put 'sasl-error 'error-message "SASL error") +(put 'sasl-error 'error-conditions '(sasl-error error)) + +(defun sasl-error (datum) + (signal 'sasl-error (list datum))) + +;;; @ SASL client +;;; + +(defun sasl-make-client (mechanism name service server) + "Return a newly allocated SASL client. +NAME is name of the authorization. SERVICE is name of the service desired. +SERVER is the fully qualified host name of the server to authenticate to." + (vector mechanism name service server (make-symbol "sasl-client-properties"))) + +(defun sasl-client-mechanism (client) + "Return the authentication mechanism driver of CLIENT." + (aref client 0)) + +(defun sasl-client-name (client) + "Return the authorization name of CLIENT, a string." + (aref client 1)) + +(defun sasl-client-service (client) + "Return the service name of CLIENT, a string." + (aref client 2)) + +(defun sasl-client-server (client) + "Return the server name of CLIENT, a string." + (aref client 3)) + +(defun sasl-client-set-properties (client plist) + "Destructively set the properties of CLIENT. +The second argument PLIST is the new property list." + (setplist (aref client 4) plist)) + +(defun sasl-client-set-property (client property value) + "Add the given property/value to CLIENT." + (put (aref client 4) property value)) + +(defun sasl-client-property (client property) + "Return the value of the PROPERTY of CLIENT." + (get (aref client 4) property)) + +(defun sasl-client-properties (client) + "Return the properties of CLIENT." + (symbol-plist (aref client 4))) + +;;; @ SASL mechanism +;;; + +(defun sasl-make-mechanism (name steps) + "Make an authentication mechanism. +NAME is a IANA registered SASL mechanism name. +STEPS is list of continuation function." + (vector name + (mapcar + (lambda (step) + (let ((symbol (make-symbol (symbol-name step)))) + (fset symbol (symbol-function step)) + symbol)) + steps))) + +(defun sasl-mechanism-name (mechanism) + "Return name of MECHANISM, a string." + (aref mechanism 0)) + +(defun sasl-mechanism-steps (mechanism) + "Return the authentication steps of MECHANISM, a list of functions." + (aref mechanism 1)) + +(defun sasl-find-mechanism (mechanisms) + "Retrieve an apropriate mechanism object from MECHANISMS hints." + (let* ((sasl-mechanisms sasl-mechanisms) + (mechanism + (catch 'done + (while sasl-mechanisms + (if (member (car sasl-mechanisms) mechanisms) + (throw 'done (nth 1 (assoc (car sasl-mechanisms) + sasl-mechanism-alist)))) + (setq sasl-mechanisms (cdr sasl-mechanisms)))))) + (if mechanism + (require mechanism)) + (get mechanism 'sasl-mechanism))) + +;;; @ SASL authentication step +;;; + +(defun sasl-step-data (step) + "Return the data which STEP holds, a string." + (aref step 1)) + +(defun sasl-step-set-data (step data) + "Store DATA string to STEP." + (aset step 1 data)) + +(defun sasl-next-step (client step) + "Evaluate the challenge and prepare an appropriate next response. +The data type of the value and optional 2nd argument STEP is nil or +opaque authentication step which holds the reference to the next action +and the current challenge. At the first time STEP should be set to nil." + (let* ((steps + (sasl-mechanism-steps + (sasl-client-mechanism client))) + (function + (if (vectorp step) + (nth 1 (memq (aref step 0) steps)) + (car steps)))) + (if function + (vector function (funcall function client step))))) + +(defvar sasl-read-passphrase nil) +(defun sasl-read-passphrase (prompt) + (if (not sasl-read-passphrase) + (if (functionp 'read-passwd) + (setq sasl-read-passphrase 'read-passwd) + (if (load "passwd" t) + (setq sasl-read-passphrase 'read-passwd) + (autoload 'ange-ftp-read-passwd "ange-ftp") + (setq sasl-read-passphrase 'ange-ftp-read-passwd)))) + (funcall sasl-read-passphrase prompt)) + +(defun sasl-unique-id () + "Compute a data string which must be different each time. +It contain at least 64 bits of entropy." + (concat (funcall sasl-unique-id-function)(funcall sasl-unique-id-function))) + +(defvar sasl-unique-id-char nil) + +;; stolen (and renamed) from message.el +(defun sasl-unique-id-function () + ;; Don't use microseconds from (current-time), they may be unsupported. + ;; Instead we use this randomly inited counter. + (setq sasl-unique-id-char + (% (1+ (or sasl-unique-id-char (logand (random t) (1- (lsh 1 20))))) + ;; (current-time) returns 16-bit ints, + ;; and 2^16*25 just fits into 4 digits i base 36. + (* 25 25))) + (let ((tm (current-time))) + (concat + (sasl-unique-id-number-base36 + (+ (car tm) + (lsh (% sasl-unique-id-char 25) 16)) 4) + (sasl-unique-id-number-base36 + (+ (nth 1 tm) + (lsh (/ sasl-unique-id-char 25) 16)) 4)))) + +(defun sasl-unique-id-number-base36 (num len) + (if (if (< len 0) + (<= num 0) + (= len 0)) + "" + (concat (sasl-unique-id-number-base36 (/ num 36) (1- len)) + (char-to-string (aref "zyxwvutsrqponmlkjihgfedcba9876543210" + (% num 36)))))) + +;;; PLAIN (RFC2595 Section 6) +(defconst sasl-plain-steps + '(sasl-plain-response)) + +(defun sasl-plain-response (client step) + (let ((passphrase + (sasl-read-passphrase + (format "PLAIN passphrase for %s: " (sasl-client-name client)))) + (authenticator-name + (sasl-client-property + client 'authenticator-name)) + (name (sasl-client-name client))) + (unwind-protect + (if (and authenticator-name + (not (string= authenticator-name name))) + (concat authenticator-name "\0" name "\0" passphrase) + (concat "\0" name "\0" passphrase)) + (fillarray passphrase 0)))) + +(put 'sasl-plain 'sasl-mechanism + (sasl-make-mechanism "PLAIN" sasl-plain-steps)) + +(provide 'sasl-plain) + +;;; LOGIN (No specification exists) +(defconst sasl-login-steps + '(ignore ;no initial response + sasl-login-response-1 + sasl-login-response-2)) + +(defun sasl-login-response-1 (client step) +;;; (unless (string-match "^Username:" (sasl-step-data step)) +;;; (sasl-error (format "Unexpected response: %s" (sasl-step-data step)))) + (sasl-client-name client)) + +(defun sasl-login-response-2 (client step) +;;; (unless (string-match "^Password:" (sasl-step-data step)) +;;; (sasl-error (format "Unexpected response: %s" (sasl-step-data step)))) + (sasl-read-passphrase + (format "LOGIN passphrase for %s: " (sasl-client-name client)))) + +(put 'sasl-login 'sasl-mechanism + (sasl-make-mechanism "LOGIN" sasl-login-steps)) + +(provide 'sasl-login) + +;;; ANONYMOUS (RFC2245) +(defconst sasl-anonymous-steps + '(ignore ;no initial response + sasl-anonymous-response)) + +(defun sasl-anonymous-response (client step) + (or (sasl-client-property client 'trace) + (sasl-client-name client))) + +(put 'sasl-anonymous 'sasl-mechanism + (sasl-make-mechanism "ANONYMOUS" sasl-anonymous-steps)) + +(provide 'sasl-anonymous) + +(provide 'sasl) + +;;; sasl.el ends here diff --git a/mail/sha1.el b/mail/sha1.el new file mode 100644 index 0000000..24a3af5 --- /dev/null +++ b/mail/sha1.el @@ -0,0 +1,78 @@ +;;; sha1.el --- SHA1 Secure Hash Algorithm. + +;; Copyright (C) 1999 Shuhei KOBAYASHI + +;; Author: Shuhei KOBAYASHI +;; Kenichi OKADA +;; Maintainer: Kenichi OKADA +;; Keywords: SHA1, FIPS 180-1 + +;; 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 this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Examples from FIPS PUB 180-1. +;; +;; +;; (sha1 "abc") +;; => a9993e364706816aba3e25717850c26c9cd0d89d +;; +;; (sha1 "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq") +;; => 84983e441c3bd26ebaae4aa1f95129e5e54670f1 +;; +;; (sha1 (make-string 1000000 ?a)) +;; => 34aa973cd4c4daa4f61eeb2bdbad27316534016f + +;;; Code: + +(require 'hex-util) + +(eval-when-compile + (or (fboundp 'sha1-string) + (defun sha1-string (a)))) + +(defvar sha1-dl-module + (if (and (fboundp 'sha1-string) + (subrp (symbol-function 'sha1-string))) + nil + (if (fboundp 'dynamic-link) + (let ((path (expand-file-name "sha1.so" exec-directory))) + (and (file-exists-p path) + path))))) + +(cond + (sha1-dl-module + ;; Emacs with DL patch. + (require 'sha1-dl)) + (t + (require 'sha1-el))) + +;; compatibility for another sha1.el by Keiichi Suzuki. +(defun sha1-encode (string) + (decode-hex-string + (sha1-string string))) +(defun sha1-encode-binary (string) + (decode-hex-string + (sha1-string string))) + +(make-obsolete 'sha1-encode "It's old API.") +(make-obsolete 'sha1-encode-binary "It's old API.") + +(provide 'sha1) + +;;; sha1.el ends here diff --git a/mail/smtp.el b/mail/smtp.el new file mode 100644 index 0000000..4265bbd --- /dev/null +++ b/mail/smtp.el @@ -0,0 +1,614 @@ +;;; smtp.el --- basic functions to send mail with SMTP server + +;; Copyright (C) 1995, 1996, 1998, 1999, 2000 Free Software Foundation, Inc. + +;; Author: Tomoji Kagatani +;; Simon Leinen (ESMTP support) +;; Shuhei KOBAYASHI +;; Daiki Ueno +;; Keywords: SMTP, mail + +;; This file is part of FLIM (Faithful Library about Internet Message). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + + +;;; Commentary: +;; + +;;; Code: + +(require 'custom) +(require 'mail-utils) ; mail-strip-quoted-names +(require 'sasl) +(require 'luna) +(require 'mel) ; binary-funcall + +(defgroup smtp nil + "SMTP protocol for sending mail." + :group 'mail) + +(defgroup smtp-extensions nil + "SMTP service extensions (RFC1869)." + :group 'smtp) + +(defcustom smtp-default-server nil + "Specify default SMTP server." + :type '(choice (const nil) string) + :group 'smtp) + +(defcustom smtp-server (or (getenv "SMTPSERVER") smtp-default-server) + "The name of the host running SMTP server. +It can also be a function +called from `smtp-via-smtp' with arguments SENDER and RECIPIENTS." + :type '(choice (string :tag "Name") + (function :tag "Function")) + :group 'smtp) + +(defcustom smtp-service "smtp" + "SMTP service port number. \"smtp\" or 25." + :type '(choice (integer :tag "25" 25) + (string :tag "smtp" "smtp")) + :group 'smtp) + +(defcustom smtp-local-domain nil + "Local domain name without a host name. +If the function (system-name) returns the full internet address, +don't define this value." + :type '(choice (const nil) string) + :group 'smtp) + +(defcustom smtp-fqdn nil + "Fully qualified domain name used for Message-ID." + :type '(choice (const nil) string) + :group 'smtp) + +(defcustom smtp-use-8bitmime t + "If non-nil, use ESMTP 8BITMIME (RFC1652) if available." + :type 'boolean + :group 'smtp-extensions) + +(defcustom smtp-use-size t + "If non-nil, use ESMTP SIZE (RFC1870) if available." + :type 'boolean + :group 'smtp-extensions) + +(defcustom smtp-use-starttls nil + "If non-nil, use STARTTLS (RFC2595) if available." + :type 'boolean + :group 'smtp-extensions) + +(defcustom smtp-use-sasl nil + "If non-nil, use SMTP Authentication (RFC2554) if available." + :type 'boolean + :group 'smtp-extensions) + +(defcustom smtp-sasl-user-name (user-login-name) + "Identification to be used for authorization." + :type 'string + :group 'smtp-extensions) + +(defcustom smtp-sasl-properties nil + "Properties set to SASL client." + :type 'string + :group 'smtp-extensions) + +(defcustom smtp-sasl-mechanisms nil + "List of authentication mechanisms." + :type '(repeat string) + :group 'smtp-extensions) + +(defvar sasl-mechanisms) + +;;;###autoload +(defvar smtp-open-connection-function #'open-network-stream) + +(defvar smtp-read-point nil) + +(defvar smtp-connection-alist nil) + +(defvar smtp-submit-package-function #'smtp-submit-package) + +;;; @ SMTP package +;;; A package contains a mail message, an envelope sender address, +;;; and one or more envelope recipient addresses. In ESMTP model +;;; the current sending package should be guaranteed to be accessible +;;; anywhere from the hook methods (or SMTP commands). + +(eval-and-compile + (luna-define-class smtp-package () + (sender + recipients + buffer)) + + (luna-define-internal-accessors 'smtp-package)) + +(defun smtp-make-package (sender recipients buffer) + "Create a new package structure. +A package is a unit of SMTP message +SENDER specifies the package sender, a string. +RECIPIENTS is a list of recipients. +BUFFER may be a buffer or a buffer name which contains mail message." + (luna-make-entity 'smtp-package :sender sender :recipients recipients :buffer buffer)) + +(defun smtp-package-buffer-internal-size (package) + "Return the size of PACKAGE, an integer." + (save-excursion + (set-buffer (smtp-package-buffer-internal package)) + (let ((size + (+ (buffer-size) + ;; Add one byte for each change-of-line + ;; because or CR-LF representation: + (count-lines (point-min) (point-max)) + ;; For some reason, an empty line is + ;; added to the message. Maybe this + ;; is a bug, but it can't hurt to add + ;; those two bytes anyway: + 2))) + (goto-char (point-min)) + (while (re-search-forward "^\\." nil t) + (setq size (1+ size))) + size))) + +;;; @ SMTP connection +;;; We should consider the function `open-network-stream' is a emulation +;;; for another network stream. They are likely to be implemented with an +;;; external program and the function `process-contact' returns the +;;; process id instead of `(HOST SERVICE)' pair. + +(eval-and-compile + (luna-define-class smtp-connection () + (process + server + service + extensions + encoder + decoder)) + + (luna-define-internal-accessors 'smtp-connection)) + +(defun smtp-make-connection (process server service) + "Create a new connection structure. +PROCESS is an internal subprocess-object. SERVER is name of the host +to connect to. SERVICE is name of the service desired." + (luna-make-entity 'smtp-connection :process process :server server :service service)) + +(luna-define-generic smtp-connection-opened (connection) + "Say whether the CONNECTION to server has been opened.") + +(luna-define-generic smtp-close-connection (connection) + "Close the CONNECTION to server.") + +(luna-define-method smtp-connection-opened ((connection smtp-connection)) + (let ((process (smtp-connection-process-internal connection))) + (if (memq (process-status process) '(open run)) + t))) + +(luna-define-method smtp-close-connection ((connection smtp-connection)) + (let ((process (smtp-connection-process-internal connection))) + (delete-process process))) + +(defun smtp-make-fqdn () + "Return user's fully qualified domain name." + (if smtp-fqdn + smtp-fqdn + (let ((system-name (system-name))) + (cond + (smtp-local-domain + (concat system-name "." smtp-local-domain)) + ((string-match "[^.]\\.[^.]" system-name) + system-name) + (t + (error "Cannot generate valid FQDN")))))) + +(defun smtp-find-connection (buffer) + "Find the connection delivering to BUFFER." + (let ((entry (assq buffer smtp-connection-alist)) + connection) + (when entry + (setq connection (nth 1 entry)) + (if (smtp-connection-opened connection) + connection + (setq smtp-connection-alist + (delq entry smtp-connection-alist)) + nil)))) + +(eval-and-compile + (autoload 'starttls-open-stream "starttls") + (autoload 'starttls-negotiate "starttls")) + +(defun smtp-open-connection (buffer server service) + "Open a SMTP connection for a service to a host. +Return a newly allocated connection-object. +BUFFER is the buffer to associate with the connection. SERVER is name +of the host to connect to. SERVICE is name of the service desired." + (let ((process + (binary-funcall smtp-open-connection-function + "SMTP" buffer server service)) + connection) + (when process + (setq connection (smtp-make-connection process server service)) + (set-process-filter process 'smtp-process-filter) + (setq smtp-connection-alist + (cons (list buffer connection) + smtp-connection-alist)) + connection))) + +;;;###autoload +(defun smtp-via-smtp (sender recipients buffer) + "Like `smtp-send-buffer', but sucks in any errors." + (condition-case nil + (progn + (smtp-send-buffer sender recipients buffer) + t) + (smtp-error))) + +(make-obsolete 'smtp-via-smtp "It's old API.") + +;;;###autoload +(defun smtp-send-buffer (sender recipients buffer) + "Send a message. +SENDER is an envelope sender address. +RECIPIENTS is a list of envelope recipient addresses. +BUFFER may be a buffer or a buffer name which contains mail message." + (let ((server + (if (functionp smtp-server) + (funcall smtp-server sender recipients) + smtp-server)) + (package + (smtp-make-package sender recipients buffer)) + (smtp-open-connection-function + (if smtp-use-starttls + #'starttls-open-stream + smtp-open-connection-function))) + (save-excursion + (set-buffer + (get-buffer-create + (format "*trace of SMTP session to %s*" server))) + (erase-buffer) + (buffer-disable-undo) + (unless (smtp-find-connection (current-buffer)) + (smtp-open-connection (current-buffer) server smtp-service)) + (make-local-variable 'smtp-read-point) + (setq smtp-read-point (point-min)) + (funcall smtp-submit-package-function package)))) + +(defun smtp-submit-package (package) + (unwind-protect + (progn + (smtp-primitive-greeting package) + (condition-case nil + (smtp-primitive-ehlo package) + (smtp-response-error + (smtp-primitive-helo package))) + (if smtp-use-starttls + (smtp-primitive-starttls package)) + (if smtp-use-sasl + (smtp-primitive-auth package)) + (smtp-primitive-mailfrom package) + (smtp-primitive-rcptto package) + (smtp-primitive-data package)) + (let ((connection (smtp-find-connection (current-buffer)))) + (when (smtp-connection-opened connection) + (smtp-primitive-quit package) + (smtp-close-connection connection))))) + +;;; @ hook methods for `smtp-submit-package' +;;; + +(defun smtp-primitive-greeting (package) + (let* ((connection + (smtp-find-connection (current-buffer))) + (response + (smtp-read-response connection))) + (if (/= (car response) 220) + (smtp-response-error response)))) + +(defun smtp-primitive-ehlo (package) + (let* ((connection + (smtp-find-connection (current-buffer))) + response) + (smtp-send-command connection (format "EHLO %s" (smtp-make-fqdn))) + (setq response (smtp-read-response connection)) + (if (/= (car response) 250) + (smtp-response-error response)) + (smtp-connection-set-extensions-internal + connection (mapcar + (lambda (extension) + (let ((extensions + (split-string extension))) + (setcar extensions + (car (read-from-string + (downcase (car extensions))))) + extensions)) + (cdr response))))) + +(defun smtp-primitive-helo (package) + (let* ((connection + (smtp-find-connection (current-buffer))) + response) + (smtp-send-command connection (format "HELO %s" (smtp-make-fqdn))) + (setq response (smtp-read-response connection)) + (if (/= (car response) 250) + (smtp-response-error response)))) + +(defun smtp-primitive-auth (package) + (let* ((connection + (smtp-find-connection (current-buffer))) + (mechanisms + (cdr (assq 'auth (smtp-connection-extensions-internal connection)))) + (sasl-mechanisms + (or smtp-sasl-mechanisms sasl-mechanisms)) + (mechanism + (sasl-find-mechanism mechanisms)) + client + name + step + response) + (unless mechanism + (error "No authentication mechanism available")) + (setq client (sasl-make-client mechanism smtp-sasl-user-name "smtp" + (smtp-connection-server-internal connection))) + (if smtp-sasl-properties + (sasl-client-set-properties client smtp-sasl-properties)) + (setq name (sasl-mechanism-name mechanism) + ;; Retrieve the initial response + step (sasl-next-step client nil)) + (smtp-send-command + connection + (if (sasl-step-data step) + (format "AUTH %s %s" name (base64-encode-string (sasl-step-data step) t)) + (format "AUTH %s" name))) + (catch 'done + (while t + (setq response (smtp-read-response connection)) + (when (= (car response) 235) + ;; The authentication process is finished. + (setq step (sasl-next-step client step)) + (if (null step) + (throw 'done nil)) + (smtp-response-error response)) ;Bogus server? + (if (/= (car response) 334) + (smtp-response-error response)) + (sasl-step-set-data step (base64-decode-string (nth 1 response))) + (setq step (sasl-next-step client step)) + (smtp-send-command + connection + (if (sasl-step-data step) + (base64-encode-string (sasl-step-data step) t) + "")))) +;;; (smtp-connection-set-encoder-internal +;;; connection (sasl-client-encoder client)) +;;; (smtp-connection-set-decoder-internal +;;; connection (sasl-client-decoder client)) + )) + +(defun smtp-primitive-starttls (package) + (let* ((connection + (smtp-find-connection (current-buffer))) + response) + ;; STARTTLS --- begin a TLS negotiation (RFC 2595) + (smtp-send-command connection "STARTTLS") + (setq response (smtp-read-response connection)) + (if (/= (car response) 220) + (smtp-response-error response)) + (starttls-negotiate (smtp-connection-process-internal connection)))) + +(defun smtp-primitive-mailfrom (package) + (let* ((connection + (smtp-find-connection (current-buffer))) + (extensions + (smtp-connection-extensions-internal + connection)) + (sender + (smtp-package-sender-internal package)) + extension + response) + ;; SIZE --- Message Size Declaration (RFC1870) + (if (and smtp-use-size + (assq 'size extensions)) + (setq extension (format "SIZE=%d" (smtp-package-buffer-internal-size package)))) + ;; 8BITMIME --- 8bit-MIMEtransport (RFC1652) + (if (and smtp-use-8bitmime + (assq '8bitmime extensions)) + (setq extension (concat extension " BODY=8BITMIME"))) + (smtp-send-command + connection + (if extension + (format "MAIL FROM:<%s> %s" sender extension) + (format "MAIL FROM:<%s>" sender))) + (setq response (smtp-read-response connection)) + (if (/= (car response) 250) + (smtp-response-error response)))) + +(defun smtp-primitive-rcptto (package) + (let* ((connection + (smtp-find-connection (current-buffer))) + (recipients + (smtp-package-recipients-internal package)) + response) + (while recipients + (smtp-send-command + connection (format "RCPT TO:<%s>" (pop recipients))) + (setq response (smtp-read-response connection)) + (unless (memq (car response) '(250 251)) + (smtp-response-error response))))) + +(defun smtp-primitive-data (package) + (let* ((connection + (smtp-find-connection (current-buffer))) + response) + (smtp-send-command connection "DATA") + (setq response (smtp-read-response connection)) + (if (/= (car response) 354) + (smtp-response-error response)) + (save-excursion + (set-buffer (smtp-package-buffer-internal package)) + (goto-char (point-min)) + (while (not (eobp)) + (smtp-send-data + connection (buffer-substring (point) (progn (end-of-line)(point)))) + (beginning-of-line 2))) + (smtp-send-command connection ".") + (setq response (smtp-read-response connection)) + (if (/= (car response) 250) + (smtp-response-error response)))) + +(defun smtp-primitive-quit (package) + (let* ((connection + (smtp-find-connection (current-buffer))) + response) + (smtp-send-command connection "QUIT") + (setq response (smtp-read-response connection)) + (if (/= (car response) 221) + (smtp-response-error response)))) + +;;; @ low level process manipulating function +;;; +(defun smtp-process-filter (process output) + (save-excursion + (set-buffer (process-buffer process)) + (goto-char (point-max)) + (insert output))) + +(put 'smtp-error 'error-message "SMTP error") +(put 'smtp-error 'error-conditions '(smtp-error error)) + +(put 'smtp-response-error 'error-message "SMTP response error") +(put 'smtp-response-error 'error-conditions '(smtp-response-error smtp-error error)) + +(defun smtp-response-error (response) + (signal 'smtp-response-error response)) + +(defun smtp-read-response (connection) + (let ((decoder + (smtp-connection-decoder-internal connection)) + (response-continue t) + response) + (while response-continue + (goto-char smtp-read-point) + (while (not (search-forward "\r\n" nil t)) + (accept-process-output (smtp-connection-process-internal connection)) + (goto-char smtp-read-point)) + (if decoder + (let ((string (buffer-substring smtp-read-point (- (point) 2)))) + (delete-region smtp-read-point (point)) + (insert (funcall decoder string) "\r\n"))) + (setq response + (nconc response + (list (buffer-substring + (+ 4 smtp-read-point) + (- (point) 2))))) + (goto-char + (prog1 smtp-read-point + (setq smtp-read-point (point)))) + (if (looking-at "[1-5][0-9][0-9] ") + (setq response (cons (read (point-marker)) response) + response-continue nil))) + response)) + +(defun smtp-send-command (connection command) + (save-excursion + (let ((process + (smtp-connection-process-internal connection)) + (encoder + (smtp-connection-encoder-internal connection))) + (set-buffer (process-buffer process)) + (goto-char (point-max)) + (setq command (concat command "\r\n")) + (insert command) + (setq smtp-read-point (point)) + (if encoder + (setq command (funcall encoder command))) + (process-send-string process command)))) + +(defun smtp-send-data (connection data) + (let ((process + (smtp-connection-process-internal connection)) + (encoder + (smtp-connection-encoder-internal connection))) + ;; Escape "." at start of a line. + (if (eq (string-to-char data) ?.) + (setq data (concat "." data "\r\n")) + (setq data (concat data "\r\n"))) + (if encoder + (setq data (funcall encoder data))) + (process-send-string process data))) + +(defun smtp-deduce-address-list (smtp-text-buffer header-start header-end) + "Get address list suitable for smtp RCPT TO:
." + (let ((simple-address-list "") + this-line + this-line-end + addr-regexp + (smtp-address-buffer (generate-new-buffer " *smtp-mail*"))) + (unwind-protect + (save-excursion + ;; + (set-buffer smtp-address-buffer) + (setq case-fold-search t) + (erase-buffer) + (insert (save-excursion + (set-buffer smtp-text-buffer) + (buffer-substring-no-properties header-start header-end))) + (goto-char (point-min)) + ;; RESENT-* fields should stop processing of regular fields. + (save-excursion + (if (re-search-forward "^RESENT-TO:" header-end t) + (setq addr-regexp + "^\\(RESENT-TO:\\|RESENT-CC:\\|RESENT-BCC:\\)") + (setq addr-regexp "^\\(TO:\\|CC:\\|BCC:\\)"))) + + (while (re-search-forward addr-regexp header-end t) + (replace-match "") + (setq this-line (match-beginning 0)) + (forward-line 1) + ;; get any continuation lines. + (while (and (looking-at "^[ \t]+") (< (point) header-end)) + (forward-line 1)) + (setq this-line-end (point-marker)) + (setq simple-address-list + (concat simple-address-list " " + (mail-strip-quoted-names + (buffer-substring this-line this-line-end))))) + (erase-buffer) + (insert-string " ") + (insert-string simple-address-list) + (insert-string "\n") + ;; newline --> blank + (subst-char-in-region (point-min) (point-max) 10 ? t) + ;; comma --> blank + (subst-char-in-region (point-min) (point-max) ?, ? t) + ;; tab --> blank + (subst-char-in-region (point-min) (point-max) 9 ? t) + + (goto-char (point-min)) + ;; tidyness in case hook is not robust when it looks at this + (while (re-search-forward "[ \t]+" header-end t) (replace-match " ")) + + (goto-char (point-min)) + (let (recipient-address-list) + (while (re-search-forward " \\([^ ]+\\) " (point-max) t) + (backward-char 1) + (setq recipient-address-list + (cons (buffer-substring (match-beginning 1) (match-end 1)) + recipient-address-list))) + recipient-address-list)) + (kill-buffer smtp-address-buffer)))) + +(provide 'smtp) + +;;; smtp.el ends here diff --git a/mail/smtpmail.el b/mail/smtpmail.el index 6f53489..c1a314e 100644 --- a/mail/smtpmail.el +++ b/mail/smtpmail.el @@ -1,43 +1,40 @@ -;;; smtpmail.el --- simple SMTP protocol (RFC 821) for sending mail -;;; ### Hacked by Mike Taylor, 11th October 1999 to add support for -;;; automatically appending a domain to RCPT TO: addresses. +;;; smtpmail.el --- SMTP interface for mail-mode -;; Copyright (C) 1995, 1996 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1996, 1998, 1999 Free Software Foundation, Inc. ;; Author: Tomoji Kagatani -;; Maintainer: Brian D. Carlstrom -;; ESMTP support: Simon Leinen ;; Keywords: mail -;; This file is part of GNU Emacs. +;; This file is part of FLIM (Faithful Library about Internet Message). -;; GNU Emacs 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 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. -;; GNU Emacs 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. +;; 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, +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. ;;; Commentary: ;; Send Mail to smtp host from smtpmail temp buffer. -;; Please add these lines in your .emacs(_emacs) or use customize. +;; Please add these lines in your .emacs(_emacs). ;; -;;(setq send-mail-function 'smtpmail-send-it) ; if you use `mail' -;;(setq message-send-mail-function 'smtpmail-send-it) ; if you use `message' -;;(setq smtpmail-default-smtp-server "YOUR SMTP HOST") -;;(setq smtpmail-local-domain "YOUR DOMAIN NAME") -;;(setq smtpmail-sendto-domain "YOUR DOMAIN NAME") -;;(setq smtpmail-debug-info t) ; only to debug problems +;;(setq send-mail-function 'smtpmail-send-it) +;;(setq smtp-default-server "YOUR SMTP HOST") +;;(setq smtp-service "smtp") +;;(setq smtp-local-domain "YOUR DOMAIN NAME") +;;(setq smtp-debug-info t) +;;(autoload 'smtpmail-send-it "smtpmail") +;;(setq user-full-name "YOUR NAME HERE") ;; To queue mail, set smtpmail-queue-mail to t and use ;; smtpmail-send-queued-mail to send. @@ -45,94 +42,47 @@ ;;; Code: +(require 'custom) +(require 'smtp) (require 'sendmail) (require 'time-stamp) +(require 'mel) ; binary-write-decoded-region, binary-find-file-noselect -;;; -(defgroup smtpmail nil - "SMTP protocol for sending mail." - :group 'mail) - - -(defcustom smtpmail-default-smtp-server nil - "*Specify default SMTP server." - :type '(choice (const nil) string) - :group 'smtpmail) - -(defcustom smtpmail-smtp-server - (or (getenv "SMTPSERVER") smtpmail-default-smtp-server) - "*The name of the host running SMTP server." - :type '(choice (const nil) string) - :group 'smtpmail) - -(defcustom smtpmail-smtp-service 25 - "*SMTP service port number. smtp or 25 ." - :type 'integer - :group 'smtpmail) - -(defcustom smtpmail-local-domain nil - "*Local domain name without a host name. -If the function (system-name) returns the full internet address, -don't define this value." - :type '(choice (const nil) string) - :group 'smtpmail) - -(defcustom smtpmail-sendto-domain nil - "*Local domain name without a host name. -This is appended (with an @-sign) to any specified recipients which do -not include an @-sign, so that each RCPT TO address is fully qualified. -\(Some configurations of sendmail require this.) - -Don't bother to set this unless you have get an error like: - Sending failed; SMTP protocol error -when sending mail, and the *trace of SMTP session to * -buffer includes an exchange like: - RCPT TO: - 501 : recipient address must contain a domain -" - :type '(choice (const nil) string) - :group 'smtpmail) - -(defun maybe-append-domain (recipient) - (if (or (not smtpmail-sendto-domain) - (string-match "@" recipient)) - recipient - (concat recipient "@" smtpmail-sendto-domain))) - -(defcustom smtpmail-debug-info nil - "*smtpmail debug info printout. messages and process buffer." - :type 'boolean - :group 'smtpmail) +(eval-when-compile (require 'static)) -(defcustom smtpmail-code-conv-from nil ;; *junet* - "*smtpmail code convert from this code to *internal*..for tiny-mime.." - :type 'boolean - :group 'smtpmail) +;; (static-when (featurep 'xemacs) +;; (define-obsolete-variable-alias 'smtpmail-default-smtp-server +;; 'smtp-default-server) +;; (define-obsolete-variable-alias 'smtpmail-smtp-server 'smtp-server) +;; (define-obsolete-variable-alias 'smtpmail-smtp-service 'smtp-service) +;; (define-obsolete-variable-alias 'smtpmail-local-domain 'smtp-local-domain) +;; (define-obsolete-variable-alias 'smtpmail-debug-info 'smtp-debug-info) +;; ) + +;;; (defcustom smtpmail-queue-mail nil - "*Specify if mail is queued (if t) or sent immediately (if nil). + "Specify if mail is queued (if t) or sent immediately (if nil). If queued, it is stored in the directory `smtpmail-queue-dir' and sent with `smtpmail-send-queued-mail'." :type 'boolean - :group 'smtpmail) + :group 'smtp) (defcustom smtpmail-queue-dir "~/Mail/queued-mail/" - "*Directory where `smtpmail.el' stores queued mail." + "Directory where `smtpmail.el' stores queued mail." :type 'directory - :group 'smtpmail) + :group 'smtp) (defvar smtpmail-queue-index-file "index" "File name of queued mail index, This is relative to `smtpmail-queue-dir'.") -(defvar smtpmail-address-buffer) -(defvar smtpmail-recipient-address-list) +(defvar smtpmail-queue-index + (concat (file-name-as-directory smtpmail-queue-dir) + smtpmail-queue-index-file)) -;; Buffer-local variable. -(defvar smtpmail-read-point) +(defvar smtpmail-recipient-address-list nil) -(defvar smtpmail-queue-index (concat smtpmail-queue-dir - smtpmail-queue-index-file)) ;;; ;;; @@ -146,12 +96,9 @@ This is relative to `smtpmail-queue-dir'.") 0)) (tembuf (generate-new-buffer " smtpmail temp")) (case-fold-search nil) + resend-to-addresses delimline - (mailbuf (current-buffer)) - (smtpmail-code-conv-from - (if enable-multibyte-characters - (let ((sendmail-coding-system smtpmail-code-conv-from)) - (select-message-coding-system))))) + (mailbuf (current-buffer))) (unwind-protect (save-excursion (set-buffer tembuf) @@ -162,10 +109,14 @@ This is relative to `smtpmail-queue-dir'.") (or (= (preceding-char) ?\n) (insert ?\n)) ;; Change header-delimiter to be what sendmail expects. - (mail-sendmail-undelimit-header) + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "\n")) + (replace-match "\n") + (backward-char 1) (setq delimline (point-marker)) ;; (sendmail-synch-aliases) - (if mail-aliases + (if (and mail-aliases (fboundp 'expand-mail-aliases)) ; XEmacs (expand-mail-aliases (point-min) delimline)) (goto-char (point-min)) ;; ignore any blank lines in the header @@ -173,17 +124,38 @@ This is relative to `smtpmail-queue-dir'.") (< (point) delimline)) (replace-match "\n")) (let ((case-fold-search t)) - ;; We used to process Resent-... headers here, - ;; but it was not done properly, and the job - ;; is done correctly in smtpmail-deduce-address-list. + (goto-char (point-min)) + (goto-char (point-min)) + (while (re-search-forward "^Resent-to:" delimline t) + (setq resend-to-addresses + (save-restriction + (narrow-to-region (point) + (save-excursion + (forward-line 1) + (while (looking-at "^[ \t]") + (forward-line 1)) + (point))) + (append (mail-parse-comma-list) + resend-to-addresses)))) +;;; Apparently this causes a duplicate Sender. +;;; ;; If the From is different than current user, insert Sender. +;;; (goto-char (point-min)) +;;; (and (re-search-forward "^From:" delimline t) +;;; (progn +;;; (require 'mail-utils) +;;; (not (string-equal +;;; (mail-strip-quoted-names +;;; (save-restriction +;;; (narrow-to-region (point-min) delimline) +;;; (mail-fetch-field "From"))) +;;; (user-login-name)))) +;;; (progn +;;; (forward-line 1) +;;; (insert "Sender: " (user-login-name) "\n"))) ;; Don't send out a blank subject line (goto-char (point-min)) - (if (re-search-forward "^Subject:\\([ \t]*\n\\)+\\b" delimline t) - (replace-match "") - ;; This one matches a Subject just before the header delimiter. - (if (and (re-search-forward "^Subject:\\([ \t]*\n\\)+" delimline t) - (= (match-end 0) delimline)) - (replace-match ""))) + (if (re-search-forward "^Subject:[ \t]*\n" delimline t) + (replace-match "")) ;; Put the "From:" field in unless for some odd reason ;; they put one in themselves. (goto-char (point-min)) @@ -246,25 +218,24 @@ This is relative to `smtpmail-queue-dir'.") ;; ;; ;; - (setq smtpmail-address-buffer (generate-new-buffer "*smtp-mail*")) (setq smtpmail-recipient-address-list - (smtpmail-deduce-address-list tembuf (point-min) delimline)) - (kill-buffer smtpmail-address-buffer) - + (or resend-to-addresses + (smtp-deduce-address-list tembuf (point-min) delimline))) + (smtpmail-do-bcc delimline) ; Send or queue (if (not smtpmail-queue-mail) - (if (not (null smtpmail-recipient-address-list)) - (if (not (smtpmail-via-smtp - smtpmail-recipient-address-list tembuf)) - (error "Sending failed; SMTP protocol error")) + (if smtpmail-recipient-address-list + (smtp-send-buffer user-mail-address + smtpmail-recipient-address-list + tembuf) (error "Sending failed; no recipients")) - (let* ((file-data (concat - smtpmail-queue-dir - (concat (time-stamp-yyyy-mm-dd) - "_" (time-stamp-hh:mm:ss)))) - (file-data (convert-standard-filename file-data)) - (file-elisp (concat file-data ".el")) + (let* ((file-data (convert-standard-filename + (concat + (file-name-as-directory smtpmail-queue-dir) + (time-stamp-yyyy-mm-dd) + "_" (time-stamp-hh:mm:ss)))) + (file-elisp (concat file-data ".el")) (buffer-data (create-file-buffer file-data)) (buffer-elisp (create-file-buffer file-elisp)) (buffer-scratch "*queue-mail*")) @@ -272,7 +243,9 @@ This is relative to `smtpmail-queue-dir'.") (set-buffer buffer-data) (erase-buffer) (insert-buffer tembuf) - (write-file file-data) + (or (file-directory-p smtpmail-queue-dir) + (make-directory smtpmail-queue-dir t)) + (binary-write-decoded-region (point-min) (point-max) file-data) (set-buffer buffer-elisp) (erase-buffer) (insert (concat @@ -308,11 +281,10 @@ This is relative to `smtpmail-queue-dir'.") (end-of-line) (point)))) (load file-msg) - (setq tembuf (find-file-noselect file-msg)) - (if (not (null smtpmail-recipient-address-list)) - (if (not (smtpmail-via-smtp smtpmail-recipient-address-list - tembuf)) - (error "Sending failed; SMTP protocol error")) + (setq tembuf (binary-find-file-noselect file-msg)) + (if smtpmail-recipient-address-list + (smtp-send-buffer user-mail-address + smtpmail-recipient-address-list tembuf) (error "Sending failed; no recipients")) (delete-file file-msg) (delete-file (concat file-msg ".el")) @@ -323,397 +295,27 @@ This is relative to `smtpmail-queue-dir'.") (kill-buffer buffer-index) ))) -;(defun smtpmail-via-smtp (host,port,sender,destination,smtpmail-text-buffer) - -(defun smtpmail-fqdn () - (if smtpmail-local-domain - (concat (system-name) "." smtpmail-local-domain) - (system-name))) - -(defun smtpmail-via-smtp (recipient smtpmail-text-buffer) - (let ((process nil) - (host (or smtpmail-smtp-server - (error "`smtpmail-smtp-server' not defined"))) - (port smtpmail-smtp-service) - response-code - greeting - process-buffer - (supported-extensions '())) - (unwind-protect - (catch 'done - ;; get or create the trace buffer - (setq process-buffer - (get-buffer-create (format "*trace of SMTP session to %s*" host))) - - ;; clear the trace buffer of old output - (save-excursion - (set-buffer process-buffer) - (erase-buffer)) - - ;; open the connection to the server - (setq process (open-network-stream "SMTP" process-buffer host port)) - (and (null process) (throw 'done nil)) - - ;; set the send-filter - (set-process-filter process 'smtpmail-process-filter) - - (save-excursion - (set-buffer process-buffer) - (set-buffer-process-coding-system 'raw-text-unix 'raw-text-unix) - (make-local-variable 'smtpmail-read-point) - (setq smtpmail-read-point (point-min)) - - - (if (or (null (car (setq greeting (smtpmail-read-response process)))) - (not (integerp (car greeting))) - (>= (car greeting) 400)) - (throw 'done nil) - ) - - ;; EHLO - (smtpmail-send-command process (format "EHLO %s" (smtpmail-fqdn))) - - (if (or (null (car (setq response-code (smtpmail-read-response process)))) - (not (integerp (car response-code))) - (>= (car response-code) 400)) - (progn - ;; HELO - (smtpmail-send-command process (format "HELO %s" (smtpmail-fqdn))) - - (if (or (null (car (setq response-code (smtpmail-read-response process)))) - (not (integerp (car response-code))) - (>= (car response-code) 400)) - (throw 'done nil))) - (let ((extension-lines (cdr (cdr response-code)))) - (while extension-lines - (let ((name (intern (downcase (car (split-string (substring (car extension-lines) 4) "[ ]")))))) - (and name - (cond ((memq name '(verb xvrb 8bitmime onex xone - expn size dsn etrn - help xusr)) - (setq supported-extensions - (cons name supported-extensions))) - (t (message "unknown extension %s" - name))))) - (setq extension-lines (cdr extension-lines))))) - - (if (or (member 'onex supported-extensions) - (member 'xone supported-extensions)) - (progn - (smtpmail-send-command process (format "ONEX")) - (if (or (null (car (setq response-code (smtpmail-read-response process)))) - (not (integerp (car response-code))) - (>= (car response-code) 400)) - (throw 'done nil)))) - - (if (and smtpmail-debug-info - (or (member 'verb supported-extensions) - (member 'xvrb supported-extensions))) - (progn - (smtpmail-send-command process (format "VERB")) - (if (or (null (car (setq response-code (smtpmail-read-response process)))) - (not (integerp (car response-code))) - (>= (car response-code) 400)) - (throw 'done nil)))) - - (if (member 'xusr supported-extensions) - (progn - (smtpmail-send-command process (format "XUSR")) - (if (or (null (car (setq response-code (smtpmail-read-response process)))) - (not (integerp (car response-code))) - (>= (car response-code) 400)) - (throw 'done nil)))) - - ;; MAIL FROM: - (let ((size-part - (if (member 'size supported-extensions) - (format " SIZE=%d" - (save-excursion - (set-buffer smtpmail-text-buffer) - ;; size estimate: - (+ (- (point-max) (point-min)) - ;; Add one byte for each change-of-line - ;; because or CR-LF representation: - (count-lines (point-min) (point-max)) - ;; For some reason, an empty line is - ;; added to the message. Maybe this - ;; is a bug, but it can't hurt to add - ;; those two bytes anyway: - 2))) - "")) - (body-part - (if (member '8bitmime supported-extensions) - ;; FIXME: - ;; Code should be added here that transforms - ;; the contents of the message buffer into - ;; something the receiving SMTP can handle. - ;; For a receiver that supports 8BITMIME, this - ;; may mean converting BINARY to BASE64, or - ;; adding Content-Transfer-Encoding and the - ;; other MIME headers. The code should also - ;; return an indication of what encoding the - ;; message buffer is now, i.e. ASCII or - ;; 8BITMIME. - (if nil - " BODY=8BITMIME" - "") - ""))) -; (smtpmail-send-command process (format "MAIL FROM:%s@%s" (user-login-name) (smtpmail-fqdn))) - (smtpmail-send-command process (format "MAIL FROM: <%s>%s%s" - user-mail-address - size-part - body-part)) - - (if (or (null (car (setq response-code (smtpmail-read-response process)))) - (not (integerp (car response-code))) - (>= (car response-code) 400)) - (throw 'done nil) - )) - - ;; RCPT TO: - (let ((n 0)) - (while (not (null (nth n recipient))) - (smtpmail-send-command process (format "RCPT TO: <%s>" (maybe-append-domain (nth n recipient)))) - (setq n (1+ n)) - - (setq response-code (smtpmail-read-response process)) - (if (or (null (car response-code)) - (not (integerp (car response-code))) - (>= (car response-code) 400)) - (throw 'done nil) - ) - )) - - ;; DATA - (smtpmail-send-command process "DATA") - - (if (or (null (car (setq response-code (smtpmail-read-response process)))) - (not (integerp (car response-code))) - (>= (car response-code) 400)) - (throw 'done nil) - ) - - ;; Mail contents - (smtpmail-send-data process smtpmail-text-buffer) - - ;;DATA end "." - (smtpmail-send-command process ".") - - (if (or (null (car (setq response-code (smtpmail-read-response process)))) - (not (integerp (car response-code))) - (>= (car response-code) 400)) - (throw 'done nil) - ) - - ;;QUIT -; (smtpmail-send-command process "QUIT") -; (and (null (car (smtpmail-read-response process))) -; (throw 'done nil)) - t )) - (if process - (save-excursion - (set-buffer (process-buffer process)) - (smtpmail-send-command process "QUIT") - (smtpmail-read-response process) - -; (if (or (null (car (setq response-code (smtpmail-read-response process)))) -; (not (integerp (car response-code))) -; (>= (car response-code) 400)) -; (throw 'done nil) -; ) - (delete-process process)))))) - - -(defun smtpmail-process-filter (process output) - (save-excursion - (set-buffer (process-buffer process)) - (goto-char (point-max)) - (insert output))) - -(defun smtpmail-read-response (process) - (let ((case-fold-search nil) - (response-strings nil) - (response-continue t) - (return-value '(nil ())) - match-end) - - (while response-continue - (goto-char smtpmail-read-point) - (while (not (search-forward "\r\n" nil t)) - (accept-process-output process) - (goto-char smtpmail-read-point)) - - (setq match-end (point)) - (setq response-strings - (cons (buffer-substring smtpmail-read-point (- match-end 2)) - response-strings)) - - (goto-char smtpmail-read-point) - (if (looking-at "[0-9]+ ") - (let ((begin (match-beginning 0)) - (end (match-end 0))) - (if smtpmail-debug-info - (message "%s" (car response-strings))) - - (setq smtpmail-read-point match-end) - - ;; ignore lines that start with "0" - (if (looking-at "0[0-9]+ ") - nil - (setq response-continue nil) - (setq return-value - (cons (string-to-int - (buffer-substring begin end)) - (nreverse response-strings))))) - - (if (looking-at "[0-9]+-") - (progn (if smtpmail-debug-info - (message "%s" (car response-strings))) - (setq smtpmail-read-point match-end) - (setq response-continue t)) - (progn - (setq smtpmail-read-point match-end) - (setq response-continue nil) - (setq return-value - (cons nil (nreverse response-strings))) - ) - ))) - (setq smtpmail-read-point match-end) - return-value)) - - -(defun smtpmail-send-command (process command) - (goto-char (point-max)) - (if (= (aref command 0) ?P) - (insert "PASS \r\n") - (insert command "\r\n")) - (setq smtpmail-read-point (point)) - (process-send-string process command) - (process-send-string process "\r\n")) - -(defun smtpmail-send-data-1 (process data) - (goto-char (point-max)) - - (if (and (multibyte-string-p data) - smtpmail-code-conv-from) - (setq data (string-as-multibyte - (encode-coding-string data smtpmail-code-conv-from)))) - - (if smtpmail-debug-info - (insert data "\r\n")) - - (setq smtpmail-read-point (point)) - ;; Escape "." at start of a line - (if (eq (string-to-char data) ?.) - (process-send-string process ".")) - (process-send-string process data) - (process-send-string process "\r\n") - ) - -(defun smtpmail-send-data (process buffer) - (let - ((data-continue t) - (sending-data nil) - this-line - this-line-end) - - (save-excursion - (set-buffer buffer) - (goto-char (point-min))) - - (while data-continue - (save-excursion - (set-buffer buffer) - (beginning-of-line) - (setq this-line (point)) - (end-of-line) - (setq this-line-end (point)) - (setq sending-data nil) - (setq sending-data (buffer-substring this-line this-line-end)) - (if (/= (forward-line 1) 0) - (setq data-continue nil))) - - (smtpmail-send-data-1 process sending-data) - ) - ) - ) - - -(defun smtpmail-deduce-address-list (smtpmail-text-buffer header-start header-end) - "Get address list suitable for smtp RCPT TO:
." - (require 'mail-utils) ;; pick up mail-strip-quoted-names - - (unwind-protect - (save-excursion - (set-buffer smtpmail-address-buffer) (erase-buffer) - (let - ((case-fold-search t) - (simple-address-list "") - this-line - this-line-end - addr-regexp) - (insert-buffer-substring smtpmail-text-buffer header-start header-end) - (goto-char (point-min)) - ;; RESENT-* fields should stop processing of regular fields. - (save-excursion - (if (re-search-forward "^Resent-\\(to\\|cc\\|bcc\\):" header-end t) - (setq addr-regexp "^Resent-\\(to\\|cc\\|bcc\\):") - (setq addr-regexp "^\\(To:\\|Cc:\\|Bcc:\\)"))) - - (while (re-search-forward addr-regexp header-end t) - (replace-match "") - (setq this-line (match-beginning 0)) - (forward-line 1) - ;; get any continuation lines - (while (and (looking-at "^[ \t]+") (< (point) header-end)) - (forward-line 1)) - (setq this-line-end (point-marker)) - (setq simple-address-list - (concat simple-address-list " " - (mail-strip-quoted-names (buffer-substring this-line this-line-end)))) - ) - (erase-buffer) - (insert-string " ") - (insert-string simple-address-list) - (insert-string "\n") - (subst-char-in-region (point-min) (point-max) 10 ? t);; newline --> blank - (subst-char-in-region (point-min) (point-max) ?, ? t);; comma --> blank - (subst-char-in-region (point-min) (point-max) 9 ? t);; tab --> blank - - (goto-char (point-min)) - ;; tidyness in case hook is not robust when it looks at this - (while (re-search-forward "[ \t]+" header-end t) (replace-match " ")) - - (goto-char (point-min)) - (let (recipient-address-list) - (while (re-search-forward " \\([^ ]+\\) " (point-max) t) - (backward-char 1) - (setq recipient-address-list (cons (buffer-substring (match-beginning 1) (match-end 1)) - recipient-address-list)) - ) - (setq smtpmail-recipient-address-list recipient-address-list)) - - ) - ) - ) - ) - (defun smtpmail-do-bcc (header-end) - "Delete [Resent-]BCC: and their continuation lines from the header area. + "Delete BCC: and their continuation lines from the header area. There may be multiple BCC: lines, and each may have arbitrarily many continuation lines." (let ((case-fold-search t)) (save-excursion (goto-char (point-min)) ;; iterate over all BCC: lines - (while (re-search-forward "^\\(RESENT-\\)?BCC:" header-end t) - (delete-region (match-beginning 0) - (progn (forward-line 1) (point))) + (while (re-search-forward "^BCC:" header-end t) + (delete-region (match-beginning 0) (progn (forward-line 1) (point))) ;; get rid of any continuation lines (while (and (looking-at "^[ \t].*\n") (< (point) header-end)) - (replace-match "")))))) + (replace-match "")) + ) + ) ;; save-excursion + ) ;; let + ) + +;;; (provide 'smtpmail) diff --git a/mime/emh-comp.el b/mime/emh-comp.el new file mode 100644 index 0000000..dcbe6c6 --- /dev/null +++ b/mime/emh-comp.el @@ -0,0 +1,527 @@ +;;; emh-comp.el --- emh functions for composing messages + +;; Copyright (C) 1993,94,95,96,97,98,99,2000 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; OKABE Yasuo +;; Created: 1996/2/29 (separated from tm-mh-e.el) +;; Renamed: 1997/2/21 from tmh-comp.el +;; Keywords: mail composing, MH, MIME, mail + +;; This file is part of emh. + +;; 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 'mh-comp) +(require 'mime-edit) +(require 'emh-def) + +;; Avoid byte compile warnings. +;; (defvar gnus-article-buffer) +;; (defvar gnus-article-copy) +;; (defvar gnus-original-article-buffer) +;; (eval-when-compile +;; (fset 'gnus-copy-article-buffer 'ignore) +;; ) + + +;;; @ variable +;;; + +(defvar emh-forwcomps "forwcomps" + "Name of file to be used as a skeleton for forwarding messages. +Default is \"forwcomps\". If not a complete path name, the file +is searched for first in the user's MH directory, then in the +system MH lib directory.") + +;; (defvar emh-message-yank-function 'mh-yank-cur-msg) + + +;;; @ for tm-edit +;;; + +(defun emh::make-message (folder number) + (vector folder number) + ) + +(defun emh::message/folder (message) + (elt message 0) + ) + +(defun emh::message/number (message) + (elt message 1) + ) + +(defun emh::message/file-name (message) + (expand-file-name + (emh::message/number message) + (mh-expand-file-name (emh::message/folder message)) + )) + +;;; modified by OKABE Yasuo +;;; 1995/11/14 (cf. [tm-ja:1096]) +(defun emh-prompt-for-message (prompt folder &optional default) + (let* ((files + (directory-files (mh-expand-file-name folder) nil "^[0-9]+$") + ) + (folder-buf (get-buffer folder)) + (default + (if folder-buf + (save-excursion + (set-buffer folder-buf) + (let* ((show-buffer (get-buffer mh-show-buffer)) + (show-buffer-file-name + (buffer-file-name show-buffer))) + (if show-buffer-file-name + (file-name-nondirectory show-buffer-file-name))))))) + (if (or (null default) + (not (string-match "^[0-9]+$" default))) + (setq default + (if (and (string= folder mh-sent-from-folder) + mh-sent-from-msg) + (int-to-string mh-sent-from-msg) + (save-excursion + (let (cur-msg) + (if (and + (= 0 (mh-exec-cmd-quiet nil "pick" folder "cur")) + (set-buffer mh-temp-buffer) + (setq cur-msg (buffer-string)) + (string-match "^[0-9]+$" cur-msg)) + (substring cur-msg 0 (match-end 0)) + (car files))))))) + (completing-read prompt + (let ((i 0)) + (mapcar (function + (lambda (file) + (setq i (+ i 1)) + (list file i) + )) + files) + ) nil nil default) + )) + +;;; modified by OKABE Yasuo +;;; 1995/11/14 (cf. [tm-ja:1096]) +(defun emh-query-message (&optional message) + (let (folder number) + (if message + (progn + (setq folder (emh::message/folder message)) + (setq number (emh::message/number message)) + )) + (or (stringp folder) + (setq folder (mh-prompt-for-folder + "Message from" + (if (and (stringp mh-sent-from-folder) + (string-match "^\\+" mh-sent-from-folder)) + mh-sent-from-folder "+inbox") + nil))) + (setq number + (if (numberp number) + (number-to-string number) + (emh-prompt-for-message "Message number: " folder) + )) + (emh::make-message folder number) + )) + +(defun emh-insert-message (&optional message) + ;; always ignores message + ;; (let ((article-buffer + ;; (if (not (and (stringp mh-sent-from-folder) + ;; (numberp mh-sent-from-msg) + ;; )) + ;; (cond ((and (boundp 'gnus-original-article-buffer) + ;; (bufferp mh-sent-from-folder) + ;; (get-buffer gnus-original-article-buffer) + ;; ) + ;; gnus-original-article-buffer) + ;; ((and (boundp 'gnus-article-buffer) + ;; (get-buffer gnus-article-buffer) + ;; (bufferp mh-sent-from-folder) + ;; ) + ;; (save-excursion + ;; (set-buffer gnus-article-buffer) + ;; (if (eq major-mode 'mime-view-mode) + ;; mime-raw-buffer + ;; (current-buffer) + ;; ))) + ;; )))) + (if (null article-buffer) + (emh-insert-mail + (emh::make-message mh-sent-from-folder mh-sent-from-msg)) + ;; (insert-buffer article-buffer) + ;; (mime-edit-inserted-message-filter) + ;; ) + )) + +(defun emh-insert-mail (&optional message) + (save-excursion + (save-restriction + (let ((message-file + (emh::message/file-name (emh-query-message message)))) + (narrow-to-region (point) (point)) + (insert-file-contents message-file) + (push-mark (point-max)) + (mime-edit-inserted-message-filter) + )))) + +(set-alist 'mime-edit-message-inserter-alist + 'mh-letter-mode (function emh-insert-message)) +(set-alist 'mime-edit-mail-inserter-alist + 'mh-letter-mode (function emh-insert-mail)) +(set-alist 'mime-edit-mail-inserter-alist + 'news-reply-mode (function emh-insert-mail)) +(set-alist + 'mime-edit-split-message-sender-alist + 'mh-letter-mode + (function + (lambda (&optional arg) + (interactive "P") + (write-region (point-min) (point-max) + mime-edit-draft-file-name nil 'no-message) + (cond (arg + (pop-to-buffer "MH mail delivery") + (erase-buffer) + (mh-exec-cmd-output mh-send-prog t "-watch" "-nopush" + "-nodraftfolder" + mh-send-args + mime-edit-draft-file-name) + (goto-char (point-max)) ; show the interesting part + (recenter -1) + (sit-for 1)) + (t + (apply 'mh-exec-cmd-quiet t mh-send-prog + (mh-list-to-string + (list "-nopush" "-nodraftfolder" + "-noverbose" "-nowatch" + mh-send-args mime-edit-draft-file-name))))) + ))) + + +;;; @ commands using tm-edit features +;;; + +(defun emh-edit-again (msg) + "Clean-up a draft or a message previously sent and make it resendable. +Default is the current message. +The variable mh-new-draft-cleaned-headers specifies the headers to remove. +See also documentation for `\\[mh-send]' function." + (interactive (list (mh-get-msg-num t))) + (catch 'tag + (let* ((from-folder mh-current-folder) + (config (current-window-configuration)) + (draft + (cond ((and mh-draft-folder (equal from-folder mh-draft-folder)) + (let ((name (format "draft-%d" msg))) + (if (get-buffer name) + (throw 'tag (pop-to-buffer name)) + ) + (let ((filename + (mh-msg-filename msg mh-draft-folder) + )) + (set-buffer (get-buffer-create name)) + (binary-insert-file-contents filename) + (setq buffer-file-name filename) + ) + (pop-to-buffer name) + (if (re-search-forward "^-+$" nil t) + (replace-match "") + ) + name)) + (t + (let ((flag enable-multibyte-characters) + (coding-system-for-read 'binary)) + (prog1 + (mh-read-draft "clean-up" + (mh-msg-filename msg) nil) + (set-buffer-multibyte flag) + )) + )))) + (goto-char (point-min)) + (mh-clean-msg-header (point-min) mh-new-draft-cleaned-headers nil) + (let ((cs (detect-coding-region (point-min)(point-max)))) + (set-buffer-file-coding-system + (if (listp cs) + (car cs) + cs))) + (save-buffer) + (mime-edit-again nil 'no-separator 'not-turn-on) + (goto-char (point-min)) + (mh-compose-and-send-mail draft "" from-folder nil nil nil nil nil nil + config) + ))) + +;;; by OKABE Yasuo +;;; 1996/2/29 (cf. [tm-ja:1643]) +(defun emh-extract-rejected-mail (msg) + "Extract a letter returned by the mail system and make it re-editable. +Default is the current message. The variable mh-new-draft-cleaned-headers +gives the headers to clean out of the original message." + (interactive (list (mh-get-msg-num t))) + (let ((from-folder mh-current-folder) + (config (current-window-configuration)) + (draft (mh-read-draft "extraction" (mh-msg-filename msg) nil))) + (setq buffer-read-only nil) + (goto-char (point-min)) + (cond + ((and + (re-search-forward + (concat "^\\($\\|[Cc]ontent-[Tt]ype:[ \t]+multipart/\\)") nil t) + (not (bolp)) + (re-search-forward "boundary=\"\\([^\"]+\\)\"" nil t)) + (let ((case-fold-search t) + (boundary (buffer-substring (match-beginning 1) (match-end 1)))) + (cond + ((re-search-forward + (concat "^--" boundary "\n" + "content-type:[ \t]+" + "\\(message/rfc822\\|text/rfc822-headers\\)\n" + "\\(.+\n\\)*\n") nil t) + (delete-region (point-min) (point)) + (mh-clean-msg-header (point-min) mh-new-draft-cleaned-headers nil) + (search-forward + (concat "\n--" boundary "--\n") nil t) + (delete-region (match-beginning 0) (point-max))) + (t + (message "Seems no message/rfc822 part."))))) + ((re-search-forward mh-rejected-letter-start nil t) + (skip-chars-forward " \t\n") + (delete-region (point-min) (point)) + (mh-clean-msg-header (point-min) mh-new-draft-cleaned-headers nil)) + (t + (message "Does not appear to be a rejected letter."))) + (goto-char (point-min)) + (if (re-search-forward "^-+$" nil t) + (replace-match "") + ) + (mime-edit-again nil t t) + (goto-char (point-min)) + (set-buffer-modified-p nil) + (mh-compose-and-send-mail draft "" from-folder msg + (mh-get-header-field "To:") + (mh-get-header-field "From:") + (mh-get-header-field "Cc:") + nil nil config))) + +;;; by OKABE Yasuo +;;; 1995/11/14 (cf. [tm-ja:1099]) +(defun emh-forward (to cc &optional msg-or-seq) + "Forward a message or message sequence as MIME message/rfc822. +Defaults to displayed message. If optional prefix argument provided, +then prompt for the message sequence. See also documentation for +`\\[mh-send]' function." + (interactive (list (mh-read-address "To: ") + (mh-read-address "Cc: ") + (if current-prefix-arg + (mh-read-seq-default "Forward" t) + (mh-get-msg-num t) + ))) + (or msg-or-seq + (setq msg-or-seq (mh-get-msg-num t))) + (let* ((folder mh-current-folder) + (config (current-window-configuration)) + ;; uses "draft" for compatibility with forw. + ;; forw always leaves file in "draft" since it doesn't have -draft + (draft-name (expand-file-name "draft" mh-user-path)) + (draft (cond ((or (not (file-exists-p draft-name)) + (y-or-n-p "The file `draft' exists. Discard it? ")) + (mh-exec-cmd "comp" + "-noedit" "-nowhatnowproc" + "-form" emh-forwcomps + "-nodraftfolder") + (prog1 + (mh-read-draft "" draft-name t) + (mh-insert-fields "To:" to "Cc:" cc) + (set-buffer-modified-p nil))) + (t + (mh-read-draft "" draft-name nil))))) + (let ((tag-regexp + (concat "^" (regexp-quote (mime-make-tag "message" "rfc822")))) + orig-from orig-subject multipart-flag) + (goto-char (point-min)) + (save-excursion + (save-restriction + (goto-char (point-max)) + (if (not (bolp)) (insert "\n")) + (let ((beg (point))) + (narrow-to-region beg beg) + (mh-exec-cmd-output "pick" nil folder msg-or-seq) + (if (> (count-lines (point) (point-max)) 1) + (setq multipart-flag t) + ) + (while (re-search-forward "^\\([0-9]+\\)\n" nil t) + (let ((forw-msg + (buffer-substring (match-beginning 1) (match-end 1))) + (beg (match-beginning 0)) + (end (match-end 0)) + ) + (save-restriction + (narrow-to-region beg end) + ;; modified for Emacs 18 + (delete-region beg end) + (insert-file-contents + (mh-expand-file-name forw-msg + (mh-expand-file-name folder)) + ) + (save-excursion + (push-mark (point-max)) + (mime-edit-inserted-message-filter)) + (goto-char (point-max)) + ) + (save-excursion + (goto-char beg) + (mime-edit-insert-tag "message" "rfc822") + ))) + (delete-region (point) (point-max)) + (if multipart-flag + (mime-edit-enclose-digest-region beg (point)) + )))) + (re-search-forward tag-regexp) + (forward-line 1) + (save-restriction + (narrow-to-region (point) (point-max)) + (setq orig-from (eword-decode-string + (mh-get-header-field "From:"))) + (setq orig-subject (eword-decode-string + (mh-get-header-field "Subject:"))) + ) + (let ((forw-subject + (mh-forwarded-letter-subject orig-from orig-subject))) + (mh-insert-fields "Subject:" forw-subject) + (goto-char (point-min)) + (re-search-forward tag-regexp) + (forward-line -1) + (delete-other-windows) + (if (numberp msg-or-seq) + (mh-add-msgs-to-seq msg-or-seq 'forwarded t) + (mh-add-msgs-to-seq (mh-seq-to-msgs msg-or-seq) 'forwarded t)) + (mh-compose-and-send-mail draft "" folder msg-or-seq + to forw-subject cc + mh-note-forw "Forwarded:" + config))))) + +(cond ((not (featurep 'mh-utils)) + (defun emh::insert-letter (folder number verbatim) + (mh-insert-letter verbatim folder number) + ) + ) + ((and (boundp 'mh-e-version) + (string-lessp mh-e-version "5")) + (defun emh::insert-letter (folder number verbatim) + (mh-insert-letter number folder verbatim) + ) + ) + (t + (defalias 'emh::insert-letter 'mh-insert-letter) + )) + +(defun emh-insert-letter (verbatim) + "Interface to mh-insert-letter." + (interactive "P") + (let* + ((folder (mh-prompt-for-folder + "Message from" + (if (and (stringp mh-sent-from-folder) + (string-match "^\\+" mh-sent-from-folder)) + mh-sent-from-folder "+inbox") + nil)) + (number (emh-prompt-for-message "Message number: " folder))) + (emh::insert-letter folder number verbatim))) + +;; (defun emh-yank-cur-msg-with-no-filter () +;; "Insert the current message into the draft buffer. +;; This function makes new show-buffer from article-buffer to disable +;; variable `mime-preview-text/plain-hook'. If you don't want to use text +;; filters for replying message, please set it to +;; `emh-message-yank-function'. +;; Prefix each non-blank line in the message with the string in +;; `mh-ins-buf-prefix'. The entire message will be inserted if +;; `mh-yank-from-start-of-msg' is non-nil. If this variable is nil, the +;; portion of the message following the point will be yanked. If +;; `mh-delete-yanked-msg-window' is non-nil, any window displaying the +;; yanked message will be deleted." +;; (interactive) +;; (if (and mh-sent-from-folder mh-sent-from-msg) +;; (let ((to-point (point)) +;; (to-buffer (current-buffer))) +;; (set-buffer mh-sent-from-folder) +;; (if mh-delete-yanked-msg-window +;; (delete-windows-on mh-show-buffer)) +;; (set-buffer mh-show-buffer) ; Find displayed message +;; (let ((mh-ins-str +;; (if mime-raw-buffer +;; (let (mime-display-text/plain-hook buf) +;; (prog1 +;; (save-window-excursion +;; (set-buffer mime-raw-buffer) +;; (setq buf (mime-view-mode)) +;; (buffer-string) +;; ) +;; (kill-buffer buf) +;; )) +;; (buffer-string) +;; ))) +;; (set-buffer to-buffer) +;; (save-restriction +;; (narrow-to-region to-point to-point) +;; (push-mark) +;; (insert mh-ins-str) +;; (mh-insert-prefix-string mh-ins-buf-prefix) +;; (insert "\n")))) +;; (error "There is no current message"))) + +;; (defun emh-yank-current-message () +;; "Insert the current message into the draft buffer. +;; It uses variable `emh-message-yank-function' +;; to select message yanking function." +;; (interactive) +;; (let ((mh-sent-from-folder mh-sent-from-folder) +;; (mh-sent-from-msg mh-sent-from-msg)) +;; (if (and (not (stringp mh-sent-from-folder)) +;; (boundp 'gnus-article-buffer) +;; (get-buffer gnus-article-buffer) +;; (bufferp mh-sent-from-folder) +;; ) ; might be called from GNUS +;; (if (boundp 'gnus-article-copy) ; might be sgnus +;; (save-excursion +;; (gnus-copy-article-buffer) +;; (setq mh-sent-from-folder gnus-article-copy) +;; (set-buffer mh-sent-from-folder) +;; (setq mh-show-buffer gnus-article-copy) +;; ) +;; (save-excursion +;; (setq mh-sent-from-folder gnus-article-buffer) +;; (set-buffer gnus-article-buffer) +;; (setq mh-show-buffer (current-buffer)) +;; ))) +;; (funcall emh-message-yank-function) +;; )) + +;; (substitute-key-definition +;; 'mh-yank-cur-msg 'emh-yank-current-message mh-letter-mode-map) +;; (substitute-key-definition +;; 'mh-insert-letter 'emh-insert-letter mh-letter-mode-map) + + +;;; @ end +;;; + +(provide 'emh-comp) +(require 'emh) + +;;; emh-comp.el ends here diff --git a/mime/emh-def.el b/mime/emh-def.el new file mode 100644 index 0000000..cf80a48 --- /dev/null +++ b/mime/emh-def.el @@ -0,0 +1,41 @@ +;;; emh-def.el --- definition for emh + +;; Copyright (C) 2000 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Keywords: mail composing, MH, MIME, mail + +;; This file is part of emh. + +;; 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: + +(or (fboundp 'find-face) + (defun find-face (face-or-name) + "Retrieve the face of the given name. +If FACE-OR-NAME is a face object, it is simply returned. +Otherwise, FACE-OR-NAME should be a symbol. If there is no such face, +nil is returned. Otherwise the associated face object is returned." + (car (memq face-or-name (face-list))))) + + +;;; @ end +;;; + +(provide 'emh-def) + +;;; emh-def.el ends here diff --git a/mime/emh-face.el b/mime/emh-face.el new file mode 100644 index 0000000..f37af61 --- /dev/null +++ b/mime/emh-face.el @@ -0,0 +1,156 @@ +;;; emh-face.el --- header highlighting in emh. + +;; Copyright (C) 1997,2000 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Created: 1997/3/4 +;; Keywords: header, highlighting + +;; This file is part of emh. + +;; 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 'emh-def) +(require 'std11) + +(defsubst emh-set-face-foreground (face color) + (condition-case nil + (set-face-foreground face color) + (error (message "Color `%s' is not found." color)))) + +(defsubst emh-make-face-bold (face) + (set-face-font face (face-font 'bold))) + +(defsubst emh-make-face-italic (face) + (set-face-font face (face-font 'italic))) + +(or (find-face 'from-field-body) + (progn + (make-face 'from-field-body) + (emh-set-face-foreground 'from-field-body "dark slate blue") + (emh-make-face-bold 'from-field-body) + )) + +(or (find-face 'subject-field-body) + (progn + (make-face 'subject-field-body) + (emh-set-face-foreground 'subject-field-body "violet red") + (emh-make-face-bold 'subject-field-body) + )) + +(or (find-face 'to-field-body) + (progn + (make-face 'to-field-body) + (emh-set-face-foreground 'to-field-body "red") + (emh-make-face-bold 'to-field-body) + )) + +(or (find-face 'cc-field-body) + (progn + (make-face 'cc-field-body) + (emh-set-face-foreground 'cc-field-body "salmon") + (emh-make-face-bold 'cc-field-body) + )) + +(or (find-face 'reply-to-field-body) + (progn + (make-face 'reply-to-field-body) + (emh-set-face-foreground 'reply-to-field-body "salmon") + (emh-make-face-bold 'reply-to-field-body) + )) + +(or (find-face '-to-field-body) + (progn + (make-face '-to-field-body) + (emh-set-face-foreground '-to-field-body "red") + )) + +(or (find-face 'date-field-body) + (progn + (make-face 'date-field-body) + (emh-set-face-foreground 'date-field-body "blue violet") + (emh-make-face-bold 'date-field-body) + )) + +(or (find-face 'message-id-field-body) + (progn + (make-face 'message-id-field-body) + (emh-set-face-foreground 'message-id-field-body "royal blue") + (emh-make-face-bold 'message-id-field-body) + )) + +(or (find-face 'field-body) + (progn + (make-face 'field-body) + (emh-set-face-foreground 'field-body "dark green") + (emh-make-face-italic 'field-body) + )) + +(or (find-face 'field-name) + (progn + (make-face 'field-name) + (emh-set-face-foreground 'field-name "dark green") + (emh-make-face-bold 'field-name) + )) + +(defvar emh-header-face + '(("^From:" field-name from-field-body) + ("^Subject:" field-name subject-field-body) + ("^To:" field-name to-field-body) + ("^cc:" field-name cc-field-body) + ("^Reply-To:" field-name reply-to-field-body) + ("^.+-To:" field-name -to-field-body) + ("^Date:" field-name date-field-body) + ("^Message-Id:" field-name message-id-field-body) + (t field-name field-body) + )) + +(defun emh-highlight-header () + (goto-char (point-min)) + (while (looking-at "^[^:]+:") + (let* ((beg (match-beginning 0)) + (med (match-end 0)) + (end (std11-field-end)) + (field-name (buffer-substring beg med)) + (rule (catch 'found + (let ((rest emh-header-face)) + (while rest + (let* ((rule (car rest)) + (key (car rule))) + (if (and (stringp key) + (string-match key field-name)) + (throw 'found (cdr rule)) + )) + (setq rest (cdr rest)) + ) + (cdr (assq t emh-header-face)) + ))) + ) + (overlay-put (make-overlay beg med) 'face (car rule)) + (overlay-put (make-overlay med end) 'face (cadr rule)) + ) + (forward-char) + )) + + +;;; @ end +;;; + +(provide 'emh-face) + +;;; emh-face.el ends here diff --git a/mime/emh-setup.el b/mime/emh-setup.el new file mode 100644 index 0000000..5e64f05 --- /dev/null +++ b/mime/emh-setup.el @@ -0,0 +1,97 @@ +;;; emh-setup.el --- setup file for emh. + +;; Copyright (C) 1994,1995,1996,1997,1998 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Keywords: mh-e, mail, news, MIME, multimedia, multilingual + +;; This file is part of emh. + +;; 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 'semi-setup) + + +;;; @ for emh +;;; + +(eval-after-load "mh-e" '(require 'emh)) + + +;;; @ for mime-edit +;;; + +(autoload 'turn-on-mime-edit "mime-edit" + "Unconditionally turn on MIME-Edit minor mode." t) + +(defun emh-setup-mh-draft-setting () + (make-local-variable 'mail-header-separator) + (setq mail-header-separator "--------") + (mime-decode-header-in-buffer nil mail-header-separator) + (let ((ua mime-edit-user-agent-value)) + (make-local-variable 'mime-edit-user-agent-value) + (setq mime-edit-user-agent-value (concat "EMH/" emh-version " " ua)) + ) + (turn-on-mime-edit) + (save-excursion + (goto-char (point-min)) + (setq buffer-read-only nil) + (if (re-search-forward "^-*$" nil t) + (progn + (replace-match mail-header-separator) + (set-buffer-modified-p (buffer-modified-p)) + )) + )) + +(add-hook 'mh-letter-mode-hook 'emh-setup-mh-draft-setting t) +(add-hook 'mh-before-send-letter-hook 'mime-edit-maybe-translate) + + +;;; @@ for emh-comp.el +;;; + +(autoload 'emh-edit-again "emh-comp" + "Clean-up a draft or a message previously sent and make it resendable." t) +(autoload 'emh-extract-rejected-mail "emh-comp" + "Extract a letter returned by the mail system and make it re-editable." t) +(autoload 'emh-forward "emh-comp" + "Forward a message or message sequence by MIME style." t) + +(eval-after-load + "mh-e" + '(progn + (substitute-key-definition + 'mh-edit-again 'emh-edit-again + mh-folder-mode-map) + (substitute-key-definition + 'mh-extract-rejected-mail 'emh-extract-rejected-mail + mh-folder-mode-map) + (substitute-key-definition + 'mh-forward 'emh-forward + mh-folder-mode-map) + )) + +(eval-after-load "mh-comp" '(require 'emh-comp)) + + +;;; @ end +;;; + +(provide 'emh-setup) + +;;; emh-setup.el ends here diff --git a/mime/emh.el b/mime/emh.el new file mode 100644 index 0000000..2da4435 --- /dev/null +++ b/mime/emh.el @@ -0,0 +1,355 @@ +;;; emh.el --- MIME extender for mh-e + +;; Copyright (C) 1995,1996,1997,1998,2000 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; OKABE Yasuo +;; Maintainer: MORIOKA Tomohiko +;; Created: 1993/11/21 +;; Renamed: 1993/11/27 from mh-e-mime.el +;; Renamed: 1997/02/21 from tm-mh-e.el +;; Keywords: MH, MIME, multimedia, encoded-word, multilingual, mail + +;; This file is part of emh. + +;; 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 'mh-e) +(require 'alist) +(require 'mime-view) + + +;;; @ version +;;; + +(defconst emh-version "1.14.1") + + +;;; @ variable +;;; + +(defgroup emh nil + "MIME Extension for mh-e" + :group 'mime + :group 'mh) + +(defcustom emh-automatic-mime-preview t + "*If non-nil, show MIME processed message." + :group 'emh + :type 'boolean) + +(defcustom emh-decode-encoded-word t + "*If non-nil, decode encoded-word when it is not MIME preview mode." + :group 'emh + :type 'boolean) + + +;;; @ functions +;;; + +(defsubst emh-raw-buffer (folder-buffer) + (concat "article-" (if (bufferp folder-buffer) + (buffer-name folder-buffer) + folder-buffer))) + +(defun mh-display-msg (msg-num folder &optional show-buffer mode) + "Display message number MSG-NUM of FOLDER. +This function uses `mime-view-mode' if MODE is not nil. If MODE is +nil, `emh-automatic-mime-preview' is used as default value." + (or mode + (setq mode emh-automatic-mime-preview) + ) + ;; Display message NUMBER of FOLDER. + ;; Sets the current buffer to the show buffer. + (set-buffer folder) + (or show-buffer + (setq show-buffer mh-show-buffer)) + ;; Bind variables in folder buffer in case they are local + (let ((msg-filename (mh-msg-filename msg-num))) + (if (not (file-exists-p msg-filename)) + (error "Message %d does not exist" msg-num)) + (set-buffer show-buffer) + (cond ((not (equal msg-filename buffer-file-name)) + ;; Buffer does not yet contain message. + (clear-visited-file-modtime) + (unlock-buffer) + (setq buffer-file-name nil) ; no locking during setup + (setq buffer-read-only nil) + (erase-buffer) + (if mode + (let* ((aname (emh-raw-buffer folder)) + (abuf (get-buffer aname))) + (if abuf + (progn + (set-buffer abuf) + (setq buffer-read-only nil) + (erase-buffer)) + (setq abuf (get-buffer-create aname)) + (set-buffer abuf) + (set-buffer-multibyte nil)) + (8bit-insert-encoded-file msg-filename) + (set-buffer-modified-p nil) + (setq buffer-read-only t) + (setq buffer-file-name msg-filename) + (mh-show-mode) + (mime-display-message (mime-open-entity 'buffer aname) + (concat "show-" folder)) + (goto-char (point-min))) + (let ((clean-message-header mh-clean-message-header) + (invisible-headers mh-invisible-headers) + (visible-headers mh-visible-headers)) + ;; 1995/9/21 + ;; modified by ARIURA + ;; to support mhl. + (if mhl-formfile + (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear" + (if (stringp mhl-formfile) + (list "-form" mhl-formfile)) + msg-filename) + (insert-file-contents msg-filename)) + ;; end + (goto-char (point-min)) + (cond (clean-message-header + (mh-clean-msg-header (point-min) + invisible-headers + visible-headers) + (goto-char (point-min))) + (t + (mh-start-of-uncleaned-message))) + (if emh-decode-encoded-word + (mime-decode-header-in-buffer)) + (set-buffer-modified-p nil) + (setq buffer-read-only t) + (setq buffer-file-name msg-filename) + (mh-show-mode) + )) + (or (eq buffer-undo-list t) ;don't save undo info for prev msgs + (setq buffer-undo-list nil)) +;;; Added by itokon (02/19/96) + (setq buffer-file-name msg-filename) +;;; + (set-mark nil) + (setq mode-line-buffer-identification + (list (format mh-show-buffer-mode-line-buffer-id + folder msg-num))) + (set-buffer folder) + (setq mh-showing-with-headers nil))))) + +(defun emh-view-message (&optional msg) + "MIME decode and play this message." + (interactive) + (if (or (null emh-automatic-mime-preview) + (null (get-buffer mh-show-buffer)) + (save-excursion + (set-buffer mh-show-buffer) + (not (eq major-mode 'mime-view-mode)) + )) + (let ((emh-automatic-mime-preview t)) + (mh-invalidate-show-buffer) + (mh-show-msg msg) + )) + (pop-to-buffer mh-show-buffer) + ) + +(defun emh-toggle-decoding-mode (arg) + "Toggle MIME processing mode. +With arg, turn MIME processing on if arg is positive." + (interactive "P") + (setq emh-automatic-mime-preview + (if (null arg) + (not emh-automatic-mime-preview) + arg)) + (let ((raw-buffer (emh-raw-buffer (current-buffer)))) + (if (get-buffer raw-buffer) + (kill-buffer raw-buffer) + )) + (mh-invalidate-show-buffer) + (mh-show (mh-get-msg-num t)) + ) + +(defun emh-show (&optional message) + (interactive) + (mh-invalidate-show-buffer) + (mh-show message) + ) + +(defun emh-header-display () + (interactive) + (mh-invalidate-show-buffer) + (let (mime-view-ignored-field-list + mime-view-visible-field-list + emh-decode-encoded-word) + (mh-header-display) + )) + +(defun emh-raw-display () + (interactive) + (mh-invalidate-show-buffer) + (let (emh-automatic-mime-preview + emh-decode-encoded-word) + (mh-header-display) + )) + +(defun emh-burst-multipart/digest () + "Burst apart the current message, which should be a multipart/digest. +The message is replaced by its table of contents and the letters from the +digest are inserted into the folder after that message." + (interactive) + (let ((digest (mh-get-msg-num t))) + (mh-process-or-undo-commands mh-current-folder) + (mh-set-folder-modified-p t) ; lock folder while bursting + (message "Bursting digest...") + (mh-exec-cmd "mhn" "-store" mh-current-folder digest) + (mh-scan-folder mh-current-folder (format "%d-last" mh-first-msg-num)) + (message "Bursting digest...done") + )) + + +;;; @ for mime-view +;;; + +(defvar emh-display-header-hook (if window-system '(emh-highlight-header)) + "Hook for header filtering.") + +(autoload 'emh-highlight-header "emh-face") + +(defun emh-header-presentation-method (entity situation) + (mime-insert-header entity + mime-view-ignored-field-list + mime-view-visible-field-list) + (run-hooks 'emh-display-header-hook) + ) + +(set-alist 'mime-header-presentation-method-alist + 'mh-show-mode #'emh-header-presentation-method) + + +(defun emh-quitting-method () + (let ((buf (current-buffer))) + (mime-maybe-hide-echo-buffer) + (pop-to-buffer + (let ((name (buffer-name buf))) + (substring name 5) + )) + (if (not emh-automatic-mime-preview) + (mh-invalidate-show-buffer) + ) + (mh-show (mh-get-msg-num t)) + )) + +(set-alist 'mime-preview-quitting-method-alist + 'mh-show-mode #'emh-quitting-method) + + +(defun emh-following-method (buf) + (save-excursion + (set-buffer buf) + (goto-char (point-max)) + (setq mh-show-buffer buf) + (apply (function mh-send) + (std11-field-bodies '("From" "cc" "Subject") "")) + (setq mh-sent-from-folder buf) + (setq mh-sent-from-msg 1) + (let ((last (point))) + (mh-yank-cur-msg) + (goto-char last) + ))) + +(set-alist 'mime-preview-following-method-alist + 'mh-show-mode #'emh-following-method) + + +;;; @@ for mime-partial +;;; + +(defun emh-request-partial-message () + (let ((msg-filename (mh-msg-filename (mh-get-msg-num t))) + (show-buffer mh-show-buffer)) + (set-buffer (get-buffer-create " *Partial Article*")) + (erase-buffer) + (setq mime-preview-buffer show-buffer) + (raw-text-insert-file-contents msg-filename) + (mime-parse-buffer) + )) + +(defun emh-get-folder-buffer () + (let ((buffer-name (buffer-name (current-buffer)))) + (and (or (string-match "^article-\\(.+\\)$" buffer-name) + (string-match "^show-\\(.+\\)$" buffer-name)) + (substring buffer-name + (match-beginning 1) (match-end 1)) + ))) + +(autoload 'mime-combine-message/partial-pieces-automatically + "mime-partial" + "Internal method to combine message/partial messages automatically.") + +(mime-add-condition + 'action + '((type . message)(subtype . partial) + (major-mode . mh-show-mode) + (method . mime-combine-message/partial-pieces-automatically) + (summary-buffer-exp . (emh-get-folder-buffer)) + (request-partial-message-method . emh-request-partial-message) + )) + + +;;; @ set up +;;; + +(define-key mh-folder-mode-map "v" (function emh-view-message)) +(define-key mh-folder-mode-map "\et" (function emh-toggle-decoding-mode)) +(define-key mh-folder-mode-map "." (function emh-show)) +(define-key mh-folder-mode-map "," (function emh-header-display)) +(define-key mh-folder-mode-map "\e," (function emh-raw-display)) +(define-key mh-folder-mode-map "\C-c\C-b" + (function emh-burst-multipart/digest)) + +(defun emh-summary-before-quit () + (let ((buf (get-buffer mh-show-buffer))) + (if buf + (let ((the-buf (current-buffer))) + (switch-to-buffer buf) + (if (and mime-preview-buffer + (setq buf (get-buffer mime-preview-buffer)) + ) + (progn + (switch-to-buffer the-buf) + (kill-buffer buf) + ) + (switch-to-buffer the-buf) + ) + )))) + +(add-hook 'mh-before-quit-hook (function emh-summary-before-quit)) + + +;;; @ for BBDB +;;; + +(eval-after-load "bbdb" '(require 'mime-bbdb)) + + +;;; @ end +;;; + +(provide 'emh) + +(run-hooks 'emh-load-hook) + +;;; emh.el ends here diff --git a/mime/eword-decode.el b/mime/eword-decode.el new file mode 100644 index 0000000..0fc7d33 --- /dev/null +++ b/mime/eword-decode.el @@ -0,0 +1,823 @@ +;;; eword-decode.el --- RFC 2047 based encoded-word decoder for GNU Emacs + +;; Copyright (C) 1995,1996,1997,1998,1999,2000 Free Software Foundation, Inc. + +;; Author: ENAMI Tsugutomo +;; MORIOKA Tomohiko +;; TANAKA Akira +;; Created: 1995/10/03 +;; Original: 1992/07/20 ENAMI Tsugutomo's `mime.el'. +;; Renamed: 1993/06/03 to tiny-mime.el by MORIOKA Tomohiko +;; Renamed: 1995/10/03 to tm-ew-d.el (split off encoder) +;; by MORIOKA Tomohiko +;; Renamed: 1997/02/22 from tm-ew-d.el by MORIOKA Tomohiko +;; Keywords: encoded-word, MIME, multilingual, header, 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-def) +(require 'mel) +(require 'std11) + +(eval-when-compile (require 'cl)) ; list*, pop + + +;;; @ Variables +;;; + +;; User options are defined in mime-def.el. + + +;;; @ MIME encoded-word definition +;;; + +(eval-and-compile + (defconst eword-encoded-text-regexp "[!->@-~]+") + + (defconst eword-encoded-word-regexp + (eval-when-compile + (concat (regexp-quote "=?") + "\\(" + mime-charset-regexp + "\\)" + (regexp-quote "?") + "\\([BbQq]\\)" + (regexp-quote "?") + "\\(" + eword-encoded-text-regexp + "\\)" + (regexp-quote "?=")))) + ) + + +;;; @ for string +;;; + +(defun eword-decode-string (string &optional must-unfold) + "Decode MIME encoded-words in STRING. + +STRING is unfolded before decoding. + +If an encoded-word is broken or your emacs implementation can not +decode the charset included in it, it is not decoded. + +If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even +if there are in decoded encoded-words (generated by bad manner MUA +such as a version of Net$cape)." + (setq string (std11-unfold-string string)) + (let ((dest "")(ew nil) + beg end) + (while (and (string-match eword-encoded-word-regexp string) + (setq beg (match-beginning 0) + end (match-end 0)) + ) + (if (> beg 0) + (if (not + (and (eq ew t) + (string-match "^[ \t]+$" (substring string 0 beg)) + )) + (setq dest (concat dest (substring string 0 beg))) + ) + ) + (setq dest + (concat dest + (eword-decode-encoded-word + (substring string beg end) must-unfold) + )) + (setq string (substring string end)) + (setq ew t) + ) + (concat dest string) + )) + +(defun eword-decode-structured-field-body (string + &optional start-column max-column + start) + (let ((tokens (eword-lexical-analyze string start 'must-unfold)) + (result "") + token) + (while tokens + (setq token (car tokens)) + (setq result (concat result (eword-decode-token token))) + (setq tokens (cdr tokens))) + result)) + +(defun eword-decode-and-unfold-structured-field-body (string + &optional + start-column + max-column + start) + "Decode and unfold STRING as structured field body. +It decodes non us-ascii characters in FULL-NAME encoded as +encoded-words or invalid \"raw\" string. \"Raw\" non us-ascii +characters are regarded as variable `default-mime-charset'. + +If an encoded-word is broken or your emacs implementation can not +decode the charset included in it, it is not decoded." + (let ((tokens (eword-lexical-analyze string start 'must-unfold)) + (result "")) + (while tokens + (let* ((token (car tokens)) + (type (car token))) + (setq tokens (cdr tokens)) + (setq result + (if (eq type 'spaces) + (concat result " ") + (concat result (eword-decode-token token)) + )))) + result)) + +(defun eword-decode-and-fold-structured-field-body (string + start-column + &optional max-column + start) + (if (and mime-field-decoding-max-size + (> (length string) mime-field-decoding-max-size)) + string + (or max-column + (setq max-column fill-column)) + (let ((c start-column) + (tokens (eword-lexical-analyze string start 'must-unfold)) + (result "") + token) + (while (and (setq token (car tokens)) + (setq tokens (cdr tokens))) + (let* ((type (car token))) + (if (eq type 'spaces) + (let* ((next-token (car tokens)) + (next-str (eword-decode-token next-token)) + (next-len (string-width next-str)) + (next-c (+ c next-len 1))) + (if (< next-c max-column) + (setq result (concat result " " next-str) + c next-c) + (setq result (concat result "\n " next-str) + c (1+ next-len))) + (setq tokens (cdr tokens)) + ) + (let* ((str (eword-decode-token token))) + (setq result (concat result str) + c (+ c (string-width str))) + )))) + (if token + (concat result (eword-decode-token token)) + result)))) + +(defun eword-decode-unstructured-field-body (string &optional start-column + max-column) + (eword-decode-string + (decode-mime-charset-string string default-mime-charset))) + +(defun eword-decode-and-unfold-unstructured-field-body (string + &optional start-column + max-column) + (eword-decode-string + (decode-mime-charset-string (std11-unfold-string string) + default-mime-charset) + 'must-unfold)) + +(defun eword-decode-unfolded-unstructured-field-body (string + &optional start-column + max-column) + (eword-decode-string + (decode-mime-charset-string string default-mime-charset) + 'must-unfold)) + + +;;; @ for region +;;; + +(defun eword-decode-region (start end &optional unfolding must-unfold) + "Decode MIME encoded-words in region between START and END. + +If UNFOLDING is not nil, it unfolds before decoding. + +If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even +if there are in decoded encoded-words (generated by bad manner MUA +such as a version of Net$cape)." + (interactive "*r") + (save-excursion + (save-restriction + (narrow-to-region start end) + (if unfolding + (eword-decode-unfold) + ) + (goto-char (point-min)) + (while (re-search-forward (concat "\\(" eword-encoded-word-regexp "\\)" + "\\(\n?[ \t]\\)+" + "\\(" eword-encoded-word-regexp "\\)") + nil t) + (replace-match "\\1\\6") + (goto-char (point-min)) + ) + (while (re-search-forward eword-encoded-word-regexp nil t) + (insert (eword-decode-encoded-word + (prog1 + (buffer-substring (match-beginning 0) (match-end 0)) + (delete-region (match-beginning 0) (match-end 0)) + ) must-unfold)) + ) + ))) + +(defun eword-decode-unfold () + (goto-char (point-min)) + (let (field beg end) + (while (re-search-forward std11-field-head-regexp nil t) + (setq beg (match-beginning 0) + end (std11-field-end)) + (setq field (buffer-substring beg end)) + (if (string-match eword-encoded-word-regexp field) + (save-restriction + (narrow-to-region (goto-char beg) end) + (while (re-search-forward "\n\\([ \t]\\)" nil t) + (replace-match (match-string 1)) + ) + (goto-char (point-max)) + )) + ))) + + +;;; @ for message header +;;; + +(defvar mime-field-decoder-alist nil) + +(defvar mime-field-decoder-cache nil) + +(defvar mime-update-field-decoder-cache 'mime-update-field-decoder-cache + "*Field decoder cache update function.") + +;;;###autoload +(defun mime-set-field-decoder (field &rest specs) + "Set decoder of FIELD. +SPECS must be like `MODE1 DECODER1 MODE2 DECODER2 ...'. +Each mode must be `nil', `plain', `wide', `summary' or `nov'. +If mode is `nil', corresponding decoder is set up for every modes." + (when specs + (let ((mode (pop specs)) + (function (pop specs))) + (if mode + (progn + (let ((cell (assq mode mime-field-decoder-alist))) + (if cell + (setcdr cell (put-alist field function (cdr cell))) + (setq mime-field-decoder-alist + (cons (cons mode (list (cons field function))) + mime-field-decoder-alist)) + )) + (apply (function mime-set-field-decoder) field specs) + ) + (mime-set-field-decoder field + 'plain function + 'wide function + 'summary function + 'nov function) + )))) + +;;;###autoload +(defmacro mime-find-field-presentation-method (name) + "Return field-presentation-method from NAME. +NAME must be `plain', `wide', `summary' or `nov'." + (cond ((eq name nil) + `(or (assq 'summary mime-field-decoder-cache) + '(summary)) + ) + ((and (consp name) + (car name) + (consp (cdr name)) + (symbolp (car (cdr name))) + (null (cdr (cdr name)))) + `(or (assq ,name mime-field-decoder-cache) + (cons ,name nil)) + ) + (t + `(or (assq (or ,name 'summary) mime-field-decoder-cache) + (cons (or ,name 'summary) nil)) + ))) + +(defun mime-find-field-decoder-internal (field &optional mode) + "Return function to decode field-body of FIELD in MODE. +Optional argument MODE must be object of field-presentation-method." + (cdr (or (assq field (cdr mode)) + (prog1 + (funcall mime-update-field-decoder-cache + field (car mode)) + (setcdr mode + (cdr (assq (car mode) mime-field-decoder-cache))) + )))) + +;;;###autoload +(defun mime-find-field-decoder (field &optional mode) + "Return function to decode field-body of FIELD in MODE. +Optional argument MODE must be object or name of +field-presentation-method. Name of field-presentation-method must be +`plain', `wide', `summary' or `nov'. +Default value of MODE is `summary'." + (if (symbolp mode) + (let ((p (cdr (mime-find-field-presentation-method mode)))) + (if (and p (setq p (assq field p))) + (cdr p) + (cdr (funcall mime-update-field-decoder-cache + field (or mode 'summary))))) + (inline (mime-find-field-decoder-internal field mode)) + )) + +;;;###autoload +(defun mime-update-field-decoder-cache (field mode &optional function) + "Update field decoder cache `mime-field-decoder-cache'." + (cond ((eq function 'identity) + (setq function nil) + ) + ((null function) + (let ((decoder-alist + (cdr (assq (or mode 'summary) mime-field-decoder-alist)))) + (setq function (cdr (or (assq field decoder-alist) + (assq t decoder-alist))))) + )) + (let ((cell (assq mode mime-field-decoder-cache)) + ret) + (if cell + (if (setq ret (assq field (cdr cell))) + (setcdr ret function) + (setcdr cell (cons (setq ret (cons field function)) (cdr cell)))) + (setq mime-field-decoder-cache + (cons (cons mode (list (setq ret (cons field function)))) + mime-field-decoder-cache))) + ret)) + +;; ignored fields +(mime-set-field-decoder 'Archive nil nil) +(mime-set-field-decoder 'Content-Md5 nil nil) +(mime-set-field-decoder 'Control nil nil) +(mime-set-field-decoder 'Date nil nil) +(mime-set-field-decoder 'Distribution nil nil) +(mime-set-field-decoder 'Followup-Host nil nil) +(mime-set-field-decoder 'Followup-To nil nil) +(mime-set-field-decoder 'Lines nil nil) +(mime-set-field-decoder 'Message-Id nil nil) +(mime-set-field-decoder 'Newsgroups nil nil) +(mime-set-field-decoder 'Nntp-Posting-Host nil nil) +(mime-set-field-decoder 'Path nil nil) +(mime-set-field-decoder 'Posted-And-Mailed nil nil) +(mime-set-field-decoder 'Received nil nil) +(mime-set-field-decoder 'Status nil nil) +(mime-set-field-decoder 'X-Face nil nil) +(mime-set-field-decoder 'X-Face-Version nil nil) +(mime-set-field-decoder 'X-Info nil nil) +(mime-set-field-decoder 'X-Pgp-Key-Info nil nil) +(mime-set-field-decoder 'X-Pgp-Sig nil nil) +(mime-set-field-decoder 'X-Pgp-Sig-Version nil nil) +(mime-set-field-decoder 'Xref nil nil) + +;; structured fields +(let ((fields + '(Reply-To Resent-Reply-To From Resent-From Sender Resent-Sender + To Resent-To Cc Resent-Cc Bcc Resent-Bcc Dcc + Mail-Followup-To + Mime-Version Content-Type Content-Transfer-Encoding + Content-Disposition User-Agent)) + field) + (while fields + (setq field (pop fields)) + (mime-set-field-decoder + field + 'plain #'eword-decode-structured-field-body + 'wide #'eword-decode-and-fold-structured-field-body + 'summary #'eword-decode-and-unfold-structured-field-body + 'nov #'eword-decode-and-unfold-structured-field-body) + )) + +;; unstructured fields (default) +(mime-set-field-decoder + t + 'plain #'eword-decode-unstructured-field-body + 'wide #'eword-decode-unstructured-field-body + 'summary #'eword-decode-and-unfold-unstructured-field-body + 'nov #'eword-decode-unfolded-unstructured-field-body) + +;;;###autoload +(defun mime-decode-field-body (field-body field-name + &optional mode max-column) + "Decode FIELD-BODY as FIELD-NAME in MODE, and return the result. +Optional argument MODE must be `plain', `wide', `summary' or `nov'. +Default mode is `summary'. + +If MODE is `wide' and MAX-COLUMN is non-nil, the result is folded with +MAX-COLUMN. + +Non MIME encoded-word part in FILED-BODY is decoded with +`default-mime-charset'." + (let (field-name-symbol len decoder) + (if (symbolp field-name) + (setq field-name-symbol field-name + len (1+ (string-width (symbol-name field-name)))) + (setq field-name-symbol (intern (capitalize field-name)) + len (1+ (string-width field-name)))) + (setq decoder (mime-find-field-decoder field-name-symbol mode)) + (if decoder + (funcall decoder field-body len max-column) + ;; Don't decode + (if (eq mode 'summary) + (std11-unfold-string field-body) + field-body) + ))) + +;;;###autoload +(defun mime-decode-header-in-region (start end + &optional code-conversion) + "Decode MIME encoded-words in region between START and END. +If CODE-CONVERSION is nil, it decodes only encoded-words. If it is +mime-charset, it decodes non-ASCII bit patterns as the mime-charset. +Otherwise it decodes non-ASCII bit patterns as the +default-mime-charset." + (interactive "*r") + (save-excursion + (save-restriction + (narrow-to-region start end) + (let ((default-charset + (if code-conversion + (if (mime-charset-to-coding-system code-conversion) + code-conversion + default-mime-charset)))) + (if default-charset + (let ((mode-obj (mime-find-field-presentation-method 'wide)) + beg p end field-name len field-decoder) + (goto-char (point-min)) + (while (re-search-forward std11-field-head-regexp nil t) + (setq beg (match-beginning 0) + p (match-end 0) + field-name (buffer-substring beg (1- p)) + len (string-width field-name) + field-name (intern (capitalize field-name)) + field-decoder (inline + (mime-find-field-decoder-internal + field-name mode-obj))) + (when field-decoder + (setq end (std11-field-end)) + (let ((body (buffer-substring p end)) + (default-mime-charset default-charset)) + (delete-region p end) + (insert (funcall field-decoder body (1+ len))) + )) + )) + (eword-decode-region (point-min) (point-max) t) + ))))) + +;;;###autoload +(defun mime-decode-header-in-buffer (&optional code-conversion separator) + "Decode MIME encoded-words in header fields. +If CODE-CONVERSION is nil, it decodes only encoded-words. If it is +mime-charset, it decodes non-ASCII bit patterns as the mime-charset. +Otherwise it decodes non-ASCII bit patterns as the +default-mime-charset. +If SEPARATOR is not nil, it is used as header separator." + (interactive "*") + (mime-decode-header-in-region + (point-min) + (save-excursion + (goto-char (point-min)) + (if (re-search-forward + (concat "^\\(" (regexp-quote (or separator "")) "\\)?$") + nil t) + (match-beginning 0) + (point-max) + )) + code-conversion)) + +(defalias 'eword-decode-header 'mime-decode-header-in-buffer) +(make-obsolete 'eword-decode-header 'mime-decode-header-in-buffer) + + +;;; @ encoded-word decoder +;;; + +(defvar eword-decode-encoded-word-error-handler + 'eword-decode-encoded-word-default-error-handler) + +(defvar eword-warning-face nil + "Face used for invalid encoded-word.") + +(defun eword-decode-encoded-word-default-error-handler (word signal) + (and (add-text-properties 0 (length word) + (and eword-warning-face + (list 'face eword-warning-face)) + word) + word)) + +(defun eword-decode-encoded-word (word &optional must-unfold) + "Decode WORD if it is an encoded-word. + +If your emacs implementation can not decode the charset of WORD, it +returns WORD. Similarly the encoded-word is broken, it returns WORD. + +If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even +if there are in decoded encoded-word (generated by bad manner MUA such +as a version of Net$cape)." + (or (if (string-match eword-encoded-word-regexp word) + (let ((charset + (substring word (match-beginning 1) (match-end 1)) + ) + (encoding + (upcase + (substring word (match-beginning 2) (match-end 2)) + )) + (text + (substring word (match-beginning 3) (match-end 3)) + )) + (condition-case err + (eword-decode-encoded-text charset encoding text must-unfold) + (error + (funcall eword-decode-encoded-word-error-handler word err) + )) + )) + word)) + + +;;; @ encoded-text decoder +;;; + +(defun eword-decode-encoded-text (charset encoding string + &optional must-unfold) + "Decode STRING as an encoded-text. + +If your emacs implementation can not decode CHARSET, it returns nil. + +If ENCODING is not \"B\" or \"Q\", it occurs error. +So you should write error-handling code if you don't want break by errors. + +If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even +if there are in decoded encoded-text (generated by bad manner MUA such +as a version of Net$cape)." + (let ((cs (mime-charset-to-coding-system charset))) + (if cs + (let ((dest (encoded-text-decode-string string encoding))) + (when dest + (setq dest (decode-mime-charset-string dest charset)) + (if must-unfold + (mapconcat (function + (lambda (chr) + (cond ((eq chr ?\n) "") + ((eq chr ?\t) " ") + (t (char-to-string chr))) + )) + (std11-unfold-string dest) + "") + dest)))))) + + +;;; @ lexical analyze +;;; + +(defvar eword-lexical-analyze-cache nil) +(defvar eword-lexical-analyze-cache-max 299 + "*Max position of eword-lexical-analyze-cache. +It is max size of eword-lexical-analyze-cache - 1.") + +(defvar mime-header-lexical-analyzer + '(eword-analyze-quoted-string + eword-analyze-domain-literal + eword-analyze-comment + eword-analyze-spaces + eword-analyze-special + eword-analyze-encoded-word + eword-analyze-atom) + "*List of functions to return result of lexical analyze. +Each function must have three arguments: STRING, START and MUST-UNFOLD. +STRING is the target string to be analyzed. +START is start position of STRING to analyze. +If MUST-UNFOLD is not nil, each function must unfold and eliminate +bare-CR and bare-LF from the result even if they are included in +content of the encoded-word. +Each function must return nil if it can not analyze STRING as its +format. + +Previous function is preferred to next function. If a function +returns nil, next function is used. Otherwise the return value will +be the result.") + +(defun eword-analyze-quoted-string (string start &optional must-unfold) + (let ((p (std11-check-enclosure string ?\" ?\" nil start))) + (if p + (cons (cons 'quoted-string + (decode-mime-charset-string + (std11-strip-quoted-pair + (substring string (1+ start) (1- p))) + default-mime-charset)) + ;;(substring string p)) + p) + ))) + +(defun eword-analyze-domain-literal (string start &optional must-unfold) + (std11-analyze-domain-literal string start)) + +(defun eword-analyze-comment (string from &optional must-unfold) + (let ((len (length string)) + (i (or from 0)) + dest last-str + chr ret) + (when (and (> len i) + (eq (aref string i) ?\()) + (setq i (1+ i) + from i) + (catch 'tag + (while (< i len) + (setq chr (aref string i)) + (cond ((eq chr ?\\) + (setq i (1+ i)) + (if (>= i len) + (throw 'tag nil) + ) + (setq last-str (concat last-str + (substring string from (1- i)) + (char-to-string (aref string i))) + i (1+ i) + from i) + ) + ((eq chr ?\)) + (setq ret (concat last-str + (substring string from i))) + (throw 'tag (cons + (cons 'comment + (nreverse + (if (string= ret "") + dest + (cons + (eword-decode-string + (decode-mime-charset-string + ret default-mime-charset) + must-unfold) + dest) + ))) + (1+ i))) + ) + ((eq chr ?\() + (if (setq ret (eword-analyze-comment string i must-unfold)) + (setq last-str + (concat last-str + (substring string from i)) + dest + (if (string= last-str "") + (cons (car ret) dest) + (list* (car ret) + (eword-decode-string + (decode-mime-charset-string + last-str default-mime-charset) + must-unfold) + dest) + ) + i (cdr ret) + from i + last-str "") + (throw 'tag nil) + )) + (t + (setq i (1+ i)) + )) + ))))) + +(defun eword-analyze-spaces (string start &optional must-unfold) + (std11-analyze-spaces string start)) + +(defun eword-analyze-special (string start &optional must-unfold) + (std11-analyze-special string start)) + +(defun eword-analyze-encoded-word (string start &optional must-unfold) + (if (and (string-match eword-encoded-word-regexp string start) + (= (match-beginning 0) start)) + (let ((end (match-end 0)) + (dest (eword-decode-encoded-word (match-string 0 string) + must-unfold)) + ) + ;;(setq string (substring string end)) + (setq start end) + (while (and (string-match (eval-when-compile + (concat "[ \t\n]*\\(" + eword-encoded-word-regexp + "\\)")) + string start) + (= (match-beginning 0) start)) + (setq end (match-end 0)) + (setq dest + (concat dest + (eword-decode-encoded-word (match-string 1 string) + must-unfold)) + ;;string (substring string end)) + start end) + ) + (cons (cons 'atom dest) ;;string) + end) + ))) + +(defun eword-analyze-atom (string start &optional must-unfold) + (if (and (string-match std11-atom-regexp string start) + (= (match-beginning 0) start)) + (let ((end (match-end 0))) + (cons (cons 'atom (decode-mime-charset-string + (substring string start end) + default-mime-charset)) + ;;(substring string end) + end) + ))) + +(defun eword-lexical-analyze-internal (string start must-unfold) + (let ((len (length string)) + dest ret) + (while (< start len) + (setq ret + (let ((rest mime-header-lexical-analyzer) + func r) + (while (and (setq func (car rest)) + (null + (setq r (funcall func string start must-unfold))) + ) + (setq rest (cdr rest))) + (or r + (list (cons 'error (substring string start)) (1+ len))) + )) + (setq dest (cons (car ret) dest) + start (cdr ret)) + ) + (nreverse dest) + )) + +(defun eword-lexical-analyze (string &optional start must-unfold) + "Return lexical analyzed list corresponding STRING. +It is like std11-lexical-analyze, but it decodes non us-ascii +characters encoded as encoded-words or invalid \"raw\" format. +\"Raw\" non us-ascii characters are regarded as variable +`default-mime-charset'." + (let ((key (substring string (or start 0))) + ret cell) + (set-text-properties 0 (length key) nil key) + (if (setq ret (assoc key eword-lexical-analyze-cache)) + (cdr ret) + (setq ret (eword-lexical-analyze-internal key 0 must-unfold)) + (setq eword-lexical-analyze-cache + (cons (cons key ret) + eword-lexical-analyze-cache)) + (if (cdr (setq cell (nthcdr eword-lexical-analyze-cache-max + eword-lexical-analyze-cache))) + (setcdr cell nil)) + ret))) + +(defun eword-decode-token (token) + (let ((type (car token)) + (value (cdr token))) + (cond ((eq type 'quoted-string) + (std11-wrap-as-quoted-string value)) + ((eq type 'comment) + (let ((dest "")) + (while value + (setq dest (concat dest + (if (stringp (car value)) + (std11-wrap-as-quoted-pairs + (car value) '(?( ?))) + (eword-decode-token (car value)) + )) + value (cdr value)) + ) + (concat "(" dest ")") + )) + (t value)))) + +(defun eword-extract-address-components (string &optional start) + "Extract full name and canonical address from STRING. +Returns a list of the form (FULL-NAME CANONICAL-ADDRESS). +If no name can be extracted, FULL-NAME will be nil. +It decodes non us-ascii characters in FULL-NAME encoded as +encoded-words or invalid \"raw\" string. \"Raw\" non us-ascii +characters are regarded as variable `default-mime-charset'." + (let* ((structure (car (std11-parse-address + (eword-lexical-analyze + (std11-unfold-string string) start + 'must-unfold)))) + (phrase (std11-full-name-string structure)) + (address (std11-address-string structure)) + ) + (list phrase address) + )) + + +;;; @ end +;;; + +(provide 'eword-decode) + +;;; eword-decode.el ends here diff --git a/mime/eword-encode.el b/mime/eword-encode.el new file mode 100644 index 0000000..f075db3 --- /dev/null +++ b/mime/eword-encode.el @@ -0,0 +1,694 @@ +;;; eword-encode.el --- RFC 2047 based encoded-word encoder for GNU Emacs + +;; Copyright (C) 1995,1996,1997,1998,1999,2000 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Keywords: encoded-word, MIME, multilingual, header, 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-def) +(require 'mel) +(require 'std11) +(require 'eword-decode) + + +;;; @ variables +;;; + +;; User options are defined in mime-def.el. + +(defvar mime-header-charset-encoding-alist + '((us-ascii . nil) + (iso-8859-1 . "Q") + (iso-8859-2 . "Q") + (iso-8859-3 . "Q") + (iso-8859-4 . "Q") + (iso-8859-5 . "Q") + (koi8-r . "Q") + (iso-8859-7 . "Q") + (iso-8859-8 . "Q") + (iso-8859-9 . "Q") + (iso-2022-jp . "B") + (iso-2022-jp-3 . "B") + (iso-2022-kr . "B") + (gb2312 . "B") + (cn-gb . "B") + (cn-gb-2312 . "B") + (euc-kr . "B") + (tis-620 . "B") + (iso-2022-jp-2 . "B") + (iso-2022-int-1 . "B") + (utf-8 . "B") + )) + +(defvar mime-header-default-charset-encoding "Q") + + +;;; @ encoded-text encoder +;;; + +(defun eword-encode-text (charset encoding string &optional mode) + "Encode STRING as an encoded-word, and return the result. +CHARSET is a symbol to indicate MIME charset of the encoded-word. +ENCODING allows \"B\" or \"Q\". +MODE is allows `text', `comment', `phrase' or nil. Default value is +`phrase'." + (let ((text (encoded-text-encode-string string encoding mode))) + (if text + (concat "=?" (upcase (symbol-name charset)) "?" + encoding "?" text "?=") + ))) + + +;;; @ charset word +;;; + +(defsubst eword-encode-char-type (character) + (if (memq character '(? ?\t ?\n)) + nil + (char-charset character) + )) + +(defun eword-encode-divide-into-charset-words (string) + (let ((len (length string)) + dest) + (while (> len 0) + (let* ((chr (aref string 0)) + ;; (chr (sref string 0)) + (charset (eword-encode-char-type chr)) + (i 1) + ;; (i (char-length chr)) + ) + (while (and (< i len) + (setq chr (aref string i)) + ;; (setq chr (sref string i)) + (eq charset (eword-encode-char-type chr))) + (setq i (1+ i)) + ;; (setq i (char-next-index chr i)) + ) + (setq dest (cons (cons charset (substring string 0 i)) dest) + string (substring string i) + len (- len i)))) + (nreverse dest))) + + +;;; @ word +;;; + +(defun eword-encode-charset-words-to-words (charset-words) + (let (dest) + (while charset-words + (let* ((charset-word (car charset-words)) + (charset (car charset-word)) + ) + (if charset + (let ((charsets (list charset)) + (str (cdr charset-word)) + ) + (catch 'tag + (while (setq charset-words (cdr charset-words)) + (setq charset-word (car charset-words) + charset (car charset-word)) + (if (null charset) + (throw 'tag nil) + ) + (or (memq charset charsets) + (setq charsets (cons charset charsets)) + ) + (setq str (concat str (cdr charset-word))) + )) + (setq dest (cons (cons charsets str) dest)) + ) + (setq dest (cons charset-word dest) + charset-words (cdr charset-words) + )))) + (nreverse dest) + )) + + +;;; @ rule +;;; + +(defmacro make-ew-rword (text charset encoding type) + (` (list (, text)(, charset)(, encoding)(, type)))) +(defmacro ew-rword-text (rword) + (` (car (, rword)))) +(defmacro ew-rword-charset (rword) + (` (car (cdr (, rword))))) +(defmacro ew-rword-encoding (rword) + (` (car (cdr (cdr (, rword)))))) +(defmacro ew-rword-type (rword) + (` (car (cdr (cdr (cdr (, rword))))))) + +(defun ew-find-charset-rule (charsets) + (if charsets + (let* ((charset (find-mime-charset-by-charsets charsets)) + (encoding + (cdr (or (assq charset mime-header-charset-encoding-alist) + (cons charset mime-header-default-charset-encoding))))) + (list charset encoding)))) + +(defun tm-eword::words-to-ruled-words (wl &optional mode) + (mapcar (function + (lambda (word) + (let ((ret (ew-find-charset-rule (car word)))) + (make-ew-rword (cdr word) (car ret)(nth 1 ret) mode) + ))) + wl)) + +(defun ew-space-process (seq) + (let (prev a ac b c cc) + (while seq + (setq b (car seq)) + (setq seq (cdr seq)) + (setq c (car seq)) + (setq cc (ew-rword-charset c)) + (if (and (null (ew-rword-charset b)) + (not (eq (ew-rword-type b) 'special))) + (progn + (setq a (car prev)) + (setq ac (ew-rword-charset a)) + (if (and (ew-rword-encoding a) + (ew-rword-encoding c)) + (cond ((eq ac cc) + (setq prev (cons + (cons (concat (car a)(car b)(car c)) + (cdr a)) + (cdr prev) + )) + (setq seq (cdr seq)) + ) + (t + (setq prev (cons + (cons (concat (car a)(car b)) + (cdr a)) + (cdr prev) + )) + )) + (setq prev (cons b prev)) + )) + (setq prev (cons b prev)) + )) + (reverse prev) + )) + +(defun eword-encode-split-string (str &optional mode) + (ew-space-process + (tm-eword::words-to-ruled-words + (eword-encode-charset-words-to-words + (eword-encode-divide-into-charset-words str)) + mode))) + + +;;; @ length +;;; + +(defun tm-eword::encoded-word-length (rword) + (let ((string (ew-rword-text rword)) + (charset (ew-rword-charset rword)) + (encoding (ew-rword-encoding rword)) + ret) + (setq ret + (cond ((string-equal encoding "B") + (setq string (encode-mime-charset-string string charset)) + (base64-encoded-length string) + ) + ((string-equal encoding "Q") + (setq string (encode-mime-charset-string string charset)) + (Q-encoded-text-length string (ew-rword-type rword)) + ))) + (if ret + (cons (+ 7 (length (symbol-name charset)) ret) string) + ))) + + +;;; @ encode-string +;;; + +(defun ew-encode-rword-1 (column rwl &optional must-output) + (catch 'can-not-output + (let* ((rword (car rwl)) + (ret (tm-eword::encoded-word-length rword)) + string len) + (if (null ret) + (cond ((and (setq string (car rword)) + (or (<= (setq len (+ (length string) column)) 76) + (<= column 1)) + ) + (setq rwl (cdr rwl)) + ) + ((memq (aref string 0) '(? ?\t)) + (setq string (concat "\n" string) + len (length string) + rwl (cdr rwl)) + ) + (must-output + (setq string "\n " + len 1) + ) + (t + (throw 'can-not-output nil) + )) + (cond ((and (setq len (car ret)) + (<= (+ column len) 76) + ) + (setq string + (eword-encode-text + (ew-rword-charset rword) + (ew-rword-encoding rword) + (cdr ret) + (ew-rword-type rword) + )) + (setq len (+ (length string) column)) + (setq rwl (cdr rwl)) + ) + (t + (setq string (car rword)) + (let* ((p 0) np + (str "") nstr) + (while (and (< p len) + (progn + (setq np (1+ p)) + ;;(setq np (char-next-index (sref string p) p)) + (setq nstr (substring string 0 np)) + (setq ret (tm-eword::encoded-word-length + (cons nstr (cdr rword)) + )) + (setq nstr (cdr ret)) + (setq len (+ (car ret) column)) + (<= len 76) + )) + (setq str nstr + p np)) + (if (string-equal str "") + (if must-output + (setq string "\n " + len 1) + (throw 'can-not-output nil)) + (setq rwl (cons (cons (substring string p) (cdr rword)) + (cdr rwl))) + (setq string + (eword-encode-text + (ew-rword-charset rword) + (ew-rword-encoding rword) + str + (ew-rword-type rword))) + (setq len (+ (length string) column)) + ) + ))) + ) + (list string len rwl) + ))) + +(defun eword-encode-rword-list (column rwl) + (let (ret dest str ew-f pew-f folded-points) + (while rwl + (setq ew-f (nth 2 (car rwl))) + (if (and pew-f ew-f) + (setq rwl (cons '(" ") rwl) + pew-f nil) + (setq pew-f ew-f) + ) + (if (null (setq ret (ew-encode-rword-1 column rwl))) + (let ((i (1- (length dest))) + c s r-dest r-column) + (catch 'success + (while (catch 'found + (while (>= i 0) + (cond ((memq (setq c (aref dest i)) '(? ?\t)) + (if (memq i folded-points) + (throw 'found nil) + (setq folded-points (cons i folded-points)) + (throw 'found i)) + ) + ((eq c ?\n) + (throw 'found nil) + )) + (setq i (1- i)))) + (setq s (substring dest i) + r-column (length s) + r-dest (concat (substring dest 0 i) "\n" s)) + (when (setq ret (ew-encode-rword-1 r-column rwl)) + (setq dest r-dest + column r-column) + (throw 'success t) + )) + (setq ret (ew-encode-rword-1 column rwl 'must-output)) + ))) + (setq str (car ret)) + (setq dest (concat dest str)) + (setq column (nth 1 ret) + rwl (nth 2 ret)) + ) + (list dest column) + )) + + +;;; @ converter +;;; + +(defun eword-encode-phrase-to-rword-list (phrase) + (let (token type dest str) + (while phrase + (setq token (car phrase)) + (setq type (car token)) + (cond ((eq type 'quoted-string) + (setq str (concat "\"" (cdr token) "\"")) + (setq dest + (append dest + (list + (let ((ret (ew-find-charset-rule + (find-charset-string str)))) + (make-ew-rword + str (car ret)(nth 1 ret) 'phrase) + ) + ))) + ) + ((eq type 'comment) + (setq dest + (append dest + '(("(" nil nil special)) + (tm-eword::words-to-ruled-words + (eword-encode-charset-words-to-words + (eword-encode-divide-into-charset-words + (cdr token))) + 'comment) + '((")" nil nil special)) + )) + ) + (t + (setq dest + (append dest + (tm-eword::words-to-ruled-words + (eword-encode-charset-words-to-words + (eword-encode-divide-into-charset-words + (cdr token)) + ) 'phrase))) + )) + (setq phrase (cdr phrase)) + ) + (ew-space-process dest) + )) + +(defun eword-encode-addr-seq-to-rword-list (seq) + (let (dest pname) + (while seq + (let* ((token (car seq)) + (name (car token)) + ) + (cond ((eq name 'spaces) + (setq dest (nconc dest (list (list (cdr token) nil nil)))) + ) + ((eq name 'comment) + (setq dest + (nconc + dest + (list (list "(" nil nil)) + (eword-encode-split-string (cdr token) 'comment) + (list (list ")" nil nil)) + )) + ) + ((eq name 'quoted-string) + (setq dest + (nconc + dest + (list + (list (concat "\"" (cdr token) "\"") nil nil) + ))) + ) + (t + (setq dest + (if (or (eq pname 'spaces) + (eq pname 'comment)) + (nconc dest (list (list (cdr token) nil nil))) + (nconc (nreverse (cdr (reverse dest))) + ;; (butlast dest) + (list + (list (concat (car (car (last dest))) + (cdr token)) + nil nil))))) + )) + (setq seq (cdr seq) + pname name)) + ) + dest)) + +(defun eword-encode-phrase-route-addr-to-rword-list (phrase-route-addr) + (if (eq (car phrase-route-addr) 'phrase-route-addr) + (let ((phrase (nth 1 phrase-route-addr)) + (route (nth 2 phrase-route-addr)) + dest) + ;; (if (eq (car (car phrase)) 'spaces) + ;; (setq phrase (cdr phrase)) + ;; ) + (setq dest (eword-encode-phrase-to-rword-list phrase)) + (if dest + (setq dest (append dest '((" " nil nil)))) + ) + (append + dest + (eword-encode-addr-seq-to-rword-list + (append '((specials . "<")) + route + '((specials . ">")))) + )))) + +(defun eword-encode-addr-spec-to-rword-list (addr-spec) + (if (eq (car addr-spec) 'addr-spec) + (eword-encode-addr-seq-to-rword-list (cdr addr-spec)) + )) + +(defun eword-encode-mailbox-to-rword-list (mbox) + (let ((addr (nth 1 mbox)) + (comment (nth 2 mbox)) + dest) + (setq dest (or (eword-encode-phrase-route-addr-to-rword-list addr) + (eword-encode-addr-spec-to-rword-list addr) + )) + (if comment + (setq dest + (append dest + '((" " nil nil) + ("(" nil nil)) + (eword-encode-split-string comment 'comment) + (list '(")" nil nil)) + ))) + dest)) + +(defsubst eword-encode-mailboxes-to-rword-list (mboxes) + (let ((dest (eword-encode-mailbox-to-rword-list (car mboxes)))) + (if dest + (while (setq mboxes (cdr mboxes)) + (setq dest + (nconc dest + (list '("," nil nil)) + (eword-encode-mailbox-to-rword-list + (car mboxes)))))) + dest)) + +(defsubst eword-encode-address-to-rword-list (address) + (cond + ((eq (car address) 'mailbox) + (eword-encode-mailbox-to-rword-list address)) + ((eq (car address) 'group) + (nconc + (eword-encode-phrase-to-rword-list (nth 1 address)) + (list (list ":" nil nil)) + (eword-encode-mailboxes-to-rword-list (nth 2 address)) + (list (list ";" nil nil)))))) + +(defsubst eword-encode-addresses-to-rword-list (addresses) + (let ((dest (eword-encode-address-to-rword-list (car addresses)))) + (if dest + (while (setq addresses (cdr addresses)) + (setq dest + (nconc dest + (list '("," nil nil)) + ;; (list '(" " nil nil)) + (eword-encode-address-to-rword-list (car addresses)))))) + dest)) + +(defsubst eword-encode-msg-id-to-rword-list (msg-id) + (list + (list + (concat "<" + (caar (eword-encode-addr-seq-to-rword-list (cdr msg-id))) + ">") + nil nil))) + +(defsubst eword-encode-in-reply-to-to-rword-list (in-reply-to) + (let (dest) + (while in-reply-to + (setq dest + (append dest + (let ((elt (car in-reply-to))) + (if (eq (car elt) 'phrase) + (eword-encode-phrase-to-rword-list (cdr elt)) + (eword-encode-msg-id-to-rword-list elt) + )))) + (setq in-reply-to (cdr in-reply-to))) + dest)) + + +;;; @ application interfaces +;;; + +(defvar eword-encode-default-start-column 10 + "Default start column if it is omitted.") + +(defun eword-encode-string (string &optional column mode) + "Encode STRING as encoded-words, and return the result. +Optional argument COLUMN is start-position of the field. +Optional argument MODE allows `text', `comment', `phrase' or nil. +Default value is `phrase'." + (car (eword-encode-rword-list + (or column eword-encode-default-start-column) + (eword-encode-split-string string mode)))) + +(defun eword-encode-address-list (string &optional column) + "Encode header field STRING as list of address, and return the result. +Optional argument COLUMN is start-position of the field." + (car (eword-encode-rword-list + (or column eword-encode-default-start-column) + (eword-encode-addresses-to-rword-list + (std11-parse-addresses-string string)) + ))) + +(defun eword-encode-in-reply-to (string &optional column) + "Encode header field STRING as In-Reply-To field, and return the result. +Optional argument COLUMN is start-position of the field." + (car (eword-encode-rword-list + (or column 13) + (eword-encode-in-reply-to-to-rword-list + (std11-parse-msg-ids-string string))))) + +(defun eword-encode-structured-field-body (string &optional column) + "Encode header field STRING as structured field, and return the result. +Optional argument COLUMN is start-position of the field." + (car (eword-encode-rword-list + (or column eword-encode-default-start-column) + (eword-encode-addr-seq-to-rword-list (std11-lexical-analyze string)) + ))) + +(defun eword-encode-unstructured-field-body (string &optional column) + "Encode header field STRING as unstructured field, and return the result. +Optional argument COLUMN is start-position of the field." + (car (eword-encode-rword-list + (or column eword-encode-default-start-column) + (eword-encode-split-string string 'text)))) + +;;;###autoload +(defun mime-encode-field-body (field-body field-name) + "Encode FIELD-BODY as FIELD-NAME, and return the result. +A lexical token includes non-ASCII character is encoded as MIME +encoded-word. ASCII token is not encoded." + (setq field-body (std11-unfold-string field-body)) + (if (string= field-body "") + "" + (let (start) + (if (symbolp field-name) + (setq start (1+ (length (symbol-name field-name)))) + (setq start (1+ (length field-name)) + field-name (intern (capitalize field-name)))) + (cond ((memq field-name + '(Reply-To + From Sender + Resent-Reply-To Resent-From + Resent-Sender To Resent-To + Cc Resent-Cc Bcc Resent-Bcc + Dcc)) + (eword-encode-address-list field-body start)) + ((eq field-name 'In-Reply-To) + (eword-encode-in-reply-to field-body start)) + ((memq field-name '(Mime-Version User-Agent)) + (eword-encode-structured-field-body field-body start)) + (t + (eword-encode-unstructured-field-body field-body start)))))) +(defalias 'eword-encode-field-body 'mime-encode-field-body) +(make-obsolete 'eword-encode-field-body 'mime-encode-field-body) + +(defun eword-in-subject-p () + (let ((str (std11-field-body "Subject"))) + (if (and str (string-match eword-encoded-word-regexp str)) + str))) +(make-obsolete 'eword-in-subject-p "Don't use it.") + +(defsubst eword-find-field-encoding-method (field-name) + (setq field-name (downcase field-name)) + (let ((alist mime-field-encoding-method-alist)) + (catch 'found + (while alist + (let* ((pair (car alist)) + (str (car pair))) + (if (and (stringp str) + (string= field-name (downcase str))) + (throw 'found (cdr pair)) + )) + (setq alist (cdr alist))) + (cdr (assq t mime-field-encoding-method-alist)) + ))) + +;;;###autoload +(defun mime-encode-header-in-buffer (&optional code-conversion) + "Encode header fields to network representation, such as MIME encoded-word. + +It refer variable `mime-field-encoding-method-alist'." + (interactive "*") + (save-excursion + (save-restriction + (std11-narrow-to-header mail-header-separator) + (goto-char (point-min)) + (let ((default-cs (mime-charset-to-coding-system default-mime-charset)) + bbeg end field-name) + (while (re-search-forward std11-field-head-regexp nil t) + (setq bbeg (match-end 0) + field-name (buffer-substring (match-beginning 0) (1- bbeg)) + end (std11-field-end)) + (and (delq 'ascii (find-charset-region bbeg end)) + (let ((method (eword-find-field-encoding-method + (downcase field-name)))) + (cond ((eq method 'mime) + (let ((field-body + (buffer-substring-no-properties bbeg end) + )) + (delete-region bbeg end) + (insert (mime-encode-field-body field-body + field-name)))) + (code-conversion + (let ((cs + (or (mime-charset-to-coding-system + method) + default-cs))) + (encode-coding-region bbeg end cs) + ))) + )) + )) + ))) +(defalias 'eword-encode-header 'mime-encode-header-in-buffer) +(make-obsolete 'eword-encode-header 'mime-encode-header-in-buffer) + + +;;; @ end +;;; + +(provide 'eword-encode) + +;;; eword-encode.el ends here diff --git a/mime/mail-mime-setup.el b/mime/mail-mime-setup.el new file mode 100644 index 0000000..7b375b7 --- /dev/null +++ b/mime/mail-mime-setup.el @@ -0,0 +1,65 @@ +;;; mail-mime-setup.el --- setup file for mail-mode. + +;; Copyright (C) 1994,1995,1996,1997,1998,2000 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Keywords: mail-mode, MIME, multimedia, multilingual, encoded-word + +;; This file is part of SEMI (Setting for Emacs MIME Interfaces). + +;; 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 'semi-setup) +(require 'alist) + + +(autoload 'turn-on-mime-edit "mime-edit" + "Unconditionally turn on MIME-Edit minor mode." t) + +;; (autoload 'eword-decode-header "eword-decode" +;; "Decode MIME encoded-words in header fields." t) + + +;;; @ for mail-mode, RMAIL and VM +;;; + +;; (add-hook 'mail-setup-hook 'eword-decode-header) +(add-hook 'mail-setup-hook 'turn-on-mime-edit 'append) +(add-hook 'mail-send-hook 'mime-edit-maybe-translate) +(set-alist 'mime-edit-split-message-sender-alist + 'mail-mode (function + (lambda () + (interactive) + (funcall send-mail-function) + ))) + + +;;; @ for signature +;;; + +(if mime-setup-use-signature + (setq mail-signature nil) + ) + + +;;; @ end +;;; + +(provide 'mail-mime-setup) + +;;; mail-mime-setup.el ends here diff --git a/mime/mcharset.el b/mime/mcharset.el new file mode 100644 index 0000000..124453d --- /dev/null +++ b/mime/mcharset.el @@ -0,0 +1,108 @@ +;;; mcharset.el --- MIME charset API + +;; Copyright (C) 1997,1998,1999,2000 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Keywords: emulation, compatibility, Mule + +;; This file is part of APEL (A Portable Emacs Library). + +;; 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 'custom) + +(cond ((featurep 'mule) + (if (>= emacs-major-version 20) + (require 'mcs-20) + ;; for MULE 1.* and 2.* + (require 'mcs-om))) + ((boundp 'NEMACS) + ;; for Nemacs and Nepoch + (require 'mcs-nemacs)) + (t + (require 'mcs-ltn1))) + +(defcustom default-mime-charset-for-write + (if (mime-charset-p 'utf-8) + 'utf-8 + 'x-ctext) + "Default value of MIME-charset for encoding. +It may be used when suitable MIME-charset is not found. +It must be symbol." + :group 'i18n + :type 'mime-charset) + +(defcustom default-mime-charset-detect-method-for-write + nil + "Function called when suitable MIME-charset is not found to encode. +It must be nil or function. +If it is nil, variable `default-mime-charset-for-write' is used. +If it is a function, interface must be (TYPE CHARSETS &rest ARGS). +CHARSETS is list of charset. +If TYPE is 'region, ARGS has START and END." + :group 'i18n + :type '(choice function (const nil))) + +(defun charsets-to-mime-charset (charsets) + "Return MIME charset from list of charset CHARSETS. +Return nil if suitable mime-charset is not found." + (if charsets + (catch 'tag + (let ((rest charsets-mime-charset-alist) + cell) + (while (setq cell (car rest)) + (if (catch 'not-subset + (let ((set1 charsets) + (set2 (car cell)) + obj) + (while set1 + (setq obj (car set1)) + (or (memq obj set2) + (throw 'not-subset nil)) + (setq set1 (cdr set1))) + t)) + (throw 'tag (cdr cell))) + (setq rest (cdr rest))) + )))) + +(defun find-mime-charset-by-charsets (charsets &optional mode &rest args) + "Like `charsets-to-mime-charset', but it does not return nil. + +When suitable mime-charset is not found and variable +`default-mime-charset-detect-method-for-write' is not nil, +`find-mime-charset-by-charsets' calls the variable as function and +return the return value of the function. +Interface of the function is (MODE CHARSETS &rest ARGS). + +When suitable mime-charset is not found and variable +`default-mime-charset-detect-method-for-write' is nil, +variable `default-mime-charset-for-write' is returned." + (or (charsets-to-mime-charset charsets) + (if default-mime-charset-detect-method-for-write + (apply default-mime-charset-detect-method-for-write + mode charsets args) + default-mime-charset-for-write))) + + +;;; @ end +;;; + +(require 'product) +(product-provide (provide 'mcharset) (require 'apel-ver)) + +;;; mcharset.el ends here diff --git a/mime/mcs-20.el b/mime/mcs-20.el new file mode 100644 index 0000000..ca9f394 --- /dev/null +++ b/mime/mcs-20.el @@ -0,0 +1,167 @@ +;;; mcs-20.el --- MIME charset implementation for Emacs 20 and XEmacs/mule + +;; Copyright (C) 1997,1998,1999,2000 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Keywords: emulation, compatibility, Mule + +;; This file is part of APEL (A Portable Emacs Library). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This module requires Emacs 20.0.93, XEmacs 20.3-b5 (with mule) +;; or later. + +;;; Code: + +(require 'custom) +(eval-when-compile (require 'wid-edit)) + +(if (featurep 'xemacs) + (require 'mcs-xm) + (require 'mcs-e20)) + + +;;; @ MIME charset +;;; + +(defcustom mime-charset-coding-system-alist + (let ((rest + '((us-ascii . raw-text) + (gb2312 . cn-gb-2312) + (cn-gb . cn-gb-2312) + (iso-2022-jp-2 . iso-2022-7bit-ss2) + (iso-2022-jp-3 . iso-2022-7bit-ss2) + (tis-620 . tis620) + (windows-874 . tis-620) + (cp874 . tis-620) + (x-ctext . ctext) + (unknown . undecided) + (x-unknown . undecided) + )) + dest) + (while rest + (let ((pair (car rest))) + (or (find-coding-system (car pair)) + (setq dest (cons pair dest)) + )) + (setq rest (cdr rest)) + ) + dest) + "Alist MIME CHARSET vs CODING-SYSTEM. +MIME CHARSET and CODING-SYSTEM must be symbol." + :group 'i18n + :type '(repeat (cons symbol coding-system))) + +(defcustom mime-charset-to-coding-system-default-method + nil + "Function called when suitable coding-system is not found from MIME-charset. +It must be nil or function. +If it is a function, interface must be (CHARSET LBT CODING-SYSTEM)." + :group 'i18n + :type '(choice function (const nil))) + +(defun mime-charset-to-coding-system (charset &optional lbt) + "Return coding-system corresponding with CHARSET. +CHARSET is a symbol whose name is MIME charset. +If optional argument LBT (`CRLF', `LF', `CR', `unix', `dos' or `mac') +is specified, it is used as line break code type of coding-system." + (if (stringp charset) + (setq charset (intern (downcase charset))) + ) + (let ((cs (assq charset mime-charset-coding-system-alist))) + (setq cs + (if cs + (cdr cs) + charset)) + (if lbt + (setq cs (intern (format "%s-%s" cs + (cond ((eq lbt 'CRLF) 'dos) + ((eq lbt 'LF) 'unix) + ((eq lbt 'CR) 'mac) + (t lbt))))) + ) + (if (find-coding-system cs) + cs + (if mime-charset-to-coding-system-default-method + (funcall mime-charset-to-coding-system-default-method + charset lbt cs) + )))) + +(defalias 'mime-charset-p 'mime-charset-to-coding-system) + +(defvar widget-mime-charset-prompt-value-history nil + "History of input to `widget-mime-charset-prompt-value'.") + +(define-widget 'mime-charset 'coding-system + "A mime-charset." + :format "%{%t%}: %v" + :tag "MIME-charset" + :prompt-history 'widget-mime-charset-prompt-value-history + :prompt-value 'widget-mime-charset-prompt-value + :action 'widget-mime-charset-action) + +(defun widget-mime-charset-prompt-value (widget prompt value unbound) + ;; Read mime-charset from minibuffer. + (intern + (completing-read (format "%s (default %s) " prompt value) + (mapcar (function + (lambda (sym) + (list (symbol-name sym)))) + (mime-charset-list))))) + +(defun widget-mime-charset-action (widget &optional event) + ;; Read a mime-charset from the minibuffer. + (let ((answer + (widget-mime-charset-prompt-value + widget + (widget-apply widget :menu-tag-get) + (widget-value widget) + t))) + (widget-value-set widget answer) + (widget-apply widget :notify widget event) + (widget-setup))) + +(defcustom default-mime-charset 'x-unknown + "Default value of MIME-charset. +It is used when MIME-charset is not specified. +It must be symbol." + :group 'i18n + :type 'mime-charset) + +(defun detect-mime-charset-region (start end) + "Return MIME charset for region between START and END." + (find-mime-charset-by-charsets (find-charset-region start end) + 'region start end)) + +(defun write-region-as-mime-charset (charset start end filename + &optional append visit lockname) + "Like `write-region', q.v., but encode by MIME CHARSET." + (let ((coding-system-for-write + (or (mime-charset-to-coding-system charset) + 'binary))) + (write-region start end filename append visit lockname))) + + +;;; @ end +;;; + +(require 'product) +(product-provide (provide 'mcs-20) (require 'apel-ver)) + +;;; mcs-20.el ends here diff --git a/mime/mcs-e20.el b/mime/mcs-e20.el new file mode 100644 index 0000000..47d57c0 --- /dev/null +++ b/mime/mcs-e20.el @@ -0,0 +1,157 @@ +;;; mcs-e20.el --- MIME charset implementation for Emacs 20.1 and 20.2 + +;; Copyright (C) 1996,1997,1998,1999,2000 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Keywords: emulation, compatibility, Mule + +;; This file is part of APEL (A Portable Emacs Library). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This module requires Emacs 20.1 and 20.2. + +;;; Code: + +(eval-when-compile (require 'static)) + +(defsubst find-coding-system (obj) + "Return OBJ if it is a coding-system." + (if (coding-system-p obj) + obj)) + +(defsubst encode-mime-charset-region (start end charset &optional lbt) + "Encode the text between START and END as MIME CHARSET." + (let (cs) + (if (and enable-multibyte-characters + (setq cs (mime-charset-to-coding-system charset lbt))) + (encode-coding-region start end cs) + ))) + +(defsubst decode-mime-charset-region (start end charset &optional lbt) + "Decode the text between START and END as MIME CHARSET." + (let (cs) + (if (and enable-multibyte-characters + (setq cs (mime-charset-to-coding-system charset lbt))) + (decode-coding-region start end cs) + ))) + + +(defsubst encode-mime-charset-string (string charset &optional lbt) + "Encode the STRING as MIME CHARSET." + (let (cs) + (if (and enable-multibyte-characters + (setq cs (mime-charset-to-coding-system charset lbt))) + (encode-coding-string string cs) + string))) + +(defsubst decode-mime-charset-string (string charset &optional lbt) + "Decode the STRING as MIME CHARSET." + (let (cs) + (if (and enable-multibyte-characters + (setq cs (mime-charset-to-coding-system charset lbt))) + (decode-coding-string string cs) + string))) + + +(defvar charsets-mime-charset-alist + '(((ascii) . us-ascii) + ((ascii latin-iso8859-1) . iso-8859-1) + ((ascii latin-iso8859-2) . iso-8859-2) + ((ascii latin-iso8859-3) . iso-8859-3) + ((ascii latin-iso8859-4) . iso-8859-4) +;;; ((ascii cyrillic-iso8859-5) . iso-8859-5) + ((ascii cyrillic-iso8859-5) . koi8-r) + ((ascii arabic-iso8859-6) . iso-8859-6) + ((ascii greek-iso8859-7) . iso-8859-7) + ((ascii hebrew-iso8859-8) . iso-8859-8) + ((ascii latin-iso8859-9) . iso-8859-9) + ((ascii latin-jisx0201 + japanese-jisx0208-1978 japanese-jisx0208) . iso-2022-jp) + ((ascii latin-jisx0201 + katakana-jisx0201 japanese-jisx0208) . shift_jis) + ((ascii korean-ksc5601) . euc-kr) + ((ascii chinese-gb2312) . gb2312) + ((ascii chinese-big5-1 chinese-big5-2) . big5) + ((ascii thai-tis620 composition) . tis-620) + ((ascii latin-iso8859-1 greek-iso8859-7 + latin-jisx0201 japanese-jisx0208-1978 + chinese-gb2312 japanese-jisx0208 + korean-ksc5601 japanese-jisx0212) . iso-2022-jp-2) +; ((ascii latin-iso8859-1 greek-iso8859-7 +; latin-jisx0201 japanese-jisx0208-1978 +; chinese-gb2312 japanese-jisx0208 +; korean-ksc5601 japanese-jisx0212 +; chinese-cns11643-1 chinese-cns11643-2) . iso-2022-int-1) +; ((ascii latin-iso8859-1 latin-iso8859-2 +; cyrillic-iso8859-5 greek-iso8859-7 +; latin-jisx0201 japanese-jisx0208-1978 +; chinese-gb2312 japanese-jisx0208 +; korean-ksc5601 japanese-jisx0212 +; chinese-cns11643-1 chinese-cns11643-2 +; chinese-cns11643-3 chinese-cns11643-4 +; chinese-cns11643-5 chinese-cns11643-6 +; chinese-cns11643-7) . iso-2022-int-1) + )) + +(defun coding-system-to-mime-charset (coding-system) + "Convert CODING-SYSTEM to a MIME-charset. +Return nil if corresponding MIME-charset is not found." + (or (car (rassq coding-system mime-charset-coding-system-alist)) + (coding-system-get coding-system 'mime-charset) + )) + +(defun mime-charset-list () + "Return a list of all existing MIME-charset." + (let ((dest (mapcar (function car) mime-charset-coding-system-alist)) + (rest coding-system-list) + cs) + (while rest + (setq cs (car rest)) + (unless (rassq cs mime-charset-coding-system-alist) + (if (setq cs (coding-system-get cs 'mime-charset)) + (or (rassq cs mime-charset-coding-system-alist) + (memq cs dest) + (setq dest (cons cs dest)) + ))) + (setq rest (cdr rest))) + dest)) + +(static-when (and (string= (decode-coding-string "\e.A\eN!" 'ctext) "\eN!") + (or (not (find-coding-system 'x-ctext)) + (coding-system-get 'x-ctext 'apel))) + (unless (find-coding-system 'x-ctext) + (make-coding-system + 'x-ctext 2 ?x + "Compound text based generic encoding for decoding unknown messages." + '((ascii t) (latin-iso8859-1 t) t t + nil ascii-eol ascii-cntl nil locking-shift single-shift nil nil nil + init-bol nil nil) + '((safe-charsets . t) + (mime-charset . x-ctext))) + (coding-system-put 'x-ctext 'apel t) + )) + + +;;; @ end +;;; + +(require 'product) +(product-provide (provide 'mcs-e20) (require 'apel-ver)) + +;;; mcs-e20.el ends here diff --git a/mime/mel-b-ccl.el b/mime/mel-b-ccl.el new file mode 100644 index 0000000..7e31dfa --- /dev/null +++ b/mime/mel-b-ccl.el @@ -0,0 +1,477 @@ +;;; mel-b-ccl.el --- Base64 encoder/decoder using CCL. + +;; Copyright (C) 1998,1999,2000 Free Software Foundation, Inc. + +;; Author: Tanaka Akira +;; Created: 1998/9/17 +;; Keywords: MIME, Base64 + +;; 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 this program; 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 'ccl) +(require 'pccl) +(require 'mime-def) + + +;;; @ constants +;;; + +(eval-when-compile + +(defconst mel-ccl-4-table + '( 0 1 2 3)) + +(defconst mel-ccl-16-table + '( 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)) + +(defconst mel-ccl-64-table + '( 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 + 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 + 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 + 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63)) + +(defconst mel-ccl-256-table + '( 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 + 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 + 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 + 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 + 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 + 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 + 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 + 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 + 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 + 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 + 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 + 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 + 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 + 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 + 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 + 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255)) + +(defconst mel-ccl-256-to-64-table + '(nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil 62 nil nil nil 63 + 52 53 54 55 56 57 58 59 60 61 nil nil nil t nil nil + nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 + 15 16 17 18 19 20 21 22 23 24 25 nil nil nil nil nil + nil 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 + 41 42 43 44 45 46 47 48 49 50 51 nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) + +(defconst mel-ccl-64-to-256-table + (mapcar + 'char-int + "ABCDEFGHIJKLMNOPQRSTUVWXYZ\ +abcdefghijklmnopqrstuvwxyz\ +0123456789\ ++/")) + +) + + +;;; @ CCL programs +;;; + +(eval-when-compile + +(defun mel-ccl-decode-b-bit-ex (v) + (logior + (lsh (logand v (lsh 255 16)) -16) + (logand v (lsh 255 8)) + (lsh (logand v 255) 16))) + +) + +(eval-when-compile + +(defconst mel-ccl-decode-b-0-table + (vconcat + (mapcar + (lambda (v) + (if (integerp v) + (mel-ccl-decode-b-bit-ex (lsh v 18)) + (lsh 1 24))) + mel-ccl-256-to-64-table))) + +(defconst mel-ccl-decode-b-1-table + (vconcat + (mapcar + (lambda (v) + (if (integerp v) + (mel-ccl-decode-b-bit-ex (lsh v 12)) + (lsh 1 25))) + mel-ccl-256-to-64-table))) + +(defconst mel-ccl-decode-b-2-table + (vconcat + (mapcar + (lambda (v) + (if (integerp v) + (mel-ccl-decode-b-bit-ex (lsh v 6)) + (lsh 1 26))) + mel-ccl-256-to-64-table))) + +(defconst mel-ccl-decode-b-3-table + (vconcat + (mapcar + (lambda (v) + (if (integerp v) + (mel-ccl-decode-b-bit-ex v) + (lsh 1 27))) + mel-ccl-256-to-64-table))) + +) + +(check-broken-facility ccl-cascading-read) + +(if-broken ccl-cascading-read + (define-ccl-program mel-ccl-decode-b + `(1 + (loop + (loop + (read-branch + r1 + ,@(mapcar + (lambda (v) + (cond + ((or (eq v nil) (eq v t)) '(repeat)) + (t `((r0 = ,(lsh v 2)) (break))))) + mel-ccl-256-to-64-table))) + (loop + (read-branch + r1 + ,@(mapcar + (lambda (v) + (cond + ((or (eq v nil) (eq v t)) '(repeat)) + ((= (lsh v -4) 0) `((write r0) (r0 = ,(lsh (logand v 15) 4)) (break))) + (t `((r0 |= ,(lsh v -4)) (write r0) (r0 = ,(lsh (logand v 15) 4)) (break))))) + mel-ccl-256-to-64-table))) + (loop + (read-branch + r1 + ,@(mapcar + (lambda (v) + (cond + ((eq v nil) '(repeat)) + ((eq v t) '(end)) + ((= (lsh v -2) 0) `((write r0) (r0 = ,(lsh (logand v 3) 6)) (break))) + (t `((r0 |= ,(lsh v -2)) (write r0) (r0 = ,(lsh (logand v 3) 6)) (break))))) + mel-ccl-256-to-64-table))) + (loop + (read-branch + r1 + ,@(mapcar + (lambda (v) + (cond + ((eq v nil) '(repeat)) + ((eq v t) '(end)) + (t `((r0 |= ,v) (write r0) (break))))) + mel-ccl-256-to-64-table))) + (repeat)))) + (define-ccl-program mel-ccl-decode-b + `(1 + (loop + (read r0 r1 r2 r3) + (r4 = r0 ,mel-ccl-decode-b-0-table) + (r5 = r1 ,mel-ccl-decode-b-1-table) + (r4 |= r5) + (r5 = r2 ,mel-ccl-decode-b-2-table) + (r4 |= r5) + (r5 = r3 ,mel-ccl-decode-b-3-table) + (r4 |= r5) + (if (r4 & ,(lognot (1- (lsh 1 24)))) + ((loop + (if (r4 & ,(lsh 1 24)) + ((r0 = r1) (r1 = r2) (r2 = r3) (read r3) + (r4 >>= 1) (r4 &= ,(logior (lsh 7 24))) + (r5 = r3 ,mel-ccl-decode-b-3-table) + (r4 |= r5) + (repeat)) + (break))) + (loop + (if (r4 & ,(lsh 1 25)) + ((r1 = r2) (r2 = r3) (read r3) + (r4 >>= 1) (r4 &= ,(logior (lsh 7 24))) + (r5 = r3 ,mel-ccl-decode-b-3-table) + (r4 |= r5) + (repeat)) + (break))) + (loop + (if (r2 != ?=) + (if (r4 & ,(lsh 1 26)) + ((r2 = r3) (read r3) + (r4 >>= 1) (r4 &= ,(logior (lsh 7 24))) + (r5 = r3 ,mel-ccl-decode-b-3-table) + (r4 |= r5) + (repeat)) + ((r6 = 0) + (break))) + ((r6 = 1) + (break)))) + (loop + (if (r3 != ?=) + (if (r4 & ,(lsh 1 27)) + ((read r3) + (r4 = r3 ,mel-ccl-decode-b-3-table) + (repeat)) + (break)) + ((r6 |= 2) + (break)))) + (r4 = r0 ,mel-ccl-decode-b-0-table) + (r5 = r1 ,mel-ccl-decode-b-1-table) + (r4 |= r5) + (branch + r6 + ;; BBBB + ((r5 = r2 ,mel-ccl-decode-b-2-table) + (r4 |= r5) + (r5 = r3 ,mel-ccl-decode-b-3-table) + (r4 |= r5) + (r4 >8= 0) + (write r7) + (r4 >8= 0) + (write r7) + (write-repeat r4)) + ;; error: BB=B + ((write (r4 & 255)) + (end)) + ;; BBB= + ((r5 = r2 ,mel-ccl-decode-b-2-table) + (r4 |= r5) + (r4 >8= 0) + (write r7) + (write (r4 & 255)) + (end) ; Excessive (end) is workaround for XEmacs 21.0. + ; Without this, "AAA=" is converted to "^@^@^@". + (end)) + ;; BB== + ((write (r4 & 255)) + (end)))) + ((r4 >8= 0) + (write r7) + (r4 >8= 0) + (write r7) + (write-repeat r4)))))) + ) + +(eval-when-compile + +;; Generated CCL program works not properly on 20.2 because CCL_EOF_BLOCK +;; is not executed. +(defun mel-ccl-encode-base64-generic + (&optional quantums-per-line output-crlf terminate-with-newline) + `(2 + ((r3 = 0) + (r2 = 0) + (read r1) + (loop + (branch + r1 + ,@(mapcar + (lambda (r1) + `((write ,(nth (lsh r1 -2) mel-ccl-64-to-256-table)) + (r0 = ,(logand r1 3)))) + mel-ccl-256-table)) + (r2 = 1) + (read-branch + r1 + ,@(mapcar + (lambda (r1) + `((write r0 ,(vconcat + (mapcar + (lambda (r0) + (nth (logior (lsh r0 4) + (lsh r1 -4)) + mel-ccl-64-to-256-table)) + mel-ccl-4-table))) + (r0 = ,(logand r1 15)))) + mel-ccl-256-table)) + (r2 = 2) + (read-branch + r1 + ,@(mapcar + (lambda (r1) + `((write r0 ,(vconcat + (mapcar + (lambda (r0) + (nth (logior (lsh r0 2) + (lsh r1 -6)) + mel-ccl-64-to-256-table)) + mel-ccl-16-table))))) + mel-ccl-256-table)) + (r1 &= 63) + (write r1 ,(vconcat + (mapcar + (lambda (r1) + (nth r1 mel-ccl-64-to-256-table)) + mel-ccl-64-table))) + (r3 += 1) + (r2 = 0) + (read r1) + ,@(when quantums-per-line + `((if (r3 == ,quantums-per-line) + ((write ,(if output-crlf "\r\n" "\n")) + (r3 = 0))))) + (repeat))) + (branch + r2 + ,(if terminate-with-newline + `(if (r3 > 0) (write ,(if output-crlf "\r\n" "\n"))) + `(r0 = 0)) + ((write r0 ,(vconcat + (mapcar + (lambda (r0) + (nth (lsh r0 4) mel-ccl-64-to-256-table)) + mel-ccl-4-table))) + (write ,(if terminate-with-newline + (if output-crlf "==\r\n" "==\n") + "=="))) + ((write r0 ,(vconcat + (mapcar + (lambda (r0) + (nth (lsh r0 2) mel-ccl-64-to-256-table)) + mel-ccl-16-table))) + (write ,(if terminate-with-newline + (if output-crlf "=\r\n" "=\n") + "=")))) + )) +) + +(define-ccl-program mel-ccl-encode-b + (mel-ccl-encode-base64-generic)) + +;; 19 * 4 = 76 +(define-ccl-program mel-ccl-encode-base64-crlf-crlf + (mel-ccl-encode-base64-generic 19 t)) + +(define-ccl-program mel-ccl-encode-base64-crlf-lf + (mel-ccl-encode-base64-generic 19 nil)) + + +;;; @ coding system +;;; + +(make-ccl-coding-system + 'mel-ccl-b-rev ?B "MIME B-encoding (reversed)" + 'mel-ccl-encode-b 'mel-ccl-decode-b) + +(make-ccl-coding-system + 'mel-ccl-base64-crlf-rev + ?B "MIME Base64-encoding (reversed)" + 'mel-ccl-encode-base64-crlf-crlf + 'mel-ccl-decode-b) + +(make-ccl-coding-system + 'mel-ccl-base64-lf-rev + ?B "MIME Base64-encoding (LF encoding) (reversed)" + 'mel-ccl-encode-base64-crlf-lf + 'mel-ccl-decode-b) + + +;;; @ B +;;; + +(check-broken-facility ccl-execute-eof-block-on-decoding-some) + +(unless-broken ccl-execute-eof-block-on-decoding-some + + (defun base64-ccl-encode-string (string &optional no-line-break) + "Encode STRING with base64 encoding." + (if no-line-break + (decode-coding-string string 'mel-ccl-b-rev) + (decode-coding-string string 'mel-ccl-base64-lf-rev))) + (defalias-maybe 'base64-encode-string 'base64-ccl-encode-string) + + (defun base64-ccl-encode-region (start end &optional no-line-break) + "Encode region from START to END with base64 encoding." + (interactive "*r") + (if no-line-break + (decode-coding-region start end 'mel-ccl-b-rev) + (decode-coding-region start end 'mel-ccl-base64-lf-rev))) + (defalias-maybe 'base64-encode-region 'base64-ccl-encode-region) + + (defun base64-ccl-insert-encoded-file (filename) + "Encode contents of file FILENAME to base64, and insert the result." + (interactive "*fInsert encoded file: ") + (let ((coding-system-for-read 'mel-ccl-base64-lf-rev) + format-alist) + (insert-file-contents filename))) + + (mel-define-method-function (mime-encode-string string (nil "base64")) + 'base64-ccl-encode-string) + (mel-define-method-function (mime-encode-region start end (nil "base64")) + 'base64-ccl-encode-region) + (mel-define-method-function + (mime-insert-encoded-file filename (nil "base64")) + 'base64-ccl-insert-encoded-file) + + (mel-define-method-function (encoded-text-encode-string string (nil "B")) + 'base64-ccl-encode-string) + ) + +(defun base64-ccl-decode-string (string) + "Decode base64 encoded STRING" + (encode-coding-string string 'mel-ccl-b-rev)) +(defalias-maybe 'base64-decode-string 'base64-ccl-decode-string) + +(defun base64-ccl-decode-region (start end) + "Decode base64 encoded the region from START to END." + (interactive "*r") + (encode-coding-region start end 'mel-ccl-b-rev)) +(defalias-maybe 'base64-decode-region 'base64-ccl-decode-region) + +(defun base64-ccl-write-decoded-region (start end filename) + "Decode the region from START to END and write out to FILENAME." + (interactive "*r\nFWrite decoded region to file: ") + (let ((coding-system-for-write 'mel-ccl-b-rev) + jka-compr-compression-info-list jam-zcat-filename-list) + (write-region start end filename))) + +(mel-define-method-function (mime-decode-string string (nil "base64")) + 'base64-ccl-decode-string) +(mel-define-method-function (mime-decode-region start end (nil "base64")) + 'base64-ccl-decode-region) +(mel-define-method-function + (mime-write-decoded-region start end filename (nil "base64")) + 'base64-ccl-write-decoded-region) + +(mel-define-method encoded-text-decode-string (string (nil "B")) + (if (string-match (eval-when-compile + (concat "\\`" B-encoded-text-regexp "\\'")) + string) + (base64-ccl-decode-string string) + (error "Invalid encoded-text %s" string))) + + +;;; @ end +;;; + +(provide 'mel-b-ccl) + +;;; mel-b-ccl.el ends here. diff --git a/mime/mel-g.el b/mime/mel-g.el new file mode 100644 index 0000000..9f79197 --- /dev/null +++ b/mime/mel-g.el @@ -0,0 +1,135 @@ +;;; mel-g.el --- Gzip64 encoder/decoder. + +;; Copyright (C) 1995,1996,1997,1998 MORIOKA Tomohiko +;; Copyright (C) 1996,1997,1999 Shuhei KOBAYASHI + +;; Author: Shuhei KOBAYASHI +;; MORIOKA Tomohiko +;; Maintainer: Shuhei KOBAYASHI +;; Created: 1995/10/25 +;; Keywords: Gzip64, base64, gzip, MIME + +;; 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 this program; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; NOTE: Gzip64 is an experimental Content-Transfer-Encoding and its +;;; use is STRONGLY DISCOURAGED except for private communication. + +;;; Code: + +(require 'mime-def) +(require 'path-util) + + +;;; @ variables +;;; + +(defvar gzip64-external-encoder + (let ((file (exec-installed-p "mmencode"))) + (and file + (` ("sh" "-c" (, (concat "gzip -c | " file)))))) + "*list of gzip64 encoder program name and its arguments.") + +(defvar gzip64-external-decoder + (let ((file (exec-installed-p "mmencode"))) + (and file + (` ("sh" "-c" (, (concat file " -u | gzip -dc")))))) + "*list of gzip64 decoder program name and its arguments.") + + +;;; @ encoder/decoder for region +;;; + +(defun gzip64-external-encode-region (beg end) + (interactive "*r") + (save-excursion + (let ((coding-system-for-write 'binary)) + (apply (function call-process-region) + beg end (car gzip64-external-encoder) + t t nil + (cdr gzip64-external-encoder))) + ;; for OS/2 + ;; regularize line break code + ;;(goto-char (point-min)) + ;;(while (re-search-forward "\r$" nil t) + ;; (replace-match "")) + )) + +(defun gzip64-external-decode-region (beg end) + (interactive "*r") + (save-excursion + (let ((coding-system-for-read 'binary)) + (apply (function call-process-region) + beg end (car gzip64-external-decoder) + t t nil + (cdr gzip64-external-decoder))))) + +(mel-define-method-function (mime-encode-region start end (nil "x-gzip64")) + 'gzip64-external-encode-region) +(mel-define-method-function (mime-decode-region start end (nil "x-gzip64")) + 'gzip64-external-decode-region) + + +;;; @ encoder/decoder for string +;;; + +(mel-define-method mime-encode-string (string (nil "x-gzip64")) + (with-temp-buffer + (insert string) + (gzip64-external-encode-region (point-min)(point-max)) + (buffer-string))) + +(mel-define-method mime-decode-string (string (nil "x-gzip64")) + (with-temp-buffer + (insert string) + (gzip64-external-decode-region (point-min)(point-max)) + (buffer-string))) + + +;;; @ encoder/decoder for file +;;; + +(mel-define-method mime-insert-encoded-file (filename (nil "x-gzip64")) + (interactive "*fInsert encoded file: ") + (apply (function call-process) + (car gzip64-external-encoder) + filename t nil + (cdr gzip64-external-encoder))) + +(mel-define-method mime-write-decoded-region (start end filename + (nil "x-gzip64")) + "Decode and write current region encoded by gzip64 into FILENAME. +START and END are buffer positions." + (interactive "*r\nFWrite decoded region to file: ") + (let ((coding-system-for-read 'binary) + (coding-system-for-write 'binary)) + (apply (function call-process-region) + start end (car gzip64-external-decoder) + nil nil nil + (let ((args (cdr gzip64-external-decoder))) + (append (butlast args) + (list (concat (car (last args)) ">" filename))))))) + + +;;; @ end +;;; + +(provide 'mel-g) + +;;; mel-g.el ends here. diff --git a/mime/mel-q-ccl.el b/mime/mel-q-ccl.el new file mode 100644 index 0000000..cb54a56 --- /dev/null +++ b/mime/mel-q-ccl.el @@ -0,0 +1,996 @@ +;;; mel-q-ccl.el --- Quoted-Printable encoder/decoder using CCL. + +;; Copyright (C) 1998,1999 Tanaka Akira + +;; Author: Tanaka Akira +;; Created: 1998/9/17 +;; Keywords: MIME, Quoted-Printable, Q-encoding + +;; 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 this program; 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 'ccl) +(require 'pccl) +(require 'mime-def) + + +;;; @ constants +;;; + +(eval-when-compile + +(defconst mel-ccl-16-table + '( 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)) + +(defconst mel-ccl-28-table + '( 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 + 16 17 18 19 20 21 22 23 24 25 26 27)) + +(defconst mel-ccl-256-table + '( 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 + 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 + 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 + 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 + 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 + 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 + 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 + 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 + 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 + 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 + 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 + 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 + 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 + 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 + 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 + 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255)) + +(defconst mel-ccl-256-to-16-table + '(nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + 0 1 2 3 4 5 6 7 8 9 nil nil nil nil nil nil + nil 10 11 12 13 14 15 nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) + +(defconst mel-ccl-16-to-256-table + (mapcar 'char-int "0123456789ABCDEF")) + +(defconst mel-ccl-high-table + (vconcat + (mapcar + (lambda (v) (nth (lsh v -4) mel-ccl-16-to-256-table)) + mel-ccl-256-table))) + +(defconst mel-ccl-low-table + (vconcat + (mapcar + (lambda (v) (nth (logand v 15) mel-ccl-16-to-256-table)) + mel-ccl-256-table))) + +(defconst mel-ccl-u-raw + (mapcar + 'char-int + "0123456789\ +ABCDEFGHIJKLMNOPQRSTUVWXYZ\ +abcdefghijklmnopqrstuvwxyz\ +!@#$%&'()*+,-./:;<>@[\\]^`{|}~")) + +(defconst mel-ccl-c-raw + (mapcar + 'char-int + "0123456789\ +ABCDEFGHIJKLMNOPQRSTUVWXYZ\ +abcdefghijklmnopqrstuvwxyz\ +!@#$%&'*+,-./:;<>@[]^`{|}~")) + +(defconst mel-ccl-p-raw + (mapcar + 'char-int + "0123456789\ +ABCDEFGHIJKLMNOPQRSTUVWXYZ\ +abcdefghijklmnopqrstuvwxyz\ +!*+-/")) + +(defconst mel-ccl-qp-table + [enc enc enc enc enc enc enc enc enc wsp lf enc enc cr enc enc + enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc + wsp raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw + raw raw raw raw raw raw raw raw raw raw raw raw raw enc raw raw + raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw + raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw + raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw + raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw enc + enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc + enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc + enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc + enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc + enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc + enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc + enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc + enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc]) + +) + + +;;; @ CCL programs +;;; + +;;; Q + +(define-ccl-program mel-ccl-decode-q + `(1 + ((loop + (read-branch + r0 + ,@(mapcar + (lambda (r0) + (cond + ((= r0 (char-int ?_)) + `(write-repeat ? )) + ((= r0 (char-int ?=)) + `((loop + (read-branch + r1 + ,@(mapcar + (lambda (v) + (if (integerp v) + `((r0 = ,v) (break)) + '(repeat))) + mel-ccl-256-to-16-table))) + (loop + (read-branch + r1 + ,@(mapcar + (lambda (v) + (if (integerp v) + `((write r0 ,(vconcat + (mapcar + (lambda (r0) + (logior (lsh r0 4) v)) + mel-ccl-16-table))) + (break)) + '(repeat))) + mel-ccl-256-to-16-table))) + (repeat))) + (t + `(write-repeat ,r0)))) + mel-ccl-256-table)))))) + +(eval-when-compile + +(defun mel-ccl-encode-q-generic (raw) + `(3 + (loop + (loop + (read-branch + r0 + ,@(mapcar + (lambda (r0) + (cond + ((= r0 32) `(write-repeat ?_)) + ((member r0 raw) `(write-repeat ,r0)) + (t '(break)))) + mel-ccl-256-table))) + (write ?=) + (write r0 ,mel-ccl-high-table) + (write r0 ,mel-ccl-low-table) + (repeat)))) + +;; On xemacs, generated program counts iso-8859-1 8bit character as 6bytes. +(defun mel-ccl-count-q-length (raw) + `(0 + ((r0 = 0) + (loop + (read-branch + r1 + ,@(mapcar + (lambda (r1) + (if (or (= r1 32) (member r1 raw)) + '((r0 += 1) (repeat)) + '((r0 += 3) (repeat)))) + mel-ccl-256-table)))))) + +) + +(define-ccl-program mel-ccl-encode-uq + (mel-ccl-encode-q-generic mel-ccl-u-raw)) +(define-ccl-program mel-ccl-encode-cq + (mel-ccl-encode-q-generic mel-ccl-c-raw)) +(define-ccl-program mel-ccl-encode-pq + (mel-ccl-encode-q-generic mel-ccl-p-raw)) + +(define-ccl-program mel-ccl-count-uq + (mel-ccl-count-q-length mel-ccl-u-raw)) +(define-ccl-program mel-ccl-count-cq + (mel-ccl-count-q-length mel-ccl-c-raw)) +(define-ccl-program mel-ccl-count-pq + (mel-ccl-count-q-length mel-ccl-p-raw)) + +;; Quoted-Printable + +(eval-when-compile + +(defvar eof-block-branches) +(defvar eof-block-reg) +(defun mel-ccl-set-eof-block (branch) + (let ((p (assoc branch eof-block-branches))) + (unless p + (setq p (cons branch (length eof-block-branches)) + eof-block-branches (cons p eof-block-branches))) + `(,eof-block-reg = ,(cdr p)))) + +) + +(eval-when-compile + +(defun mel-ccl-try-to-read-crlf (input-crlf reg + succ + cr-eof cr-fail + lf-eof lf-fail + crlf-eof crlf-fail) + (if input-crlf + `(,(mel-ccl-set-eof-block cr-eof) + (read-if (,reg == ?\r) + (,(mel-ccl-set-eof-block lf-eof) + (read-if (,reg == ?\n) + ,succ + ,lf-fail)) + ,cr-fail)) + `(,(mel-ccl-set-eof-block crlf-eof) + (read-if (,reg == ?\n) + ,succ + ,crlf-fail)))) + +) + +(eval-when-compile + +;; Generated CCL program works not properly on 20.2 because CCL_EOF_BLOCK +;; is not executed. +(defun mel-ccl-encode-quoted-printable-generic (input-crlf output-crlf) + (let ((hard (if output-crlf "\r\n" "\n")) + (soft (if output-crlf "=\r\n" "=\n")) + (eof-block-branches nil) + (eof-block-reg 'r4) + (after-wsp 'r5) + (column 'r6) + (type 'r3) + (current 'r0) + (type-raw 0) + (type-enc 1) + (type-wsp 2) + (type-brk 3) + ) + `(4 + ((,column = 0) + (,after-wsp = 0) + ,(mel-ccl-set-eof-block '(end)) + (read r0) + (loop ; invariant: column <= 75 + (loop + (loop + (branch + r0 + ,@(mapcar + (lambda (r0) + (let ((tmp (aref mel-ccl-qp-table r0))) + (cond + ((eq r0 (char-int ?F)) + `(if (,column == 0) + (,(mel-ccl-set-eof-block '((write "F") (end))) + (read-if (r0 == ?r) + (,(mel-ccl-set-eof-block '((write "Fr") (end))) + (read-if (r0 == ?o) + (,(mel-ccl-set-eof-block '((write "Fro") (end))) + (read-if (r0 == ?m) + (,(mel-ccl-set-eof-block '((write "From") (end))) + (read-if (r0 == ? ) + ((,column = 7) + (,after-wsp = 1) + ,(mel-ccl-set-eof-block '((write "From=20") (end))) + (read r0) + (write-repeat "=46rom ")) + ((,column = 4) + (write-repeat "From")))) + ((,column = 3) + (write-repeat "Fro")))) + ((,column = 2) + (write-repeat "Fr")))) + ((,column = 1) + (write-repeat "F")))) + ((,type = ,type-raw) (break)) ; RAW + )) + ((eq r0 (char-int ?.)) + `(if (,column == 0) + ,(mel-ccl-try-to-read-crlf + input-crlf 'r0 + ;; "." CR LF (input-crlf: t) + ;; "." LF (input-crlf: nil) + `((write ,(concat "=2E" hard)) + ,(mel-ccl-set-eof-block '(end)) + (read r0) + (repeat)) + ;; "." + '((write ".") (end)) + ;; "." noCR (input-crlf: t) + `((,column = 1) + (write-repeat ".")) + ;; "." CR (input-crlf: t) + '((write ".=0D") (end)) + ;; "." CR noLF (input-crlf: t) + `((,column = 4) + (write-repeat ".=0D")) + ;; "." (input-crlf: nil) + '((write ".") (end)) + ;; "." noLF (input-crlf: nil) + `((,column = 1) + (write-repeat "."))) + ((,type = ,type-raw) (break)) ; RAW + )) + ((eq tmp 'raw) `((,type = ,type-raw) (break))) + ((eq tmp 'enc) `((,type = ,type-enc) (break))) + ((eq tmp 'wsp) `((,type = ,type-wsp) (break))) + ((eq tmp 'cr) `((,type = ,(if input-crlf type-brk type-enc)) + (break))) + ((eq tmp 'lf) `((,type = ,(if input-crlf type-enc type-brk)) + (break))) + ))) + mel-ccl-256-table))) + ;; r0:type{raw,enc,wsp,brk} + (branch + ,type + ;; r0:type-raw + (if (,column < 75) + ((,column += 1) + (,after-wsp = 0) + ,(mel-ccl-set-eof-block '(end)) + (write-read-repeat r0)) + ((r1 = (r0 + 0)) + (,after-wsp = 0) + ,@(mel-ccl-try-to-read-crlf + input-crlf 'r0 + `((,column = 0) + (write r1) + ,(mel-ccl-set-eof-block `((write ,hard) (end))) + (read r0) + (write-repeat ,hard)) + '((write r1) (end)) + `((,column = 1) + (write ,soft) (write-repeat r1)) + `((write ,soft) (write r1) (write "=0D") (end)) + `((,column = 4) + (write ,soft) (write r1) (write-repeat "=0D")) + '((write r1) (end)) + `((,column = 1) + (write ,soft) (write-repeat r1))))) + ;; r0:type-enc + ((,after-wsp = 0) + (if (,column < 73) + ((,column += 3) + (write "=") + (write r0 ,mel-ccl-high-table) + ,(mel-ccl-set-eof-block '(end)) + (write-read-repeat r0 ,mel-ccl-low-table)) + (if (,column < 74) + ((r1 = (r0 + 0)) + (,after-wsp = 0) + ,@(mel-ccl-try-to-read-crlf + input-crlf 'r0 + `((,column = 0) + (write "=") + (write r1 ,mel-ccl-high-table) + (write r1 ,mel-ccl-low-table) + (write ,hard) + ,(mel-ccl-set-eof-block '(end)) + (read r0) + (repeat)) + `((write "=") + (write r1 ,mel-ccl-high-table) + (write r1 ,mel-ccl-low-table) + (end)) + `((,column = 3) + (write ,(concat soft "=")) + (write r1 ,mel-ccl-high-table) + (write r1 ,mel-ccl-low-table) + (repeat)) + `((write ,(concat soft "=")) + (write r1 ,mel-ccl-high-table) + (write r1 ,mel-ccl-low-table) + (write "=0D") + (end)) + `((,column = 6) + (write ,(concat soft "=")) + (write r1 ,mel-ccl-high-table) + (write r1 ,mel-ccl-low-table) + (write-repeat "=0D")) + `((write "=") + (write r1 ,mel-ccl-high-table) + (write r1 ,mel-ccl-low-table) + (end)) + `((,column = 3) + (write ,(concat soft "=")) + (write r1 ,mel-ccl-high-table) + (write r1 ,mel-ccl-low-table) + (repeat)))) + ((,column = 3) + (write ,(concat soft "=")) + (write r0 ,mel-ccl-high-table) + ,(mel-ccl-set-eof-block '(end)) + (write-read-repeat r0 ,mel-ccl-low-table))))) + ;; r0:type-wsp + (if (,column < 73) + ((r1 = (r0 + 0)) + ,@(mel-ccl-try-to-read-crlf + input-crlf 'r0 + `((,column = 0) + (,after-wsp = 0) + (write "=") + (write r1 ,mel-ccl-high-table) + (write r1 ,mel-ccl-low-table) + (write ,hard) + ,(mel-ccl-set-eof-block `(end)) + (read r0) + (repeat)) + `((write "=") + (write r1 ,mel-ccl-high-table) + (write r1 ,mel-ccl-low-table) + (end)) + `((,column += 1) + (,after-wsp = 1) + (write-repeat r1)) + `((write r1) + (write "=0D") + (end)) + `((,column += 4) + (,after-wsp = 0) + (write r1) + (write-repeat "=0D")) + `((write "=") + (write r1 ,mel-ccl-high-table) + (write r1 ,mel-ccl-low-table) + (end)) + `((,column += 1) + (,after-wsp = 1) + (write-repeat r1)))) + (if (,column < 74) + ((r1 = (r0 + 0)) + ,@(mel-ccl-try-to-read-crlf + input-crlf 'r0 + `((,column = 0) + (,after-wsp = 0) + (write "=") + (write r1 ,mel-ccl-high-table) + (write r1 ,mel-ccl-low-table) + (write ,hard) + ,(mel-ccl-set-eof-block `(end)) + (read r0) + (repeat)) + `((write "=") + (write r1 ,mel-ccl-high-table) + (write r1 ,mel-ccl-low-table) + (end)) + `((,column += 1) + (,after-wsp = 1) + (write-repeat r1)) + `((write r1) + (write ,(concat soft "=0D")) + (end)) + `((,column = 3) + (,after-wsp = 0) + (write r1) + (write-repeat ,(concat soft "=0D"))) + `((write "=") + (write r1 ,mel-ccl-high-table) + (write r1 ,mel-ccl-low-table) + (end)) + `((,column += 1) + (,after-wsp = 1) + (write-repeat r1)))) + (if (,column < 75) + ((,column += 1) + (,after-wsp = 1) + ,(mel-ccl-set-eof-block `((write ,soft) (end))) + (write-read-repeat r0)) + ((write ,soft) + (,column = 0) + (,after-wsp = 0) + (repeat))))) + ;; r0:type-brk + ,(if input-crlf + ;; r0{CR}:type-brk + `((if ((,column > 73) & ,after-wsp) + ((,column = 0) + (,after-wsp = 0) + (write ,soft))) + ,(mel-ccl-set-eof-block `((if (,column > 73) (write ,soft)) + (write "=0D") (end))) + (read-if (r0 == ?\n) + (if ,after-wsp + ((,after-wsp = 0) + (,column = 0) + (write ,(concat soft hard)) + ,(mel-ccl-set-eof-block '(end)) + (read r0) + (repeat)) + ((,after-wsp = 0) + (,column = 0) + (write ,hard) + ,(mel-ccl-set-eof-block '(end)) + (read r0) + (repeat))) + (if (,column < 73) + ((,after-wsp = 0) + (,column += 3) + (write-repeat "=0D")) + (if (,column < 74) + (if (r0 == ?\r) + ((,after-wsp = 0) + ,(mel-ccl-set-eof-block + `((write ,(concat soft "=0D=0D")) (end))) + (read-if (r0 == ?\n) + ((,column = 0) + ,(mel-ccl-set-eof-block + `((write ,(concat "=0D" hard)) (end))) + (read r0) + (write-repeat ,(concat "=0D" hard))) + ((,column = 6) + (write-repeat ,(concat soft "=0D=0D"))))) + ((,after-wsp = 0) + (,column = 3) + (write-repeat ,(concat soft "=0D")))) + ((,after-wsp = 0) + (,column = 3) + (write-repeat ,(concat soft "=0D"))))))) + ;; r0{LF}:type-brk + `(if ,after-wsp + ;; WSP ; r0{LF}:type-brk + ((,after-wsp = 0) + (,column = 0) + (write ,(concat soft (if output-crlf "\r" ""))) + ,(mel-ccl-set-eof-block `(end)) + (write-read-repeat r0)) + ;; noWSP ; r0{LF}:type-brk + ((,after-wsp = 0) + (,column = 0) + ,@(if output-crlf '((write ?\r)) '()) + ,(mel-ccl-set-eof-block `(end)) + (write-read-repeat r0))) + ))))) + (branch + ,eof-block-reg + ,@(reverse (mapcar 'car eof-block-branches)))))) + +(defun mel-ccl-decode-quoted-printable-generic (input-crlf output-crlf) + `(1 + ((read r0) + (loop + (branch + r0 + ,@(mapcar + (lambda (r0) + (let ((tmp (aref mel-ccl-qp-table r0))) + (cond + ((eq tmp 'raw) `(write-read-repeat r0)) + ((eq tmp 'wsp) (if (eq r0 (char-int ? )) + `(r1 = 1) + `(r1 = 0))) + ((eq tmp 'cr) + (if input-crlf + ;; r0='\r' + `((read r0) + ;; '\r' r0 + (if (r0 == ?\n) + ;; '\r' r0='\n' + ;; hard line break found. + ,(if output-crlf + '((write ?\r) + (write-read-repeat r0)) + '(write-read-repeat r0)) + ;; '\r' r0:[^\n] + ;; invalid control character (bare CR) found. + ;; -> ignore it and rescan from r0. + (repeat))) + ;; r0='\r' + ;; invalid character (bare CR) found. + ;; -> ignore. + `((read r0) + (repeat)))) + ((eq tmp 'lf) + (if input-crlf + ;; r0='\n' + ;; invalid character (bare LF) found. + ;; -> ignore. + `((read r0) + (repeat)) + ;; r0='\r\n' + ;; hard line break found. + (if output-crlf + '((write ?\r) + (write-read-repeat r0)) + '(write-read-repeat r0)))) + ((eq r0 (char-int ?=)) + ;; r0='=' + `((read r0) + ;; '=' r0 + (r1 = (r0 == ?\t)) + (if ((r0 == ? ) | r1) + ;; '=' r0:[\t ] + ;; Skip transport-padding. + ;; It should check CR LF after + ;; transport-padding. + (loop + (read-if (r0 == ?\t) + (repeat) + (if (r0 == ? ) + (repeat) + (break))))) + ;; '=' [\t ]* r0:[^\t ] + (branch + r0 + ,@(mapcar + (lambda (r0) + (cond + ((eq r0 (char-int ?\r)) + (if input-crlf + ;; '=' [\t ]* r0='\r' + `((read r0) + ;; '=' [\t ]* '\r' r0 + (if (r0 == ?\n) + ;; '=' [\t ]* '\r' r0='\n' + ;; soft line break found. + ((read r0) + (repeat)) + ;; '=' [\t ]* '\r' r0:[^\n] + ;; invalid input -> + ;; output "=" and rescan from r0. + ((write "=") + (repeat)))) + ;; '=' [\t ]* r0='\r' + ;; invalid input (bare CR found) -> + ;; output "=" and rescan from next. + `((write ?=) + (read r0) + (repeat)))) + ((eq r0 (char-int ?\n)) + (if input-crlf + ;; '=' [\t ]* r0='\n' + ;; invalid input (bare LF found) -> + ;; output "=" and rescan from next. + `((write ?=) + (read r0) + (repeat)) + ;; '=' [\t ]* r0='\r\n' + ;; soft line break found. + `((read r0) + (repeat)))) + ((setq tmp (nth r0 mel-ccl-256-to-16-table)) + ;; '=' [\t ]* r0:[0-9A-F] + ;; upper nibble of hexadecimal digit found. + `((r1 = (r0 + 0)) + (r0 = ,tmp))) + (t + ;; '=' [\t ]* r0:[^\r0-9A-F] + ;; invalid input -> + ;; output "=" and rescan from r0. + `((write ?=) + (repeat))))) + mel-ccl-256-table)) + ;; '=' [\t ]* r1:r0:[0-9A-F] + (read-branch + r2 + ,@(mapcar + (lambda (r2) + (if (setq tmp (nth r2 mel-ccl-256-to-16-table)) + ;; '=' [\t ]* r1:r0:[0-9A-F] r2:[0-9A-F] + `(write-read-repeat + r0 + ,(vconcat + (mapcar + (lambda (r0) + (logior (lsh r0 4) tmp)) + mel-ccl-16-table))) + ;; '=' [\t ]* r1:r0:[0-9A-F] r2:[^0-9A-F] + ;; invalid input + `(r3 = 0) ; nop + )) + mel-ccl-256-table)) + ;; '=' [\t ]* r1:r0:[0-9A-F] r2:[^0-9A-F] + ;; invalid input -> + ;; output "=" with hex digit and rescan from r2. + (write ?=) + (r0 = (r2 + 0)) + (write-repeat r1))) + (t + ;; r0:[^\t\r -~] + ;; invalid character found. + ;; -> ignore. + `((read r0) + (repeat)))))) + mel-ccl-256-table)) + ;; r1[0]:[\t ] + (loop + ,@(apply + 'append + (mapcar + (lambda (regnum) + (let ((reg (aref [r1 r2 r3 r4 r5] regnum))) + (apply + 'append + (mapcar + (lambda (bit) + (if (= bit 0) + (if (= regnum 0) + nil + `((read r0) + (if (r0 == ?\t) + (,reg = 0) + (if (r0 == ?\ ) + (,reg = 1) + ((r6 = ,(+ (* regnum 28) bit)) + (break)))))) + `((read r0) + (if (r0 == ?\ ) + (,reg |= ,(lsh 1 bit)) + (if (r0 != ?\t) + ((r6 = ,(+ (* regnum 28) bit)) + (break))))))) + mel-ccl-28-table)))) + '(0 1 2 3 4))) + ;; white space buffer exhaust. + ;; error: line length limit (76bytes) violation. + ;; -> ignore these white spaces. + (repeat)) + ,(if input-crlf + `(if (r0 == ?\r) + ((read r0) + (if (r0 == ?\n) + ;; trailing white spaces found. + ;; -> ignore these white spacs. + ((write ,(if output-crlf "\r\n" "\n")) + (read r0) + (repeat)) + ;; [\t ]* \r r0:[^\n] + ;; error: bare CR found. + ;; -> output white spaces and ignore bare CR. + )) + ;; [\t ]* r0:[^\r] + ;; middle white spaces found. + ) + `(if (r0 == ?\n) + ;; trailing white spaces found. + ;; -> ignore these white spacs. + ((write ,(if output-crlf "\r\n" "\n")) + (read r0) + (repeat)) + ;; [\t ]* r0:[^\n] + ;; middle white spaces found. + )) + ,@(apply + 'append + (mapcar + (lambda (regnum) + (let ((reg (aref [r1 r2 r3 r4 r5] regnum))) + (apply + 'append + (mapcar + (lambda (bit) + `((if (,reg & ,(lsh 1 bit)) + (write ?\ ) + (write ?\t)) + (if (r6 == ,(+ (* regnum 28) bit 1)) + (repeat)))) + mel-ccl-28-table)))) + '(0 1 2 3 4))) + (repeat) + )))) + +) + +(define-ccl-program mel-ccl-encode-quoted-printable-crlf-crlf + (mel-ccl-encode-quoted-printable-generic t t)) + +(define-ccl-program mel-ccl-encode-quoted-printable-crlf-lf + (mel-ccl-encode-quoted-printable-generic t nil)) + +(define-ccl-program mel-ccl-encode-quoted-printable-lf-crlf + (mel-ccl-encode-quoted-printable-generic nil t)) + +(define-ccl-program mel-ccl-encode-quoted-printable-lf-lf + (mel-ccl-encode-quoted-printable-generic nil nil)) + +(define-ccl-program mel-ccl-decode-quoted-printable-crlf-crlf + (mel-ccl-decode-quoted-printable-generic t t)) + +(define-ccl-program mel-ccl-decode-quoted-printable-crlf-lf + (mel-ccl-decode-quoted-printable-generic t nil)) + +(define-ccl-program mel-ccl-decode-quoted-printable-lf-crlf + (mel-ccl-decode-quoted-printable-generic nil t)) + +(define-ccl-program mel-ccl-decode-quoted-printable-lf-lf + (mel-ccl-decode-quoted-printable-generic nil nil)) + + +;;; @ coding system +;;; + +(make-ccl-coding-system + 'mel-ccl-uq-rev ?Q "MIME Q-encoding in unstructured field (reversed)" + 'mel-ccl-encode-uq 'mel-ccl-decode-q) + +(make-ccl-coding-system + 'mel-ccl-cq-rev ?Q "MIME Q-encoding in comment (reversed)" + 'mel-ccl-encode-cq 'mel-ccl-decode-q) + +(make-ccl-coding-system + 'mel-ccl-pq-rev ?Q "MIME Q-encoding in phrase (reversed)" + 'mel-ccl-encode-pq 'mel-ccl-decode-q) + +(make-ccl-coding-system + 'mel-ccl-quoted-printable-crlf-crlf-rev + ?Q "MIME Quoted-Printable-encoding (reversed)" + 'mel-ccl-encode-quoted-printable-crlf-crlf + 'mel-ccl-decode-quoted-printable-crlf-crlf) + +(make-ccl-coding-system + 'mel-ccl-quoted-printable-lf-crlf-rev + ?Q "MIME Quoted-Printable-encoding (LF encoding) (reversed)" + 'mel-ccl-encode-quoted-printable-crlf-lf + 'mel-ccl-decode-quoted-printable-lf-crlf) + +(make-ccl-coding-system + 'mel-ccl-quoted-printable-crlf-lf-rev + ?Q "MIME Quoted-Printable-encoding (LF internal) (reversed)" + 'mel-ccl-encode-quoted-printable-lf-crlf + 'mel-ccl-decode-quoted-printable-crlf-lf) + +(make-ccl-coding-system + 'mel-ccl-quoted-printable-lf-lf-rev + ?Q "MIME Quoted-Printable-encoding (LF encoding) (LF internal) (reversed)" + 'mel-ccl-encode-quoted-printable-lf-lf + 'mel-ccl-decode-quoted-printable-lf-lf) + + +;;; @ quoted-printable +;;; + +(check-broken-facility ccl-execute-eof-block-on-decoding-some) + +(unless-broken ccl-execute-eof-block-on-decoding-some + + (defun quoted-printable-ccl-encode-string (string) + "Encode STRING with quoted-printable encoding." + (decode-coding-string + string + 'mel-ccl-quoted-printable-lf-lf-rev)) + + (defun quoted-printable-ccl-encode-region (start end) + "Encode the region from START to END with quoted-printable encoding." + (interactive "*r") + (decode-coding-region start end 'mel-ccl-quoted-printable-lf-lf-rev)) + + (defun quoted-printable-ccl-insert-encoded-file (filename) + "Encode contents of the file named as FILENAME, and insert it." + (interactive "*fInsert encoded file: ") + (let ((coding-system-for-read 'mel-ccl-quoted-printable-lf-lf-rev) + format-alist) + (insert-file-contents filename))) + + (mel-define-method-function + (mime-encode-string string (nil "quoted-printable")) + 'quoted-printable-ccl-encode-string) + (mel-define-method-function + (mime-encode-region start end (nil "quoted-printable")) + 'quoted-printable-ccl-encode-region) + (mel-define-method-function + (mime-insert-encoded-file filename (nil "quoted-printable")) + 'quoted-printable-ccl-insert-encoded-file) + ) + +(defun quoted-printable-ccl-decode-string (string) + "Decode quoted-printable encoded STRING." + (encode-coding-string + string + 'mel-ccl-quoted-printable-lf-lf-rev)) + +(defun quoted-printable-ccl-decode-region (start end) + "Decode the region from START to END with quoted-printable +encoding." + (interactive "*r") + (encode-coding-region start end 'mel-ccl-quoted-printable-lf-lf-rev)) + +(defun quoted-printable-ccl-write-decoded-region (start end filename) + "Decode quoted-printable encoded current region and write out to FILENAME." + (interactive "*r\nFWrite decoded region to file: ") + (let ((coding-system-for-write 'mel-ccl-quoted-printable-lf-lf-rev) + jka-compr-compression-info-list jam-zcat-filename-list) + (write-region start end filename))) + +(mel-define-method-function + (mime-decode-string string (nil "quoted-printable")) + 'quoted-printable-ccl-decode-string) +(mel-define-method-function + (mime-decode-region start end (nil "quoted-printable")) + 'quoted-printable-ccl-decode-region) +(mel-define-method-function + (mime-write-decoded-region start end filename (nil "quoted-printable")) + 'quoted-printable-ccl-write-decoded-region) + + +;;; @ Q +;;; + +(defun q-encoding-ccl-encode-string (string &optional mode) + "Encode STRING to Q-encoding of encoded-word, and return the result. +MODE allows `text', `comment', `phrase' or nil. Default value is +`phrase'." + (decode-coding-string + string + (cond + ((eq mode 'text) 'mel-ccl-uq-rev) + ((eq mode 'comment) 'mel-ccl-cq-rev) + (t 'mel-ccl-pq-rev)))) + +(defun q-encoding-ccl-decode-string (string) + "Decode Q encoded STRING and return the result." + (encode-coding-string + string + 'mel-ccl-uq-rev)) + +(unless (featurep 'xemacs) + (defun q-encoding-ccl-encoded-length (string &optional mode) + (let ((status [nil nil nil nil nil nil nil nil nil])) + (fillarray status nil) ; XXX: Is this necessary? + (ccl-execute-on-string + (cond + ((eq mode 'text) 'mel-ccl-count-uq) + ((eq mode 'comment) 'mel-ccl-count-cq) + (t 'mel-ccl-count-pq)) + status + string) + (aref status 0))) + ) + +(mel-define-method-function (encoded-text-encode-string string (nil "Q")) + 'q-encoding-ccl-encode-string) + +(mel-define-method encoded-text-decode-string (string (nil "Q")) + (if (string-match (eval-when-compile + (concat "\\`" Q-encoded-text-regexp "\\'")) + string) + (q-encoding-ccl-decode-string string) + (error "Invalid encoded-text %s" string))) + + +;;; @ end +;;; + +(provide 'mel-q-ccl) + +;;; mel-q-ccl.el ends here. diff --git a/mime/mel-u.el b/mime/mel-u.el new file mode 100644 index 0000000..ead3efb --- /dev/null +++ b/mime/mel-u.el @@ -0,0 +1,163 @@ +;;; mel-u.el --- uuencode encoder/decoder. + +;; Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Created: 1995/10/25 +;; Keywords: uuencode + +;; 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 this program; 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-def) +(require 'path-util) + + +(mel-define-backend "x-uue") + + +;;; @ variables +;;; + +(defvar uuencode-external-encoder '("uuencode" "-") + "*list of uuencode encoder program name and its arguments.") + +(defvar uuencode-external-decoder '("sh" "-c" "uudecode") + "*list of uuencode decoder program name and its arguments.") + + +;;; @ uuencode encoder/decoder for region +;;; + +(defun uuencode-external-encode-region (start end) + "Encode current region by unofficial uuencode format. +This function uses external uuencode encoder which is specified by +variable `uuencode-external-encoder'." + (interactive "*r") + (save-excursion + (let ((coding-system-for-read 'binary) + (coding-system-for-write 'binary)) + (apply (function call-process-region) + start end (car uuencode-external-encoder) + t t nil + (cdr uuencode-external-encoder))) + ;; for OS/2 + ;; regularize line break code + (goto-char (point-min)) + (while (re-search-forward "\r$" nil t) + (replace-match "")))) + +(defun uuencode-external-decode-region (start end) + "Decode current region by unofficial uuencode format. +This function uses external uuencode decoder which is specified by +variable `uuencode-external-decoder'." + (interactive "*r") + (save-excursion + (let ((filename (save-excursion + (save-restriction + (narrow-to-region start end) + (goto-char start) + (if (re-search-forward "^begin [0-9]+ " nil t) + (if (looking-at ".+$") + (buffer-substring (match-beginning 0) + (match-end 0))))))) + (default-directory temporary-file-directory)) + (if filename + (let ((coding-system-for-read 'binary) + (coding-system-for-write 'binary)) + (apply (function call-process-region) + start end (car uuencode-external-decoder) + t nil nil + (cdr uuencode-external-decoder)) + (insert-file-contents filename) + ;; The previous line causes the buffer to be made read-only, I + ;; do not pretend to understand the control flow leading to this + ;; but suspect it has something to do with image-mode. -slb + ;; Use `inhibit-read-only' to avoid to force + ;; buffer-read-only nil. - tomo. + (let ((inhibit-read-only t)) + (delete-file filename))))))) + +(mel-define-method-function (mime-encode-region start end (nil "x-uue")) + 'uuencode-external-encode-region) +(mel-define-method-function (mime-decode-region start end (nil "x-uue")) + 'uuencode-external-decode-region) + + +;;; @ encoder/decoder for string +;;; + +(mel-define-method mime-encode-string (string (nil "x-uue")) + (with-temp-buffer + (insert string) + (uuencode-external-encode-region (point-min)(point-max)) + (buffer-string))) + +(mel-define-method mime-decode-string (string (nil "x-uue")) + (with-temp-buffer + (insert string) + (uuencode-external-decode-region (point-min)(point-max)) + (buffer-string))) + + +;;; @ uuencode encoder/decoder for file +;;; + +(mel-define-method mime-insert-encoded-file (filename (nil "x-uue")) + "Insert file encoded by unofficial uuencode format. +This function uses external uuencode encoder which is specified by +variable `uuencode-external-encoder'." + (interactive "*fInsert encoded file: ") + (call-process (car uuencode-external-encoder) + filename t nil + (file-name-nondirectory filename))) + +(mel-define-method mime-write-decoded-region (start end filename + (nil "x-uue")) + "Decode and write current region encoded by uuencode into FILENAME. +START and END are buffer positions." + (interactive "*r\nFWrite decoded region to file: ") + (save-excursion + (let ((file (save-excursion + (save-restriction + (narrow-to-region start end) + (goto-char start) + (if (re-search-forward "^begin [0-9]+ " nil t) + (if (looking-at ".+$") + (buffer-substring (match-beginning 0) + (match-end 0))))))) + (default-directory temporary-file-directory)) + (if file + (let ((coding-system-for-read 'binary) + (coding-system-for-write 'binary)) + (apply (function call-process-region) + start end (car uuencode-external-decoder) + nil nil nil + (cdr uuencode-external-decoder)) + (rename-file file filename 'overwrites)))))) + + +;;; @ end +;;; + +(provide 'mel-u) + +(mel-define-backend "x-uuencode" ("x-uue")) + +;;; mel-u.el ends here. diff --git a/mime/mel.el b/mime/mel.el new file mode 100644 index 0000000..6d7de59 --- /dev/null +++ b/mime/mel.el @@ -0,0 +1,334 @@ +;;; mel.el --- A MIME encoding/decoding library. + +;; Copyright (C) 1995,1996,1997,1998,1999,2000 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Created: 1995/6/25 +;; Keywords: MIME, Base64, Quoted-Printable, uuencode, gzip64 + +;; 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 this program; 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-def) +(require 'alist) + +(defcustom mime-encoding-list + '("7bit" "8bit" "binary" "base64" "quoted-printable") + "List of Content-Transfer-Encoding. Each encoding must be string." + :group 'mime + :type '(repeat string)) + +(defun mime-encoding-list (&optional service) + "Return list of Content-Transfer-Encoding. +If SERVICE is specified, it returns available list of +Content-Transfer-Encoding for it." + (if service + (let (dest) + (mapatoms (lambda (sym) + (or (eq sym nil) + (setq dest (cons (symbol-name sym) dest))) + ) + (symbol-value (intern (format "%s-obarray" service)))) + (let ((rest mel-encoding-module-alist) + pair) + (while (setq pair (car rest)) + (let ((key (car pair))) + (or (member key dest) + (<= (length key) 1) + (setq dest (cons key dest)))) + (setq rest (cdr rest))) + ) + dest) + mime-encoding-list)) + +(defun mime-encoding-alist (&optional service) + "Return table of Content-Transfer-Encoding for completion." + (mapcar #'list (mime-encoding-list service))) + +(defsubst mel-use-module (name encodings) + (while encodings + (set-alist 'mel-encoding-module-alist + (car encodings) + (cons name (cdr (assoc (car encodings) + mel-encoding-module-alist)))) + (setq encodings (cdr encodings)))) + +(defsubst mel-find-function (service encoding) + (mel-find-function-from-obarray + (symbol-value (intern (format "%s-obarray" service))) encoding)) + + +;;; @ setting for modules +;;; + +(defun 8bit-insert-encoded-file (filename) + "Insert file FILENAME encoded by \"7bit\" format." + (let ((coding-system-for-read 'raw-text) + format-alist) + ;; Returns list of absolute file name and length of data inserted. + (insert-file-contents filename))) + +(defun 8bit-write-decoded-region (start end filename) + "Decode and write current region encoded by \"8bit\" into FILENAME." + (let ((coding-system-for-write 'raw-text) + format-alist) + (write-region start end filename))) + +(mel-define-backend "8bit") +(mel-define-method-function (mime-encode-string string (nil "8bit")) + 'identity) +(mel-define-method-function (mime-decode-string string (nil "8bit")) + 'identity) +(mel-define-method mime-encode-region (start end (nil "8bit"))) +(mel-define-method mime-decode-region (start end (nil "8bit"))) +(mel-define-method-function (mime-insert-encoded-file filename (nil "8bit")) + '8bit-insert-encoded-file) +(mel-define-method-function (mime-write-decoded-region + start end filename (nil "8bit")) + '8bit-write-decoded-region) + + +(defalias '7bit-insert-encoded-file '8bit-insert-encoded-file) +(defalias '7bit-write-decoded-region '8bit-write-decoded-region) + +(mel-define-backend "7bit" ("8bit")) + + +(defun binary-write-decoded-region (start end filename) + "Decode and write current region encoded by \"binary\" into FILENAME." + (let ((coding-system-for-write 'binary) + jka-compr-compression-info-list jam-zcat-filename-list) + (write-region start end filename))) + +(defalias 'binary-insert-encoded-file 'insert-file-contents-literally) + +(defun binary-find-file-noselect (filename &optional nowarn rawfile) + "Like `find-file-noselect', q.v., but don't code and format conversion." + (let ((coding-system-for-read 'binary) + format-alist) + (find-file-noselect filename nowarn rawfile))) + +(defun binary-funcall (name &rest args) + "Like `funcall', q.v., but read and write as binary." + (let ((coding-system-for-read 'binary) + (coding-system-for-write 'binary)) + (apply name args))) + +(defun binary-to-text-funcall (coding-system name &rest args) + "Like `funcall', q.v., but write as binary and read as text. +Read text is decoded as CODING-SYSTEM." + (let ((coding-system-for-read coding-system) + (coding-system-for-write 'binary)) + (apply name args))) + +(mel-define-backend "binary") +(mel-define-method-function (mime-encode-string string (nil "binary")) + 'identity) +(mel-define-method-function (mime-decode-string string (nil "binary")) + 'identity) +(mel-define-method mime-encode-region (start end (nil "binary"))) +(mel-define-method mime-decode-region (start end (nil "binary"))) +(mel-define-method-function (mime-insert-encoded-file filename (nil "binary")) + 'binary-insert-encoded-file) +(mel-define-method-function (mime-write-decoded-region + start end filename (nil "binary")) + 'binary-write-decoded-region) + +(defvar mel-b-builtin + (and (fboundp 'base64-encode-string) + (subrp (symbol-function 'base64-encode-string)))) + +(when mel-b-builtin + (mel-define-backend "base64") + (mel-define-method-function (mime-encode-string string (nil "base64")) + 'base64-encode-string) + (mel-define-method-function (mime-decode-string string (nil "base64")) + 'base64-decode-string) + (mel-define-method-function (mime-encode-region start end (nil "base64")) + 'base64-encode-region) + (mel-define-method-function (mime-decode-region start end (nil "base64")) + 'base64-decode-region) + (mel-define-method mime-insert-encoded-file (filename (nil "base64")) + "Encode contents of file FILENAME to base64, and insert the result. +It calls external base64 encoder specified by +`base64-external-encoder'. So you must install the program (maybe +mmencode included in metamail or XEmacs package)." + (interactive "*fInsert encoded file: ") + (insert (base64-encode-string + (with-temp-buffer + (set-buffer-multibyte nil) + (binary-insert-encoded-file filename) + (buffer-string)))) + (or (bolp) (insert ?\n))) + + ;; (mel-define-method-function (encoded-text-encode-string string (nil "B")) + ;; 'base64-encode-string) + (mel-define-method encoded-text-decode-string (string (nil "B")) + (if (string-match (eval-when-compile + (concat "\\`" B-encoded-text-regexp "\\'")) + string) + (base64-decode-string string) + (error "Invalid encoded-text %s" string))) + ) + +(mel-use-module 'mel-b-el '("base64" "B")) +(mel-use-module 'mel-q '("quoted-printable" "Q")) +(mel-use-module 'mel-g '("x-gzip64")) +(mel-use-module 'mel-u '("x-uue" "x-uuencode")) + +(defvar mel-b-ccl-module + (and (featurep 'mule) + (progn + (require 'path-util) + (module-installed-p 'mel-b-ccl)))) + +(defvar mel-q-ccl-module + (and (featurep 'mule) + (progn + (require 'path-util) + (module-installed-p 'mel-q-ccl)))) + +(when mel-b-ccl-module + (mel-use-module 'mel-b-ccl '("base64" "B"))) + +(when mel-q-ccl-module + (mel-use-module 'mel-q-ccl '("quoted-printable" "Q"))) + +(when base64-dl-module + (mel-use-module 'mel-b-dl '("base64" "B"))) + + +;;; @ region +;;; + +;;;###autoload +(defun mime-encode-region (start end encoding) + "Encode region START to END of current buffer using ENCODING. +ENCODING must be string." + (interactive + (list (region-beginning)(region-end) + (completing-read "Encoding: " + (mime-encoding-alist) + nil t "base64"))) + (funcall (mel-find-function 'mime-encode-region encoding) start end)) + + +;;;###autoload +(defun mime-decode-region (start end encoding) + "Decode region START to END of current buffer using ENCODING. +ENCODING must be string." + (interactive + (list (region-beginning)(region-end) + (completing-read "Encoding: " + (mime-encoding-alist 'mime-decode-region) + nil t "base64"))) + (funcall (mel-find-function 'mime-decode-region encoding) + start end)) + + +;;; @ string +;;; + +;;;###autoload +(defun mime-decode-string (string encoding) + "Decode STRING using ENCODING. +ENCODING must be string. If ENCODING is found in +`mime-string-decoding-method-alist' as its key, this function decodes +the STRING by its value." + (let ((f (mel-find-function 'mime-decode-string encoding))) + (if f + (funcall f string) + string))) + + +(mel-define-service encoded-text-encode-string) +(defun encoded-text-encode-string (string encoding &optional mode) + "Encode STRING as encoded-text using ENCODING. +ENCODING must be string. +Optional argument MODE allows `text', `comment', `phrase' or nil. +Default value is `phrase'." + (if (string= encoding "B") + (base64-encode-string string 'no-line-break) + (let ((f (mel-find-function 'encoded-text-encode-string encoding))) + (if f + (funcall f string mode) + string)))) + +(mel-define-service encoded-text-decode-string (string encoding) + "Decode STRING as encoded-text using ENCODING. ENCODING must be string.") + +(defun base64-encoded-length (string) + (* (/ (+ (length string) 2) 3) 4)) + +(defsubst Q-encoding-printable-char-p (chr mode) + (and (not (memq chr '(?= ?? ?_))) + (<= ?\ chr)(<= chr ?~) + (cond ((eq mode 'text) t) + ((eq mode 'comment) + (not (memq chr '(?\( ?\) ?\\)))) + (t + (string-match "[A-Za-z0-9!*+/=_---]" (char-to-string chr)))))) + +(defun Q-encoded-text-length (string &optional mode) + (let ((l 0)(i 0)(len (length string)) chr) + (while (< i len) + (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))) + l)) + + +;;; @ file +;;; + +;;;###autoload +(defun mime-insert-encoded-file (filename encoding) + "Insert file FILENAME encoded by ENCODING format." + (interactive + (list (read-file-name "Insert encoded file: ") + (completing-read "Encoding: " + (mime-encoding-alist) + nil t "base64"))) + (funcall (mel-find-function 'mime-insert-encoded-file encoding) + filename)) + + +;;;###autoload +(defun mime-write-decoded-region (start end filename encoding) + "Decode and write current region encoded by ENCODING into FILENAME. +START and END are buffer positions." + (interactive + (list (region-beginning)(region-end) + (read-file-name "Write decoded region to file: ") + (completing-read "Encoding: " + (mime-encoding-alist 'mime-write-decoded-region) + nil t "base64"))) + (funcall (mel-find-function 'mime-write-decoded-region encoding) + start end filename)) + + +;;; @ end +;;; + +(provide 'mel) + +;;; mel.el ends here. diff --git a/mime/mime-bbdb.el b/mime/mime-bbdb.el new file mode 100644 index 0000000..1b61d64 --- /dev/null +++ b/mime/mime-bbdb.el @@ -0,0 +1,303 @@ +;;; mime-bbdb.el --- SEMI shared module for BBDB + +;; Copyright (C) 1995,1996,1997 Shuhei KOBAYASHI +;; Copyright (C) 1997,1998 MORIOKA Tomohiko + +;; Author: Shuhei KOBAYASHI +;; Maintainer: Shuhei KOBAYASHI +;; Keywords: BBDB, MIME, multimedia, multilingual, mail, news + +;; This file is part of SEMI (Suite of Emacs MIME Interfaces). + +;; 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 'path-util) +(require 'std11) +(require 'mime-view) + +(if (module-installed-p 'bbdb-com) + (require 'bbdb-com) + (eval-when-compile + ;; imported from bbdb-1.51 + (defmacro bbdb-pop-up-elided-display () + '(if (boundp 'bbdb-pop-up-elided-display) + bbdb-pop-up-elided-display + bbdb-elided-display)) + (defmacro bbdb-user-mail-names () + "Returns a regexp matching the address of the logged-in user" + '(or bbdb-user-mail-names + (setq bbdb-user-mail-names + (concat "\\b" (regexp-quote (user-login-name)) "\\b")))) + )) + + +;;; @ User Variables +;;; + +(defvar mime-bbdb/use-mail-extr t + "*If non-nil, `mail-extract-address-components' is used. +Otherwise `mime-bbdb/extract-address-components' overrides it.") + +(defvar mime-bbdb/auto-create-p nil + "*If t, create new BBDB records automatically. +If function, then it is called with no arguments to decide whether an +entry should be automatically creaded. + +mime-bbdb uses this variable instead of `bbdb/mail-auto-create-p' or +`bbdb/news-auto-create-p' unless other tm-MUA overrides it.") + +(defvar mime-bbdb/delete-empty-window nil + "*If non-nil, delete empty BBDB window. +All bbdb-MUAs but bbdb-gnus display BBDB window even if it is empty. +If you prefer behavior of bbdb-gnus, set this variable to t. + +For framepop users: If empty, `framepop-banish' is used instead.") + +;;; @ mail-extr +;;; + +(defun mime-bbdb/extract-address-components (str) + (let* ((ret (std11-extract-address-components str)) + (phrase (car ret)) + (address (car (cdr ret))) + (methods mime-bbdb/canonicalize-full-name-methods)) + (while (and phrase methods) + (setq phrase (funcall (car methods) phrase) + methods (cdr methods))) + (if (string= address "") (setq address nil)) + (if (string= phrase "") (setq phrase nil)) + (list phrase address) + )) + +(or mime-bbdb/use-mail-extr + (progn + (require 'mail-extr) ; for `what-domain' + (or (fboundp 'tm:mail-extract-address-components) + (fset 'tm:mail-extract-address-components + (symbol-function 'mail-extract-address-components))) + (fset 'mail-extract-address-components + (symbol-function 'mime-bbdb/extract-address-components)) + )) + + +;;; @ bbdb-extract-field-value +;;; + +(or (fboundp 'tm:bbdb-extract-field-value) + (progn + ;; (require 'bbdb-hooks) ; not provided. + ;; (or (fboundp 'bbdb-extract-field-value) ; defined as autoload + (or (fboundp 'bbdb-header-start) + (load "bbdb-hooks")) + (fset 'tm:bbdb-extract-field-value + (symbol-function 'bbdb-extract-field-value)) + (defun bbdb-extract-field-value (field) + (let ((value (tm:bbdb-extract-field-value field))) + (and value + (eword-decode-string value)))) + )) + + +;;; @ full-name canonicalization methods +;;; + +(defun mime-bbdb/canonicalize-spaces (str) + (let (dest) + (while (string-match "\\s +" str) + (setq dest (cons (substring str 0 (match-beginning 0)) dest)) + (setq str (substring str (match-end 0))) + ) + (or (string= str "") + (setq dest (cons str dest))) + (setq dest (nreverse dest)) + (mapconcat 'identity dest " ") + )) + +(defun mime-bbdb/canonicalize-dots (str) + (let (dest) + (while (string-match "\\." str) + (setq dest (cons (substring str 0 (match-end 0)) dest)) + (setq str (substring str (match-end 0))) + ) + (or (string= str "") + (setq dest (cons str dest))) + (setq dest (nreverse dest)) + (mapconcat 'identity dest " ") + )) + +(defvar mime-bbdb/canonicalize-full-name-methods + '(eword-decode-string + mime-bbdb/canonicalize-dots + mime-bbdb/canonicalize-spaces)) + + +;;; @ BBDB functions for mime-view-mode +;;; + +(defun mime-bbdb/update-record (&optional offer-to-create) + "Return the record corresponding to the current MIME previewing message. +Creating or modifying it as necessary. A record will be created if +mime-bbdb/auto-create-p is non-nil, or if OFFER-TO-CREATE is non-nil and +the user confirms the creation." + (save-excursion + (if (and mime-preview-buffer + (get-buffer mime-preview-buffer)) + (set-buffer mime-preview-buffer)) + (if bbdb-use-pop-up + (mime-bbdb/pop-up-bbdb-buffer offer-to-create) + (let* ((message (get-text-property (point-min) 'mime-view-entity)) + (from (mime-entity-fetch-field message 'From)) + addr) + (if (or (null from) + (null (setq addr (car (mime-entity-read-field message 'From)))) + (string-match (bbdb-user-mail-names) + (std11-address-string addr))) + (setq from (or (mime-entity-fetch-field message 'To) + from)) + ) + (if from + (bbdb-annotate-message-sender + (mime-decode-field-body from 'From) t + (or (bbdb-invoke-hook-for-value mime-bbdb/auto-create-p) + offer-to-create) + offer-to-create)) + )))) + +(defun mime-bbdb/annotate-sender (string) + "Add a line to the end of the Notes field of the BBDB record +corresponding to the sender of this message." + (interactive + (list (if bbdb-readonly-p + (error "The Insidious Big Brother Database is read-only.") + (read-string "Comments: ")))) + (bbdb-annotate-notes (mime-bbdb/update-record t) string)) + +(defun mime-bbdb/edit-notes (&optional arg) + "Edit the notes field or (with a prefix arg) a user-defined field +of the BBDB record corresponding to the sender of this message." + (interactive "P") + (let ((record (or (mime-bbdb/update-record t) + (error "")))) + (bbdb-display-records (list record)) + (if arg + (bbdb-record-edit-property record nil t) + (bbdb-record-edit-notes record t)))) + +(defun mime-bbdb/show-sender () + "Display the contents of the BBDB for the sender of this message. +This buffer will be in bbdb-mode, with associated keybindings." + (interactive) + (let ((record (mime-bbdb/update-record t))) + (if record + (bbdb-display-records (list record)) + (error "unperson")))) + +(defun mime-bbdb/pop-up-bbdb-buffer (&optional offer-to-create) + "Make the *BBDB* buffer be displayed along with the MIME preview window(s), +displaying the record corresponding to the sender of the current message." + (let ((framepop (eq temp-buffer-show-function 'framepop-display-buffer))) + (or framepop + (bbdb-pop-up-bbdb-buffer + (function + (lambda (w) + (let ((b (current-buffer))) + (set-buffer (window-buffer w)) + (prog1 (eq major-mode 'mime-view-mode) + (set-buffer b))))))) + (let ((bbdb-gag-messages t) + (bbdb-use-pop-up nil) + (bbdb-electric-p nil)) + (let ((record (mime-bbdb/update-record offer-to-create)) + (bbdb-elided-display (bbdb-pop-up-elided-display)) + (b (current-buffer))) + (if framepop + (if record + (bbdb-display-records (list record)) + (framepop-banish)) + (bbdb-display-records (if record (list record) nil)) + (if (and (null record) + mime-bbdb/delete-empty-window) + (delete-windows-on (get-buffer "*BBDB*")))) + (set-buffer b) + record)))) + +(defun mime-bbdb/define-keys () + (let ((mime-view-mode-map (current-local-map))) + (define-key mime-view-mode-map ";" 'mime-bbdb/edit-notes) + (define-key mime-view-mode-map ":" 'mime-bbdb/show-sender) + )) + +(add-hook 'mime-view-define-keymap-hook 'mime-bbdb/define-keys) + + +;;; @ for signature.el +;;; + +(defun signature/get-bbdb-sigtype (addr) + "Extract sigtype information from BBDB." + (let ((record (bbdb-search-simple nil addr))) + (and record + (bbdb-record-getprop record 'sigtype)) + )) + +(defun signature/set-bbdb-sigtype (sigtype addr) + "Add sigtype information to BBDB." + (let* ((bbdb-notice-hook nil) + (record (bbdb-annotate-message-sender + addr t + (bbdb-invoke-hook-for-value + bbdb/mail-auto-create-p) + t))) + (if record + (progn + (bbdb-record-putprop record 'sigtype sigtype) + (bbdb-change-record record nil)) + ))) + +(defun signature/get-sigtype-from-bbdb (&optional verbose) + (let* ((to (std11-field-body "To")) + (addr (and to + (car (cdr (mail-extract-address-components to))))) + (sigtype (signature/get-bbdb-sigtype addr)) + return + ) + (if addr + (if verbose + (progn + (setq return (signature/get-sigtype-interactively sigtype)) + (if (and (not (string-equal return sigtype)) + (y-or-n-p + (format "Register \"%s\" for <%s>? " return addr)) + ) + (signature/set-bbdb-sigtype return addr) + ) + return) + (or sigtype + (signature/get-signature-file-name)) + )) + )) + + +;;; @ end +;;; + +(provide 'mime-bbdb) + +(run-hooks 'mime-bbdb-load-hook) + +;;; end of mime-bbdb.el diff --git a/mime/mime-conf.el b/mime/mime-conf.el new file mode 100644 index 0000000..84fed40 --- /dev/null +++ b/mime/mime-conf.el @@ -0,0 +1,277 @@ +;;; mime-conf.el --- mailcap parser and MIME playback configuration + +;; Copyright (C) 1997,1998,1999,2000 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Created: 1997-06-27 +;; Original: 1997-06-27 mailcap.el by MORIOKA Tomohiko +;; Renamed: 2000-11-24 to mime-conf.el by MORIOKA Tomohiko +;; Keywords: mailcap, setting, configuration, MIME, multimedia + +;; 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-def) + + +;;; @ comment +;;; + +(defsubst mime-mailcap-skip-comment () + (let ((chr (char-after (point)))) + (when (and chr + (or (= chr ?\n) + (= chr ?#))) + (forward-line) + t))) + + +;;; @ token +;;; + +(defsubst mime-mailcap-look-at-token () + (if (looking-at mime-token-regexp) + (let ((beg (match-beginning 0)) + (end (match-end 0))) + (goto-char end) + (buffer-substring beg end) + ))) + + +;;; @ typefield +;;; + +(defsubst mime-mailcap-look-at-type-field () + (let ((type (mime-mailcap-look-at-token))) + (if type + (if (eq (char-after (point)) ?/) + (progn + (forward-char) + (let ((subtype (mime-mailcap-look-at-token))) + (if subtype + (cons (cons 'type (intern type)) + (unless (string= subtype "*") + (list (cons 'subtype (intern subtype))) + ))))) + (list (cons 'type (intern type))) + )))) + + +;;; @ field separator +;;; + +(defsubst mime-mailcap-skip-field-separator () + (let ((ret (looking-at "\\([ \t]\\|\\\\\n\\)*;\\([ \t]\\|\\\\\n\\)*"))) + (when ret + (goto-char (match-end 0)) + t))) + + +;;; @ mtext +;;; + +(defsubst mime-mailcap-look-at-schar () + (let ((chr (char-after (point)))) + (if (and chr + (>= chr ? ) + (/= chr ?\;) + (/= chr ?\\) + ) + (prog1 + chr + (forward-char))))) + +(defsubst mime-mailcap-look-at-qchar () + (when (eq (char-after (point)) ?\\) + (prog2 + (forward-char) + (char-after (point)) + (forward-char)))) + +(defsubst mime-mailcap-look-at-mtext () + (let ((beg (point))) + (while (or (mime-mailcap-look-at-qchar) + (mime-mailcap-look-at-schar))) + (buffer-substring beg (point)) + )) + + +;;; @ field +;;; + +(defsubst mime-mailcap-look-at-field () + (let ((token (mime-mailcap-look-at-token))) + (if token + (if (looking-at "[ \t]*=[ \t]*") + (let ((value (progn + (goto-char (match-end 0)) + (mime-mailcap-look-at-mtext)))) + (if value + (cons (intern token) value) + )) + (list (intern token)) + )))) + + +;;; @ mailcap entry +;;; + +(defun mime-mailcap-look-at-entry () + (let ((type (mime-mailcap-look-at-type-field))) + (if (and type (mime-mailcap-skip-field-separator)) + (let ((view (mime-mailcap-look-at-mtext)) + fields field) + (when view + (while (and (mime-mailcap-skip-field-separator) + (setq field (mime-mailcap-look-at-field)) + ) + (setq fields (cons field fields)) + ) + (nconc type + (list (cons 'view view)) + fields)))))) + + +;;; @ main +;;; + +;;;###autoload +(defun mime-parse-mailcap-buffer (&optional buffer order) + "Parse BUFFER as a mailcap, and return the result. +If optional argument ORDER is a function, result is sorted by it. +If optional argument ORDER is not specified, result is sorted original +order. Otherwise result is not sorted." + (save-excursion + (if buffer + (set-buffer buffer)) + (goto-char (point-min)) + (let (entries entry) + (while (progn + (while (mime-mailcap-skip-comment)) + (setq entry (mime-mailcap-look-at-entry)) + ) + (setq entries (cons entry entries)) + (forward-line) + ) + (cond ((functionp order) (sort entries order)) + ((null order) (nreverse entries)) + (t entries) + )))) + + +;;;###autoload +(defcustom mime-mailcap-file "~/.mailcap" + "*File name of user's mailcap file." + :group 'mime + :type 'file) + +;;;###autoload +(defun mime-parse-mailcap-file (&optional filename order) + "Parse FILENAME as a mailcap, and return the result. +If optional argument ORDER is a function, result is sorted by it. +If optional argument ORDER is not specified, result is sorted original +order. Otherwise result is not sorted." + (or filename + (setq filename mime-mailcap-file)) + (with-temp-buffer + (insert-file-contents filename) + (mime-parse-mailcap-buffer (current-buffer) order) + )) + + +;;;###autoload +(defun mime-format-mailcap-command (mtext situation) + "Return formated command string from MTEXT and SITUATION. + +MTEXT is a command text of mailcap specification, such as +view-command. + +SITUATION is an association-list about information of entity. Its key +may be: + + 'type primary media-type + 'subtype media-subtype + 'filename filename + STRING parameter of Content-Type field" + (let ((i 0) + (len (length mtext)) + (p 0) + dest) + (while (< i len) + (let ((chr (aref mtext i))) + (cond ((eq chr ?%) + (setq i (1+ i) + chr (aref mtext i)) + (cond ((eq chr ?s) + (let ((file (cdr (assq 'filename situation)))) + (if (null file) + (error "'filename is not specified in situation.") + (setq dest (concat dest + (substring mtext p (1- i)) + file) + i (1+ i) + p i) + ))) + ((eq chr ?t) + (let ((type (or (mime-type/subtype-string + (cdr (assq 'type situation)) + (cdr (assq 'subtype situation))) + "text/plain"))) + (setq dest (concat dest + (substring mtext p (1- i)) + type) + i (1+ i) + p i) + )) + ((eq chr ?\{) + (setq i (1+ i)) + (if (not (string-match "}" mtext i)) + (error "parse error!!!") + (let* ((me (match-end 0)) + (attribute (substring mtext i (1- me))) + (parameter (cdr (assoc attribute situation)))) + (if (null parameter) + (error "\"%s\" is not specified in situation." + attribute) + (setq dest (concat dest + (substring mtext p (- i 2)) + parameter) + i me + p i) + ) + ))) + (t (error "Invalid sequence `%%%c'." chr)) + )) + ((eq chr ?\\) + (setq dest (concat dest (substring mtext p i)) + p (1+ i) + i (+ i 2)) + ) + (t (setq i (1+ i))) + ))) + (concat dest (substring mtext p)) + )) + + +;;; @ end +;;; + +(provide 'mime-conf) + +;;; mime-conf.el ends here diff --git a/mime/mime-def.el b/mime/mime-def.el new file mode 100644 index 0000000..5ff449e --- /dev/null +++ b/mime/mime-def.el @@ -0,0 +1,402 @@ +;;; mime-def.el --- definition module about MIME -*- coding: iso-8859-4; -*- + +;; Copyright (C) 1995,96,97,98,99,2000 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Keywords: definition, 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 'custom) +(require 'mcharset) +(require 'alist) + +(eval-when-compile + (require 'cl) ; list* + (require 'luna) ; luna-arglist-to-arguments + ) + +(eval-and-compile + (defconst mime-library-product ["FLIM" (1 14 2) "Yagi-Nishiguchi"] + "Product name, version number and code name of MIME-library package.")) + +(defmacro mime-product-name (product) + `(aref ,product 0)) + +(defmacro mime-product-version (product) + `(aref ,product 1)) + +(defmacro mime-product-code-name (product) + `(aref ,product 2)) + +(defconst mime-library-version + (eval-when-compile + (concat (mime-product-name mime-library-product) " " + (mapconcat #'number-to-string + (mime-product-version mime-library-product) ".") + " - \"" (mime-product-code-name mime-library-product) "\""))) + + +;;; @ variables +;;; + +(defgroup mime '((default-mime-charset custom-variable)) + "Emacs MIME Interfaces" + :group 'news + :group 'mail) + +(defcustom mime-uuencode-encoding-name-list '("x-uue" "x-uuencode") + "*List of encoding names for uuencode format." + :group 'mime + :type '(repeat string)) + + +;;; @@ for encoded-word +;;; + +(defgroup mime-header nil + "Header representation, specially encoded-word" + :group 'mime) + +;;; @@@ decoding +;;; + +(defcustom mime-field-decoding-max-size 1000 + "*Max size to decode header field." + :group 'mime-header + :type '(choice (integer :tag "Limit (bytes)") + (const :tag "Don't limit" nil))) + +;;; @@@ encoding +;;; + +(defcustom mime-field-encoding-method-alist + '(("X-Nsubject" . iso-2022-jp-2) + ("Newsgroups" . nil) + ("Message-ID" . nil) + (t . mime) + ) + "*Alist to specify field encoding method. +Its key is field-name, value is encoding method. + +If method is `mime', this field will be encoded into MIME format. + +If method is a MIME-charset, this field will be encoded as the charset +when it must be convert into network-code. + +If method is `default-mime-charset', this field will be encoded as +variable `default-mime-charset' when it must be convert into +network-code. + +If method is nil, this field will not be encoded." + :group 'mime-header + :type '(repeat (cons (choice :tag "Field" + (string :tag "Name") + (const :tag "Default" t)) + (choice :tag "Method" + (const :tag "MIME conversion" mime) + (symbol :tag "non-MIME conversion") + (const :tag "no-conversion" nil))))) + + +;;; @ required functions +;;; + +(defsubst regexp-* (regexp) + (concat regexp "*")) + +(defsubst regexp-or (&rest args) + (concat "\\(" (mapconcat (function identity) args "\\|") "\\)")) + +(or (fboundp 'char-int) + (defalias 'char-int 'identity)) + + +;;; @ about STD 11 +;;; + +(eval-and-compile + (defconst std11-quoted-pair-regexp "\\\\.") + (defconst std11-non-qtext-char-list '(?\" ?\\ ?\r ?\n)) + (defconst std11-qtext-regexp + (eval-when-compile + (concat "[^" std11-non-qtext-char-list "]")))) +(defconst std11-quoted-string-regexp + (eval-when-compile + (concat "\"" + (regexp-* + (regexp-or std11-qtext-regexp std11-quoted-pair-regexp)) + "\""))) + + +;;; @ about MIME +;;; + +(eval-and-compile + (defconst mime-tspecial-char-list + '(?\] ?\[ ?\( ?\) ?< ?> ?@ ?, ?\; ?: ?\\ ?\" ?/ ?? ?=))) +(defconst mime-token-regexp + (eval-when-compile + (concat "[^" mime-tspecial-char-list "\000-\040]+"))) +(defconst mime-charset-regexp mime-token-regexp) + +(defconst mime-media-type/subtype-regexp + (concat mime-token-regexp "/" mime-token-regexp)) + + +;;; @@ base64 / B +;;; + +(defconst base64-token-regexp "[A-Za-z0-9+/]") +(defconst base64-token-padding-regexp "[A-Za-z0-9+/=]") + +(defconst B-encoded-text-regexp + (concat "\\(\\(" + base64-token-regexp + base64-token-regexp + base64-token-regexp + base64-token-regexp + "\\)*" + base64-token-regexp + base64-token-regexp + base64-token-padding-regexp + base64-token-padding-regexp + "\\)")) + +;; (defconst eword-B-encoding-and-encoded-text-regexp +;; (concat "\\(B\\)\\?" eword-B-encoded-text-regexp)) + + +;;; @@ Quoted-Printable / Q +;;; + +(defconst quoted-printable-hex-chars "0123456789ABCDEF") + +(defconst quoted-printable-octet-regexp + (concat "=[" quoted-printable-hex-chars + "][" quoted-printable-hex-chars "]")) + +(defconst Q-encoded-text-regexp + (concat "\\([^=?]\\|" quoted-printable-octet-regexp "\\)+")) + +;; (defconst eword-Q-encoding-and-encoded-text-regexp +;; (concat "\\(Q\\)\\?" eword-Q-encoded-text-regexp)) + + +;;; @ Content-Type +;;; + +(defsubst make-mime-content-type (type subtype &optional parameters) + (list* (cons 'type type) + (cons 'subtype subtype) + (nreverse parameters)) + ) + +(defsubst mime-content-type-primary-type (content-type) + "Return primary-type of CONTENT-TYPE." + (cdr (car content-type))) + +(defsubst mime-content-type-subtype (content-type) + "Return subtype of CONTENT-TYPE." + (cdr (cadr content-type))) + +(defsubst mime-content-type-parameters (content-type) + "Return parameters of CONTENT-TYPE." + (cddr content-type)) + +(defsubst mime-content-type-parameter (content-type parameter) + "Return PARAMETER value of CONTENT-TYPE." + (cdr (assoc parameter (mime-content-type-parameters content-type)))) + + +(defsubst mime-type/subtype-string (type &optional subtype) + "Return type/subtype string from TYPE and SUBTYPE." + (if type + (if subtype + (format "%s/%s" type subtype) + (format "%s" type)))) + + +;;; @ Content-Disposition +;;; + +(defsubst mime-content-disposition-type (content-disposition) + "Return disposition-type of CONTENT-DISPOSITION." + (cdr (car content-disposition))) + +(defsubst mime-content-disposition-parameters (content-disposition) + "Return disposition-parameters of CONTENT-DISPOSITION." + (cdr content-disposition)) + +(defsubst mime-content-disposition-parameter (content-disposition parameter) + "Return PARAMETER value of CONTENT-DISPOSITION." + (cdr (assoc parameter (cdr content-disposition)))) + +(defsubst mime-content-disposition-filename (content-disposition) + "Return filename of CONTENT-DISPOSITION." + (mime-content-disposition-parameter content-disposition "filename")) + + +;;; @ message structure +;;; + +(defvar mime-message-structure nil + "Information about structure of message. +Please use reference function `mime-entity-SLOT' to get value of SLOT. + +Following is a list of slots of the structure: + +node-id node-id (list of integers) +content-type content-type (content-type) +content-disposition content-disposition (content-disposition) +encoding Content-Transfer-Encoding (string or nil) +children entities included in this entity (list of entity) + +If an entity includes other entities in its body, such as multipart or +message/rfc822, `mime-entity' structures of them are included in +`children', so the `mime-entity' structure become a tree.") + +(make-variable-buffer-local 'mime-message-structure) + +(make-obsolete-variable 'mime-message-structure "should not use it.") + + +;;; @ for mel-backend +;;; + +(defvar mel-service-list nil) + +(defmacro mel-define-service (name &optional args &rest rest) + "Define NAME as a service for Content-Transfer-Encodings. +If ARGS is specified, NAME is defined as a generic function for the +service." + `(progn + (add-to-list 'mel-service-list ',name) + (defvar ,(intern (format "%s-obarray" name)) (make-vector 7 0)) + ,@(if args + `((defun ,name ,args + ,@rest + (funcall (mel-find-function ',name ,(car (last args))) + ,@(luna-arglist-to-arguments (butlast args))) + ))) + )) + +(put 'mel-define-service 'lisp-indent-function 'defun) + + +(defvar mel-encoding-module-alist nil) + +(defsubst mel-find-function-from-obarray (ob-array encoding) + (let* ((f (intern-soft encoding ob-array))) + (or f + (let ((rest (cdr (assoc encoding mel-encoding-module-alist)))) + (while (and rest + (progn + (require (car rest)) + (null (setq f (intern-soft encoding ob-array))) + )) + (setq rest (cdr rest)) + ) + f)))) + +(defsubst mel-copy-method (service src-backend dst-backend) + (let* ((oa (symbol-value (intern (format "%s-obarray" service)))) + (f (mel-find-function-from-obarray oa src-backend)) + sym) + (when f + (setq sym (intern dst-backend oa)) + (or (fboundp sym) + (fset sym (symbol-function f)) + )))) + +(defsubst mel-copy-backend (src-backend dst-backend) + (let ((services mel-service-list)) + (while services + (mel-copy-method (car services) src-backend dst-backend) + (setq services (cdr services))))) + +(defmacro mel-define-backend (type &optional parents) + "Define TYPE as a mel-backend. +If PARENTS is specified, TYPE inherits PARENTS. +Each parent must be backend name (string)." + (cons 'progn + (mapcar (lambda (parent) + `(mel-copy-backend ,parent ,type) + ) + parents))) + +(defmacro mel-define-method (name args &rest body) + "Define NAME as a method function of (nth 1 (car (last ARGS))) backend. +ARGS is like an argument list of lambda, but (car (last ARGS)) must be +specialized parameter. (car (car (last ARGS))) is name of variable +and (nth 1 (car (last ARGS))) is name of backend (encoding)." + (let* ((specializer (car (last args))) + (class (nth 1 specializer))) + `(progn + (mel-define-service ,name) + (fset (intern ,class ,(intern (format "%s-obarray" name))) + (lambda ,(butlast args) + ,@body))))) + +(put 'mel-define-method 'lisp-indent-function 'defun) + +(defmacro mel-define-method-function (spec function) + "Set SPEC's function definition to FUNCTION. +First element of SPEC is service. +Rest of ARGS is like an argument list of lambda, but (car (last ARGS)) +must be specialized parameter. (car (car (last ARGS))) is name of +variable and (nth 1 (car (last ARGS))) is name of backend (encoding)." + (let* ((name (car spec)) + (args (cdr spec)) + (specializer (car (last args))) + (class (nth 1 specializer))) + `(let (sym) + (mel-define-service ,name) + (setq sym (intern ,class ,(intern (format "%s-obarray" name)))) + (or (fboundp sym) + (fset sym (symbol-function ,function)))))) + +(defmacro mel-define-function (function spec) + (let* ((name (car spec)) + (args (cdr spec)) + (specializer (car (last args))) + (class (nth 1 specializer))) + `(progn + (define-function ,function + (intern ,class ,(intern (format "%s-obarray" name)))) + ))) + +(defvar base64-dl-module + (if (and (fboundp 'base64-encode-string) + (subrp (symbol-function 'base64-encode-string))) + nil + (if (fboundp 'dynamic-link) + (let ((path (expand-file-name "base64.so" exec-directory))) + (and (file-exists-p path) + path) + )))) + + +;;; @ end +;;; + +(provide 'mime-def) + +;;; mime-def.el ends here diff --git a/mime/mime-edit.el b/mime/mime-edit.el new file mode 100644 index 0000000..37963cb --- /dev/null +++ b/mime/mime-edit.el @@ -0,0 +1,3040 @@ +;;; mime-edit.el --- Simple MIME Composer for GNU Emacs + +;; Copyright (C) 1993,94,95,96,97,98,99,2000 Free Software Foundation, Inc. + +;; Author: UMEDA Masanobu +;; MORIOKA Tomohiko +;; Daiki Ueno +;; Created: 1994/08/21 renamed from mime.el +;; Renamed: 1997/2/21 from tm-edit.el +;; Keywords: MIME, multimedia, multilingual, mail, news + +;; This file is part of SEMI (Sophisticated Emacs MIME Interfaces). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This is an Emacs minor mode for editing Internet multimedia +;; messages formatted in MIME (RFC 2045, 2046, 2047, 2048 and 2049). +;; All messages in this mode are composed in the tagged MIME format, +;; that are described in the following examples. The messages +;; composed in the tagged MIME format are automatically translated +;; into a MIME compliant message when exiting the mode. + +;; Mule (multilingual feature of Emacs 20 and multilingual extension +;; for XEmacs 20) has a capability of handling multilingual text in +;; limited ISO-2022 manner that is based on early experiences in +;; Japanese Internet community and resulted in RFC 1468 (ISO-2022-JP +;; charset for MIME). In order to enable multilingual capability in +;; single text message in MIME, charset of multilingual text written +;; in Mule is declared as either `ISO-2022-JP-2' [RFC 1554]. Mule is +;; required for reading the such messages. + +;; This MIME composer can work with Mail mode, mh-e letter Mode, and +;; News mode. First of all, you need the following autoload +;; definition to load mime-edit-mode automatically: +;; +;; (autoload 'turn-on-mime-edit "mime-edit" +;; "Minor mode for editing MIME message." t) +;; +;; In case of Mail mode (includes VM mode), you need the following +;; hook definition: +;; +;; (add-hook 'mail-mode-hook 'turn-on-mime-edit) +;; (add-hook 'mail-send-hook 'mime-edit-maybe-translate) +;; +;; In case of MH-E, you need the following hook definition: +;; +;; (add-hook 'mh-letter-mode-hook +;; (function +;; (lambda () +;; (turn-on-mime-edit) +;; (make-local-variable 'mail-header-separator) +;; (setq mail-header-separator "--------") +;; )))) +;; (add-hook 'mh-before-send-letter-hook 'mime-edit-maybe-translate) +;; +;; In case of News mode, you need the following hook definition: +;; +;; (add-hook 'news-reply-mode-hook 'turn-on-mime-edit) +;; (add-hook 'news-inews-hook 'mime-edit-maybe-translate) +;; +;; In case of Emacs 19, it is possible to emphasize the message tags +;; using font-lock mode as follows: +;; +;; (add-hook 'mime-edit-mode-hook +;; (function +;; (lambda () +;; (font-lock-mode 1) +;; (setq font-lock-keywords (list mime-edit-tag-regexp)) +;; )))) + +;; The message tag looks like: +;; +;; --[[TYPE/SUBTYPE;PARAMETERS][ENCODING]] +;; +;; The tagged MIME message examples: +;; +;; This is a conventional plain text. It should be translated into +;; text/plain. +;; +;;--[[text/plain]] +;; This is also a plain text. But, it is explicitly specified as is. +;;--[[text/plain; charset=ISO-8859-1]] +;; This is also a plain text. But charset is specified as iso-8859-1. +;; +;; ¡Hola! Buenos días. ¿Cómo está usted? +;;--[[text/enriched]] +;;
This is a richtext.
+;; +;;--[[image/gif][base64]]^M...image encoded in base64 comes here... +;; +;;--[[audio/basic][base64]]^M...audio encoded in base64 comes here... + +;;; Code: + +(require 'sendmail) +(require 'mail-utils) +(require 'mel) +(require 'mime-view) +(require 'signature) +(require 'alist) +(require 'invisible) +(require 'pgg-def) +(require 'pgg-parse) + +(autoload 'pgg-encrypt-region "pgg" + "PGP encryption of current region." t) +(autoload 'pgg-sign-region "pgg" + "PGP signature of current region." t) +(autoload 'pgg-insert-key "pgg" + "Insert PGP public key at point." t) +(autoload 'smime-encrypt-region "smime" + "S/MIME encryption of current region.") +(autoload 'smime-sign-region "smime" + "S/MIME signature of current region.") +(defvar smime-output-buffer) +(defvar smime-errors-buffer) + + +;;; @ version +;;; + +(eval-and-compile + (defconst mime-edit-version + (concat + (mime-product-name mime-user-interface-product) " " + (mapconcat #'number-to-string + (mime-product-version mime-user-interface-product) ".") + " - \"" (mime-product-code-name mime-user-interface-product) "\""))) + + +;;; @ variables +;;; + +(defgroup mime-edit nil + "MIME edit mode" + :group 'mime) + +(defcustom mime-ignore-preceding-spaces nil + "*Ignore preceding white spaces if non-nil." + :group 'mime-edit + :type 'boolean) + +(defcustom mime-ignore-trailing-spaces nil + "*Ignore trailing white spaces if non-nil." + :group 'mime-edit + :type 'boolean) + +(defcustom mime-ignore-same-text-tag t + "*Ignore preceding text content-type tag that is same with new one. +If non-nil, the text tag is not inserted unless something different." + :group 'mime-edit + :type 'boolean) + +(defcustom mime-auto-hide-body t + "*Hide non-textual body encoded in base64 after insertion if non-nil." + :group 'mime-edit + :type 'boolean) + +(defcustom mime-edit-voice-recorder + (function mime-edit-voice-recorder-for-sun) + "*Function to record a voice message and encode it." + :group 'mime-edit + :type 'function) + +(defcustom mime-edit-mode-hook nil + "*Hook called when enter MIME mode." + :group 'mime-edit + :type 'hook) + +(defcustom mime-edit-translate-hook nil + "*Hook called before translating into a MIME compliant message. +To insert a signature file automatically, call the function +`mime-edit-insert-signature' from this hook." + :group 'mime-edit + :type 'hook) + +(defcustom mime-edit-exit-hook nil + "*Hook called when exit MIME mode." + :group 'mime-edit + :type 'hook) + +(defvar mime-content-types + '(("text" + ;; Charset parameter need not to be specified, since it is + ;; defined automatically while translation. + ("plain" + ;;("charset" "" "ISO-2022-JP" "US-ASCII" "ISO-8859-1" "ISO-8859-8") + ) + ("enriched") + ("html") + ("css") ; rfc2318 + ("xml") ; rfc2376 + ("x-latex") + ;; ("x-rot13-47-48") + ) + ("message" + ("external-body" + ("access-type" + ("anon-ftp" + ("site" "ftp.jaist.ac.jp" "wnoc-fuk.wide.ad.jp" "nic.karrn.ad.jp") + ("directory" "/pub/GNU/elisp/mime") + ("name") + ("mode" "image" "ascii" "local8")) + ("ftp" + ("site") + ("directory") + ("name") + ("mode" "image" "ascii" "local8")) + ("tftp" ("site") ("name")) + ("afs" ("site") ("name")) + ("local-file" ("site") ("name")) + ("mail-server" + ("server" "ftpmail@nic.karrn.ad.jp") + ("subject")) + ("url" ("url")) + )) + ("rfc822") + ("news") + ) + ("application" + ("octet-stream" ("type" "" "tar" "shar")) + ("postscript") + ("vnd.ms-powerpoint") + ("x-kiss" ("x-cnf"))) + ("image" + ("gif") + ("jpeg") + ("png") + ("tiff") + ("x-pic") + ("x-mag") + ("x-xwd") + ("x-xbm") + ) + ("audio" ("basic")) + ("video" ("mpeg")) + ) + "*Alist of content-type, subtype, parameters and its values.") + +(defcustom mime-file-types + '( + + ;; Programming languages + + ("\\.cc$" + "application" "octet-stream" (("type" . "C++")) + "7bit" + "attachment" (("filename" . file)) + ) + + ("\\.el$" + "application" "octet-stream" (("type" . "emacs-lisp")) + "7bit" + "attachment" (("filename" . file)) + ) + + ("\\.lsp$" + "application" "octet-stream" (("type" . "common-lisp")) + "7bit" + "attachment" (("filename" . file)) + ) + + ("\\.pl$" + "application" "octet-stream" (("type" . "perl")) + "7bit" + "attachment" (("filename" . file)) + ) + + ;; Text or translated text + + ("\\.txt$" + "text" "plain" nil + nil + "inline" (("filename" . file)) + ) + + ;; .rc : procmail modules pm-xxxx.rc + ;; *rc : other resource files + + ("\\.\\(rc\\|lst\\|log\\|sql\\|mak\\)$\\|\\..*rc$" + "text" "plain" nil + nil + "attachment" (("filename" . file)) + ) + + ("\\.html$" + "text" "html" nil + nil + nil nil) + + ("\\.diff$\\|\\.patch$" + "application" "octet-stream" (("type" . "patch")) + nil + "attachment" (("filename" . file)) + ) + + ("\\.signature" + "text" "plain" nil nil nil nil) + + + ;; Octect binary text + + ("\\.doc$" ;MS Word + "application" "msword" nil + "base64" + "attachment" (("filename" . file)) + ) + ("\\.ppt$" ; MS Power Point + "application" "vnd.ms-powerpoint" nil + "base64" + "attachment" (("filename" . file)) + ) + + ("\\.pln$" + "text" "plain" nil + nil + "inline" (("filename" . file)) + ) + ("\\.ps$" + "application" "postscript" nil + "quoted-printable" + "attachment" (("filename" . file)) + ) + + ;; Pure binary + + ("\\.jpg$" + "image" "jpeg" nil + "base64" + "inline" (("filename" . file)) + ) + ("\\.gif$" + "image" "gif" nil + "base64" + "inline" (("filename" . file)) + ) + ("\\.png$" + "image" "png" nil + "base64" + "inline" (("filename" . file)) + ) + ("\\.tiff$" + "image" "tiff" nil + "base64" + "inline" (("filename" . file)) + ) + ("\\.pic$" + "image" "x-pic" nil + "base64" + "inline" (("filename" . file)) + ) + ("\\.mag$" + "image" "x-mag" nil + "base64" + "inline" (("filename" . file)) + ) + ("\\.xbm$" + "image" "x-xbm" nil + "base64" + "inline" (("filename" . file)) + ) + ("\\.xwd$" + "image" "x-xwd" nil + "base64" + "inline" (("filename" . file)) + ) + ("\\.au$" + "audio" "basic" nil + "base64" + "attachment" (("filename" . file)) + ) + ("\\.mpg$" + "video" "mpeg" nil + "base64" + "attachment" (("filename" . file)) + ) + ("\\.tar\\.gz$" + "application" "octet-stream" (("type" . "tar+gzip")) + "base64" + "attachment" (("filename" . file)) + ) + ("\\.tgz$" + "application" "octet-stream" (("type" . "tar+gzip")) + "base64" + "attachment" (("filename" . file)) + ) + ("\\.tar\\.Z$" + "application" "octet-stream" (("type" . "tar+compress")) + "base64" + "attachment" (("filename" . file)) + ) + ("\\.taz$" + "application" "octet-stream" (("type" . "tar+compress")) + "base64" + "attachment" (("filename" . file)) + ) + ("\\.gz$" + "application" "octet-stream" (("type" . "gzip")) + "base64" + "attachment" (("filename" . file)) + ) + ("\\.Z$" + "application" "octet-stream" (("type" . "compress")) + "base64" + "attachment" (("filename" . file)) + ) + ("\\.lzh$" + "application" "octet-stream" (("type" . "lha")) + "base64" + "attachment" (("filename" . file)) + ) + ("\\.zip$" + "application" "zip" nil + "base64" + "attachment" (("filename" . file)) + ) + + ;; Rest + + (".*" + "application" "octet-stream" nil + nil + "attachment" (("filename" . file))) + ) + "*Alist of file name, types, parameters, and default encoding. +If encoding is nil, it is determined from its contents." + :type `(repeat + (list regexp + ;; primary-type + (choice :tag "Primary-Type" + ,@(nconc (mapcar (lambda (cell) + (list 'item (car cell)) + ) + mime-content-types) + '(string))) + ;; subtype + (choice :tag "Sub-Type" + ,@(nconc + (apply #'nconc + (mapcar (lambda (cell) + (mapcar (lambda (cell) + (list 'item (car cell)) + ) + (cdr cell))) + mime-content-types)) + '(string))) + ;; parameters + (repeat :tag "Parameters of Content-Type field" + (cons string (choice string symbol))) + ;; content-transfer-encoding + (choice :tag "Encoding" + ,@(cons + '(const nil) + (mapcar (lambda (cell) + (list 'item cell) + ) + (mime-encoding-list)))) + ;; disposition-type + (choice :tag "Disposition-Type" + (item nil) + (item "inline") + (item "attachment") + string) + ;; parameters + (repeat :tag "Parameters of Content-Disposition field" + (cons string (choice string symbol))) + )) + :group 'mime-edit) + + +;;; @@ about charset, encoding and transfer-level +;;; + +(defvar mime-charset-type-list + '((us-ascii 7 nil) + (iso-8859-1 8 "quoted-printable") + (iso-8859-2 8 "quoted-printable") + (iso-8859-3 8 "quoted-printable") + (iso-8859-4 8 "quoted-printable") + (iso-8859-5 8 "quoted-printable") + (koi8-r 8 "quoted-printable") + (iso-8859-7 8 "quoted-printable") + (iso-8859-8 8 "quoted-printable") + (iso-8859-9 8 "quoted-printable") + (iso-2022-jp 7 "base64") + (iso-2022-jp-3 7 "base64") + (iso-2022-kr 7 "base64") + (euc-kr 8 "base64") + (cn-gb 8 "base64") + (gb2312 8 "base64") + (cn-big5 8 "base64") + (big5 8 "base64") + (shift_jis 8 "base64") + (tis-620 8 "base64") + (iso-2022-jp-2 7 "base64") + (iso-2022-int-1 7 "base64") + )) + +(defvar mime-transfer-level 7 + "*A number of network transfer level. It should be bigger than 7.") +(make-variable-buffer-local 'mime-transfer-level) + +(defsubst mime-encoding-name (transfer-level &optional not-omit) + (cond ((> transfer-level 8) "binary") + ((= transfer-level 8) "8bit") + (not-omit "7bit") + )) + +(defvar mime-transfer-level-string + (mime-encoding-name mime-transfer-level 'not-omit) + "A string formatted version of mime-transfer-level") +(make-variable-buffer-local 'mime-transfer-level-string) + +;;; @@ about content transfer encoding + +(defvar mime-content-transfer-encoding-priority-list + '(nil "8bit" "binary")) + +;;; @@ about message inserting +;;; + +(defvar mime-edit-yank-ignored-field-list + '("Received" "Approved" "Path" "Replied" "Status" + "Xref" "X-UIDL" "X-Filter" "X-Gnus-.*" "X-VM-.*") + "Delete these fields from original message when it is inserted +as message/rfc822 part. +Each elements are regexp of field-name.") + +(defvar mime-edit-yank-ignored-field-regexp + (concat "^" + (apply (function regexp-or) mime-edit-yank-ignored-field-list) + ":")) + +(defvar mime-edit-message-inserter-alist nil) +(defvar mime-edit-mail-inserter-alist nil) + + +;;; @@ about message splitting +;;; + +(defcustom mime-edit-split-message t + "*Split large message if it is non-nil." + :group 'mime-edit + :type 'boolean) + +(defcustom mime-edit-message-default-max-lines 1000 + "*Default maximum lines of a message." + :group 'mime-edit + :type 'integer) + +(defcustom mime-edit-message-max-lines-alist + '((news-reply-mode . 500)) + "Alist of major-mode vs maximum lines of a message. +If it is not specified for a major-mode, +`mime-edit-message-default-max-lines' is used." + :group 'mime-edit + :type 'list) + +(defconst mime-edit-split-ignored-field-regexp + "\\(^Content-\\|^Subject:\\|^Mime-Version:\\|^Message-Id:\\)") + +(defcustom mime-edit-split-blind-field-regexp + "\\(^[BDFbdf]cc:\\|^cc:[ \t]*$\\)" + "*Regular expression to match field-name to be ignored when split sending." + :group 'mime-edit + :type 'regexp) + +(defvar mime-edit-split-message-sender-alist + '((mail-mode . (function + (lambda () + (interactive) + (funcall send-mail-function) + ))))) + +(defvar mime-edit-news-reply-mode-server-running nil) + + +;;; @@ about tag +;;; + +(defconst mime-edit-single-part-tag-regexp + "--[[][[]\\([^]]*\\)]\\([[]\\([^]]*\\)]\\|\\)]" + "*Regexp of MIME tag in the form of [[CONTENT-TYPE][ENCODING]].") + +(defconst mime-edit-quoted-single-part-tag-regexp + (concat "- " (substring mime-edit-single-part-tag-regexp 1))) + +(defconst mime-edit-multipart-beginning-regexp "--<<\\([^<>]+\\)>>-{\n") + +(defconst mime-edit-multipart-end-regexp "--}-<<\\([^<>]+\\)>>\n") + +(defconst mime-edit-beginning-tag-regexp + (regexp-or mime-edit-single-part-tag-regexp + mime-edit-multipart-beginning-regexp)) + +(defconst mime-edit-end-tag-regexp + (regexp-or mime-edit-single-part-tag-regexp + mime-edit-multipart-end-regexp)) + +(defconst mime-edit-tag-regexp + (regexp-or mime-edit-single-part-tag-regexp + mime-edit-multipart-beginning-regexp + mime-edit-multipart-end-regexp)) + +(defvar mime-tag-format "--[[%s]]" + "*Control-string making a MIME tag.") + +(defvar mime-tag-format-with-encoding "--[[%s][%s]]" + "*Control-string making a MIME tag with encoding.") + + +;;; @@ multipart boundary +;;; + +(defvar mime-multipart-boundary "Multipart" + "*Boundary of a multipart message.") + + +;;; @@ optional header fields +;;; + +(defvar mime-edit-insert-user-agent-field t + "*If non-nil, insert User-Agent header field.") + +(defvar mime-edit-user-agent-value + (concat (mime-product-name mime-user-interface-product) + "/" + (mapconcat #'number-to-string + (mime-product-version mime-user-interface-product) ".") + " (" + (mime-product-code-name mime-user-interface-product) + ") " + (mime-product-name mime-library-product) + "/" + (mapconcat #'number-to-string + (mime-product-version mime-library-product) ".") + " (" + (mime-product-code-name mime-library-product) + ") " + (if (fboundp 'apel-version) + (concat (apel-version) " ")) + (if (featurep 'xemacs) + (concat (cond ((featurep 'utf-2000) + (concat "UTF-2000-MULE/" utf-2000-version)) + ((featurep 'mule) "MULE")) + " XEmacs" + (if (string-match "^[0-9]+\\(\\.[0-9]+\\)" emacs-version) + (concat + "/" + (substring emacs-version 0 (match-end 0)) + (cond ((and (boundp 'xemacs-betaname) + xemacs-betaname) + ;; It does not exist in XEmacs + ;; versions prior to 20.3. + (concat " " xemacs-betaname)) + ((and (boundp 'emacs-patch-level) + emacs-patch-level) + ;; It does not exist in FSF Emacs or in + ;; XEmacs versions earlier than 21.1.1. + (format " (patch %d)" emacs-patch-level)) + (t "")) + " (" xemacs-codename ") (" + system-configuration ")") + " (" emacs-version ")")) + (let ((ver (if (string-match "\\.[0-9]+$" emacs-version) + (substring emacs-version 0 (match-beginning 0)) + emacs-version))) + (if (featurep 'mule) + (if (boundp 'enable-multibyte-characters) + (concat "Emacs/" ver + " (" system-configuration ")" + (if enable-multibyte-characters + (concat " MULE/" mule-version) + " (with unibyte mode)") + (if (featurep 'meadow) + (let ((mver (Meadow-version))) + (if (string-match "^Meadow-" mver) + (concat " Meadow/" + (substring mver + (match-end 0))) + )))) + (concat "MULE/" mule-version + " (based on Emacs " ver ")")) + (concat "Emacs/" ver " (" system-configuration ")"))))) + "Body of User-Agent field. +If variable `mime-edit-insert-user-agent-field' is not nil, it is +inserted into message header.") + + +;;; @ constants +;;; + +(defconst mime-tspecials-regexp "[][()<>@,;:\\\"/?.= \t]" + "*Specify MIME tspecials. +Tspecials means any character that matches with it in header must be quoted.") + +(defconst mime-edit-mime-version-value + (concat "1.0 (generated by " mime-edit-version ")") + "MIME version number.") + +(defconst mime-edit-mime-version-field-for-message/partial + (concat "MIME-Version:" + (mime-encode-field-body + (concat " 1.0 (split by " mime-edit-version ")\n") + "MIME-Version:")) + "MIME version field for message/partial.") + + +;;; @ keymap and menu +;;; + +(defvar mime-edit-mode-flag nil) +(make-variable-buffer-local 'mime-edit-mode-flag) + +(defvar mime-edit-mode-entity-prefix "\C-c\C-x" + "Keymap prefix for MIME-Edit mode commands to insert entity or set status.") +(defvar mime-edit-mode-entity-map (make-sparse-keymap) + "Keymap for MIME-Edit mode commands to insert entity or set status.") + +(define-key mime-edit-mode-entity-map "\C-t" 'mime-edit-insert-text) +(define-key mime-edit-mode-entity-map "\C-i" 'mime-edit-insert-file) +(define-key mime-edit-mode-entity-map "\C-e" 'mime-edit-insert-external) +(define-key mime-edit-mode-entity-map "\C-v" 'mime-edit-insert-voice) +(define-key mime-edit-mode-entity-map "\C-y" 'mime-edit-insert-message) +(define-key mime-edit-mode-entity-map "\C-m" 'mime-edit-insert-mail) +(define-key mime-edit-mode-entity-map "\C-w" 'mime-edit-insert-signature) +(define-key mime-edit-mode-entity-map "\C-s" 'mime-edit-insert-signature) +(define-key mime-edit-mode-entity-map "\C-k" 'mime-edit-insert-key) +(define-key mime-edit-mode-entity-map "t" 'mime-edit-insert-tag) + +(define-key mime-edit-mode-entity-map "7" 'mime-edit-set-transfer-level-7bit) +(define-key mime-edit-mode-entity-map "8" 'mime-edit-set-transfer-level-8bit) +(define-key mime-edit-mode-entity-map "/" 'mime-edit-set-split) +(define-key mime-edit-mode-entity-map "s" 'mime-edit-set-sign) +(define-key mime-edit-mode-entity-map "v" 'mime-edit-set-sign) +(define-key mime-edit-mode-entity-map "e" 'mime-edit-set-encrypt) +(define-key mime-edit-mode-entity-map "h" 'mime-edit-set-encrypt) +(define-key mime-edit-mode-entity-map "p" 'mime-edit-preview-message) +(define-key mime-edit-mode-entity-map "\C-z" 'mime-edit-exit) +(define-key mime-edit-mode-entity-map "?" 'mime-edit-help) + +(defvar mime-edit-mode-enclosure-prefix "\C-c\C-m" + "Keymap prefix for MIME-Edit mode commands about enclosure.") +(defvar mime-edit-mode-enclosure-map (make-sparse-keymap) + "Keymap for MIME-Edit mode commands about enclosure.") + +(define-key mime-edit-mode-enclosure-map + "\C-a" 'mime-edit-enclose-alternative-region) +(define-key mime-edit-mode-enclosure-map + "\C-p" 'mime-edit-enclose-parallel-region) +(define-key mime-edit-mode-enclosure-map + "\C-m" 'mime-edit-enclose-mixed-region) +(define-key mime-edit-mode-enclosure-map + "\C-d" 'mime-edit-enclose-digest-region) +(define-key mime-edit-mode-enclosure-map + "\C-s" 'mime-edit-enclose-pgp-signed-region) +(define-key mime-edit-mode-enclosure-map + "\C-e" 'mime-edit-enclose-pgp-encrypted-region) +(define-key mime-edit-mode-enclosure-map + "\C-q" 'mime-edit-enclose-quote-region) + +(defvar mime-edit-mode-map (make-sparse-keymap) + "Keymap for MIME-Edit mode commands.") +(define-key mime-edit-mode-map + mime-edit-mode-entity-prefix mime-edit-mode-entity-map) +(define-key mime-edit-mode-map + mime-edit-mode-enclosure-prefix mime-edit-mode-enclosure-map) + +(defconst mime-edit-menu-title "MIME-Edit") + +(defconst mime-edit-menu-list + '((mime-help "Describe MIME editor mode" mime-edit-help) + (file "Insert File" mime-edit-insert-file) + (external "Insert External" mime-edit-insert-external) + (voice "Insert Voice" mime-edit-insert-voice) + (message "Insert Message" mime-edit-insert-message) + (mail "Insert Mail" mime-edit-insert-mail) + (signature "Insert Signature" mime-edit-insert-signature) + (text "Insert Text" mime-edit-insert-text) + (tag "Insert Tag" mime-edit-insert-tag) + (alternative "Enclose as alternative" + mime-edit-enclose-alternative-region) + (parallel "Enclose as parallel" mime-edit-enclose-parallel-region) + (mixed "Enclose as serial" mime-edit-enclose-mixed-region) + (digest "Enclose as digest" mime-edit-enclose-digest-region) + (signed "Enclose as signed" mime-edit-enclose-pgp-signed-region) + (encrypted "Enclose as encrypted" mime-edit-enclose-pgp-encrypted-region) + (quote "Verbatim region" mime-edit-enclose-quote-region) + (key "Insert Public Key" mime-edit-insert-key) + (split "About split" mime-edit-set-split) + (sign "About sign" mime-edit-set-sign) + (encrypt "About encryption" mime-edit-set-encrypt) + (preview "Preview Message" mime-edit-preview-message) + (level "Toggle transfer-level" mime-edit-toggle-transfer-level) + ) + "MIME-edit menubar entry.") + +(cond ((featurep 'xemacs) + ;; modified by Pekka Marjola + ;; 1995/9/5 (c.f. [tm-en:69]) + (defun mime-edit-define-menu-for-xemacs () + "Define menu for XEmacs." + (cond ((featurep 'menubar) + (make-local-variable 'current-menubar) + (set-buffer-menubar current-menubar) + (add-submenu + nil + (cons mime-edit-menu-title + (mapcar (function + (lambda (item) + (vector (nth 1 item)(nth 2 item) + mime-edit-mode-flag) + )) + mime-edit-menu-list))) + ))) + + ;; modified by Steven L. Baur + ;; 1995/12/6 (c.f. [tm-en:209]) + (or (boundp 'mime-edit-popup-menu-for-xemacs) + (setq mime-edit-popup-menu-for-xemacs + (append '("MIME Commands" "---") + (mapcar (function (lambda (item) + (vector (nth 1 item) + (nth 2 item) + t))) + mime-edit-menu-list))) + ) + ) + ((>= emacs-major-version 19) + (define-key mime-edit-mode-map [menu-bar mime-edit] + (cons mime-edit-menu-title + (make-sparse-keymap mime-edit-menu-title))) + (mapcar (function + (lambda (item) + (define-key mime-edit-mode-map + (vector 'menu-bar 'mime-edit (car item)) + (cons (nth 1 item)(nth 2 item)) + ) + )) + (reverse mime-edit-menu-list) + ) + )) + + +;;; @ functions +;;; + +(defvar mime-edit-touched-flag nil) + +;;;###autoload +(defun mime-edit-mode () + "MIME minor mode for editing the tagged MIME message. + +In this mode, basically, the message is composed in the tagged MIME +format. The message tag looks like: + + --[[text/plain; charset=ISO-2022-JP][7bit]] + +The tag specifies the MIME content type, subtype, optional parameters +and transfer encoding of the message following the tag. Messages +without any tag are treated as `text/plain' by default. Charset and +transfer encoding are automatically defined unless explicitly +specified. Binary messages such as audio and image are usually +hidden. The messages in the tagged MIME format are automatically +translated into a MIME compliant message when exiting this mode. + +Available charsets depend on Emacs version being used. The following +lists the available charsets of each emacs. + +Without mule: US-ASCII and ISO-8859-1 (or other charset) are available. +With mule: US-ASCII, ISO-8859-* (except for ISO-8859-5), KOI8-R, + ISO-2022-JP, ISO-2022-JP-2, EUC-KR, CN-GB-2312, + CN-BIG5 and ISO-2022-INT-1 are available. + +ISO-2022-JP-2 and ISO-2022-INT-1 charsets used in mule is expected to +be used to represent multilingual text in intermixed manner. Any +languages that has no registered charset are represented as either +ISO-2022-JP-2 or ISO-2022-INT-1 in mule. + +If you want to use non-ISO-8859-1 charset in Emacs 19 or XEmacs +without mule, please set variable `default-mime-charset'. This +variable must be symbol of which name is a MIME charset. + +If you want to add more charsets in mule, please set variable +`charsets-mime-charset-alist'. This variable must be alist of which +key is list of charset and value is symbol of MIME charset. If name +of coding-system is different as MIME charset, please set variable +`mime-charset-coding-system-alist'. This variable must be alist of +which key is MIME charset and value is coding-system. + +Following commands are available in addition to major mode commands: + +\[make single part\] +\\[mime-edit-insert-text] insert a text message. +\\[mime-edit-insert-file] insert a (binary) file. +\\[mime-edit-insert-external] insert a reference to external body. +\\[mime-edit-insert-voice] insert a voice message. +\\[mime-edit-insert-message] insert a mail or news message. +\\[mime-edit-insert-mail] insert a mail message. +\\[mime-edit-insert-signature] insert a signature file at end. +\\[mime-edit-insert-key] insert PGP public key. +\\[mime-edit-insert-tag] insert a new MIME tag. + +\[make enclosure (maybe multipart)\] +\\[mime-edit-enclose-alternative-region] enclose as multipart/alternative. +\\[mime-edit-enclose-parallel-region] enclose as multipart/parallel. +\\[mime-edit-enclose-mixed-region] enclose as multipart/mixed. +\\[mime-edit-enclose-digest-region] enclose as multipart/digest. +\\[mime-edit-enclose-pgp-signed-region] enclose as PGP signed. +\\[mime-edit-enclose-pgp-encrypted-region] enclose as PGP encrypted. +\\[mime-edit-enclose-quote-region] enclose as verbose mode + (to avoid to expand tags) + +\[other commands\] +\\[mime-edit-set-transfer-level-7bit] set transfer-level as 7. +\\[mime-edit-set-transfer-level-8bit] set transfer-level as 8. +\\[mime-edit-set-split] set message splitting mode. +\\[mime-edit-set-sign] set PGP-sign mode. +\\[mime-edit-set-encrypt] set PGP-encryption mode. +\\[mime-edit-preview-message] preview editing MIME message. +\\[mime-edit-exit] exit and translate into a MIME + compliant message. +\\[mime-edit-help] show this help. +\\[mime-edit-maybe-translate] exit and translate if in MIME mode, + then split. + +Additional commands are available in some major modes: +C-c C-c exit, translate and run the original command. +C-c C-s exit, translate and run the original command. + +The following is a message example written in the tagged MIME format. +TABs at the beginning of the line are not a part of the message: + + This is a conventional plain text. It should be translated + into text/plain. + --[[text/plain]] + This is also a plain text. But, it is explicitly specified as + is. + --[[text/plain; charset=ISO-8859-1]] + This is also a plain text. But charset is specified as + iso-8859-1. + + ¡Hola! Buenos días. ¿Cómo está usted? + --[[text/enriched]] + This is a enriched text. + --[[image/gif][base64]]...image encoded in base64 here... + --[[audio/basic][base64]]...audio encoded in base64 here... + +User customizable variables (not documented all of them): + mime-edit-prefix + Specifies a key prefix for MIME minor mode commands. + + mime-ignore-preceding-spaces + Preceding white spaces in a message body are ignored if non-nil. + + mime-ignore-trailing-spaces + Trailing white spaces in a message body are ignored if non-nil. + + mime-auto-hide-body + Hide a non-textual body message encoded in base64 after insertion + if non-nil. + + mime-transfer-level + A number of network transfer level. It should be bigger than 7. + If you are in 8bit-through environment, please set 8. + + mime-edit-voice-recorder + Specifies a function to record a voice message and encode it. + The function `mime-edit-voice-recorder-for-sun' is for Sun + SparcStations. + + mime-edit-mode-hook + Turning on MIME mode calls the value of mime-edit-mode-hook, if + it is non-nil. + + mime-edit-translate-hook + The value of mime-edit-translate-hook is called just before translating + the tagged MIME format into a MIME compliant message if it is + non-nil. If the hook call the function mime-edit-insert-signature, + the signature file will be inserted automatically. + + mime-edit-exit-hook + Turning off MIME mode calls the value of mime-edit-exit-hook, if it is + non-nil." + (interactive) + (if mime-edit-mode-flag + (mime-edit-exit) + (if mime-edit-touched-flag + (mime-edit-again) + (make-local-variable 'mime-edit-touched-flag) + (setq mime-edit-touched-flag t) + (turn-on-mime-edit) + ))) + + +(cond ((featurep 'xemacs) + (add-minor-mode 'mime-edit-mode-flag + '((" MIME-Edit " mime-transfer-level-string)) + mime-edit-mode-map + nil + 'mime-edit-mode) + ) + (t + (set-alist 'minor-mode-alist + 'mime-edit-mode-flag + '((" MIME-Edit " mime-transfer-level-string))) + (set-alist 'minor-mode-map-alist + 'mime-edit-mode-flag + mime-edit-mode-map) + )) + + +;;;###autoload +(defun turn-on-mime-edit () + "Unconditionally turn on MIME-Edit mode." + (interactive) + (if mime-edit-mode-flag + (error "You are already editing a MIME message.") + (setq mime-edit-mode-flag t) + + ;; Set transfer level into mode line + ;; + (setq mime-transfer-level-string + (mime-encoding-name mime-transfer-level 'not-omit)) + (force-mode-line-update) + + ;; Define menu for XEmacs. + (if (featurep 'xemacs) + (mime-edit-define-menu-for-xemacs) + ) + + (enable-invisible) + + ;; I don't care about saving these. + (setq paragraph-start + (regexp-or mime-edit-single-part-tag-regexp + paragraph-start)) + (setq paragraph-separate + (regexp-or mime-edit-single-part-tag-regexp + paragraph-separate)) + (run-hooks 'mime-edit-mode-hook) + (message + (substitute-command-keys + "Type \\[mime-edit-exit] to exit MIME mode, and type \\[mime-edit-help] to get help.")) + )) + +;;;###autoload +(defalias 'edit-mime 'turn-on-mime-edit) ; for convenience + + +(defun mime-edit-exit (&optional nomime no-error) + "Translate the tagged MIME message into a MIME compliant message. +With no argument encode a message in the buffer into MIME, otherwise +just return to previous mode." + (interactive "P") + (if (not mime-edit-mode-flag) + (if (null no-error) + (error "You aren't editing a MIME message.") + ) + (if (not nomime) + (progn + (run-hooks 'mime-edit-translate-hook) + (mime-edit-translate-buffer))) + ;; Restore previous state. + (setq mime-edit-mode-flag nil) + (if (and (featurep 'xemacs) + (featurep 'menubar)) + (delete-menu-item (list mime-edit-menu-title)) + ) + (end-of-invisible) + (set-buffer-modified-p (buffer-modified-p)) + (run-hooks 'mime-edit-exit-hook) + (message "Exit MIME editor mode.") + )) + +(defun mime-edit-maybe-translate () + (interactive) + (mime-edit-exit nil t) + (call-interactively 'mime-edit-maybe-split-and-send) + ) + +(defun mime-edit-help () + "Show help message about MIME mode." + (interactive) + (with-output-to-temp-buffer "*Help*" + (princ "MIME editor mode:\n") + (princ (documentation 'mime-edit-mode)) + (print-help-return-message))) + +(defun mime-edit-insert-text (&optional subtype) + "Insert a text message. +Charset is automatically obtained from the `charsets-mime-charset-alist'. +If optional argument SUBTYPE is not nil, text/SUBTYPE tag is inserted." + (interactive) + (let ((ret (mime-edit-insert-tag "text" subtype nil))) + (when ret + (if (looking-at mime-edit-single-part-tag-regexp) + (progn + ;; Make a space between the following message. + (insert "\n") + (forward-char -1) + )) + (if (and (member (cadr ret) '("enriched")) + (fboundp 'enriched-mode)) + (enriched-mode t) + (if (boundp 'enriched-mode) + (enriched-mode -1) + )) + ))) + +(defun mime-edit-insert-file (file &optional verbose) + "Insert a message from a file." + (interactive "fInsert file as MIME message: \nP") + (let* ((guess (mime-find-file-type file)) + (type (nth 0 guess)) + (subtype (nth 1 guess)) + (parameters (nth 2 guess)) + (encoding (nth 3 guess)) + (disposition-type (nth 4 guess)) + (disposition-params (nth 5 guess)) + ) + (if verbose + (setq type (mime-prompt-for-type type) + subtype (mime-prompt-for-subtype type subtype) + )) + (if (or (interactive-p) verbose) + (setq encoding (mime-prompt-for-encoding encoding)) + ) + (if (or (consp parameters) (stringp disposition-type)) + (let ((rest parameters) cell attribute value) + (setq parameters "") + (while rest + (setq cell (car rest)) + (setq attribute (car cell)) + (setq value (cdr cell)) + (if (eq value 'file) + (setq value (std11-wrap-as-quoted-string + (file-name-nondirectory file))) + ) + (setq parameters (concat parameters "; " attribute "=" value)) + (setq rest (cdr rest)) + ) + (if disposition-type + (progn + (setq parameters + (concat parameters "\n" + "Content-Disposition: " disposition-type)) + (setq rest disposition-params) + (while rest + (setq cell (car rest)) + (setq attribute (car cell)) + (setq value (cdr cell)) + (if (eq value 'file) + (setq value (std11-wrap-as-quoted-string + (file-name-nondirectory file))) + ) + (setq parameters + (concat parameters "; " attribute "=" value)) + (setq rest (cdr rest)) + ) + )) + )) + (mime-edit-insert-tag type subtype parameters) + (mime-edit-insert-binary-file file encoding) + )) + +(defun mime-edit-insert-external () + "Insert a reference to external body." + (interactive) + (mime-edit-insert-tag "message" "external-body" nil ";\n\t") + ;;(forward-char -1) + ;;(insert "Content-Description: " (read-string "Content-Description: ") "\n") + ;;(forward-line 1) + (let* ((pritype (mime-prompt-for-type)) + (subtype (mime-prompt-for-subtype pritype)) + (parameters (mime-prompt-for-parameters pritype subtype ";\n\t"))) + (and pritype + subtype + (insert "Content-Type: " + pritype "/" subtype (or parameters "") "\n"))) + (if (and (not (eobp)) + (not (looking-at mime-edit-single-part-tag-regexp))) + (insert (mime-make-text-tag) "\n"))) + +(defun mime-edit-insert-voice () + "Insert a voice message." + (interactive) + (let ((encoding + (completing-read + "What transfer encoding: " + (mime-encoding-alist) nil t nil))) + (mime-edit-insert-tag "audio" "basic" nil) + (mime-edit-define-encoding encoding) + (save-restriction + (narrow-to-region (1- (point))(point)) + (unwind-protect + (funcall mime-edit-voice-recorder encoding) + (progn + (insert "\n") + (invisible-region (point-min)(point-max)) + (goto-char (point-max)) + ))))) + +(defun mime-edit-insert-signature (&optional arg) + "Insert a signature file." + (interactive "P") + (let ((signature-insert-hook + (function + (lambda () + (let ((items (mime-find-file-type signature-file-name))) + (apply (function mime-edit-insert-tag) + (car items) (cadr items) (list (caddr items)))) + ))) + ) + (insert-signature arg) + )) + + +;; Insert a new tag around a point. + +(defun mime-edit-insert-tag (&optional pritype subtype parameters delimiter) + "Insert new MIME tag and return a list of PRITYPE, SUBTYPE, and PARAMETERS. +If nothing is inserted, return nil." + (interactive) + (let ((p (point))) + (mime-edit-goto-tag) + (if (and (re-search-forward mime-edit-tag-regexp nil t) + (< (match-beginning 0) p) + (< p (match-end 0)) + ) + (goto-char (match-beginning 0)) + (goto-char p) + )) + (let ((oldtag nil) + (newtag nil) + (current (point)) + ) + (setq pritype + (or pritype + (mime-prompt-for-type))) + (setq subtype + (or subtype + (mime-prompt-for-subtype pritype))) + (setq parameters + (or parameters + (mime-prompt-for-parameters pritype subtype delimiter))) + ;; Make a new MIME tag. + (setq newtag (mime-make-tag pritype subtype parameters)) + ;; Find an current MIME tag. + (setq oldtag + (save-excursion + (if (mime-edit-goto-tag) + (buffer-substring (match-beginning 0) (match-end 0)) + ;; Assume content type is 'text/plan'. + (mime-make-tag "text" "plain") + ))) + ;; We are only interested in TEXT. + (if (and oldtag + (not (mime-test-content-type + (mime-edit-get-contype oldtag) "text"))) + (setq oldtag nil)) + ;; Make a new tag. + (if (or (not oldtag) ;Not text + (or mime-ignore-same-text-tag + (not (string-equal oldtag newtag)))) + (progn + ;; Mark the beginning of the tag for convenience. + (push-mark (point) 'nomsg) + (insert newtag "\n") + (list pritype subtype parameters) ;New tag is created. + ) + ;; Restore previous point. + (goto-char current) + nil ;Nothing is created. + ) + )) + +(defun mime-edit-insert-binary-file (file &optional encoding) + "Insert binary FILE at point. +Optional argument ENCODING specifies an encoding method such as base64." + (let* ((tagend (1- (point))) ;End of the tag + (hide-p (and mime-auto-hide-body + (stringp encoding) + (not + (let ((en (downcase encoding))) + (or (string-equal en "7bit") + (string-equal en "8bit") + (string-equal en "binary") + ))))) + ) + (save-restriction + (narrow-to-region tagend (point)) + (mime-insert-encoded-file file encoding) + (if hide-p + (progn + (invisible-region (point-min) (point-max)) + (goto-char (point-max)) + ) + (goto-char (point-max)) + )) + (or hide-p + (looking-at mime-edit-tag-regexp) + (= (point)(point-max)) + (mime-edit-insert-tag "text" "plain") + ) + ;; Define encoding even if it is 7bit. + (if (stringp encoding) + (save-excursion + (goto-char tagend) ; Make sure which line the tag is on. + (mime-edit-define-encoding encoding) + )) + )) + + +;; Commands work on a current message flagment. + +(defun mime-edit-goto-tag () + "Search for the beginning of the tagged MIME message." + (let ((current (point))) + (if (looking-at mime-edit-tag-regexp) + t + ;; At first, go to the end. + (cond ((re-search-forward mime-edit-beginning-tag-regexp nil t) + (goto-char (1- (match-beginning 0))) ;For multiline tag + ) + (t + (goto-char (point-max)) + )) + ;; Then search for the beginning. + (re-search-backward mime-edit-end-tag-regexp nil t) + (or (looking-at mime-edit-beginning-tag-regexp) + ;; Restore previous point. + (progn + (goto-char current) + nil + )) + ))) + +(defun mime-edit-content-beginning () + "Return the point of the beginning of content." + (save-excursion + (let ((beg (save-excursion + (beginning-of-line) (point)))) + (if (mime-edit-goto-tag) + (let ((top (point))) + (goto-char (match-end 0)) + (if (and (= beg top) + (= (following-char) ?\^M)) + (point) + (forward-line 1) + (point))) + ;; Default text/plain tag. + (goto-char (point-min)) + (re-search-forward + (concat "\n" (regexp-quote mail-header-separator) + (if mime-ignore-preceding-spaces + "[ \t\n]*\n" "\n")) nil 'move) + (point)) + ))) + +(defun mime-edit-content-end () + "Return the point of the end of content." + (save-excursion + (if (mime-edit-goto-tag) + (progn + (goto-char (match-end 0)) + (if (invisible-p (point)) + (next-visible-point (point)) + ;; Move to the end of this text. + (if (re-search-forward mime-edit-tag-regexp nil 'move) + ;; Don't forget a multiline tag. + (goto-char (match-beginning 0)) + ) + (point) + )) + ;; Assume the message begins with text/plain. + (goto-char (mime-edit-content-beginning)) + (if (re-search-forward mime-edit-tag-regexp nil 'move) + ;; Don't forget a multiline tag. + (goto-char (match-beginning 0))) + (point)) + )) + +(defun mime-edit-define-charset (charset) + "Set charset of current tag to CHARSET." + (save-excursion + (if (mime-edit-goto-tag) + (let ((tag (buffer-substring (match-beginning 0) (match-end 0)))) + (delete-region (match-beginning 0) (match-end 0)) + (insert + (mime-create-tag + (mime-edit-set-parameter + (mime-edit-get-contype tag) + "charset" + (let ((comment (get charset 'mime-charset-comment))) + (if comment + (concat (upcase (symbol-name charset)) " (" comment ")") + (upcase (symbol-name charset))))) + (mime-edit-get-encoding tag))) + )))) + +(defun mime-edit-define-encoding (encoding) + "Set encoding of current tag to ENCODING." + (save-excursion + (if (mime-edit-goto-tag) + (let ((tag (buffer-substring (match-beginning 0) (match-end 0)))) + (delete-region (match-beginning 0) (match-end 0)) + (insert (mime-create-tag (mime-edit-get-contype tag) encoding))) + ))) + +(defun mime-edit-choose-charset () + "Choose charset of a text following current point." + (detect-mime-charset-region (point) (mime-edit-content-end)) + ) + +(defun mime-make-text-tag (&optional subtype) + "Make a tag for a text after current point. +Subtype of text type can be specified by an optional argument SUBTYPE. +Otherwise, it is obtained from mime-content-types." + (let* ((pritype "text") + (subtype (or subtype + (car (car (cdr (assoc pritype mime-content-types))))))) + ;; Charset should be defined later. + (mime-make-tag pritype subtype))) + + +;; Tag handling functions + +(defun mime-make-tag (pritype subtype &optional parameters encoding) + "Make a tag of MIME message of PRITYPE, SUBTYPE and optional PARAMETERS." + (mime-create-tag (concat (or pritype "") "/" (or subtype "") + (or parameters "")) + encoding)) + +(defun mime-create-tag (contype &optional encoding) + "Make a tag with CONTENT-TYPE and optional ENCODING." + (format (if encoding mime-tag-format-with-encoding mime-tag-format) + contype encoding)) + +(defun mime-edit-get-contype (tag) + "Return Content-Type (including parameters) of TAG." + (and (stringp tag) + (or (string-match mime-edit-single-part-tag-regexp tag) + (string-match mime-edit-multipart-beginning-regexp tag) + (string-match mime-edit-multipart-end-regexp tag) + ) + (substring tag (match-beginning 1) (match-end 1)) + )) + +(defun mime-edit-get-encoding (tag) + "Return encoding of TAG." + (and (stringp tag) + (string-match mime-edit-single-part-tag-regexp tag) + (match-beginning 3) + (not (= (match-beginning 3) (match-end 3))) + (substring tag (match-beginning 3) (match-end 3)))) + +(defun mime-get-parameter (contype parameter) + "For given CONTYPE return value for PARAMETER. +Nil if no such parameter." + (if (string-match + (concat + ";[ \t\n]*" + (regexp-quote parameter) + "[ \t\n]*=[ \t\n]*\\([^\" \t\n;]*\\|\"[^\"]*\"\\)\\([ \t\n]*;\\|$\\)") + contype) + (substring contype (match-beginning 1) (match-end 1)) + nil ;No such parameter + )) + +(defun mime-edit-set-parameter (contype parameter value) + "For given CONTYPE set PARAMETER to VALUE." + (let (ctype opt-fields) + (if (string-match "\n[^ \t\n\r]+:" contype) + (setq ctype (substring contype 0 (match-beginning 0)) + opt-fields (substring contype (match-beginning 0))) + (setq ctype contype) + ) + (if (string-match + (concat + ";[ \t\n]*\\(" + (regexp-quote parameter) + "[ \t\n]*=[ \t\n]*\\([^\" \t\n;]*\\|\"[^\"]*\"\\)\\)[ \t\n]*\\(;\\|$\\)") + ctype) + ;; Change value + (concat (substring ctype 0 (match-beginning 1)) + parameter "=" value + (substring contype (match-end 1)) + opt-fields) + (concat ctype "; " parameter "=" value opt-fields) + ))) + +(defun mime-strip-parameters (contype) + "Return primary content-type and subtype without parameters for CONTYPE." + (if (string-match "^[ \t]*\\([^; \t\n]*\\)" contype) + (substring contype (match-beginning 1) (match-end 1)) nil)) + +(defun mime-test-content-type (contype type &optional subtype) + "Test if CONTYPE is a TYPE and an optional SUBTYPE." + (and (stringp contype) + (stringp type) + (string-match + (concat "^[ \t]*" (downcase type) "/" (downcase (or subtype ""))) + (downcase contype)))) + + +;; Basic functions + +(defun mime-find-file-type (file) + "Guess Content-Type, subtype, and parameters from FILE." + (let ((guess nil) + (guesses mime-file-types)) + (while (and (not guess) guesses) + (if (string-match (car (car guesses)) file) + (setq guess (cdr (car guesses)))) + (setq guesses (cdr guesses))) + guess + )) + +(defun mime-prompt-for-type (&optional default) + "Ask for Content-type." + (let ((type "")) + ;; Repeat until primary content type is specified. + (while (string-equal type "") + (setq type + (completing-read "What content type: " + mime-content-types + nil + 'require-match ;Type must be specified. + default + )) + (if (string-equal type "") + (progn + (message "Content type is required.") + (beep) + (sit-for 1) + )) + ) + type)) + +(defun mime-prompt-for-subtype (type &optional default) + "Ask for subtype of media-type TYPE." + (let ((subtypes (cdr (assoc type mime-content-types)))) + (or (and default + (assoc default subtypes)) + (setq default (car (car subtypes))) + )) + (let* ((answer + (completing-read + (if default + (concat + "What content subtype: (default " default ") ") + "What content subtype: ") + (cdr (assoc type mime-content-types)) + nil + 'require-match ;Subtype must be specified. + nil + ))) + (if (string-equal answer "") default answer))) + +(defun mime-prompt-for-parameters (pritype subtype &optional delimiter) + "Ask for Content-type parameters of Content-Type PRITYPE and SUBTYPE. +Optional DELIMITER specifies parameter delimiter (';' by default)." + (let* ((delimiter (or delimiter "; ")) + (parameters + (mapconcat + (function identity) + (delq nil + (mime-prompt-for-parameters-1 + (cdr (assoc subtype + (cdr (assoc pritype mime-content-types)))))) + delimiter + ))) + (if (and (stringp parameters) + (not (string-equal parameters ""))) + (concat delimiter parameters) + "" ;"" if no parameters + ))) + +(defun mime-prompt-for-parameters-1 (optlist) + (apply (function append) + (mapcar (function mime-prompt-for-parameter) optlist))) + +(defun mime-prompt-for-parameter (parameter) + "Ask for PARAMETER. +Parameter must be '(PROMPT CHOICE1 (CHOISE2 ...))." + (let* ((prompt (car parameter)) + (choices (mapcar (function + (lambda (e) + (if (consp e) e (list e)))) + (cdr parameter))) + (default (car (car choices))) + (answer nil)) + (if choices + (progn + (setq answer + (completing-read + (concat "What " prompt + ": (default " + (if (string-equal default "") "\"\"" default) + ") ") + choices nil nil "")) + ;; If nothing is selected, use default. + (if (string-equal answer "") + (setq answer default))) + (setq answer + (read-string (concat "What " prompt ": ")))) + (cons (if (and answer + (not (string-equal answer ""))) + (concat prompt "=" + ;; Note: control characters ignored! + (if (string-match mime-tspecials-regexp answer) + (concat "\"" answer "\"") answer))) + (mime-prompt-for-parameters-1 (cdr (assoc answer (cdr parameter))))) + )) + +(defun mime-prompt-for-encoding (default) + "Ask for Content-Transfer-Encoding." + (let (encoding) + (while (string= + (setq encoding + (completing-read + "What transfer encoding: " + (mime-encoding-alist) nil t default) + ) + "")) + encoding)) + + +;;; @ Translate the tagged MIME messages into a MIME compliant message. +;;; + +(defvar mime-edit-translate-buffer-hook + '(mime-edit-pgp-enclose-buffer + mime-edit-translate-body + mime-edit-translate-header)) + +(defun mime-edit-translate-header () + "Encode the message header into network representation." + (mime-encode-header-in-buffer 'code-conversion) + (run-hooks 'mime-edit-translate-header-hook)) + +(defun mime-edit-translate-buffer () + "Encode the tagged MIME message in current buffer in MIME compliant message." + (interactive) + (undo-boundary) + (if (catch 'mime-edit-error + (save-excursion + (run-hooks 'mime-edit-translate-buffer-hook) + )) + (progn + (undo) + (error "Translation error!") + ))) + +(defun mime-edit-find-inmost () + (goto-char (point-min)) + (if (re-search-forward mime-edit-multipart-beginning-regexp nil t) + (let ((bb (match-beginning 0)) + (be (match-end 0)) + (type (buffer-substring (match-beginning 1)(match-end 1))) + end-exp eb) + (setq end-exp (format "--}-<<%s>>\n" type)) + (widen) + (if (re-search-forward end-exp nil t) + (setq eb (match-beginning 0)) + (setq eb (point-max)) + ) + (narrow-to-region be eb) + (goto-char be) + (if (re-search-forward mime-edit-multipart-beginning-regexp nil t) + (progn + (narrow-to-region (match-beginning 0)(point-max)) + (mime-edit-find-inmost) + ) + (widen) + (list type bb be eb) + )))) + +(defun mime-edit-process-multipart-1 (boundary) + (let ((ret (mime-edit-find-inmost))) + (if ret + (let ((type (car ret)) + (bb (nth 1 ret))(be (nth 2 ret)) + (eb (nth 3 ret)) + ) + (narrow-to-region bb eb) + (delete-region bb be) + (setq bb (point-min)) + (setq eb (point-max)) + (widen) + (goto-char eb) + (if (looking-at mime-edit-multipart-end-regexp) + (let ((beg (match-beginning 0)) + (end (match-end 0)) + ) + (delete-region beg end) + (or (looking-at mime-edit-beginning-tag-regexp) + (eobp) + (insert (concat (mime-make-text-tag) "\n")) + ))) + (cond ((string-equal type "quote") + (mime-edit-enquote-region bb eb) + ) + ((string-equal type "pgp-signed") + (mime-edit-sign-pgp-mime bb eb boundary) + ) + ((string-equal type "pgp-encrypted") + (mime-edit-encrypt-pgp-mime bb eb boundary) + ) + ((string-equal type "kazu-signed") + (mime-edit-sign-pgp-kazu bb eb boundary) + ) + ((string-equal type "kazu-encrypted") + (mime-edit-encrypt-pgp-kazu bb eb boundary) + ) + ((string-equal type "smime-signed") + (mime-edit-sign-smime bb eb boundary) + ) + ((string-equal type "smime-encrypted") + (mime-edit-encrypt-smime bb eb boundary) + ) + (t + (setq boundary + (nth 2 (mime-edit-translate-region bb eb + boundary t))) + (goto-char bb) + (insert + (format "--[[multipart/%s; + boundary=\"%s\"][7bit]]\n" + type boundary)) + )) + boundary)))) + +(defun mime-edit-enquote-region (beg end) + (save-excursion + (save-restriction + (narrow-to-region beg end) + (goto-char beg) + (while (re-search-forward mime-edit-single-part-tag-regexp nil t) + (let ((tag (buffer-substring (match-beginning 0)(match-end 0)))) + (replace-match (concat "- " (substring tag 1))) + ))))) + +(defun mime-edit-dequote-region (beg end) + (save-excursion + (save-restriction + (narrow-to-region beg end) + (goto-char beg) + (while (re-search-forward + mime-edit-quoted-single-part-tag-regexp nil t) + (let ((tag (buffer-substring (match-beginning 0)(match-end 0)))) + (replace-match (concat "-" (substring tag 2))) + ))))) + +(defvar mime-edit-pgp-user-id nil) + +(defun mime-edit-sign-pgp-mime (beg end boundary) + (save-excursion + (save-restriction + (let* ((from (std11-field-body "From" mail-header-separator)) + (ret (progn + (narrow-to-region beg end) + (mime-edit-translate-region beg end boundary))) + (ctype (car ret)) + (encoding (nth 1 ret)) + (pgp-boundary (concat "pgp-sign-" boundary)) + micalg) + (goto-char beg) + (insert (format "Content-Type: %s\n" ctype)) + (if encoding + (insert (format "Content-Transfer-Encoding: %s\n" encoding)) + ) + (insert "\n") + (or (let ((pgg-default-user-id + (or mime-edit-pgp-user-id + (if from + (nth 1 (std11-extract-address-components from)) + pgg-default-user-id)))) + (pgg-sign-region (point-min)(point-max))) + (throw 'mime-edit-error 'pgp-error) + ) + (setq micalg + (cdr (assq 'hash-algorithm + (cdar (with-current-buffer pgg-output-buffer + (pgg-parse-armor-region + (point-min)(point-max)))))) + micalg + (if micalg + (concat "; micalg=pgp-" (downcase (symbol-name micalg))) + "")) + (goto-char beg) + (insert (format "--[[multipart/signed; + boundary=\"%s\"%s; + protocol=\"application/pgp-signature\"][7bit]] +--%s +" pgp-boundary micalg pgp-boundary)) + (goto-char (point-max)) + (insert (format "\n--%s +Content-Type: application/pgp-signature +Content-Transfer-Encoding: 7bit + +" pgp-boundary)) + (insert-buffer-substring pgg-output-buffer) + (goto-char (point-max)) + (insert (format "\n--%s--\n" pgp-boundary)) + )))) + +(defvar mime-edit-encrypt-recipient-fields-list '("To" "cc")) + +(defun mime-edit-make-encrypt-recipient-header () + (let* ((names mime-edit-encrypt-recipient-fields-list) + (values + (std11-field-bodies (cons "From" names) + nil mail-header-separator)) + (from (prog1 + (car values) + (setq values (cdr values)))) + (header (and (stringp from) + (if (string-equal from "") + "" + (format "From: %s\n" from) + ))) + recipients) + (while (and names values) + (let ((name (car names)) + (value (car values)) + ) + (and (stringp value) + (or (string-equal value "") + (progn + (setq header (concat header name ": " value "\n") + recipients (if recipients + (concat recipients " ," value) + value)) + )))) + (setq names (cdr names) + values (cdr values)) + ) + (vector from recipients header) + )) + +(defun mime-edit-encrypt-pgp-mime (beg end boundary) + (save-excursion + (save-restriction + (let (from recipients header) + (let ((ret (mime-edit-make-encrypt-recipient-header))) + (setq from (aref ret 0) + recipients (aref ret 1) + header (aref ret 2)) + ) + (narrow-to-region beg end) + (let* ((ret + (mime-edit-translate-region beg end boundary)) + (ctype (car ret)) + (encoding (nth 1 ret)) + (pgp-boundary (concat "pgp-" boundary))) + (goto-char beg) + (insert header) + (insert (format "Content-Type: %s\n" ctype)) + (if encoding + (insert (format "Content-Transfer-Encoding: %s\n" encoding)) + ) + (insert "\n") + (mime-encode-header-in-buffer) + (or (let ((pgg-default-user-id + (or mime-edit-pgp-user-id + (if from + (nth 1 (std11-extract-address-components from)) + pgg-default-user-id)))) + (pgg-encrypt-region + (point-min) (point-max) + (mapcar (lambda (recipient) + (nth 1 (std11-extract-address-components + recipient))) + (split-string recipients + "\\([ \t\n]*,[ \t\n]*\\)+"))) + ) + (throw 'mime-edit-error 'pgp-error) + ) + (delete-region (point-min)(point-max)) + (goto-char beg) + (insert (format "--[[multipart/encrypted; + boundary=\"%s\"; + protocol=\"application/pgp-encrypted\"][7bit]] +--%s +Content-Type: application/pgp-encrypted + +--%s +Content-Type: application/octet-stream +Content-Transfer-Encoding: 7bit + +" pgp-boundary pgp-boundary pgp-boundary)) + (insert-buffer-substring pgg-output-buffer) + (goto-char (point-max)) + (insert (format "\n--%s--\n" pgp-boundary)) + ))))) + +(defun mime-edit-sign-pgp-kazu (beg end boundary) + (save-excursion + (save-restriction + (narrow-to-region beg end) + (let* ((ret + (mime-edit-translate-region beg end boundary)) + (ctype (car ret)) + (encoding (nth 1 ret))) + (goto-char beg) + (insert (format "Content-Type: %s\n" ctype)) + (if encoding + (insert (format "Content-Transfer-Encoding: %s\n" encoding)) + ) + (insert "\n") + (or (pgg-sign-region beg (point-max) 'clearsign) + (throw 'mime-edit-error 'pgp-error) + ) + (goto-char beg) + (insert + "--[[application/pgp; format=mime][7bit]]\n") + )) + )) + +(defun mime-edit-encrypt-pgp-kazu (beg end boundary) + (save-excursion + (let (recipients header) + (let ((ret (mime-edit-make-encrypt-recipient-header))) + (setq recipients (aref ret 1) + header (aref ret 2)) + ) + (save-restriction + (narrow-to-region beg end) + (let* ((ret + (mime-edit-translate-region beg end boundary)) + (ctype (car ret)) + (encoding (nth 1 ret))) + (goto-char beg) + (insert header) + (insert (format "Content-Type: %s\n" ctype)) + (if encoding + (insert (format "Content-Transfer-Encoding: %s\n" encoding)) + ) + (insert "\n") + (or (pgg-encrypt-region beg (point-max) recipients) + (throw 'mime-edit-error 'pgp-error) + ) + (goto-char beg) + (insert + "--[[application/pgp; format=mime][7bit]]\n") + )) + ))) + +(defun mime-edit-sign-smime (beg end boundary) + (save-excursion + (save-restriction + (let* ((ret (progn + (narrow-to-region beg end) + (mime-edit-translate-region beg end boundary))) + (ctype (car ret)) + (encoding (nth 1 ret)) + (smime-boundary (concat "smime-sign-" boundary))) + (goto-char beg) + (insert (format "Content-Type: %s\n" ctype)) + (if encoding + (insert (format "Content-Transfer-Encoding: %s\n" encoding)) + ) + (insert "\n") + (let (buffer-undo-list) + (goto-char (point-min)) + (while (progn (end-of-line) (not (eobp))) + (insert "\r") + (forward-line 1)) + (or (prog1 (smime-sign-region (point-min)(point-max)) + (push nil buffer-undo-list) + (ignore-errors (undo))) + (throw 'mime-edit-error 'pgp-error) + )) + (goto-char beg) + (insert (format "--[[multipart/signed; + boundary=\"%s\"; micalg=sha1; + protocol=\"application/pkcs7-signature\"][7bit]] +--%s +" smime-boundary smime-boundary)) + (goto-char (point-max)) + (insert (format "\n--%s +Content-Type: application/pkcs7-signature; name=\"smime.p7s\" +Content-Transfer-Encoding: base64 +Content-Disposition: attachment; filename=\"smime.p7s\" +Content-Description: S/MIME Cryptographic Signature + +" smime-boundary)) + (insert-buffer-substring smime-output-buffer) + (goto-char (point-max)) + (insert (format "\n--%s--\n" smime-boundary)) + )))) + +(defun mime-edit-encrypt-smime (beg end boundary) + (save-excursion + (save-restriction + (let* ((ret (progn + (narrow-to-region beg end) + (mime-edit-translate-region beg end boundary))) + (ctype (car ret)) + (encoding (nth 1 ret))) + (goto-char beg) + (insert (format "Content-Type: %s\n" ctype)) + (if encoding + (insert (format "Content-Transfer-Encoding: %s\n" encoding)) + ) + (insert "\n") + (goto-char (point-min)) + (while (progn (end-of-line) (not (eobp))) + (insert "\r") + (forward-line 1)) + (or (smime-encrypt-region (point-min)(point-max)) + (throw 'mime-edit-error 'pgp-error) + ) + (delete-region (point-min)(point-max)) + (insert "--[[application/pkcs7-mime; name=\"smime.p7m\" +Content-Disposition: attachment; filename=\"smime.p7m\" +Content-Description: S/MIME Encrypted Message][base64]]\n") + (insert-buffer-substring smime-output-buffer) + )))) + +(defsubst replace-space-with-underline (str) + (mapconcat (function + (lambda (arg) + (char-to-string + (if (eq arg ?\ ) + ?_ + arg)))) str "") + ) + +(defun mime-edit-make-boundary () + (concat mime-multipart-boundary "_" + (replace-space-with-underline (current-time-string)) + )) + +(defun mime-edit-translate-body () + "Encode the tagged MIME body in current buffer in MIME compliant message." + (interactive) + (save-excursion + (let ((boundary (mime-edit-make-boundary)) + (i 1) + ret) + (while (mime-edit-process-multipart-1 + (format "%s-%d" boundary i)) + (setq i (1+ i)) + ) + (save-restriction + ;; We are interested in message body. + (let* ((beg + (progn + (goto-char (point-min)) + (re-search-forward + (concat "\n" (regexp-quote mail-header-separator) + (if mime-ignore-preceding-spaces + "[ \t\n]*\n" "\n")) nil 'move) + (point))) + (end + (progn + (goto-char (point-max)) + (and mime-ignore-trailing-spaces + (re-search-backward "[^ \t\n]\n" beg t) + (forward-char 1)) + (point)))) + (setq ret (mime-edit-translate-region + beg end + (format "%s-%d" boundary i))) + )) + (mime-edit-dequote-region (point-min)(point-max)) + (let ((contype (car ret)) ;Content-Type + (encoding (nth 1 ret)) ;Content-Transfer-Encoding + ) + ;; Insert User-Agent field + (and mime-edit-insert-user-agent-field + (or (mail-position-on-field "User-Agent") + (insert mime-edit-user-agent-value) + )) + ;; Make primary MIME headers. + (or (mail-position-on-field "MIME-Version") + (insert mime-edit-mime-version-value)) + ;; Remove old Content-Type and other fields. + (save-restriction + (goto-char (point-min)) + (search-forward (concat "\n" mail-header-separator "\n") nil t) + (narrow-to-region (point-min) (point)) + (goto-char (point-min)) + (mime-delete-field "Content-Type") + (mime-delete-field "Content-Transfer-Encoding")) + ;; Then, insert Content-Type and Content-Transfer-Encoding fields. + (mail-position-on-field "Content-Type") + (insert contype) + (if encoding + (progn + (mail-position-on-field "Content-Transfer-Encoding") + (insert encoding))) + )))) + +(defun mime-edit-translate-single-part-tag (boundary &optional prefix) + "Translate single-part-tag to MIME header." + (if (re-search-forward mime-edit-single-part-tag-regexp nil t) + (let* ((beg (match-beginning 0)) + (end (match-end 0)) + (tag (buffer-substring beg end))) + (delete-region beg end) + (let ((contype (mime-edit-get-contype tag)) + (encoding (mime-edit-get-encoding tag))) + (insert (concat prefix "--" boundary "\n")) + (save-restriction + (narrow-to-region (point)(point)) + (insert "Content-Type: " contype "\n") + (if encoding + (insert "Content-Transfer-Encoding: " encoding "\n")) + (mime-encode-header-in-buffer)) + (cons (and contype + (downcase contype)) + (and encoding + (downcase encoding)))) + ))) + +(defun mime-edit-translate-region (beg end &optional boundary multipart) + (or boundary + (setq boundary (mime-edit-make-boundary)) + ) + (save-excursion + (save-restriction + (narrow-to-region beg end) + (let ((tag nil) ;MIME tag + (contype nil) ;Content-Type + (encoding nil) ;Content-Transfer-Encoding + (nparts 0)) ;Number of body parts + ;; Normalize the body part by inserting appropriate message + ;; tags for every message contents. + (mime-edit-normalize-body) + ;; Counting the number of Content-Type. + (goto-char (point-min)) + (while (re-search-forward mime-edit-single-part-tag-regexp nil t) + (setq nparts (1+ nparts))) + ;; Begin translation. + (cond + ((and (<= nparts 1)(not multipart)) + ;; It's a singular message. + (goto-char (point-min)) + (while (re-search-forward + mime-edit-single-part-tag-regexp nil t) + (setq tag + (buffer-substring (match-beginning 0) (match-end 0))) + (delete-region (match-beginning 0) (1+ (match-end 0))) + (setq contype (mime-edit-get-contype tag)) + (setq encoding (mime-edit-get-encoding tag)) + )) + (t + ;; It's a multipart message. + (goto-char (point-min)) + (let ((prio mime-content-transfer-encoding-priority-list) + part-info nprio) + (when (setq part-info + (mime-edit-translate-single-part-tag boundary)) + (and (setq nprio (member (cdr part-info) prio)) + (setq prio nprio)) + (while (setq part-info + (mime-edit-translate-single-part-tag boundary "\n")) + (and (setq nprio (member (cdr part-info) prio)) + (setq prio nprio)))) + ;; Define Content-Type as "multipart/mixed". + (setq contype + (concat "multipart/mixed;\n boundary=\"" boundary "\"")) + (setq encoding (car prio)) + ;; Insert the trailer. + (goto-char (point-max)) + (insert "\n--" boundary "--\n") + ))) + (list contype encoding boundary nparts) + )))) + +(defun mime-edit-normalize-body () + "Normalize the body part by inserting appropriate message tags." + ;; Insert the first MIME tags if necessary. + (goto-char (point-min)) + (if (not (looking-at mime-edit-single-part-tag-regexp)) + (insert (mime-make-text-tag) "\n")) + ;; Check each tag, and add new tag or correct it if necessary. + (goto-char (point-min)) + (while (re-search-forward mime-edit-single-part-tag-regexp nil t) + (let* ((tag (buffer-substring (match-beginning 0) (match-end 0))) + (contype (mime-edit-get-contype tag)) + (charset (mime-get-parameter contype "charset")) + (encoding (mime-edit-get-encoding tag))) + ;; Remove extra whitespaces after the tag. + (if (looking-at "[ \t]+$") + (delete-region (match-beginning 0) (match-end 0))) + (let ((beg (point)) + (end (mime-edit-content-end)) + ) + (if (= end (point-max)) + nil + (goto-char end) + (or (looking-at mime-edit-beginning-tag-regexp) + (eobp) + (insert (mime-make-text-tag) "\n") + )) + (visible-region beg end) + (goto-char beg) + ) + (cond + ((mime-test-content-type contype "message") + ;; Content-type "message" should be sent as is. + (forward-line 1) + ) + ((mime-test-content-type contype "text") + ;; Define charset for text if necessary. + (setq charset (if charset + (intern (downcase charset)) + (mime-edit-choose-charset))) + (mime-edit-define-charset charset) + (cond ((string-equal contype "text/x-rot13-47-48") + (save-excursion + (forward-line) + (mule-caesar-region (point) (mime-edit-content-end)) + )) + ((string-equal contype "text/enriched") + (save-excursion + (let ((beg (progn + (forward-line) + (point))) + (end (mime-edit-content-end)) + ) + ;; Patch for hard newlines + ;; (save-excursion + ;; (goto-char beg) + ;; (while (search-forward "\n" end t) + ;; (put-text-property (match-beginning 0) + ;; (point) + ;; 'hard t))) + ;; End patch for hard newlines + (enriched-encode beg end nil) + (goto-char beg) + (if (search-forward "\n\n") + (delete-region beg (match-end 0)) + ) + )))) + ;; Point is now on current tag. + ;; Define encoding and encode text if necessary. + (or encoding ;Encoding is not specified. + (let* ((encoding + (let (bits conv) + (let ((ret (cdr (assq charset mime-charset-type-list)))) + (if ret + (setq bits (car ret) + conv (nth 1 ret)) + (setq bits 8 + conv "quoted-printable"))) + (if (<= bits mime-transfer-level) + (mime-encoding-name bits) + conv))) + (beg (mime-edit-content-beginning))) + (encode-mime-charset-region beg (mime-edit-content-end) + charset) + ;; Protect "From " in beginning of line + (save-restriction + (narrow-to-region beg (mime-edit-content-end)) + (goto-char beg) + (let (case-fold-search) + (if (re-search-forward "^From " nil t) + (unless encoding + (if (memq charset '(iso-2022-jp + iso-2022-jp-2 + iso-2022-int-1 + x-ctext)) + (while (progn + (replace-match "\e(BFrom ") + (re-search-forward "^From " nil t) + )) + (setq encoding "quoted-printable") + ))))) + ;; canonicalize line break code + (or (member encoding '(nil "7bit" "8bit" "quoted-printable")) + (save-restriction + (narrow-to-region beg (mime-edit-content-end)) + (goto-char beg) + (while (re-search-forward "\\(\\=\\|[^\r]\\)\n" nil t) + (replace-match "\\1\r\n")))) + (goto-char beg) + (mime-encode-region beg (mime-edit-content-end) + (or encoding "7bit")) + (mime-edit-define-encoding encoding) + )) + (goto-char (mime-edit-content-end)) + ) + ((null encoding) ;Encoding is not specified. + ;; Application, image, audio, video, and any other + ;; unknown content-type without encoding should be + ;; encoded. + (let* ((encoding "base64") ;Encode in BASE64 by default. + (beg (mime-edit-content-beginning)) + (end (mime-edit-content-end))) + (mime-encode-region beg end encoding) + (mime-edit-define-encoding encoding)) + (forward-line 1) + )) + ))) + +(defun mime-delete-field (field) + "Delete header FIELD." + (let ((regexp (format "^%s:[ \t]*" field))) + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (delete-region (match-beginning 0) + (1+ (std11-field-end)))))) + + +;;; +;;; Platform dependent functions +;;; + +;; Sun implementations + +(defun mime-edit-voice-recorder-for-sun (encoding) + "Record voice in a buffer using Sun audio device, +and insert data encoded as ENCODING." + (message "Start the recording on %s. Type C-g to finish the recording..." + (system-name)) + (mime-insert-encoded-file "/dev/audio" encoding) + ) + + +;;; @ Other useful commands. +;;; + +;; Message forwarding commands as content-type "message/rfc822". + +(defun mime-edit-insert-message (&optional message) + (interactive) + (let ((inserter (cdr (assq major-mode mime-edit-message-inserter-alist)))) + (if (and inserter (fboundp inserter)) + (progn + (mime-edit-insert-tag "message" "rfc822") + (funcall inserter message) + ) + (message "Sorry, I don't have message inserter for your MUA.") + ))) + +(defun mime-edit-insert-mail (&optional message) + (interactive) + (let ((inserter (cdr (assq major-mode mime-edit-mail-inserter-alist)))) + (if (and inserter (fboundp inserter)) + (progn + (mime-edit-insert-tag "message" "rfc822") + (funcall inserter message) + ) + (message "Sorry, I don't have mail inserter for your MUA.") + ))) + +(defun mime-edit-inserted-message-filter () + (save-excursion + (save-restriction + (let ((header-start (point)) + (case-fold-search t) + beg end) + ;; for Emacs 18 + ;; (if (re-search-forward "^$" (marker-position (mark-marker))) + (if (re-search-forward "^$" (mark t)) + (narrow-to-region header-start (match-beginning 0)) + ) + (goto-char header-start) + (while (and (re-search-forward + mime-edit-yank-ignored-field-regexp nil t) + (setq beg (match-beginning 0)) + (setq end (1+ (std11-field-end))) + ) + (delete-region beg end) + ) + )))) + + +;;; @ multipart enclosure +;;; + +(defun mime-edit-enclose-region-internal (type beg end) + (save-excursion + (goto-char beg) + (save-restriction + (narrow-to-region beg end) + (insert (format "--<<%s>>-{\n" type)) + (goto-char (point-max)) + (insert (format "--}-<<%s>>\n" type)) + (goto-char (point-max)) + ) + (or (looking-at mime-edit-beginning-tag-regexp) + (eobp) + (insert (mime-make-text-tag) "\n") + ) + )) + +(defun mime-edit-enclose-quote-region (beg end) + (interactive "*r") + (mime-edit-enclose-region-internal 'quote beg end) + ) + +(defun mime-edit-enclose-mixed-region (beg end) + (interactive "*r") + (mime-edit-enclose-region-internal 'mixed beg end) + ) + +(defun mime-edit-enclose-parallel-region (beg end) + (interactive "*r") + (mime-edit-enclose-region-internal 'parallel beg end) + ) + +(defun mime-edit-enclose-digest-region (beg end) + (interactive "*r") + (mime-edit-enclose-region-internal 'digest beg end) + ) + +(defun mime-edit-enclose-alternative-region (beg end) + (interactive "*r") + (mime-edit-enclose-region-internal 'alternative beg end) + ) + +(defun mime-edit-enclose-pgp-signed-region (beg end) + (interactive "*r") + (mime-edit-enclose-region-internal 'pgp-signed beg end) + ) + +(defun mime-edit-enclose-pgp-encrypted-region (beg end) + (interactive "*r") + (mime-edit-enclose-region-internal 'pgp-encrypted beg end) + ) + +(defun mime-edit-enclose-kazu-signed-region (beg end) + (interactive "*r") + (mime-edit-enclose-region-internal 'kazu-signed beg end) + ) + +(defun mime-edit-enclose-kazu-encrypted-region (beg end) + (interactive "*r") + (mime-edit-enclose-region-internal 'kazu-encrypted beg end) + ) + +(defun mime-edit-enclose-smime-signed-region (beg end) + (interactive "*r") + (mime-edit-enclose-region-internal 'smime-signed beg end) + ) + +(defun mime-edit-enclose-smime-encrypted-region (beg end) + (interactive "*r") + (mime-edit-enclose-region-internal 'smime-encrypted beg end) + ) + +(defun mime-edit-insert-key (&optional arg) + "Insert a pgp public key." + (interactive "P") + (mime-edit-insert-tag "application" "pgp-keys") + (mime-edit-define-encoding "7bit") + (pgg-insert-key) + (if (and (not (eobp)) + (not (looking-at mime-edit-single-part-tag-regexp))) + (insert (mime-make-text-tag) "\n"))) + + +;;; @ flag setting +;;; + +(defun mime-edit-set-split (arg) + (interactive + (list + (y-or-n-p "Do you want to enable split? ") + )) + (setq mime-edit-split-message arg) + (if arg + (message "This message is enabled to split.") + (message "This message is not enabled to split.") + )) + +(defun mime-edit-toggle-transfer-level (&optional transfer-level) + "Toggle transfer-level is 7bit or 8bit through. + +Optional TRANSFER-LEVEL is a number of transfer-level, 7 or 8." + (interactive) + (if (numberp transfer-level) + (setq mime-transfer-level transfer-level) + (if (< mime-transfer-level 8) + (setq mime-transfer-level 8) + (setq mime-transfer-level 7) + )) + (message (format "Current transfer-level is %d bit" + mime-transfer-level)) + (setq mime-transfer-level-string + (mime-encoding-name mime-transfer-level 'not-omit)) + (force-mode-line-update) + ) + +(defun mime-edit-set-transfer-level-7bit () + (interactive) + (mime-edit-toggle-transfer-level 7) + ) + +(defun mime-edit-set-transfer-level-8bit () + (interactive) + (mime-edit-toggle-transfer-level 8) + ) + + +;;; @ pgp +;;; + +(defvar mime-edit-pgp-processing nil) +(make-variable-buffer-local 'mime-edit-pgp-processing) + +(defun mime-edit-set-sign (arg) + (interactive + (list + (y-or-n-p "Do you want to sign? ") + )) + (if arg + (progn + (or (memq 'sign mime-edit-pgp-processing) + (setq mime-edit-pgp-processing + (nconc mime-edit-pgp-processing + (copy-sequence '(sign))))) + (message "This message will be signed.") + ) + (setq mime-edit-pgp-processing + (delq 'sign mime-edit-pgp-processing)) + (message "This message will not be signed.") + )) + +(defun mime-edit-set-encrypt (arg) + (interactive + (list + (y-or-n-p "Do you want to encrypt? ") + )) + (if arg + (progn + (or (memq 'encrypt mime-edit-pgp-processing) + (setq mime-edit-pgp-processing + (nconc mime-edit-pgp-processing + (copy-sequence '(encrypt))))) + (message "This message will be encrypt.") + ) + (setq mime-edit-pgp-processing + (delq 'encrypt mime-edit-pgp-processing)) + (message "This message will not be encrypt.") + )) + +(defun mime-edit-pgp-enclose-buffer () + (let ((beg (save-excursion + (goto-char (point-min)) + (if (search-forward (concat "\n" mail-header-separator "\n")) + (match-end 0) + ))) + ) + (if beg + (dolist (pgp-processing mime-edit-pgp-processing) + (case pgp-processing + (sign + (mime-edit-enclose-pgp-signed-region + beg (point-max)) + ) + (encrypt + (mime-edit-enclose-pgp-encrypted-region + beg (point-max)) + ))) + ))) + + +;;; @ split +;;; + +(defun mime-edit-insert-partial-header (fields subject + id number total separator) + (insert fields) + (insert (format "Subject: %s (%d/%d)\n" subject number total)) + (insert mime-edit-mime-version-field-for-message/partial) + (insert (format "\ +Content-Type: message/partial; id=%s; number=%d; total=%d\n%s\n" + id number total separator)) + ) + +(defun mime-edit-split-and-send + (&optional cmd lines mime-edit-message-max-length) + (interactive) + (or lines + (setq lines + (count-lines (point-min) (point-max))) + ) + (or mime-edit-message-max-length + (setq mime-edit-message-max-length + (or (cdr (assq major-mode mime-edit-message-max-lines-alist)) + mime-edit-message-default-max-lines)) + ) + (let* ((mime-edit-draft-file-name + (or (buffer-file-name) + (make-temp-name + (expand-file-name "mime-draft" temporary-file-directory)))) + (separator mail-header-separator) + (id (concat "\"" + (replace-space-with-underline (current-time-string)) + "@" (system-name) "\""))) + (run-hooks 'mime-edit-before-split-hook) + (let ((the-buf (current-buffer)) + (copy-buf (get-buffer-create " *Original Message*")) + (header (std11-header-string-except + mime-edit-split-ignored-field-regexp separator)) + (subject (mail-fetch-field "subject")) + (total (+ (/ lines mime-edit-message-max-length) + (if (> (mod lines mime-edit-message-max-length) 0) + 1))) + (command + (or cmd + (cdr + (assq major-mode + mime-edit-split-message-sender-alist)) + (function + (lambda () + (interactive) + (error "Split sender is not specified for `%s'." major-mode) + )) + )) + (mime-edit-partial-number 1) + data) + (save-excursion + (set-buffer copy-buf) + (erase-buffer) + (insert-buffer the-buf) + (save-restriction + (if (re-search-forward + (concat "^" (regexp-quote separator) "$") nil t) + (let ((he (match-beginning 0))) + (replace-match "") + (narrow-to-region (point-min) he) + )) + (goto-char (point-min)) + (while (re-search-forward mime-edit-split-blind-field-regexp nil t) + (delete-region (match-beginning 0) + (1+ (std11-field-end))) + ))) + (while (< mime-edit-partial-number total) + (erase-buffer) + (save-excursion + (set-buffer copy-buf) + (setq data (buffer-substring + (point-min) + (progn + (goto-line mime-edit-message-max-length) + (point)) + )) + (delete-region (point-min)(point)) + ) + (mime-edit-insert-partial-header + header subject id mime-edit-partial-number total separator) + (insert data) + (save-excursion + (message (format "Sending %d/%d..." + mime-edit-partial-number total)) + (call-interactively command) + (message (format "Sending %d/%d... done" + mime-edit-partial-number total)) + ) + (setq mime-edit-partial-number + (1+ mime-edit-partial-number)) + ) + (erase-buffer) + (save-excursion + (set-buffer copy-buf) + (setq data (buffer-string)) + (erase-buffer) + ) + (mime-edit-insert-partial-header + header subject id mime-edit-partial-number total separator) + (insert data) + (save-excursion + (message (format "Sending %d/%d..." + mime-edit-partial-number total)) + (message (format "Sending %d/%d... done" + mime-edit-partial-number total)) + ) + ))) + +(defun mime-edit-maybe-split-and-send (&optional cmd) + (interactive) + (run-hooks 'mime-edit-before-send-hook) + (let ((mime-edit-message-max-length + (or (cdr (assq major-mode mime-edit-message-max-lines-alist)) + mime-edit-message-default-max-lines)) + (lines (count-lines (point-min) (point-max))) + ) + (if (and (> lines mime-edit-message-max-length) + mime-edit-split-message) + (mime-edit-split-and-send cmd lines mime-edit-message-max-length) + ))) + + +;;; @ preview message +;;; + +(defvar mime-edit-buffer nil) ; buffer local variable + +(defun mime-edit-preview-message () + "preview editing MIME message." + (interactive) + (let* ((str (buffer-string)) + (separator mail-header-separator) + (the-buf (current-buffer)) + (buf-name (buffer-name)) + (temp-buf-name (concat "*temp-article:" buf-name "*")) + (buf (get-buffer temp-buf-name)) + (pgp-processing mime-edit-pgp-processing) + ) + (if buf + (progn + (switch-to-buffer buf) + (erase-buffer) + ) + (setq buf (get-buffer-create temp-buf-name)) + (switch-to-buffer buf) + ) + (insert str) + (setq major-mode 'mime-temp-message-mode) + (make-local-variable 'mail-header-separator) + (setq mail-header-separator separator) + (make-local-variable 'mime-edit-buffer) + (setq mime-edit-buffer the-buf) + (setq mime-edit-pgp-processing pgp-processing) + + (run-hooks 'mime-edit-translate-hook) + (mime-edit-translate-buffer) + (goto-char (point-min)) + (if (re-search-forward + (concat "^" (regexp-quote separator) "$")) + (replace-match "") + ) + (mime-view-buffer) + (make-local-variable 'mime-edit-temp-message-buffer) + (setq mime-edit-temp-message-buffer buf))) + +(defun mime-edit-quitting-method () + "Quitting method for mime-view." + (let* ((temp mime-edit-temp-message-buffer) + buf) + (mime-preview-kill-buffer) + (set-buffer temp) + (setq buf mime-edit-buffer) + (kill-buffer temp) + (switch-to-buffer buf))) + +(set-alist 'mime-preview-quitting-method-alist + 'mime-temp-message-mode + #'mime-edit-quitting-method) + + +;;; @ edit again +;;; + +(defvar mime-edit-again-ignored-field-regexp + (concat "^\\(" "Content-.*\\|Mime-Version" + (if mime-edit-insert-user-agent-field "\\|User-Agent") + "\\):") + "Regexp for deleted header fields when `mime-edit-again' is called.") + +(defsubst eliminate-top-spaces (string) + "Eliminate top sequence of space or tab in STRING." + (if (string-match "^[ \t]+" string) + (substring string (match-end 0)) + string)) + +(defun mime-edit-decode-multipart-in-buffer (content-type not-decode-text) + (let* ((subtype + (or + (cdr (assoc (mime-content-type-parameter content-type "protocol") + '(("application/pgp-encrypted" . pgp-encrypted) + ("application/pgp-signature" . pgp-signed)))) + (mime-content-type-subtype content-type))) + (boundary (mime-content-type-parameter content-type "boundary")) + (boundary-pat (concat "\n--" (regexp-quote boundary) "[ \t]*\n"))) + (re-search-forward boundary-pat nil t) + (let ((bb (match-beginning 0)) eb tag) + (setq tag (format "\n--<<%s>>-{\n" subtype)) + (goto-char bb) + (insert tag) + (setq bb (+ bb (length tag))) + (re-search-forward + (concat "\n--" (regexp-quote boundary) "--[ \t]*\n") + nil t) + (setq eb (match-beginning 0)) + (replace-match (format "--}-<<%s>>\n" subtype)) + (save-restriction + (narrow-to-region bb eb) + (goto-char (point-min)) + (while (re-search-forward boundary-pat nil t) + (let ((beg (match-beginning 0)) + end) + (delete-region beg (match-end 0)) + (save-excursion + (if (re-search-forward boundary-pat nil t) + (setq end (match-beginning 0)) + (setq end (point-max)) + ) + (save-restriction + (narrow-to-region beg end) + (cond + ((eq subtype 'pgp-encrypted) + (when (and + (progn + (goto-char (point-min)) + (re-search-forward "^-+BEGIN PGP MESSAGE-+$" + nil t)) + (prog1 + (save-window-excursion + (pgg-decrypt-region (match-beginning 0) + (point-max))) + (delete-region (point-min)(point-max)))) + (insert-buffer-substring pgg-output-buffer) + (mime-edit-decode-message-in-buffer + nil not-decode-text) + (delete-region (goto-char (point-min)) + (if (search-forward "\n\n" nil t) + (match-end 0) + (point-min))) + (goto-char (point-max)) + )) + (t + (mime-edit-decode-message-in-buffer + (if (eq subtype 'digest) + (eval-when-compile + (make-mime-content-type 'message 'rfc822)) + ) + not-decode-text) + (goto-char (point-max)) + )) + )))) + )) + (goto-char (point-min)) + (or (= (point-min) 1) + (delete-region (point-min) + (if (search-forward "\n\n" nil t) + (match-end 0) + (point-min) + ))) + )) + +(defun mime-edit-decode-single-part-in-buffer + (content-type not-decode-text &optional content-disposition) + (let* ((type (mime-content-type-primary-type content-type)) + (subtype (mime-content-type-subtype content-type)) + (ctype (format "%s/%s" type subtype)) + charset + (pstr (let ((bytes (+ 14 (length ctype)))) + (mapconcat (function + (lambda (attr) + (if (string= (car attr) "charset") + (progn + (setq charset (cdr attr)) + "") + (let* ((str (concat (car attr) + "=" (cdr attr))) + (bs (length str))) + (setq bytes (+ bytes bs 2)) + (if (< bytes 76) + (concat "; " str) + (setq bytes (+ bs 1)) + (concat ";\n " str) + ) + )))) + (mime-content-type-parameters content-type) ""))) + encoding + encoded + (limit (save-excursion + (if (search-forward "\n\n" nil t) + (1- (point))))) + (disposition-type + (mime-content-disposition-type content-disposition)) + (disposition-str + (if disposition-type + (let ((bytes (+ 21 (length (format "%s" disposition-type))))) + (mapconcat (function + (lambda (attr) + (let* ((str (concat + (car attr) + "=" + (if (string-equal "filename" + (car attr)) + (std11-wrap-as-quoted-string + (cdr attr)) + (cdr attr)))) + (bs (length str))) + (setq bytes (+ bytes bs 2)) + (if (< bytes 76) + (concat "; " str) + (setq bytes (+ bs 1)) + (concat ";\n " str) + ) + ))) + (mime-content-disposition-parameters + content-disposition) + "")))) + ) + (if disposition-type + (setq pstr (format "%s\nContent-Disposition: %s%s" + pstr disposition-type disposition-str)) + ) + (save-excursion + (if (re-search-forward + "^Content-Transfer-Encoding:" limit t) + (let ((beg (match-beginning 0)) + (hbeg (match-end 0)) + (end (std11-field-end limit))) + (setq encoding + (downcase + (eliminate-top-spaces + (std11-unfold-string + (buffer-substring hbeg end))))) + (if (or charset (eq type 'text)) + (progn + (delete-region beg (1+ end)) + (goto-char (point-min)) + (if (search-forward "\n\n" nil t) + (progn + (mime-decode-region + (match-end 0)(point-max) encoding) + (setq encoded t + encoding nil) + ))))))) + (if (or encoded (not not-decode-text)) + (progn + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "\r\n" nil t) + (replace-match "\n") + )) + (decode-mime-charset-region (point-min)(point-max) + (or charset default-mime-charset)) + )) + (let ((he (if (re-search-forward "^$" nil t) + (match-end 0) + (point-min) + ))) + (if (and (eq type 'text) + (eq subtype 'x-rot13-47-48)) + (mule-caesar-region he (point-max)) + ) + (if (= (point-min) 1) + (progn + (goto-char he) + (insert + (concat "\n" + (mime-create-tag + (format "%s/%s%s" type subtype pstr) + encoding))) + ) + (delete-region (point-min) he) + (insert + (mime-create-tag (format "%s/%s%s" type subtype pstr) + encoding)) + )) + )) + +;;;###autoload +(defun mime-edit-decode-message-in-buffer (&optional default-content-type + not-decode-text) + (save-excursion + (goto-char (point-min)) + (let ((ctl (or (mime-read-Content-Type) + default-content-type))) + (if ctl + (let ((type (mime-content-type-primary-type ctl))) + (cond + ((and (eq type 'application) + (eq (mime-content-type-subtype ctl) 'pgp-signature)) + (delete-region (point-min)(point-max)) + ) + ((eq type 'multipart) + (mime-edit-decode-multipart-in-buffer ctl not-decode-text) + ) + (t + (mime-edit-decode-single-part-in-buffer + ctl not-decode-text (mime-read-Content-Disposition)) + ))) + (or not-decode-text + (decode-mime-charset-region (point-min) (point-max) + default-mime-charset)) + ) + (if (= (point-min) 1) + (progn + (save-restriction + (std11-narrow-to-header) + (goto-char (point-min)) + (while (re-search-forward + mime-edit-again-ignored-field-regexp nil t) + (delete-region (match-beginning 0) (1+ (std11-field-end))) + )) + (mime-decode-header-in-buffer (not not-decode-text)) + )) + ))) + +;;;###autoload +(defun mime-edit-again (&optional not-decode-text no-separator not-turn-on) + "Convert current buffer to MIME-Edit buffer and turn on MIME-Edit mode. +Content-Type and Content-Transfer-Encoding header fields will be +converted to MIME-Edit tags." + (interactive) + (goto-char (point-min)) + (if (search-forward + (concat "\n" (regexp-quote mail-header-separator) "\n") + nil t) + (replace-match "\n\n") + ) + (mime-edit-decode-message-in-buffer nil not-decode-text) + (goto-char (point-min)) + (or no-separator + (and (re-search-forward "^$") + (replace-match mail-header-separator) + )) + (or not-turn-on + (turn-on-mime-edit) + )) + + +;;; @ end +;;; + +(provide 'mime-edit) + +(run-hooks 'mime-edit-load-hook) + +;;; mime-edit.el ends here diff --git a/mime/mime-image.el b/mime/mime-image.el new file mode 100644 index 0000000..76c2335 --- /dev/null +++ b/mime/mime-image.el @@ -0,0 +1,206 @@ +;;; mime-image.el --- mime-view filter to display images + +;; Copyright (C) 1995,1996,1997,1998 MORIOKA Tomohiko +;; Copyright (C) 1996 Dan Rich + +;; Author: MORIOKA Tomohiko +;; Dan Rich +;; Daiki Ueno +;; Katsumi Yamaoka +;; Maintainer: MORIOKA Tomohiko +;; Created: 1995/12/15 +;; Renamed: 1997/2/21 from tm-image.el + +;; Keywords: image, picture, X-Face, MIME, multimedia, mail, news + +;; This file is part of SEMI (Showy Emacs MIME Interfaces). + +;; 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 XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: +;; If you use this program with MULE, please install +;; etl8x16-bitmap.bdf font included in tl package. + +;;; Code: + +(eval-when-compile (require 'cl)) + +(eval-when-compile (require 'static)) + +(require 'mime-view) +(require 'alist) +(require 'path-util) + +(defsubst mime-image-normalize-xbm-buffer (buffer) + (save-excursion + (set-buffer buffer) + (let ((case-fold-search t) width height xbytes right margin) + (goto-char (point-min)) + (or (re-search-forward "_width[\t ]+\\([0-9]+\\)" nil t) + (error "!! Illegal xbm file format" (current-buffer))) + (setq width (string-to-int (match-string 1)) + xbytes (/ (+ width 7) 8)) + (goto-char (point-min)) + (or (re-search-forward "_height[\t ]+\\([0-9]+\\)" nil t) + (error "!! Illegal xbm file format" (current-buffer))) + (setq height (string-to-int (match-string 1))) + (goto-char (point-min)) + (re-search-forward "0x[0-9a-f][0-9a-f],") + (delete-region (point-min) (match-beginning 0)) + (goto-char (point-min)) + (while (re-search-forward "[\n\r\t ,;}]" nil t) + (replace-match "")) + (goto-char (point-min)) + (while (re-search-forward "0x" nil t) + (replace-match "\\x" nil t)) + (goto-char (point-min)) + (insert "(" (number-to-string width) " " + (number-to-string height) " \"") + (goto-char (point-max)) + (insert "\")") + (goto-char (point-min)) + (read (current-buffer))))) + +(static-if (featurep 'xemacs) + (progn + (defun mime-image-type-available-p (type) + (memq type (image-instantiator-format-list))) + + (defun mime-image-create (file-or-data &optional type data-p &rest props) + (when (and data-p (eq type 'xbm)) + (with-temp-buffer + (insert file-or-data) + (setq file-or-data + (mime-image-normalize-xbm-buffer (current-buffer))))) + (let ((glyph + (make-glyph + (if (and type (mime-image-type-available-p type)) + (vconcat + (list type (if data-p :data :file) file-or-data) + props) + file-or-data)))) + (if (nothing-image-instance-p (glyph-image-instance glyph)) nil + glyph))) + + (defun mime-image-insert (image &optional string area) + (let ((extent (make-extent (point) + (progn (and string + (insert string)) + (point))))) + (set-extent-property extent 'invisible t) + (set-extent-end-glyph extent image)))) + (condition-case nil + (progn + (require 'image) + (defalias 'mime-image-type-available-p 'image-type-available-p) + (defun mime-image-create + (file-or-data &optional type data-p &rest props) + (if (and data-p (eq type 'xbm)) + (with-temp-buffer + (insert file-or-data) + (setq file-or-data + (mime-image-normalize-xbm-buffer (current-buffer))) + (apply #'create-image (nth 2 file-or-data) type data-p + (nconc + (list :width (car file-or-data) + :height (nth 1 file-or-data)) + props))) + (apply #'create-image file-or-data type data-p props))) + (defalias 'mime-image-insert 'insert-image)) + (error + (condition-case nil + (progn + (require (if (featurep 'mule) 'bitmap "")) + (defun mime-image-read-xbm-buffer (buffer) + (condition-case nil + (mapconcat #'bitmap-compose + (append (bitmap-decode-xbm + (bitmap-read-xbm-buffer + (current-buffer))) nil) "\n") + (error nil))) + (defun mime-image-insert (image &optional string area) + (insert image))) + (error + (defalias 'mime-image-read-xbm-buffer + 'mime-image-normalize-xbm-buffer) + (defun mime-image-insert (image &optional string area) + (save-restriction + (narrow-to-region (point)(point)) + (let ((face (gensym "mii"))) + (or (facep face) (make-face face)) + (set-face-stipple face image) + (let ((row (make-string (/ (car image) (frame-char-width)) ? )) + (height (/ (nth 1 image) (frame-char-height))) + (i 0)) + (while (< i height) + (set-text-properties (point) (progn (insert row)(point)) + (list 'face face)) + (insert "\n") + (setq i (1+ i))))))))) + + (defun mime-image-type-available-p (type) + (eq type 'xbm)) + + (defun mime-image-create (file-or-data &optional type data-p &rest props) + (when (or (null type) (eq type 'xbm)) + (with-temp-buffer + (if data-p + (insert file-or-data) + (insert-file-contents file-or-data)) + (mime-image-read-xbm-buffer (current-buffer)))))))) + +(defvar mime-image-format-alist + '((image jpeg jpeg) + (image gif gif) + (image tiff tiff) + (image x-tiff tiff) + (image xbm xbm) + (image x-xbm xbm) + (image x-xpixmap xpm) + (image png png))) + +(dolist (rule mime-image-format-alist) + (when (mime-image-type-available-p (nth 2 rule)) + (ctree-set-calist-strictly + 'mime-preview-condition + (list (cons 'type (car rule))(cons 'subtype (nth 1 rule)) + '(body . visible) + (cons 'body-presentation-method #'mime-display-image) + (cons 'image-format (nth 2 rule)))))) + + +;;; @ content filter for images +;;; +;; (for XEmacs 19.12 or later) + +(defun mime-display-image (entity situation) + (message "Decoding image...") + (let ((format (cdr (assq 'image-format situation))) + image) + (setq image (mime-image-create (mime-entity-content entity) format 'data)) + (if (null image) + (message "Invalid glyph!") + (save-excursion + (mime-image-insert image) + (insert "\n") + (message "Decoding image... done"))))) + +;;; @ end +;;; + +(provide 'mime-image) + +;;; mime-image.el ends here diff --git a/mime/mime-parse.el b/mime/mime-parse.el new file mode 100644 index 0000000..2323fba --- /dev/null +++ b/mime/mime-parse.el @@ -0,0 +1,358 @@ +;;; mime-parse.el --- MIME message parser + +;; Copyright (C) 1994,1995,1996,1997,1998,1999 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Keywords: parse, MIME, multimedia, mail, news + +;; This file is part of SEMI (Spadework for Emacs MIME Interfaces). + +;; 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-def) +(require 'luna) +(require 'std11) + +(autoload 'mime-entity-body-buffer "mime") +(autoload 'mime-entity-body-start-point "mime") +(autoload 'mime-entity-body-end-point "mime") + + +;;; @ lexical analyzer +;;; + +(defcustom mime-lexical-analyzer + '(std11-analyze-quoted-string + std11-analyze-domain-literal + std11-analyze-comment + std11-analyze-spaces + mime-analyze-tspecial + mime-analyze-token) + "*List of functions to return result of lexical analyze. +Each function must have two arguments: STRING and START. +STRING is the target string to be analyzed. +START is start position of STRING to analyze. + +Previous function is preferred to next function. If a function +returns nil, next function is used. Otherwise the return value will +be the result." + :group 'mime + :type '(repeat function)) + +(defun mime-analyze-tspecial (string start) + (if (and (> (length string) start) + (memq (aref string start) mime-tspecial-char-list)) + (cons (cons 'tpecials (substring string start (1+ start))) + (1+ start)) + )) + +(defun mime-analyze-token (string start) + (if (and (string-match mime-token-regexp string start) + (= (match-beginning 0) start)) + (let ((end (match-end 0))) + (cons (cons 'mime-token (substring string start end)) + ;;(substring string end) + end) + ))) + + +;;; @ field parser +;;; + +(defconst mime/content-parameter-value-regexp + (concat "\\(" + std11-quoted-string-regexp + "\\|[^; \t\n]*\\)")) + +(defconst mime::parameter-regexp + (concat "^[ \t]*\;[ \t]*\\(" mime-token-regexp "\\)" + "[ \t]*=[ \t]*\\(" mime/content-parameter-value-regexp "\\)")) + +(defun mime-parse-parameter (str) + (if (string-match mime::parameter-regexp str) + (let ((e (match-end 2))) + (cons + (cons (downcase (substring str (match-beginning 1) (match-end 1))) + (std11-strip-quoted-string + (substring str (match-beginning 2) e)) + ) + (substring str e) + )))) + + +;;; @ Content-Type +;;; + +;;;###autoload +(defun mime-parse-Content-Type (string) + "Parse STRING as field-body of Content-Type field. +Return value is + (PRIMARY-TYPE SUBTYPE (NAME1 . VALUE1)(NAME2 . VALUE2) ...) +or nil. PRIMARY-TYPE and SUBTYPE are symbol and NAME_n and VALUE_n +are string." + (setq string (std11-unfold-string string)) + (if (string-match `,(concat "^\\(" mime-token-regexp + "\\)/\\(" mime-token-regexp "\\)") string) + (let* ((type (downcase + (substring string (match-beginning 1) (match-end 1)))) + (subtype (downcase + (substring string (match-beginning 2) (match-end 2)))) + ret dest) + (setq string (substring string (match-end 0))) + (while (setq ret (mime-parse-parameter string)) + (setq dest (cons (car ret) dest) + string (cdr ret)) + ) + (make-mime-content-type (intern type)(intern subtype) + (nreverse dest)) + ))) + +;;;###autoload +(defun mime-read-Content-Type () + "Read field-body of Content-Type field from current-buffer, +and return parsed it. Format of return value is as same as +`mime-parse-Content-Type'." + (let ((str (std11-field-body "Content-Type"))) + (if str + (mime-parse-Content-Type str) + ))) + + +;;; @ Content-Disposition +;;; + +(eval-and-compile + (defconst mime-disposition-type-regexp mime-token-regexp) + ) + +;;;###autoload +(defun mime-parse-Content-Disposition (string) + "Parse STRING as field-body of Content-Disposition field." + (setq string (std11-unfold-string string)) + (if (string-match (eval-when-compile + (concat "^" mime-disposition-type-regexp)) string) + (let* ((e (match-end 0)) + (type (downcase (substring string 0 e))) + ret dest) + (setq string (substring string e)) + (while (setq ret (mime-parse-parameter string)) + (setq dest (cons (car ret) dest) + string (cdr ret)) + ) + (cons (cons 'type (intern type)) + (nreverse dest)) + ))) + +;;;###autoload +(defun mime-read-Content-Disposition () + "Read field-body of Content-Disposition field from current-buffer, +and return parsed it." + (let ((str (std11-field-body "Content-Disposition"))) + (if str + (mime-parse-Content-Disposition str) + ))) + + +;;; @ Content-Transfer-Encoding +;;; + +;;;###autoload +(defun mime-parse-Content-Transfer-Encoding (string) + "Parse STRING as field-body of Content-Transfer-Encoding field." + (let ((tokens (std11-lexical-analyze string mime-lexical-analyzer)) + token) + (while (and tokens + (setq token (car tokens)) + (std11-ignored-token-p token)) + (setq tokens (cdr tokens))) + (if token + (if (eq (car token) 'mime-token) + (downcase (cdr token)) + )))) + +;;;###autoload +(defun mime-read-Content-Transfer-Encoding (&optional default-encoding) + "Read field-body of Content-Transfer-Encoding field from +current-buffer, and return it. +If is is not found, return DEFAULT-ENCODING." + (let ((str (std11-field-body "Content-Transfer-Encoding"))) + (if str + (mime-parse-Content-Transfer-Encoding str) + default-encoding))) + + +;;; @ Content-Id / Message-Id +;;; + +;;;###autoload +(defun mime-parse-msg-id (tokens) + "Parse TOKENS as msg-id of Content-Id or Message-Id field." + (car (std11-parse-msg-id tokens))) + +;;;###autoload +(defun mime-uri-parse-cid (string) + "Parse STRING as cid URI." + (inline + (mime-parse-msg-id (cons '(specials . "<") + (nconc + (cdr (cdr (std11-lexical-analyze string))) + '((specials . ">"))))))) + + +;;; @ message parser +;;; + +;; (defun mime-parse-multipart (entity) +;; (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)) +;; (mime-entity-set-children-internal entity (nreverse children)) +;; ) +;; (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 +;; (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-external (entity) +;; (require 'mmexternal) +;; (mime-entity-set-children-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-external-entity nil +;; entity (cons 0 (mime-entity-node-id-internal entity)))) +;; ;; [tomo] Should we unify with `mime-parse-encapsulated'? +;; )))) + +(defun mime-parse-message (representation-type &optional default-ctl + parent node-id) + (let ((header-start (point-min)) + header-end + body-start + (body-end (point-max)) + content-type) + (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) + (setq content-type (or (let ((str (std11-fetch-field "Content-Type"))) + (if str + (mime-parse-Content-Type str) + )) + default-ctl)) + ) + (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) + )) + + +;;; @ for buffer +;;; + +;;;###autoload +(defun mime-parse-buffer (&optional buffer representation-type) + "Parse BUFFER as a MIME message. +If buffer is omitted, it parses current-buffer." + (save-excursion + (if buffer (set-buffer buffer)) + (mime-parse-message (or representation-type + 'mime-buffer-entity) nil))) + + +;;; @ end +;;; + +(provide 'mime-parse) + +;;; mime-parse.el ends here diff --git a/mime/mime-partial.el b/mime/mime-partial.el new file mode 100644 index 0000000..618c5a6 --- /dev/null +++ b/mime/mime-partial.el @@ -0,0 +1,98 @@ +;;; mime-partial.el --- Grabbing all MIME "message/partial"s. + +;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. + +;; Author: OKABE Yasuo @ Kyoto University +;; MORIOKA Tomohiko +;; Keywords: message/partial, MIME, multimedia, mail, news + +;; This file is part of SEMI (Suite of Emacs MIME Interfaces). + +;; 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-view) +(require 'mime-play) + +(defun mime-combine-message/partial-pieces-automatically (entity situation) + "Internal method for mime-view to combine message/partial messages +automatically." + (interactive) + (let* ((id (cdr (assoc "id" situation))) + (target (cdr (assq 'major-mode situation))) + (subject-buf (eval (cdr (assq 'summary-buffer-exp situation)))) + (mother (current-buffer)) + subject-id + (root-dir (expand-file-name + (concat "m-prts-" (user-login-name)) + temporary-file-directory)) + (request-partial-message-method + (cdr (assq 'request-partial-message-method situation))) + full-file) + (setq root-dir (concat root-dir "/" (replace-as-filename id))) + (setq full-file (concat root-dir "/FULL")) + + (if (null target) + (error "%s is not supported. Sorry." target) + ) + + ;; if you can't parse the subject line, try simple decoding method + (if (or (file-exists-p full-file) + (not (y-or-n-p "Merge partials?")) + ) + (mime-store-message/partial-piece entity situation) + (setq subject-id (mime-entity-read-field entity 'Subject)) + (if (string-match "[0-9\n]+" subject-id) + (setq subject-id (substring subject-id 0 (match-beginning 0))) + ) + (save-excursion + (set-buffer subject-buf) + (while (search-backward subject-id nil t)) + (catch 'tag + (while t + (let* ((message + ;; request message at the cursor in Subject buffer. + (save-window-excursion + (funcall request-partial-message-method) + )) + (situation (mime-entity-situation message)) + (the-id (cdr (assoc "id" situation)))) + (when (string= the-id id) + (with-current-buffer mother + (mime-store-message/partial-piece message situation) + ) + (if (file-exists-p full-file) + (throw 'tag nil) + )) + (if (not (progn + (end-of-line) + (search-forward subject-id nil t) + )) + (error "not found") + ) + )) + ))))) + + +;;; @ end +;;; + +(provide 'mime-partial) + +(run-hooks 'mime-partial-load-hook) + +;;; mime-partial.el ends here diff --git a/mime/mime-pgp.el b/mime/mime-pgp.el new file mode 100644 index 0000000..718ad9e --- /dev/null +++ b/mime/mime-pgp.el @@ -0,0 +1,286 @@ +;;; mime-pgp.el --- mime-view internal methods for PGP. + +;; Copyright (C) 1995,1996,1997,1998,1999,2000 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Daiki Ueno +;; Created: 1995/12/7 +;; Renamed: 1997/2/27 from tm-pgp.el +;; Keywords: PGP, security, MIME, multimedia, mail, news + +;; This file is part of SEMI (Secure Emacs MIME Interface). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This module is based on + +;; [security-multipart] RFC 1847: "Security Multiparts for MIME: +;; Multipart/Signed and Multipart/Encrypted" by +;; Jim Galvin , Sandy Murphy , +;; Steve Crocker and +;; Ned Freed (1995/10) + +;; [PGP/MIME] RFC 2015: "MIME Security with Pretty Good Privacy +;; (PGP)" by Michael Elkins (1996/6) + +;; [PGP-kazu] draft-kazu-pgp-mime-00.txt: "PGP MIME Integration" +;; by Kazuhiko Yamamoto (1995/10; +;; expired) + +;; [OpenPGP/MIME] draft-yamamoto-openpgp-mime-00.txt: "MIME +;; Security with OpenPGP (OpenPGP/MIME)" by Kazuhiko YAMAMOTO +;; (1998/1) + +;;; Code: + +(require 'mime-play) +(require 'pgg-def) + +(autoload 'pgg-decrypt-region "pgg" + "PGP decryption of current region." t) +(autoload 'pgg-verify-region "pgg" + "PGP verification of current region." t) +(autoload 'pgg-snarf-keys-region "pgg" + "Snarf PGP public keys in current region." t) +(autoload 'smime-decrypt-region "smime" + "S/MIME decryption of current region.") +(autoload 'smime-verify-region "smime" + "S/MIME verification of current region.") +(defvar smime-output-buffer) +(defvar smime-errors-buffer) + + +;;; @ Internal method for multipart/signed +;;; +;;; It is based on RFC 1847 (security-multipart). + +(defun mime-verify-multipart/signed (entity situation) + "Internal method to verify multipart/signed." + (mime-play-entity + (nth 1 (mime-entity-children entity)) ; entity-info of signature + (list (assq 'mode situation)) ; play-mode + )) + + +;;; @ internal method for application/pgp +;;; +;;; It is based on draft-kazu-pgp-mime-00.txt (PGP-kazu). + +(defun mime-view-application/pgp (entity situation) + (let* ((p-win (or (get-buffer-window (current-buffer)) + (get-largest-window))) + (new-name + (format "%s-%s" (buffer-name) (mime-entity-number entity))) + (mother (current-buffer)) + (preview-buffer (concat "*Preview-" (buffer-name) "*")) + representation-type message-buf) + (set-buffer (setq message-buf (get-buffer-create new-name))) + (erase-buffer) + (mime-insert-entity entity) + (cond ((progn + (goto-char (point-min)) + (re-search-forward "^-+BEGIN PGP SIGNED MESSAGE-+$" nil t)) + (pgg-verify-region (match-beginning 0)(point-max) nil 'fetch) + (goto-char (point-min)) + (delete-region + (point-min) + (and + (re-search-forward "^-+BEGIN PGP SIGNED MESSAGE-+\n\n") + (match-end 0))) + (delete-region + (and (re-search-forward "^-+BEGIN PGP SIGNATURE-+") + (match-beginning 0)) + (point-max)) + (goto-char (point-min)) + (while (re-search-forward "^- -" nil t) + (replace-match "-")) + (setq representation-type (if (mime-entity-cooked-p entity) + 'cooked))) + ((progn + (goto-char (point-min)) + (re-search-forward "^-+BEGIN PGP MESSAGE-+$" nil t)) + (pgg-decrypt-region (point-min)(point-max)) + (delete-region (point-min)(point-max)) + (insert-buffer pgg-output-buffer) + (setq representation-type 'binary))) + (setq major-mode 'mime-show-message-mode) + (save-window-excursion + (mime-view-buffer nil preview-buffer mother + nil representation-type) + (make-local-variable 'mime-view-temp-message-buffer) + (setq mime-view-temp-message-buffer message-buf)) + (set-window-buffer p-win preview-buffer))) + + +;;; @ Internal method for application/pgp-signature +;;; +;;; It is based on RFC 2015 (PGP/MIME) and +;;; draft-yamamoto-openpgp-mime-00.txt (OpenPGP/MIME). + +(defun mime-verify-application/pgp-signature (entity situation) + "Internal method to check PGP/MIME signature." + (let* ((entity-node-id (mime-entity-node-id entity)) + (mother (mime-entity-parent entity)) + (knum (car entity-node-id)) + (onum (if (> knum 0) + (1- knum) + (1+ knum))) + (orig-entity (nth onum (mime-entity-children mother))) + (basename (expand-file-name "tm" temporary-file-directory)) + (sig-file (concat (make-temp-name basename) ".asc")) + status) + (save-excursion + (mime-show-echo-buffer) + (set-buffer mime-echo-buffer-name) + (set-window-start + (get-buffer-window mime-echo-buffer-name) + (point-max))) + (mime-write-entity-content entity sig-file) + (unwind-protect + (with-temp-buffer + (mime-insert-entity orig-entity) + (goto-char (point-min)) + (while (progn (end-of-line) (not (eobp))) + (insert "\r") + (forward-line 1)) + (setq status (pgg-verify-region (point-min)(point-max) + sig-file 'fetch)) + (save-excursion + (set-buffer mime-echo-buffer-name) + (insert-buffer-substring (if status pgg-output-buffer + pgg-errors-buffer)))) + (delete-file sig-file)))) + + +;;; @ Internal method for application/pgp-encrypted +;;; +;;; It is based on RFC 2015 (PGP/MIME) and +;;; draft-yamamoto-openpgp-mime-00.txt (OpenPGP/MIME). + +(defun mime-decrypt-application/pgp-encrypted (entity situation) + (let* ((entity-node-id (mime-entity-node-id entity)) + (mother (mime-entity-parent entity)) + (knum (car entity-node-id)) + (onum (if (> knum 0) + (1- knum) + (1+ knum))) + (orig-entity (nth onum (mime-entity-children mother)))) + (mime-view-application/pgp orig-entity situation))) + + +;;; @ Internal method for application/pgp-keys +;;; +;;; It is based on RFC 2015 (PGP/MIME) and +;;; draft-yamamoto-openpgp-mime-00.txt (OpenPGP/MIME). + +(defun mime-add-application/pgp-keys (entity situation) + (save-excursion + (mime-show-echo-buffer) + (set-buffer mime-echo-buffer-name) + (set-window-start + (get-buffer-window mime-echo-buffer-name) + (point-max))) + (with-temp-buffer + (mime-insert-entity-content entity) + (mime-decode-region (point-min) (point-max) + (cdr (assq 'encoding situation))) + (let ((status (pgg-snarf-keys-region (point-min)(point-max)))) + (save-excursion + (set-buffer mime-echo-buffer-name) + (insert-buffer-substring (if status pgg-output-buffer + pgg-errors-buffer)))))) + + +;;; @ Internal method for application/pkcs7-signature +;;; +;;; It is based on RFC 2633 (S/MIME version 3). + +(defun mime-verify-application/pkcs7-signature (entity situation) + "Internal method to check S/MIME signature." + (let* ((entity-node-id (mime-entity-node-id entity)) + (mother (mime-entity-parent entity)) + (knum (car entity-node-id)) + (onum (if (> knum 0) + (1- knum) + (1+ knum))) + (orig-entity (nth onum (mime-entity-children mother))) + (basename (expand-file-name "tm" temporary-file-directory)) + (sig-file (concat (make-temp-name basename) ".asc")) + status) + (save-excursion + (mime-show-echo-buffer) + (set-buffer mime-echo-buffer-name) + (set-window-start + (get-buffer-window mime-echo-buffer-name) + (point-max))) + (mime-write-entity entity sig-file) + (unwind-protect + (with-temp-buffer + (mime-insert-entity orig-entity) + (goto-char (point-min)) + (while (progn (end-of-line) (not (eobp))) + (insert "\r") + (forward-line 1)) + (setq status (smime-verify-region (point-min)(point-max) + sig-file)) + (save-excursion + (set-buffer mime-echo-buffer-name) + (insert-buffer-substring (if status smime-output-buffer + smime-errors-buffer)))) + (delete-file sig-file)))) + + +;;; @ Internal method for application/pkcs7-mime +;;; +;;; It is based on RFC 2633 (S/MIME version 3). + +(defun mime-view-application/pkcs7-mime (entity situation) + (let* ((p-win (or (get-buffer-window (current-buffer)) + (get-largest-window))) + (new-name + (format "%s-%s" (buffer-name) (mime-entity-number entity))) + (mother (current-buffer)) + (preview-buffer (concat "*Preview-" (buffer-name) "*")) + message-buf) + (when (memq (or (cdr (assq 'smime-type situation)) 'enveloped-data) + '(enveloped-data signed-data)) + (set-buffer (setq message-buf (get-buffer-create new-name))) + (let ((inhibit-read-only t) + buffer-read-only) + (erase-buffer) + (mime-insert-entity entity) + (smime-decrypt-region (point-min)(point-max)) + (delete-region (point-min)(point-max)) + (insert-buffer smime-output-buffer)) + (setq major-mode 'mime-show-message-mode) + (save-window-excursion + (mime-view-buffer nil preview-buffer mother + nil 'binary) + (make-local-variable 'mime-view-temp-message-buffer) + (setq mime-view-temp-message-buffer message-buf)) + (set-window-buffer p-win preview-buffer)))) + + +;;; @ end +;;; + +(provide 'mime-pgp) + +(run-hooks 'mime-pgp-load-hook) + +;;; mime-pgp.el ends here diff --git a/mime/mime-play.el b/mime/mime-play.el new file mode 100644 index 0000000..dad7904 --- /dev/null +++ b/mime/mime-play.el @@ -0,0 +1,517 @@ +;;; mime-play.el --- Playback processing module for mime-view.el + +;; Copyright (C) 1994,95,96,97,98,99,2000 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Created: 1995/9/26 (separated from tm-view.el) +;; Renamed: 1997/2/21 from tm-play.el +;; Keywords: MIME, multimedia, mail, news + +;; This file is part of SEMI (Secretariat of Emacs MIME Interfaces). + +;; 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-view) +(require 'alist) +(require 'filename) + +(eval-when-compile + (condition-case nil + (require 'bbdb) + (error (defvar bbdb-buffer-name nil))) + ) + +(defcustom mime-save-directory "~/" + "*Name of the directory where MIME entity will be saved in. +If t, it means current directory." + :group 'mime-view + :type '(choice (const :tag "Current directory" t) + (directory))) + +(defvar mime-play-find-every-situations t + "*Find every available situations if non-nil.") + +(defvar mime-play-messages-coding-system nil + "Coding system to be used for external MIME playback method.") + + +;;; @ content decoder +;;; + +;;;###autoload +(defun mime-preview-play-current-entity (&optional ignore-examples mode) + "Play current entity. +It decodes current entity to call internal or external method. The +method is selected from variable `mime-acting-condition'. +If IGNORE-EXAMPLES (C-u prefix) is specified, this function ignores +`mime-acting-situation-example-list'. +If MODE is specified, play as it. Default MODE is \"play\"." + (interactive "P") + (let ((entity (get-text-property (point) 'mime-view-entity))) + (if entity + (let ((situation + (get-text-property (point) 'mime-view-situation))) + (or mode + (setq mode "play")) + (setq situation + (if (assq 'mode situation) + (put-alist 'mode mode (copy-alist situation)) + (cons (cons 'mode mode) + situation))) + (if ignore-examples + (setq situation + (cons (cons 'ignore-examples ignore-examples) + situation))) + (mime-play-entity entity situation) + )))) + +;;;###autoload +(defun mime-play-entity (entity &optional situation ignored-method) + "Play entity specified by ENTITY. +It decodes the entity to call internal or external method. The method +is selected from variable `mime-acting-condition'. If MODE is +specified, play as it. Default MODE is \"play\"." + (let ((ret + (mime-unify-situations (mime-entity-situation entity situation) + mime-acting-condition + mime-acting-situation-example-list + 'method ignored-method + mime-play-find-every-situations)) + method) + (setq mime-acting-situation-example-list (cdr ret) + ret (car ret)) + (cond ((cdr ret) + (setq ret (select-menu-alist + "Methods" + (mapcar (function + (lambda (situation) + (cons + (format "%s" + (cdr (assq 'method situation))) + situation))) + ret))) + (setq ret (mime-sort-situation ret)) + (add-to-list 'mime-acting-situation-example-list (cons ret 0)) + ) + (t + (setq ret (car ret)) + )) + (setq method (cdr (assq 'method ret))) + (cond ((and (symbolp method) + (fboundp method)) + (funcall method entity ret) + ) + ((stringp method) + (mime-activate-mailcap-method entity ret) + ) + ;; ((and (listp method)(stringp (car method))) + ;; (mime-activate-external-method entity ret) + ;; ) + (t + (mime-show-echo-buffer "No method are specified for %s\n" + (mime-type/subtype-string + (cdr (assq 'type situation)) + (cdr (assq 'subtype situation)))) + (if (y-or-n-p "Do you want to save current entity to disk?") + (mime-save-content entity situation)) + )) + )) + + +;;; @ external decoder +;;; + +(defvar mime-mailcap-method-filename-alist nil) + +(defun mime-activate-mailcap-method (entity situation) + (let ((method (cdr (assoc 'method situation))) + (name (mime-entity-safe-filename entity))) + (setq name + (if (and name (not (string= name ""))) + (expand-file-name name temporary-file-directory) + (make-temp-name + (expand-file-name "EMI" temporary-file-directory)))) + (mime-write-entity-content entity name) + (message "External method is starting...") + (let ((process + (let ((command + (mime-format-mailcap-command + method + (cons (cons 'filename name) situation)))) + (binary-to-text-funcall + mime-play-messages-coding-system + #'start-process command mime-echo-buffer-name + shell-file-name shell-command-switch command)))) + (set-alist 'mime-mailcap-method-filename-alist process name) + (set-process-sentinel process 'mime-mailcap-method-sentinel)))) + +(defun mime-mailcap-method-sentinel (process event) + (let ((file (cdr (assq process mime-mailcap-method-filename-alist)))) + (if (file-exists-p file) + (delete-file file) + )) + (remove-alist 'mime-mailcap-method-filename-alist process) + (message (format "%s %s" process event))) + +(defvar mime-echo-window-is-shared-with-bbdb + (module-installed-p 'bbdb) + "*If non-nil, mime-echo window is shared with BBDB window.") + +(defvar mime-echo-window-height + (function + (lambda () + (/ (window-height) 5) + )) + "*Size of mime-echo window. +It allows function or integer. If it is function, +`mime-show-echo-buffer' calls it to get height of mime-echo window. +Otherwise `mime-show-echo-buffer' uses it as height of mime-echo +window.") + +(defun mime-show-echo-buffer (&rest forms) + "Show mime-echo buffer to display MIME-playing information." + (get-buffer-create mime-echo-buffer-name) + (let ((the-win (selected-window)) + (win (get-buffer-window mime-echo-buffer-name))) + (unless win + (unless (and mime-echo-window-is-shared-with-bbdb + (condition-case nil + (setq win (get-buffer-window bbdb-buffer-name)) + (error nil))) + (select-window (get-buffer-window (or mime-preview-buffer + (current-buffer)))) + (setq win (split-window-vertically + (- (window-height) + (if (functionp mime-echo-window-height) + (funcall mime-echo-window-height) + mime-echo-window-height) + ))) + ) + (set-window-buffer win mime-echo-buffer-name) + ) + (select-window win) + (goto-char (point-max)) + (if forms + (let ((buffer-read-only nil)) + (insert (apply (function format) forms)) + )) + (select-window the-win) + )) + + +;;; @ file name +;;; + +(defvar mime-view-file-name-char-regexp "[A-Za-z0-9+_-]") + +(defvar mime-view-file-name-regexp-1 + (concat mime-view-file-name-char-regexp "+\\." + mime-view-file-name-char-regexp "+")) + +(defvar mime-view-file-name-regexp-2 + (concat (regexp-* mime-view-file-name-char-regexp) + "\\(\\." mime-view-file-name-char-regexp "+\\)*")) + +(defun mime-entity-safe-filename (entity) + (let ((filename + (or (mime-entity-filename entity) + (let ((subj + (or (mime-entity-read-field entity 'Content-Description) + (mime-entity-read-field entity 'Subject)))) + (if (and subj + (or (string-match mime-view-file-name-regexp-1 subj) + (string-match mime-view-file-name-regexp-2 subj))) + (substring subj (match-beginning 0)(match-end 0)) + ))))) + (if filename + (replace-as-filename filename) + ))) + + +;;; @ file extraction +;;; + +(defun mime-save-content (entity situation) + (let ((name (or (mime-entity-safe-filename entity) + (format "%s" (mime-entity-media-type entity)))) + (dir (if (eq t mime-save-directory) + default-directory + mime-save-directory)) + filename) + (setq filename (read-file-name + (concat "File name: (default " + (file-name-nondirectory name) ") ") + dir + (concat (file-name-as-directory dir) + (file-name-nondirectory name)))) + (if (file-directory-p filename) + (setq filename (concat (file-name-as-directory filename) + (file-name-nondirectory name)))) + (if (file-exists-p filename) + (or (yes-or-no-p (format "File %s exists. Save anyway? " filename)) + (error ""))) + (mime-write-entity-content entity (expand-file-name filename)) + )) + + +;;; @ file detection +;;; + +(defvar mime-magic-type-alist + '(("^\377\330\377[\340\356]..JFIF" image jpeg) + ("^\211PNG" image png) + ("^GIF8[79]" image gif) + ("^II\\*\000" image tiff) + ("^MM\000\\*" image tiff) + ("^MThd" audio midi) + ("^\000\000\001\263" video mpeg) + ) + "*Alist of regexp about magic-number vs. corresponding media-types. +Each element looks like (REGEXP TYPE SUBTYPE). +REGEXP is a regular expression to match against the beginning of the +content of entity. +TYPE is symbol to indicate primary type of media-type. +SUBTYPE is symbol to indicate subtype of media-type.") + +(defun mime-detect-content (entity situation) + (let (type subtype) + (let ((mdata (mime-entity-content entity)) + (rest mime-magic-type-alist)) + (while (not (let ((cell (car rest))) + (if cell + (if (string-match (car cell) mdata) + (setq type (nth 1 cell) + subtype (nth 2 cell)) + ) + t))) + (setq rest (cdr rest)))) + (setq situation (del-alist 'method (copy-alist situation))) + (mime-play-entity entity + (if type + (put-alist 'type type + (put-alist 'subtype subtype + situation)) + situation) + 'mime-detect-content))) + + +;;; @ mail/news message +;;; + +(defun mime-preview-quitting-method-for-mime-show-message-mode () + "Quitting method for mime-view. +It is registered to variable `mime-preview-quitting-method-alist'." + (let ((mother mime-mother-buffer) + (win-conf mime-preview-original-window-configuration)) + (if (and (boundp 'mime-view-temp-message-buffer) + (buffer-live-p mime-view-temp-message-buffer)) + (kill-buffer mime-view-temp-message-buffer)) + (mime-preview-kill-buffer) + (set-window-configuration win-conf) + (pop-to-buffer mother))) + +(defun mime-view-message/rfc822 (entity situation) + (let* ((new-name + (format "%s-%s" (buffer-name) (mime-entity-number entity))) + (mother (current-buffer)) + (children (car (mime-entity-children entity))) + (preview-buffer + (mime-display-message + children new-name mother nil + (cdr (assq 'major-mode + (get-text-property (point) 'mime-view-situation)))))) + (or (get-buffer-window preview-buffer) + (let ((m-win (get-buffer-window mother))) + (if m-win + (set-window-buffer m-win preview-buffer) + (switch-to-buffer preview-buffer) + ))))) + + +;;; @ message/partial +;;; + +(defun mime-store-message/partial-piece (entity cal) + (let* ((root-dir + (expand-file-name + (concat "m-prts-" (user-login-name)) temporary-file-directory)) + (id (cdr (assoc "id" cal))) + (number (cdr (assoc "number" cal))) + (total (cdr (assoc "total" cal))) + file + (mother (current-buffer))) + (or (file-exists-p root-dir) + (make-directory root-dir)) + (setq id (replace-as-filename id)) + (setq root-dir (concat root-dir "/" id)) + (or (file-exists-p root-dir) + (make-directory root-dir)) + (setq file (concat root-dir "/FULL")) + (if (file-exists-p file) + (let ((full-buf (get-buffer-create "FULL")) + (pwin (or (get-buffer-window mother) + (get-largest-window))) + pbuf) + (save-window-excursion + (set-buffer full-buf) + (erase-buffer) + (binary-insert-encoded-file file) + (setq major-mode 'mime-show-message-mode) + (mime-view-buffer (current-buffer) nil mother) + (setq pbuf (current-buffer)) + (make-local-variable 'mime-view-temp-message-buffer) + (setq mime-view-temp-message-buffer full-buf)) + (set-window-buffer pwin pbuf) + (select-window pwin)) + (setq file (concat root-dir "/" number)) + (mime-write-entity-body entity file) + (let ((total-file (concat root-dir "/CT"))) + (setq total + (if total + (progn + (or (file-exists-p total-file) + (save-excursion + (set-buffer + (get-buffer-create mime-temp-buffer-name)) + (erase-buffer) + (insert total) + (write-region (point-min)(point-max) total-file) + (kill-buffer (current-buffer)) + )) + (string-to-number total) + ) + (and (file-exists-p total-file) + (save-excursion + (set-buffer (find-file-noselect total-file)) + (prog1 + (and (re-search-forward "[0-9]+" nil t) + (string-to-number + (buffer-substring (match-beginning 0) + (match-end 0))) + ) + (kill-buffer (current-buffer)) + ))) + ))) + (if (and total (> total 0) + (>= (length (directory-files root-dir nil "^[0-9]+$" t)) + total)) + (catch 'tag + (save-excursion + (set-buffer (get-buffer-create mime-temp-buffer-name)) + (let ((full-buf (current-buffer))) + (erase-buffer) + (let ((i 1)) + (while (<= i total) + (setq file (concat root-dir "/" (int-to-string i))) + (or (file-exists-p file) + (throw 'tag nil) + ) + (binary-insert-encoded-file file) + (goto-char (point-max)) + (setq i (1+ i)))) + (binary-write-decoded-region + (point-min)(point-max) + (expand-file-name "FULL" root-dir)) + (let ((i 1)) + (while (<= i total) + (let ((file (format "%s/%d" root-dir i))) + (and (file-exists-p file) + (delete-file file))) + (setq i (1+ i)))) + (let ((file (expand-file-name "CT" root-dir))) + (and (file-exists-p file) + (delete-file file))) + (let ((buf (current-buffer)) + (pwin (or (get-buffer-window mother) + (get-largest-window))) + (pbuf (mime-display-message + (mime-open-entity 'buffer (current-buffer)) + nil mother nil 'mime-show-message-mode))) + (with-current-buffer pbuf + (make-local-variable 'mime-view-temp-message-buffer) + (setq mime-view-temp-message-buffer buf)) + (set-window-buffer pwin pbuf) + (select-window pwin) + ))))) + ))) + + +;;; @ message/external-body +;;; + +(defvar mime-raw-dired-function + (if (and (>= emacs-major-version 19) window-system) + (function dired-other-frame) + (function mime-raw-dired-function-for-one-frame) + )) + +(defun mime-raw-dired-function-for-one-frame (dir) + (let ((win (or (get-buffer-window mime-preview-buffer) + (get-largest-window)))) + (select-window win) + (dired dir) + )) + +(defun mime-view-message/external-anon-ftp (entity cal) + (let* ((site (cdr (assoc "site" cal))) + (directory (cdr (assoc "directory" cal))) + (name (cdr (assoc "name" cal))) + (pathname (concat "/anonymous@" site ":" directory))) + (message (concat "Accessing " (expand-file-name name pathname) " ...")) + (funcall mime-raw-dired-function pathname) + (goto-char (point-min)) + (search-forward name) + )) + +(defvar mime-raw-browse-url-function mime-browse-url-function) + +(defun mime-view-message/external-url (entity cal) + (let ((url (cdr (assoc "url" cal)))) + (message (concat "Accessing " url " ...")) + (funcall mime-raw-browse-url-function url))) + + +;;; @ rot13-47 +;;; + +(defun mime-view-caesar (entity situation) + "Internal method for mime-view to display ROT13-47-48 message." + (let ((buf (get-buffer-create + (format "%s-%s" (buffer-name) (mime-entity-number entity))))) + (with-current-buffer buf + (setq buffer-read-only nil) + (erase-buffer) + (mime-insert-text-content entity) + (mule-caesar-region (point-min) (point-max)) + (set-buffer-modified-p nil) + ) + (let ((win (get-buffer-window (current-buffer)))) + (or (eq (selected-window) win) + (select-window (or win (get-largest-window))) + )) + (view-buffer buf) + (goto-char (point-min)) + )) + + +;;; @ end +;;; + +(provide 'mime-play) + +;;; mime-play.el ends here diff --git a/mime/mime-setup.el b/mime/mime-setup.el new file mode 100644 index 0000000..dae2871 --- /dev/null +++ b/mime/mime-setup.el @@ -0,0 +1,47 @@ +;;; mime-setup.el --- setup file for MIME viewer and composer. + +;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Keywords: MIME, multimedia, multilingual, mail, news + +;; This file is part of SEMI (Setting for Emacs MIME Interfaces). + +;; 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: + +(load "mail-mime-setup") + +(condition-case nil + (load "gnus-mime-setup") + (error (message "gnus-mime-setup is not found.")) + ) + +(condition-case nil + (load "emh-setup") + (error (message "emh-setup is not found.")) + ) + + +;;; @ end +;;; + +(provide 'mime-setup) + +(run-hooks 'mime-setup-load-hook) + +;;; mime-setup.el ends here diff --git a/mime/mime-view.el b/mime/mime-view.el new file mode 100644 index 0000000..8cdf3e7 --- /dev/null +++ b/mime/mime-view.el @@ -0,0 +1,1869 @@ +;;; mime-view.el --- interactive MIME viewer for GNU Emacs + +;; Copyright (C) 1995,96,97,98,99,2000 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Created: 1994/07/13 +;; Renamed: 1994/08/31 from tm-body.el +;; Renamed: 1997/02/19 from tm-view.el +;; Keywords: MIME, multimedia, mail, news + +;; This file is part of SEMI (Sample of Elastic MIME Interfaces). + +;; 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 'semi-def) +(require 'calist) +(require 'alist) +(require 'mime-conf) + +(eval-when-compile (require 'static)) + + +;;; @ version +;;; + +(defconst mime-view-version + (concat (mime-product-name mime-user-interface-product) " MIME-View " + (mapconcat #'number-to-string + (mime-product-version mime-user-interface-product) ".") + " (" (mime-product-code-name mime-user-interface-product) ")")) + + +;;; @ variables +;;; + +(defgroup mime-view nil + "MIME view mode" + :group 'mime) + +(defcustom mime-situation-examples-file "~/.mime-example" + "*File name of situation-examples demonstrated by user." + :group 'mime-view + :type 'file) + +(defcustom mime-preview-move-scroll nil + "*Decides whether to scroll when moving to next entity. +When t, scroll the buffer. Non-nil but not t means scroll when +the next entity is within next-screen-context-lines from top or +buttom. Nil means don't scroll at all." + :group 'mime-view + :type '(choice (const :tag "Off" nil) + (const :tag "On" t) + (sexp :tag "Situation" 1))) + +(defcustom mime-view-mailcap-files + (let ((files '("/etc/mailcap" "/usr/etc/mailcap" "~/.mailcap"))) + (or (member mime-mailcap-file files) + (setq files (cons mime-mailcap-file files))) + files) + "List of mailcap files." + :group 'mime-view + :type '(repeat file)) + + +;;; @ in raw-buffer (representation space) +;;; + +(defvar mime-preview-buffer nil + "MIME-preview buffer corresponding with the (raw) buffer.") +(make-variable-buffer-local 'mime-preview-buffer) + + +(defvar mime-raw-representation-type-alist + '((mime-show-message-mode . binary) + (mime-temp-message-mode . binary) + (t . cooked) + ) + "Alist of major-mode vs. representation-type of mime-raw-buffer. +Each element looks like (SYMBOL . REPRESENTATION-TYPE). SYMBOL is +major-mode or t. t means default. REPRESENTATION-TYPE must be +`binary' or `cooked'.") + + +;;; @ in preview-buffer (presentation space) +;;; + +(defvar mime-mother-buffer nil + "Mother buffer corresponding with the (MIME-preview) buffer. +If current MIME-preview buffer is generated by other buffer, such as +message/partial, it is called `mother-buffer'.") +(make-variable-buffer-local 'mime-mother-buffer) + +;; (defvar mime-raw-buffer nil +;; "Raw buffer corresponding with the (MIME-preview) buffer.") +;; (make-variable-buffer-local 'mime-raw-buffer) + +(defvar mime-preview-original-window-configuration nil + "Window-configuration before mime-view-mode is called.") +(make-variable-buffer-local 'mime-preview-original-window-configuration) + +(defun mime-preview-original-major-mode (&optional recursive point) + "Return major-mode of original buffer. +If optional argument RECURSIVE is non-nil and current buffer has +mime-mother-buffer, it returns original major-mode of the +mother-buffer." + (if (and recursive mime-mother-buffer) + (save-excursion + (set-buffer mime-mother-buffer) + (mime-preview-original-major-mode recursive) + ) + (cdr (assq 'major-mode + (get-text-property (or point + (if (> (point) (buffer-size)) + (max (1- (point-max)) (point-min)) + (point))) + 'mime-view-situation))))) + + +;;; @ entity information +;;; + +(defun mime-entity-situation (entity &optional situation) + "Return situation of ENTITY." + (let (rest param name) + ;; Content-Type + (unless (assq 'type situation) + (setq rest (or (mime-entity-content-type entity) + (make-mime-content-type 'text 'plain)) + situation (cons (car rest) situation) + rest (cdr rest)) + ) + (unless (assq 'subtype situation) + (or rest + (setq rest (or (cdr (mime-entity-content-type entity)) + '((subtype . plain))))) + (setq situation (cons (car rest) situation) + rest (cdr rest)) + ) + (while rest + (setq param (car rest)) + (or (assoc (car param) situation) + (setq situation (cons param situation))) + (setq rest (cdr rest))) + + ;; Content-Disposition + (setq rest nil) + (unless (assq 'disposition-type situation) + (setq rest (mime-entity-content-disposition entity)) + (if rest + (setq situation (cons (cons 'disposition-type + (mime-content-disposition-type rest)) + situation) + rest (mime-content-disposition-parameters rest)) + )) + (while rest + (setq param (car rest) + name (car param)) + (if (cond ((string= name "filename") + (if (assq 'filename situation) + nil + (setq name 'filename))) + ((string= name "creation-date") + (if (assq 'creation-date situation) + nil + (setq name 'creation-date))) + ((string= name "modification-date") + (if (assq 'modification-date situation) + nil + (setq name 'modification-date))) + ((string= name "read-date") + (if (assq 'read-date situation) + nil + (setq name 'read-date))) + ((string= name "size") + (if (assq 'size situation) + nil + (setq name 'size))) + (t (setq name (cons 'disposition name)) + (if (assoc name situation) + nil + name))) + (setq situation + (cons (cons name (cdr param)) + situation))) + (setq rest (cdr rest))) + + ;; Content-Transfer-Encoding + (or (assq 'encoding situation) + (setq situation + (cons (cons 'encoding (or (mime-entity-encoding entity) + "7bit")) + situation))) + + situation)) + +(defsubst mime-delq-null-situation (situations field + &rest ignored-values) + (let (dest) + (while situations + (let* ((situation (car situations)) + (cell (assq field situation))) + (if cell + (or (memq (cdr cell) ignored-values) + (setq dest (cons situation dest)) + ))) + (setq situations (cdr situations))) + dest)) + +(defun mime-compare-situation-with-example (situation example) + (let ((example (copy-alist example)) + (match 0)) + (while situation + (let* ((cell (car situation)) + (key (car cell)) + (ecell (assoc key example))) + (when ecell + (if (equal cell ecell) + (setq match (1+ match)) + (setq example (delq ecell example)) + )) + ) + (setq situation (cdr situation)) + ) + (cons match example) + )) + +(defun mime-sort-situation (situation) + (sort situation + #'(lambda (a b) + (let ((a-t (car a)) + (b-t (car b)) + (order '((type . 1) + (subtype . 2) + (mode . 3) + (method . 4) + (major-mode . 5) + (disposition-type . 6) + )) + a-order b-order) + (if (symbolp a-t) + (let ((ret (assq a-t order))) + (if ret + (setq a-order (cdr ret)) + (setq a-order 7) + )) + (setq a-order 8) + ) + (if (symbolp b-t) + (let ((ret (assq b-t order))) + (if ret + (setq b-order (cdr ret)) + (setq b-order 7) + )) + (setq b-order 8) + ) + (if (= a-order b-order) + (string< (format "%s" a-t)(format "%s" b-t)) + (< a-order b-order)) + ))) + ) + +(defun mime-unify-situations (entity-situation + condition situation-examples + &optional required-name ignored-value + every-situations) + (let (ret) + (in-calist-package 'mime-view) + (setq ret + (ctree-find-calist condition entity-situation + every-situations)) + (if required-name + (setq ret (mime-delq-null-situation ret required-name + ignored-value t))) + (or (assq 'ignore-examples entity-situation) + (if (cdr ret) + (let ((rest ret) + (max-score 0) + (max-escore 0) + max-examples + max-situations) + (while rest + (let ((situation (car rest)) + (examples situation-examples)) + (while examples + (let* ((ret + (mime-compare-situation-with-example + situation (caar examples))) + (ret-score (car ret))) + (cond ((> ret-score max-score) + (setq max-score ret-score + max-escore (cdar examples) + max-examples (list (cdr ret)) + max-situations (list situation)) + ) + ((= ret-score max-score) + (cond ((> (cdar examples) max-escore) + (setq max-escore (cdar examples) + max-examples (list (cdr ret)) + max-situations (list situation)) + ) + ((= (cdar examples) max-escore) + (setq max-examples + (cons (cdr ret) max-examples)) + (or (member situation max-situations) + (setq max-situations + (cons situation max-situations))) + ))))) + (setq examples (cdr examples)))) + (setq rest (cdr rest))) + (when max-situations + (setq ret max-situations) + (while max-examples + (let* ((example (car max-examples)) + (cell + (assoc example situation-examples))) + (if cell + (setcdr cell (1+ (cdr cell))) + (setq situation-examples + (cons (cons example 0) + situation-examples)) + )) + (setq max-examples (cdr max-examples)) + ))))) + (cons ret situation-examples) + ;; ret: list of situations + ;; situation-examples: new examples (notoce that contents of + ;; argument `situation-examples' has bees modified) + )) + +(defun mime-view-entity-title (entity) + (or (mime-entity-read-field entity 'Content-Description) + (mime-entity-read-field entity 'Subject) + (mime-entity-filename entity) + "")) + +(defvar mime-preview-situation-example-list nil) +(defvar mime-preview-situation-example-list-max-size 16) +;; (defvar mime-preview-situation-example-condition nil) + +(defun mime-find-entity-preview-situation (entity + &optional default-situation) + (or (let ((ret + (mime-unify-situations + (append (mime-entity-situation entity) + default-situation) + mime-preview-condition + mime-preview-situation-example-list))) + (setq mime-preview-situation-example-list + (cdr ret)) + (caar ret)) + default-situation)) + + +(defvar mime-acting-situation-example-list nil) +(defvar mime-acting-situation-example-list-max-size 16) +(defvar mime-situation-examples-file-coding-system nil) + +(defun mime-view-read-situation-examples-file (&optional file) + (or file + (setq file mime-situation-examples-file)) + (if (and file + (file-readable-p file)) + (with-temp-buffer + (insert-file-contents file) + (setq mime-situation-examples-file-coding-system + (static-cond + ((boundp 'buffer-file-coding-system) + (symbol-value 'buffer-file-coding-system)) + ((boundp 'file-coding-system) + (symbol-value 'file-coding-system)) + (t nil)) + ;; (and (boundp 'buffer-file-coding-system) + ;; buffer-file-coding-system) + ) + (condition-case error + (eval-buffer) + (error (message "%s is broken: %s" file (cdr error)))) + ;; format check + (condition-case nil + (let ((i 0)) + (while (and (> (length mime-preview-situation-example-list) + mime-preview-situation-example-list-max-size) + (< i 16)) + (setq mime-preview-situation-example-list + (mime-reduce-situation-examples + mime-preview-situation-example-list)) + (setq i (1+ i)))) + (error (setq mime-preview-situation-example-list nil))) + ;; (let ((rest mime-preview-situation-example-list)) + ;; (while rest + ;; (ctree-set-calist-strictly 'mime-preview-condition + ;; (caar rest)) + ;; (setq rest (cdr rest)))) + (condition-case nil + (let ((i 0)) + (while (and (> (length mime-acting-situation-example-list) + mime-acting-situation-example-list-max-size) + (< i 16)) + (setq mime-acting-situation-example-list + (mime-reduce-situation-examples + mime-acting-situation-example-list)) + (setq i (1+ i)))) + (error (setq mime-acting-situation-example-list nil)))))) + +(defun mime-save-situation-examples () + (if (or mime-preview-situation-example-list + mime-acting-situation-example-list) + (let ((file mime-situation-examples-file)) + (with-temp-buffer + (insert ";;; " (file-name-nondirectory file) "\n") + (insert "\n;; This file is generated automatically by " + mime-view-version "\n\n") + (insert ";;; Code:\n\n") + (if mime-preview-situation-example-list + (pp `(setq mime-preview-situation-example-list + ',mime-preview-situation-example-list) + (current-buffer))) + (if mime-acting-situation-example-list + (pp `(setq mime-acting-situation-example-list + ',mime-acting-situation-example-list) + (current-buffer))) + (insert "\n;;; " + (file-name-nondirectory file) + " ends here.\n") + (static-cond + ((boundp 'buffer-file-coding-system) + (setq buffer-file-coding-system + mime-situation-examples-file-coding-system)) + ((boundp 'file-coding-system) + (setq file-coding-system + mime-situation-examples-file-coding-system))) + ;; (setq buffer-file-coding-system + ;; mime-situation-examples-file-coding-system) + (setq buffer-file-name file) + (save-buffer))))) + +(add-hook 'kill-emacs-hook 'mime-save-situation-examples) + +(defun mime-reduce-situation-examples (situation-examples) + (let ((len (length situation-examples)) + i ir ic j jr jc ret + dest d-i d-j + (max-sim 0) sim + min-det-ret det-ret + min-det-org det-org + min-freq freq) + (setq i 0 + ir situation-examples) + (while (< i len) + (setq ic (car ir) + j 0 + jr situation-examples) + (while (< j len) + (unless (= i j) + (setq jc (car jr)) + (setq ret (mime-compare-situation-with-example (car ic)(car jc)) + sim (car ret) + det-ret (+ (length (car ic))(length (car jc))) + det-org (length (cdr ret)) + freq (+ (cdr ic)(cdr jc))) + (cond ((< max-sim sim) + (setq max-sim sim + min-det-ret det-ret + min-det-org det-org + min-freq freq + d-i i + d-j j + dest (cons (cdr ret) freq)) + ) + ((= max-sim sim) + (cond ((> min-det-ret det-ret) + (setq min-det-ret det-ret + min-det-org det-org + min-freq freq + d-i i + d-j j + dest (cons (cdr ret) freq)) + ) + ((= min-det-ret det-ret) + (cond ((> min-det-org det-org) + (setq min-det-org det-org + min-freq freq + d-i i + d-j j + dest (cons (cdr ret) freq)) + ) + ((= min-det-org det-org) + (cond ((> min-freq freq) + (setq min-freq freq + d-i i + d-j j + dest (cons (cdr ret) freq)) + )) + )) + )) + )) + ) + (setq jr (cdr jr) + j (1+ j))) + (setq ir (cdr ir) + i (1+ i))) + (if (> d-i d-j) + (setq i d-i + d-i d-j + d-j i)) + (setq jr (nthcdr (1- d-j) situation-examples)) + (setcdr jr (cddr jr)) + (if (= d-i 0) + (setq situation-examples + (cdr situation-examples)) + (setq ir (nthcdr (1- d-i) situation-examples)) + (setcdr ir (cddr ir)) + ) + (if (setq ir (assoc (car dest) situation-examples)) + (progn + (setcdr ir (+ (cdr ir)(cdr dest))) + situation-examples) + (cons dest situation-examples) + ;; situation-examples may be modified. + ))) + + +;;; @ presentation of preview +;;; + +;;; @@ entity-button +;;; + +;;; @@@ predicate function +;;; + +;; (defun mime-view-entity-button-visible-p (entity) +;; "Return non-nil if header of ENTITY is visible. +;; Please redefine this function if you want to change default setting." +;; (let ((media-type (mime-entity-media-type entity)) +;; (media-subtype (mime-entity-media-subtype entity))) +;; (or (not (eq media-type 'application)) +;; (and (not (eq media-subtype 'x-selection)) +;; (or (not (eq media-subtype 'octet-stream)) +;; (let ((mother-entity (mime-entity-parent entity))) +;; (or (not (eq (mime-entity-media-type mother-entity) +;; 'multipart)) +;; (not (eq (mime-entity-media-subtype mother-entity) +;; 'encrypted))) +;; ) +;; ))))) + +;;; @@@ entity button generator +;;; + +(defun mime-view-insert-entity-button (entity) + "Insert entity-button of ENTITY." + (let ((entity-node-id (mime-entity-node-id entity)) + (params (mime-entity-parameters entity)) + (subject (mime-view-entity-title entity))) + (mime-insert-button + (let ((access-type (assoc "access-type" params)) + (num (or (cdr (assoc "x-part-number" params)) + (if (consp entity-node-id) + (mapconcat (function + (lambda (num) + (format "%s" (1+ num)) + )) + (reverse entity-node-id) ".") + "0")) + )) + (cond (access-type + (let ((server (assoc "server" params))) + (setq access-type (cdr access-type)) + (if server + (format "%s %s ([%s] %s)" + num subject access-type (cdr server)) + (let ((site (cdr (assoc "site" params))) + (dir (cdr (assoc "directory" params))) + (url (cdr (assoc "url" params))) + ) + (if url + (format "%s %s ([%s] %s)" + num subject access-type url) + (format "%s %s ([%s] %s:%s)" + num subject access-type site dir)) + ))) + ) + (t + (let ((media-type (mime-entity-media-type entity)) + (media-subtype (mime-entity-media-subtype entity)) + (charset (cdr (assoc "charset" params))) + (encoding (mime-entity-encoding entity))) + (concat + num " " subject + (let ((rest + (format " <%s/%s%s%s>" + media-type media-subtype + (if charset + (concat "; " charset) + "") + (if encoding + (concat " (" encoding ")") + "")))) + (if (>= (+ (current-column)(length rest))(window-width)) + "\n\t") + rest))) + ))) + (function mime-preview-play-current-entity)) + )) + + +;;; @@ entity-header +;;; + +(defvar mime-header-presentation-method-alist nil + "Alist of major mode vs. corresponding header-presentation-method functions. +Each element looks like (SYMBOL . FUNCTION). +SYMBOL must be major mode in raw-buffer or t. t means default. +Interface of FUNCTION must be (ENTITY SITUATION).") + +(defvar mime-view-ignored-field-list + '(".*Received:" ".*Path:" ".*Id:" "^References:" + "^Replied:" "^Errors-To:" + "^Lines:" "^Sender:" ".*Host:" "^Xref:" + "^Content-Type:" "^Precedence:" + "^Status:" "^X-VM-.*:") + "All fields that match this list will be hidden in MIME preview buffer. +Each elements are regexp of field-name.") + +(defvar mime-view-visible-field-list '("^Dnas.*:" "^Message-Id:") + "All fields that match this list will be displayed in MIME preview buffer. +Each elements are regexp of field-name.") + + +;;; @@ entity-body +;;; + +;;; @@@ predicate function +;;; + +(in-calist-package 'mime-view) + +(defun mime-calist::field-match-method-as-default-rule (calist + field-type field-value) + (let ((s-field (assq field-type calist))) + (cond ((null s-field) + (cons (cons field-type field-value) calist) + ) + (t calist)))) + +(define-calist-field-match-method + 'header #'mime-calist::field-match-method-as-default-rule) + +(define-calist-field-match-method + 'body #'mime-calist::field-match-method-as-default-rule) + + +(defvar mime-preview-condition nil + "Condition-tree about how to display entity.") + +(ctree-set-calist-strictly + 'mime-preview-condition '((type . application)(subtype . octet-stream) + (encoding . nil) + (body . visible))) +(ctree-set-calist-strictly + 'mime-preview-condition '((type . application)(subtype . octet-stream) + (encoding . "7bit") + (body . visible))) +(ctree-set-calist-strictly + 'mime-preview-condition '((type . application)(subtype . octet-stream) + (encoding . "8bit") + (body . visible))) + +(ctree-set-calist-strictly + 'mime-preview-condition '((type . application)(subtype . pgp) + (body . visible))) + +(ctree-set-calist-strictly + 'mime-preview-condition '((type . application)(subtype . x-latex) + (body . visible))) + +(ctree-set-calist-strictly + 'mime-preview-condition '((type . application)(subtype . x-selection) + (body . visible))) + +(ctree-set-calist-strictly + 'mime-preview-condition '((type . application)(subtype . x-comment) + (body . visible))) + +(ctree-set-calist-strictly + 'mime-preview-condition '((type . message)(subtype . delivery-status) + (body . visible))) + +(ctree-set-calist-strictly + 'mime-preview-condition + '((body . visible) + (body-presentation-method . mime-display-text/plain))) + +(ctree-set-calist-strictly + 'mime-preview-condition + '((type . nil) + (body . visible) + (body-presentation-method . mime-display-text/plain))) + +(ctree-set-calist-strictly + 'mime-preview-condition + '((type . text)(subtype . enriched) + (body . visible) + (body-presentation-method . mime-display-text/enriched))) + +(ctree-set-calist-strictly + 'mime-preview-condition + '((type . text)(subtype . richtext) + (body . visible) + (body-presentation-method . mime-display-text/richtext))) + +(autoload 'mime-display-application/x-postpet "postpet") + +(ctree-set-calist-strictly + 'mime-preview-condition + '((type . application)(subtype . x-postpet) + (body . visible) + (body-presentation-method . mime-display-application/x-postpet))) + +(ctree-set-calist-strictly + 'mime-preview-condition + '((type . text)(subtype . t) + (body . visible) + (body-presentation-method . mime-display-text/plain))) + +(ctree-set-calist-strictly + 'mime-preview-condition + '((type . multipart)(subtype . alternative) + (body . visible) + (body-presentation-method . mime-display-multipart/alternative))) + +(ctree-set-calist-strictly + 'mime-preview-condition + '((type . multipart)(subtype . t) + (body . visible) + (body-presentation-method . mime-display-multipart/mixed))) + +(ctree-set-calist-strictly + 'mime-preview-condition + '((type . message)(subtype . partial) + (body . visible) + (body-presentation-method . mime-display-message/partial-button))) + +(ctree-set-calist-strictly + 'mime-preview-condition + '((type . message)(subtype . rfc822) + (body . visible) + (body-presentation-method . mime-display-multipart/mixed) + (childrens-situation (header . visible) + (entity-button . invisible)))) + +(ctree-set-calist-strictly + 'mime-preview-condition + '((type . message)(subtype . news) + (body . visible) + (body-presentation-method . mime-display-multipart/mixed) + (childrens-situation (header . visible) + (entity-button . invisible)))) + + +;;; @@@ entity presentation +;;; + +(defun mime-display-text/plain (entity situation) + (save-restriction + (narrow-to-region (point-max)(point-max)) + (condition-case nil + (mime-insert-text-content entity) + (error (progn + (message "Can't decode current entity.") + (sit-for 1)))) + (run-hooks 'mime-text-decode-hook) + (goto-char (point-max)) + (if (not (eq (char-after (1- (point))) ?\n)) + (insert "\n") + ) + (mime-add-url-buttons) + (run-hooks 'mime-display-text/plain-hook) + )) + +(defun mime-display-text/richtext (entity situation) + (save-restriction + (narrow-to-region (point-max)(point-max)) + (mime-insert-text-content entity) + (run-hooks 'mime-text-decode-hook) + (let ((beg (point-min))) + (remove-text-properties beg (point-max) '(face nil)) + (richtext-decode beg (point-max)) + ))) + +(defun mime-display-text/enriched (entity situation) + (save-restriction + (narrow-to-region (point-max)(point-max)) + (mime-insert-text-content entity) + (run-hooks 'mime-text-decode-hook) + (let ((beg (point-min))) + (remove-text-properties beg (point-max) '(face nil)) + (enriched-decode beg (point-max)) + ))) + + +(defvar mime-view-announcement-for-message/partial + (if (and (>= emacs-major-version 19) window-system) + "\ +\[[ This is message/partial style split message. ]] +\[[ Please press `v' key in this buffer ]] +\[[ or click here by mouse button-2. ]]" + "\ +\[[ This is message/partial style split message. ]] +\[[ Please press `v' key in this buffer. ]]" + )) + +(defun mime-display-message/partial-button (&optional entity situation) + (save-restriction + (goto-char (point-max)) + (if (not (search-backward "\n\n" nil t)) + (insert "\n") + ) + (goto-char (point-max)) + (narrow-to-region (point-max)(point-max)) + (insert mime-view-announcement-for-message/partial) + (mime-add-button (point-min)(point-max) + #'mime-preview-play-current-entity) + )) + +(defun mime-display-multipart/mixed (entity situation) + (let ((children (mime-entity-children entity)) + (original-major-mode-cell (assq 'major-mode situation)) + (default-situation + (cdr (assq 'childrens-situation situation)))) + (if original-major-mode-cell + (setq default-situation + (cons original-major-mode-cell default-situation))) + (while children + (mime-display-entity (car children) nil default-situation) + (setq children (cdr children)) + ))) + +(defcustom mime-view-type-subtype-score-alist + '(((text . enriched) . 3) + ((text . richtext) . 2) + ((text . plain) . 1) + (t . 0)) + "Alist MEDIA-TYPE vs corresponding score. +MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t. t means default." + :group 'mime-view + :type '(repeat (cons (choice :tag "Media-Type" + (cons :tag "Type/Subtype" + (symbol :tag "Primary-type") + (symbol :tag "Subtype")) + (symbol :tag "Type") + (const :tag "Default" t)) + integer))) + +(defun mime-display-multipart/alternative (entity situation) + (let* ((children (mime-entity-children entity)) + (original-major-mode-cell (assq 'major-mode situation)) + (default-situation + (cdr (assq 'childrens-situation situation))) + (i 0) + (p 0) + (max-score 0) + situations) + (if original-major-mode-cell + (setq default-situation + (cons original-major-mode-cell default-situation))) + (setq situations + (mapcar (function + (lambda (child) + (let ((situation + (mime-find-entity-preview-situation + child default-situation))) + (if (cdr (assq 'body-presentation-method situation)) + (let ((score + (cdr + (or (assoc + (cons + (cdr (assq 'type situation)) + (cdr (assq 'subtype situation))) + mime-view-type-subtype-score-alist) + (assq + (cdr (assq 'type situation)) + mime-view-type-subtype-score-alist) + (assq + t + mime-view-type-subtype-score-alist) + )))) + (if (> score max-score) + (setq p i + max-score score) + ))) + (setq i (1+ i)) + situation) + )) + children)) + (setq i 0) + (while children + (let ((child (car children)) + (situation (car situations))) + (mime-display-entity child (if (= i p) + situation + (put-alist 'body 'invisible + (copy-alist situation))))) + (setq children (cdr children) + situations (cdr situations) + i (1+ i))))) + + +;;; @ acting-condition +;;; + +(defvar mime-acting-condition nil + "Condition-tree about how to process entity.") + +(defun mime-view-read-mailcap-files (&optional files) + (or files + (setq files mime-view-mailcap-files)) + (let (entries file) + (while files + (setq file (car files)) + (if (file-readable-p file) + (setq entries (append entries (mime-parse-mailcap-file file)))) + (setq files (cdr files))) + (while entries + (let ((entry (car entries)) + view print shared) + (while entry + (let* ((field (car entry)) + (field-type (car field))) + (cond ((eq field-type 'view) (setq view field)) + ((eq field-type 'print) (setq print field)) + ((memq field-type '(compose composetyped edit))) + (t (setq shared (cons field shared)))) + ) + (setq entry (cdr entry))) + (setq shared (nreverse shared)) + (ctree-set-calist-with-default + 'mime-acting-condition + (append shared (list '(mode . "play")(cons 'method (cdr view))))) + (if print + (ctree-set-calist-with-default + 'mime-acting-condition + (append shared + (list '(mode . "print")(cons 'method (cdr view))))))) + (setq entries (cdr entries))))) + +(mime-view-read-mailcap-files) + +(ctree-set-calist-strictly + 'mime-acting-condition + '((type . application)(subtype . octet-stream) + (mode . "play") + (method . mime-detect-content) + )) + +(ctree-set-calist-with-default + 'mime-acting-condition + '((mode . "extract") + (method . mime-save-content))) + +(ctree-set-calist-strictly + 'mime-acting-condition + '((type . text)(subtype . x-rot13-47)(mode . "play") + (method . mime-view-caesar) + )) +(ctree-set-calist-strictly + 'mime-acting-condition + '((type . text)(subtype . x-rot13-47-48)(mode . "play") + (method . mime-view-caesar) + )) + +(ctree-set-calist-strictly + 'mime-acting-condition + '((type . message)(subtype . rfc822)(mode . "play") + (method . mime-view-message/rfc822) + )) +(ctree-set-calist-strictly + 'mime-acting-condition + '((type . message)(subtype . partial)(mode . "play") + (method . mime-store-message/partial-piece) + )) + +(ctree-set-calist-strictly + 'mime-acting-condition + '((type . message)(subtype . external-body) + ("access-type" . "anon-ftp") + (method . mime-view-message/external-anon-ftp) + )) + +(ctree-set-calist-strictly + 'mime-acting-condition + '((type . message)(subtype . external-body) + ("access-type" . "url") + (method . mime-view-message/external-url) + )) + +(ctree-set-calist-strictly + 'mime-acting-condition + '((type . application)(subtype . octet-stream) + (method . mime-save-content) + )) + + +;;; @ quitting method +;;; + +(defvar mime-preview-quitting-method-alist + '((mime-show-message-mode + . mime-preview-quitting-method-for-mime-show-message-mode)) + "Alist of major-mode vs. quitting-method of mime-view.") + +(defvar mime-preview-over-to-previous-method-alist nil + "Alist of major-mode vs. over-to-previous-method of mime-view.") + +(defvar mime-preview-over-to-next-method-alist nil + "Alist of major-mode vs. over-to-next-method of mime-view.") + + +;;; @ following method +;;; + +(defvar mime-preview-following-method-alist nil + "Alist of major-mode vs. following-method of mime-view.") + +(defvar mime-view-following-required-fields-list + '("From")) + + +;;; @ buffer setup +;;; + +(defun mime-display-entity (entity &optional situation + default-situation preview-buffer) + (or preview-buffer + (setq preview-buffer (current-buffer))) + (let* (e nb ne nhb nbb) + (in-calist-package 'mime-view) + (or situation + (setq situation + (mime-find-entity-preview-situation entity default-situation))) + (let ((button-is-invisible + (eq (cdr (or (assq '*entity-button situation) + (assq 'entity-button situation))) + 'invisible)) + (header-is-visible + (eq (cdr (or (assq '*header situation) + (assq 'header situation))) + 'visible)) + (body-is-visible + (eq (cdr (or (assq '*body situation) + (assq 'body situation))) + 'visible)) + (children (mime-entity-children entity))) + (set-buffer preview-buffer) + (setq nb (point)) + (narrow-to-region nb nb) + (or button-is-invisible + ;; (if (mime-view-entity-button-visible-p entity) + (mime-view-insert-entity-button entity) + ;; ) + ) + (if header-is-visible + (let ((header-presentation-method + (or (cdr (assq 'header-presentation-method situation)) + (cdr (assq (cdr (assq 'major-mode situation)) + mime-header-presentation-method-alist))))) + (setq nhb (point)) + (if header-presentation-method + (funcall header-presentation-method entity situation) + (mime-insert-header entity + mime-view-ignored-field-list + mime-view-visible-field-list)) + (run-hooks 'mime-display-header-hook) + (put-text-property nhb (point-max) 'mime-view-entity-header entity) + (goto-char (point-max)) + (insert "\n"))) + (setq nbb (point)) + (unless children + (if body-is-visible + (let ((body-presentation-method + (cdr (assq 'body-presentation-method situation)))) + (if (functionp body-presentation-method) + (funcall body-presentation-method entity situation) + (mime-display-text/plain entity situation))) + (when button-is-invisible + (goto-char (point-max)) + (mime-view-insert-entity-button entity) + ) + (unless header-is-visible + (goto-char (point-max)) + (insert "\n")) + )) + (setq ne (point-max)) + (widen) + (put-text-property nb ne 'mime-view-entity entity) + (put-text-property nb ne 'mime-view-situation situation) + (put-text-property nbb ne 'mime-view-entity-body entity) + (goto-char ne) + (if (and children body-is-visible) + (let ((body-presentation-method + (cdr (assq 'body-presentation-method situation)))) + (if (functionp body-presentation-method) + (funcall body-presentation-method entity situation) + (mime-display-multipart/mixed entity situation)))) + ))) + + +;;; @ MIME viewer mode +;;; + +(defconst mime-view-menu-title "MIME-View") +(defconst mime-view-menu-list + '((up "Move to upper entity" mime-preview-move-to-upper) + (previous "Move to previous entity" mime-preview-move-to-previous) + (next "Move to next entity" mime-preview-move-to-next) + (scroll-down "Scroll-down" mime-preview-scroll-down-entity) + (scroll-up "Scroll-up" mime-preview-scroll-up-entity) + (play "Play current entity" mime-preview-play-current-entity) + (extract "Extract current entity" mime-preview-extract-current-entity) + (print "Print current entity" mime-preview-print-current-entity) + ) + "Menu for MIME Viewer") + +(cond ((featurep 'xemacs) + (defvar mime-view-xemacs-popup-menu + (cons mime-view-menu-title + (mapcar (function + (lambda (item) + (vector (nth 1 item)(nth 2 item) t) + )) + mime-view-menu-list))) + (defun mime-view-xemacs-popup-menu (event) + "Popup the menu in the MIME Viewer buffer" + (interactive "e") + (select-window (event-window event)) + (set-buffer (event-buffer event)) + (popup-menu 'mime-view-xemacs-popup-menu)) + (defvar mouse-button-2 'button2) + (defvar mouse-button-3 'button3) + ) + (t + (defvar mime-view-popup-menu + (let ((menu (make-sparse-keymap mime-view-menu-title))) + (nconc menu + (mapcar (function + (lambda (item) + (list (intern (nth 1 item)) 'menu-item + (nth 1 item)(nth 2 item)) + )) + mime-view-menu-list)))) + (defun mime-view-popup-menu (event) + "Popup the menu in the MIME Viewer buffer" + (interactive "@e") + (let ((menu mime-view-popup-menu) events func) + (setq events (x-popup-menu t menu)) + (and events + (setq func (lookup-key menu (apply #'vector events))) + (commandp func) + (funcall func)))) + (defvar mouse-button-2 [mouse-2]) + (defvar mouse-button-3 [mouse-3]) + )) + +(defun mime-view-define-keymap (&optional default) + (let ((mime-view-mode-map (if (keymapp default) + (copy-keymap default) + (make-sparse-keymap)))) + (define-key mime-view-mode-map + "u" (function mime-preview-move-to-upper)) + (define-key mime-view-mode-map + "p" (function mime-preview-move-to-previous)) + (define-key mime-view-mode-map + "n" (function mime-preview-move-to-next)) + (define-key mime-view-mode-map + "\e\t" (function mime-preview-move-to-previous)) + (define-key mime-view-mode-map + "\t" (function mime-preview-move-to-next)) + (define-key mime-view-mode-map + " " (function mime-preview-scroll-up-entity)) + (define-key mime-view-mode-map + "\M- " (function mime-preview-scroll-down-entity)) + (define-key mime-view-mode-map + "\177" (function mime-preview-scroll-down-entity)) + (define-key mime-view-mode-map + "\C-m" (function mime-preview-next-line-entity)) + (define-key mime-view-mode-map + "\C-\M-m" (function mime-preview-previous-line-entity)) + (define-key mime-view-mode-map + "v" (function mime-preview-play-current-entity)) + (define-key mime-view-mode-map + "e" (function mime-preview-extract-current-entity)) + (define-key mime-view-mode-map + "\C-c\C-p" (function mime-preview-print-current-entity)) + + (define-key mime-view-mode-map + "\C-c\C-t\C-f" (function mime-preview-toggle-header)) + (define-key mime-view-mode-map + "\C-c\C-th" (function mime-preview-toggle-header)) + (define-key mime-view-mode-map + "\C-c\C-t\C-c" (function mime-preview-toggle-content)) + + (define-key mime-view-mode-map + "\C-c\C-v\C-f" (function mime-preview-show-header)) + (define-key mime-view-mode-map + "\C-c\C-vh" (function mime-preview-show-header)) + (define-key mime-view-mode-map + "\C-c\C-v\C-c" (function mime-preview-show-content)) + + (define-key mime-view-mode-map + "\C-c\C-d\C-f" (function mime-preview-hide-header)) + (define-key mime-view-mode-map + "\C-c\C-dh" (function mime-preview-hide-header)) + (define-key mime-view-mode-map + "\C-c\C-d\C-c" (function mime-preview-hide-content)) + + (define-key mime-view-mode-map + "a" (function mime-preview-follow-current-entity)) + (define-key mime-view-mode-map + "q" (function mime-preview-quit)) + (define-key mime-view-mode-map + "\C-c\C-x" (function mime-preview-kill-buffer)) + ;; (define-key mime-view-mode-map + ;; "<" (function beginning-of-buffer)) + ;; (define-key mime-view-mode-map + ;; ">" (function end-of-buffer)) + (define-key mime-view-mode-map + "?" (function describe-mode)) + (define-key mime-view-mode-map + [tab] (function mime-preview-move-to-next)) + (define-key mime-view-mode-map + [delete] (function mime-preview-scroll-down-entity)) + (define-key mime-view-mode-map + [backspace] (function mime-preview-scroll-down-entity)) + (if (functionp default) + (cond ((featurep 'xemacs) + (set-keymap-default-binding mime-view-mode-map default) + ) + (t + (setq mime-view-mode-map + (append mime-view-mode-map (list (cons t default)))) + ))) + (if mouse-button-2 + (define-key mime-view-mode-map + mouse-button-2 (function mime-button-dispatcher)) + ) + (cond ((featurep 'xemacs) + (define-key mime-view-mode-map + mouse-button-3 (function mime-view-xemacs-popup-menu)) + ) + ((>= emacs-major-version 19) + (define-key mime-view-mode-map + mouse-button-3 (function mime-view-popup-menu)) + (define-key mime-view-mode-map [menu-bar mime-view] + (cons mime-view-menu-title + (make-sparse-keymap mime-view-menu-title))) + (mapcar (function + (lambda (item) + (define-key mime-view-mode-map + (vector 'menu-bar 'mime-view (car item)) + (cons (nth 1 item)(nth 2 item))) + )) + (reverse mime-view-menu-list)) + )) + ;; (run-hooks 'mime-view-define-keymap-hook) + mime-view-mode-map)) + +(defvar mime-view-mode-default-map (mime-view-define-keymap)) + + +(defsubst mime-maybe-hide-echo-buffer () + "Clear mime-echo buffer and delete window for it." + (let ((buf (get-buffer mime-echo-buffer-name))) + (if buf + (save-excursion + (set-buffer buf) + (erase-buffer) + (let ((win (get-buffer-window buf))) + (if win + (delete-window win) + )) + (bury-buffer buf) + )))) + +(defvar mime-view-redisplay nil) + +;;;###autoload +(defun mime-display-message (message &optional preview-buffer + mother default-keymap-or-function + original-major-mode keymap) + "View MESSAGE in MIME-View mode. + +Optional argument PREVIEW-BUFFER specifies the buffer of the +presentation. It must be either nil or a name of preview buffer. + +Optional argument MOTHER specifies mother-buffer of the preview-buffer. + +Optional argument DEFAULT-KEYMAP-OR-FUNCTION is nil, keymap or +function. If it is a keymap, keymap of MIME-View mode will be added +to it. If it is a function, it will be bound as default binding of +keymap of MIME-View mode. + +Optional argument ORIGINAL-MAJOR-MODE is major-mode of representation +buffer of MESSAGE. If it is nil, current `major-mode' is used. + +Optional argument KEYMAP is keymap of MIME-View mode. If it is +non-nil, DEFAULT-KEYMAP-OR-FUNCTION is ignored. If it is nil, +`mime-view-mode-default-map' is used." + (mime-maybe-hide-echo-buffer) + (let ((win-conf (current-window-configuration))) + (or preview-buffer + (setq preview-buffer + (concat "*Preview-" (mime-entity-name message) "*"))) + (or original-major-mode + (setq original-major-mode major-mode)) + (let ((inhibit-read-only t)) + (set-buffer (get-buffer-create preview-buffer)) + (widen) + (erase-buffer) + (if mother + (setq mime-mother-buffer mother)) + (setq mime-preview-original-window-configuration win-conf) + (setq major-mode 'mime-view-mode) + (setq mode-name "MIME-View") + (mime-display-entity message nil + `((entity-button . invisible) + (header . visible) + (major-mode . ,original-major-mode)) + preview-buffer) + (use-local-map + (or keymap + (if default-keymap-or-function + (mime-view-define-keymap default-keymap-or-function) + mime-view-mode-default-map))) + (let ((point + (next-single-property-change (point-min) 'mime-view-entity))) + (if point + (goto-char point) + (goto-char (point-min)) + (search-forward "\n\n" nil t))) + (run-hooks 'mime-view-mode-hook) + (set-buffer-modified-p nil) + (setq buffer-read-only t) + preview-buffer))) + +;;;###autoload +(defun mime-view-buffer (&optional raw-buffer preview-buffer mother + default-keymap-or-function + representation-type) + "View RAW-BUFFER in MIME-View mode. +Optional argument PREVIEW-BUFFER is either nil or a name of preview +buffer. +Optional argument DEFAULT-KEYMAP-OR-FUNCTION is nil, keymap or +function. If it is a keymap, keymap of MIME-View mode will be added +to it. If it is a function, it will be bound as default binding of +keymap of MIME-View mode. +Optional argument REPRESENTATION-TYPE is representation-type of +message. It must be nil, `binary' or `cooked'. If it is nil, +`cooked' is used as default." + (interactive) + (or raw-buffer + (setq raw-buffer (current-buffer))) + (or representation-type + (setq representation-type + (save-excursion + (set-buffer raw-buffer) + (cdr (or (assq major-mode mime-raw-representation-type-alist) + (assq t mime-raw-representation-type-alist))) + ))) + (if (eq representation-type 'binary) + (setq representation-type 'buffer) + ) + (setq preview-buffer (mime-display-message + (mime-open-entity representation-type raw-buffer) + preview-buffer mother default-keymap-or-function)) + (or (get-buffer-window preview-buffer) + (let ((r-win (get-buffer-window raw-buffer))) + (if r-win + (set-window-buffer r-win preview-buffer) + (let ((m-win (and mother (get-buffer-window mother)))) + (if m-win + (set-window-buffer m-win preview-buffer) + (switch-to-buffer preview-buffer) + )))))) + +(defun mime-view-mode (&optional mother ctl encoding + raw-buffer preview-buffer + default-keymap-or-function) + "Major mode for viewing MIME message. + +Here is a list of the standard keys for mime-view-mode. + +key feature +--- ------- + +u Move to upper content +p or M-TAB Move to previous content +n or TAB Move to next content +SPC Scroll up or move to next content +M-SPC or DEL Scroll down or move to previous content +RET Move to next line +M-RET Move to previous line +v Decode current content as `play mode' +e Decode current content as `extract mode' +C-c C-p Decode current content as `print mode' +a Followup to current content. +q Quit +button-2 Move to point under the mouse cursor + and decode current content as `play mode' +" + (interactive) + (unless mime-view-redisplay + (save-excursion + (if raw-buffer (set-buffer raw-buffer)) + (let ((type + (cdr + (or (assq major-mode mime-raw-representation-type-alist) + (assq t mime-raw-representation-type-alist))))) + (if (eq type 'binary) + (setq type 'buffer) + ) + (setq mime-message-structure (mime-open-entity type raw-buffer)) + (or (mime-entity-content-type mime-message-structure) + (mime-entity-set-content-type mime-message-structure ctl)) + ) + (or (mime-entity-encoding mime-message-structure) + (mime-entity-set-encoding mime-message-structure encoding)) + )) + (mime-display-message mime-message-structure preview-buffer + mother default-keymap-or-function) + ) + + +;;; @@ utility +;;; + +(defun mime-preview-find-boundary-info (&optional get-mother) + (let (entity + p-beg p-end + entity-node-id len) + (while (null (setq entity + (get-text-property (point) 'mime-view-entity))) + (backward-char)) + (setq p-beg (previous-single-property-change (point) 'mime-view-entity)) + (setq entity-node-id (mime-entity-node-id entity)) + (setq len (length entity-node-id)) + (cond ((null p-beg) + (setq p-beg + (if (eq (next-single-property-change (point-min) + 'mime-view-entity) + (point)) + (point) + (point-min))) + ) + ((eq (next-single-property-change p-beg 'mime-view-entity) + (point)) + (setq p-beg (point)) + )) + (setq p-end (next-single-property-change p-beg 'mime-view-entity)) + (cond ((null p-end) + (setq p-end (point-max)) + ) + ((null entity-node-id) + (setq p-end (point-max)) + ) + (get-mother + (save-excursion + (goto-char p-end) + (catch 'tag + (let (e i) + (while (setq e + (next-single-property-change + (point) 'mime-view-entity)) + (goto-char e) + (let ((rc (mime-entity-node-id + (get-text-property (1- (point)) + 'mime-view-entity)))) + (or (and (>= (setq i (- (length rc) len)) 0) + (equal entity-node-id (nthcdr i rc))) + (throw 'tag nil))) + (setq p-end e))) + (setq p-end (point-max)))) + )) + (vector p-beg p-end entity))) + + +;;; @@ playing +;;; + +(autoload 'mime-preview-play-current-entity "mime-play" + "Play current entity." t) + +(defun mime-preview-extract-current-entity (&optional ignore-examples) + "Extract current entity into file (maybe). +It decodes current entity to call internal or external method as +\"extract\" mode. The method is selected from variable +`mime-acting-condition'." + (interactive "P") + (mime-preview-play-current-entity ignore-examples "extract") + ) + +(defun mime-preview-print-current-entity (&optional ignore-examples) + "Print current entity (maybe). +It decodes current entity to call internal or external method as +\"print\" mode. The method is selected from variable +`mime-acting-condition'." + (interactive "P") + (mime-preview-play-current-entity ignore-examples "print") + ) + + +;;; @@ following +;;; + +(defun mime-preview-follow-current-entity () + "Write follow message to current entity. +It calls following-method selected from variable +`mime-preview-following-method-alist'." + (interactive) + (let ((entity (mime-preview-find-boundary-info t)) + p-beg p-end + pb-beg) + (setq p-beg (aref entity 0) + p-end (aref entity 1) + entity (aref entity 2)) + (if (get-text-property p-beg 'mime-view-entity-body) + (setq pb-beg p-beg) + (setq pb-beg + (next-single-property-change + p-beg 'mime-view-entity-body nil + (or (next-single-property-change p-beg 'mime-view-entity) + p-end)))) + (let* ((mode (mime-preview-original-major-mode 'recursive)) + (entity-node-id (mime-entity-node-id entity)) + (new-name + (format "%s-%s" (buffer-name) (reverse entity-node-id))) + new-buf + (the-buf (current-buffer)) + fields) + (save-excursion + (set-buffer (setq new-buf (get-buffer-create new-name))) + (erase-buffer) + (insert ?\n) + (insert-buffer-substring the-buf pb-beg p-end) + (goto-char (point-min)) + (let ((current-entity + (if (and (eq (mime-entity-media-type entity) 'message) + (eq (mime-entity-media-subtype entity) 'rfc822)) + (car (mime-entity-children entity)) + entity))) + (while (and current-entity + (if (and (eq (mime-entity-media-type + current-entity) 'message) + (eq (mime-entity-media-subtype + current-entity) 'rfc822)) + nil + (mime-insert-header current-entity fields) + t)) + (setq fields (std11-collect-field-names) + current-entity (mime-entity-parent current-entity)) + )) + (let ((rest mime-view-following-required-fields-list) + field-name ret) + (while rest + (setq field-name (car rest)) + (or (std11-field-body field-name) + (progn + (save-excursion + (set-buffer the-buf) + (let ((entity (when mime-mother-buffer + (set-buffer mime-mother-buffer) + (get-text-property (point) + 'mime-view-entity)))) + (while (and entity + (null (setq ret (mime-entity-fetch-field + entity field-name)))) + (setq entity (mime-entity-parent entity))))) + (if ret + (insert (concat field-name ": " ret "\n")) + ))) + (setq rest (cdr rest)) + )) + ) + (let ((f (cdr (assq mode mime-preview-following-method-alist)))) + (if (functionp f) + (funcall f new-buf) + (message + (format + "Sorry, following method for %s is not implemented yet." + mode)) + )) + ))) + + +;;; @@ moving +;;; + +(defun mime-preview-move-to-upper () + "Move to upper entity. +If there is no upper entity, call function `mime-preview-quit'." + (interactive) + (let (cinfo) + (while (null (setq cinfo + (get-text-property (point) 'mime-view-entity))) + (backward-char) + ) + (let ((r (mime-entity-parent cinfo)) + point) + (catch 'tag + (while (setq point (previous-single-property-change + (point) 'mime-view-entity)) + (goto-char point) + (when (eq r (get-text-property (point) 'mime-view-entity)) + (if (or (eq mime-preview-move-scroll t) + (and mime-preview-move-scroll + (>= point + (save-excursion + (move-to-window-line -1) + (forward-line (* -1 next-screen-context-lines)) + (beginning-of-line) + (point))))) + (recenter next-screen-context-lines)) + (throw 'tag t) + ) + ) + (mime-preview-quit) + )))) + +(defun mime-preview-move-to-previous () + "Move to previous entity. +If there is no previous entity, it calls function registered in +variable `mime-preview-over-to-previous-method-alist'." + (interactive) + (while (and (not (bobp)) + (null (get-text-property (point) 'mime-view-entity))) + (backward-char) + ) + (let ((point (previous-single-property-change (point) 'mime-view-entity))) + (if (and point + (>= point (point-min))) + (if (get-text-property (1- point) 'mime-view-entity) + (progn (goto-char point) + (if + (or (eq mime-preview-move-scroll t) + (and mime-preview-move-scroll + (<= point + (save-excursion + (move-to-window-line 0) + (forward-line next-screen-context-lines) + (end-of-line) + (point))))) + (recenter (* -1 next-screen-context-lines)))) + (goto-char (1- point)) + (mime-preview-move-to-previous) + ) + (let ((f (assq (mime-preview-original-major-mode) + mime-preview-over-to-previous-method-alist))) + (if f + (funcall (cdr f)) + )) + ))) + +(defun mime-preview-move-to-next () + "Move to next entity. +If there is no previous entity, it calls function registered in +variable `mime-preview-over-to-next-method-alist'." + (interactive) + (while (and (not (eobp)) + (null (get-text-property (point) 'mime-view-entity))) + (forward-char) + ) + (let ((point (next-single-property-change (point) 'mime-view-entity))) + (if (and point + (<= point (point-max))) + (progn + (goto-char point) + (if (null (get-text-property point 'mime-view-entity)) + (mime-preview-move-to-next) + (and + (or (eq mime-preview-move-scroll t) + (and mime-preview-move-scroll + (>= point + (save-excursion + (move-to-window-line -1) + (forward-line + (* -1 next-screen-context-lines)) + (beginning-of-line) + (point))))) + (recenter next-screen-context-lines)) + )) + (let ((f (assq (mime-preview-original-major-mode) + mime-preview-over-to-next-method-alist))) + (if f + (funcall (cdr f)) + )) + ))) + +(defun mime-preview-scroll-up-entity (&optional h) + "Scroll up current entity. +If reached to (point-max), it calls function registered in variable +`mime-preview-over-to-next-method-alist'." + (interactive) + (if (eobp) + (let ((f (assq (mime-preview-original-major-mode) + mime-preview-over-to-next-method-alist))) + (if f + (funcall (cdr f)) + )) + (let ((point + (or (next-single-property-change (point) 'mime-view-entity) + (point-max))) + (bottom (window-end (selected-window)))) + (if (and (not h) + (> bottom point)) + (progn (goto-char point) + (recenter next-screen-context-lines)) + (condition-case nil + (scroll-up h) + (end-of-buffer + (goto-char (point-max))))) + ))) + +(defun mime-preview-scroll-down-entity (&optional h) + "Scroll down current entity. +If reached to (point-min), it calls function registered in variable +`mime-preview-over-to-previous-method-alist'." + (interactive) + (if (bobp) + (let ((f (assq (mime-preview-original-major-mode) + mime-preview-over-to-previous-method-alist))) + (if f + (funcall (cdr f)) + )) + (let ((point + (or (previous-single-property-change (point) 'mime-view-entity) + (point-min))) + (top (window-start (selected-window)))) + (if (and (not h) + (< top point)) + (progn (goto-char point) + (recenter (* -1 next-screen-context-lines))) + (condition-case nil + (scroll-down h) + (beginning-of-buffer + (goto-char (point-min))))) + ))) + +(defun mime-preview-next-line-entity (&optional lines) + "Scroll up one line (or prefix LINES lines). +If LINES is negative, scroll down LINES lines." + (interactive "p") + (mime-preview-scroll-up-entity (or lines 1)) + ) + +(defun mime-preview-previous-line-entity (&optional lines) + "Scrroll down one line (or prefix LINES lines). +If LINES is negative, scroll up LINES lines." + (interactive "p") + (mime-preview-scroll-down-entity (or lines 1)) + ) + + +;;; @@ display +;;; + +(defun mime-preview-toggle-display (type &optional display) + (let ((situation (mime-preview-find-boundary-info)) + (sym (intern (concat "*" (symbol-name type)))) + entity p-beg p-end) + (setq p-beg (aref situation 0) + p-end (aref situation 1) + entity (aref situation 2) + situation (get-text-property p-beg 'mime-view-situation)) + (cond ((eq display 'invisible) + (setq display nil)) + (display) + (t + (setq display + (eq (cdr (or (assq sym situation) + (assq type situation))) + 'invisible)))) + (setq situation (put-alist sym (if display + 'visible + 'invisible) + situation)) + (save-excursion + (let ((inhibit-read-only t)) + (delete-region p-beg p-end) + (mime-display-entity entity situation))) + (let ((ret (assoc situation mime-preview-situation-example-list))) + (if ret + (setcdr ret (1+ (cdr ret))) + (add-to-list 'mime-preview-situation-example-list + (cons situation 0)))))) + +(defun mime-preview-toggle-header (&optional force-visible) + (interactive "P") + (mime-preview-toggle-display 'header force-visible)) + +(defun mime-preview-toggle-content (&optional force-visible) + (interactive "P") + (mime-preview-toggle-display 'body force-visible)) + +(defun mime-preview-show-header () + (interactive) + (mime-preview-toggle-display 'header 'visible)) + +(defun mime-preview-show-content () + (interactive) + (mime-preview-toggle-display 'body 'visible)) + +(defun mime-preview-hide-header () + (interactive) + (mime-preview-toggle-display 'header 'invisible)) + +(defun mime-preview-hide-content () + (interactive) + (mime-preview-toggle-display 'body 'invisible)) + + +;;; @@ quitting +;;; + +(defun mime-preview-quit () + "Quit from MIME-preview buffer. +It calls function registered in variable +`mime-preview-quitting-method-alist'." + (interactive) + (let ((r (assq (mime-preview-original-major-mode) + mime-preview-quitting-method-alist))) + (if r + (funcall (cdr r)) + ))) + +(defun mime-preview-kill-buffer () + (interactive) + (kill-buffer (current-buffer)) + ) + + +;;; @ end +;;; + +(provide 'mime-view) + +(eval-when-compile + (setq mime-situation-examples-file nil) + ;; to avoid to read situation-examples-file at compile time. + ) + +(mime-view-read-situation-examples-file) + +;;; mime-view.el ends here diff --git a/mime/mime-w3.el b/mime/mime-w3.el new file mode 100644 index 0000000..9ba2dcb --- /dev/null +++ b/mime/mime-w3.el @@ -0,0 +1,86 @@ +;;; mime-w3.el --- mime-view content filter for text + +;; Copyright (C) 1994,95,96,97,98,99,2000 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Keywords: HTML, MIME, multimedia, mail, news + +;; This file is part of SEMI (Suite of Emacs MIME Interfaces). + +;; 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: + +(condition-case nil + (require 'w3) + (error nil)) +(require 'mime) + +(defmacro mime-put-keymap-region (start end keymap) + `(put-text-property ,start ,end + ',(if (featurep 'xemacs) + 'keymap + 'local-map) + ,keymap)) + +(defmacro mime-save-background-color (&rest body) + (if (featurep 'xemacs) + `(let ((color (color-name (face-background 'default)))) + (prog1 + (progn ,@body) + (font-set-face-background 'default color (current-buffer)) + )) + (cons 'progn body))) + +(defvar mime-w3-message-structure nil) + +(defun mime-preview-text/html (entity situation) + (setq mime-w3-message-structure (mime-find-root-entity entity)) + (goto-char (point-max)) + (let ((p (point))) + (insert "\n") + (goto-char p) + (mime-save-background-color + (save-restriction + (narrow-to-region p p) + (mime-insert-text-content entity) + (run-hooks 'mime-text-decode-hook) + (condition-case err + (w3-region p (point-max)) + (error (message (format "%s" err)))) + (mime-put-keymap-region p (point-max) w3-mode-map) + )))) + +(defun url-cid (url &optional proxy-info) + (let ((entity + (mime-find-entity-from-content-id (mime-uri-parse-cid url) + mime-w3-message-structure))) + (when entity + (mime-insert-entity-content entity) + (setq url-current-mime-type (mime-entity-type/subtype entity)) + ))) + +(url-register-protocol "cid" + 'url-cid + 'url-identity-expander) + + +;;; @ end +;;; + +(provide 'mime-w3) + +;;; mime-w3.el ends here diff --git a/mime/mime.el b/mime/mime.el new file mode 100644 index 0000000..2160569 --- /dev/null +++ b/mime/mime.el @@ -0,0 +1,435 @@ +;;; mime.el --- MIME library module + +;; Copyright (C) 1998,1999,2000 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 'alist) +(require 'std11) +(require 'mime-def) +(require 'eword-decode) + +(eval-when-compile (require 'mmgeneric)) + +(eval-and-compile + +(autoload 'mime-encode-header-in-buffer "eword-encode" + "Encode header fields to network representation, such as MIME encoded-word.") + +(autoload 'mime-parse-Content-Type "mime-parse" + "Parse STRING as field-body of Content-Type field.") +(autoload 'mime-read-Content-Type "mime-parse" + "Read field-body of Content-Type field from current-buffer, +and return parsed it.") + +(autoload 'mime-parse-Content-Disposition "mime-parse" + "Parse STRING as field-body of Content-Disposition field.") +(autoload 'mime-read-Content-Disposition "mime-parse" + "Read field-body of Content-Disposition field from current-buffer, +and return parsed it.") + +(autoload 'mime-parse-Content-Transfer-Encoding "mime-parse" + "Parse STRING as field-body of Content-Transfer-Encoding field.") +(autoload 'mime-read-Content-Transfer-Encoding "mime-parse" + "Read field-body of Content-Transfer-Encoding field from +current-buffer, and return it.") + +(autoload 'mime-parse-msg-id "mime-parse" + "Parse TOKENS as msg-id of Content-Id or Message-Id field.") + +(autoload 'mime-uri-parse-cid "mime-parse" + "Parse STRING as cid URI.") + +(autoload 'mime-parse-buffer "mime-parse" + "Parse BUFFER as a MIME message.") + +) + +(autoload 'mime-encode-field-body "eword-encode" + "Encode FIELD-BODY as FIELD-NAME, and return the result.") + + +;;; @ Entity Representation and Implementation +;;; + +(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." + (require (intern (format "mm%s" type))) + (luna-make-entity (mm-expand-class-name type) :location location)) + +(luna-define-generic mime-entity-cooked-p (entity) + "Return non-nil if contents of ENTITY has been already code-converted.") + + +;;; @ Entity as node of message +;;; + +(defun mime-entity-children (entity) + "Return list of entities included in the ENTITY." + (or (mime-entity-children-internal entity) + (luna-send entity 'mime-entity-children entity))) + +(defun mime-entity-node-id (entity) + "Return node-id of ENTITY." + (mime-entity-node-id-internal entity)) + +(defun mime-entity-number (entity) + "Return entity-number of ENTITY." + (reverse (mime-entity-node-id-internal entity))) + +(defun mime-find-entity-from-number (entity-number message) + "Return entity from ENTITY-NUMBER in MESSAGE." + (let ((sn (car entity-number))) + (if (null sn) + message + (let ((rc (nth sn (mime-entity-children message)))) + (if rc + (mime-find-entity-from-number (cdr entity-number) rc) + )) + ))) + +(defun mime-find-entity-from-node-id (entity-node-id message) + "Return entity from ENTITY-NODE-ID in MESSAGE." + (mime-find-entity-from-number (reverse entity-node-id) message)) + +(defun mime-find-entity-from-content-id (cid message) + "Return entity from CID in MESSAGE." + (if (equal cid (mime-entity-read-field message "Content-Id")) + message + (let ((children (mime-entity-children message)) + ret) + (while (and children + (null (setq ret (mime-find-entity-from-content-id + cid (car children))))) + (setq children (cdr children))) + ret))) + +(defun mime-entity-parent (entity &optional message) + "Return mother entity of ENTITY. +If MESSAGE is specified, it is regarded as root entity." + (if (equal entity message) + nil + (mime-entity-parent-internal entity))) + +(defun mime-root-entity-p (entity &optional message) + "Return t if ENTITY is root-entity (message). +If MESSAGE is specified, it is regarded as root entity." + (null (mime-entity-parent entity message))) + +(defun mime-find-root-entity (entity) + "Return root entity of ENTITY." + (let ((p (mime-entity-parent entity))) + (if (null p) + entity + (mime-entity-parent p)))) + + +;;; @ Header buffer (obsolete) +;;; + +;; (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.") + +;; (luna-define-generic mime-entity-header-start-point (entity) +;; "Return header-start-position of ENTITY.") + +;; (luna-define-generic mime-entity-header-end-point (entity) +;; "Return header-end-position of ENTITY.") + +;; (make-obsolete 'mime-entity-header-buffer "don't use it.") +;; (make-obsolete 'mime-goto-header-start-point "don't use it.") +;; (make-obsolete 'mime-entity-header-start-point "don't use it.") +;; (make-obsolete 'mime-entity-header-end-point "don't use it.") + + +;;; @ Body buffer (obsolete) +;;; + +;; (luna-define-generic mime-entity-body-buffer (entity)) + +;; (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.") + +;; (luna-define-generic mime-entity-body-start-point (entity) +;; "Return body-start-position of ENTITY.") + +;; (luna-define-generic mime-entity-body-end-point (entity) +;; "Return body-end-position of ENTITY.") + +;; (defalias 'mime-entity-body-start 'mime-entity-body-start-point) +;; (defalias 'mime-entity-body-end 'mime-entity-body-end-point) + +;; (make-obsolete 'mime-entity-body-buffer "don't use it.") +;; (make-obsolete 'mime-goto-body-start-point "don't use it.") +;; (make-obsolete 'mime-goto-body-end-point "don't use it.") +;; (make-obsolete 'mime-entity-body-start-point "don't use it.") +;; (make-obsolete 'mime-entity-body-end-point "don't use it.") +;; (make-obsolete 'mime-entity-body-start "don't use it.") +;; (make-obsolete 'mime-entity-body-end "don't use it.") + + +;;; @ Entity buffer (obsolete) +;;; + +;; (luna-define-generic mime-entity-buffer (entity)) +;; (make-obsolete 'mime-entity-buffer "don't use it.") + +;; (luna-define-generic mime-entity-point-min (entity)) +;; (make-obsolete 'mime-entity-point-min "don't use it.") + +;; (luna-define-generic mime-entity-point-max (entity)) +;; (make-obsolete 'mime-entity-point-max "don't use it.") + + +;;; @ Entity +;;; + +(luna-define-generic mime-insert-entity (entity) + "Insert header and body of ENTITY at point.") + +(luna-define-generic mime-write-entity (entity filename) + "Write header and body of ENTITY into FILENAME.") + + +;;; @ Entity Body +;;; + +(luna-define-generic mime-entity-body (entity) + "Return network representation of ENTITY body.") + +(luna-define-generic mime-insert-entity-body (entity) + "Insert network representation of ENTITY body at point.") + +(luna-define-generic mime-write-entity-body (entity filename) + "Write body of ENTITY into FILENAME.") + + +;;; @ Entity Content +;;; + +(luna-define-generic mime-entity-content (entity) + "Return content of ENTITY as byte sequence (string).") + +(luna-define-generic mime-insert-entity-content (entity) + "Insert content of ENTITY at point.") + +(luna-define-generic mime-write-entity-content (entity filename) + "Write content of ENTITY into FILENAME.") + +(luna-define-generic mime-insert-text-content (entity) + "Insert decoded text body of ENTITY.") + + +;;; @ Header fields +;;; + +(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) +;; "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)) +;; (mime-entity-fetch-field entity field-name) +;; ) +;; (make-obsolete 'mime-fetch-field 'mime-entity-fetch-field) + +(defun mime-entity-content-type (entity) + "Return content-type of ENTITY." + (or (mime-entity-content-type-internal entity) + (let ((ret (mime-entity-fetch-field entity "Content-Type"))) + (if ret + (mime-entity-set-content-type-internal + entity (mime-parse-Content-Type ret)) + )))) + +(defun mime-entity-content-disposition (entity) + "Return content-disposition of ENTITY." + (or (mime-entity-content-disposition-internal entity) + (let ((ret (mime-entity-fetch-field entity "Content-Disposition"))) + (if ret + (mime-entity-set-content-disposition-internal + entity (mime-parse-Content-Disposition ret)) + )))) + +(defun mime-entity-encoding (entity &optional default-encoding) + "Return content-transfer-encoding of ENTITY. +If the ENTITY does not have Content-Transfer-Encoding field, this +function returns DEFAULT-ENCODING. If it is nil, \"7bit\" is used as +default value." + (or (mime-entity-encoding-internal 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)) + default-encoding "7bit")) + ))) + +(defvar mime-field-parser-alist + '((Return-Path . std11-parse-route-addr) + + (Reply-To . std11-parse-addresses) + + (Sender . std11-parse-mailbox) + (From . std11-parse-addresses) + + (Resent-Reply-To . std11-parse-addresses) + + (Resent-Sender . std11-parse-mailbox) + (Resent-From . std11-parse-addresses) + + (To . std11-parse-addresses) + (Resent-To . std11-parse-addresses) + (Cc . std11-parse-addresses) + (Resent-Cc . std11-parse-addresses) + (Bcc . std11-parse-addresses) + (Resent-Bcc . std11-parse-addresses) + + (Message-Id . mime-parse-msg-id) + (Recent-Message-Id . mime-parse-msg-id) + + (In-Reply-To . std11-parse-msg-ids) + (References . std11-parse-msg-ids) + + (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))) + (intern (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 entity +;; (setq entity mime-message-structure)) +;; (mime-entity-read-field entity field-name) +;; ) +;; (make-obsolete 'mime-read-field 'mime-entity-read-field) + +(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) + (with-temp-buffer + (mime-insert-entity-body entity) + (if (re-search-forward "^begin [0-9]+ " nil t) + (if (looking-at ".+$") + (buffer-substring (match-beginning 0)(match-end 0)) + ))))) + +(defun mime-entity-filename (entity) + "Return filename of ENTITY." + (or (mime-entity-uu-filename entity) + (mime-content-disposition-filename + (mime-entity-content-disposition entity)) + (cdr (let ((param (mime-content-type-parameters + (mime-entity-content-type entity)))) + (or (assoc "name" param) + (assoc "x-name" param)) + )))) + + +(defsubst mime-entity-media-type (entity) + "Return primary media-type of ENTITY." + (mime-content-type-primary-type (mime-entity-content-type entity))) + +(defsubst mime-entity-media-subtype (entity) + "Return media-subtype of ENTITY." + (mime-content-type-subtype (mime-entity-content-type entity))) + +(defsubst mime-entity-parameters (entity) + "Return parameters of Content-Type of ENTITY." + (mime-content-type-parameters (mime-entity-content-type entity))) + +(defsubst mime-entity-type/subtype (entity-info) + "Return type/subtype of Content-Type of ENTITY." + (mime-type/subtype-string (mime-entity-media-type entity-info) + (mime-entity-media-subtype entity-info))) + +(defun mime-entity-set-content-type (entity content-type) + "Set ENTITY's content-type to CONTENT-TYPE." + (mime-entity-set-content-type-internal entity content-type)) + +(defun mime-entity-set-encoding (entity encoding) + "Set ENTITY's content-transfer-encoding to ENCODING." + (mime-entity-set-encoding-internal entity encoding)) + + +;;; @ end +;;; + +(provide 'mime) + +;;; mime.el ends here diff --git a/mime/mmbabyl.el b/mime/mmbabyl.el new file mode 100644 index 0000000..a38d0f5 --- /dev/null +++ b/mime/mmbabyl.el @@ -0,0 +1,178 @@ +;;; mmbabyl.el --- MIME entity module for Babyl buffer + +;; Copyright (C) 2000 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Keywords: Babyl, RMAIL, MIME, multimedia, mail + +;; This file is part of GNU Emacs. + +;; 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 'mmbuffer) + +(eval-and-compile + (luna-define-class mime-babyl-entity (mime-buffer-entity) + (visible-header-start + visible-header-end)) + + (luna-define-internal-accessors 'mime-babyl-entity)) + +(luna-define-method initialize-instance + :after ((entity mime-babyl-entity) &rest init-args) + "Initialize slots of ENTITY. +ENTITY is an instance of `mime-babyl-entity'." + (or (mime-buffer-entity-buffer-internal entity) + (mime-buffer-entity-set-buffer-internal + entity (get-buffer (mime-entity-location-internal entity)))) + (save-excursion + (set-buffer (mime-buffer-entity-buffer-internal entity)) + (goto-char (point-min)) + (let (header-start + header-end + visible-header-start + visible-header-end + body-start) + (forward-line 1) + (if (= (following-char) ?0) + (progn + (forward-line 2) + ;; If there's a Summary-line in the (otherwise empty) + ;; header, we didn't yet get past the EOOH line. + (if (looking-at "^\\*\\*\\* EOOH \\*\\*\\*\n") + (forward-line 1)) + (setq header-start (point)) + (search-forward "\n\n" nil t) + (setq header-end (1+ (match-beginning 0))) + (setq body-start (match-end 0)) + (setq visible-header-start header-start + visible-header-end header-end)) + (forward-line 1) + (setq header-start (point)) + (search-forward "\n*** EOOH ***\n" nil t) + (setq header-end (match-beginning 0)) + (setq visible-header-start (match-end 0)) + (search-forward "\n\n" nil t) + (setq visible-header-end (1+ (match-beginning 0))) + (setq body-start (match-end 0))) + (mime-buffer-entity-set-header-start-internal entity header-start) + (mime-buffer-entity-set-header-end-internal entity header-end) + (mime-buffer-entity-set-body-start-internal entity body-start) + (mime-buffer-entity-set-body-end-internal entity (point-max)) + (mime-babyl-entity-set-visible-header-start-internal + entity visible-header-start) + (mime-babyl-entity-set-visible-header-end-internal + entity visible-header-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) + + +;;; @ entity +;;; + +(luna-define-method mime-insert-entity ((entity mime-babyl-entity)) + "Insert ENTITY into the current buffer. +ENTITY is an instance of `mime-babyl-entity'. +The header part and the body part of ENTITY are separated by a blank +line." + (insert-buffer-substring (mime-buffer-entity-buffer-internal entity) + (mime-buffer-entity-header-start-internal entity) + (mime-buffer-entity-header-end-internal entity)) + (insert "\n") + (insert-buffer-substring (mime-buffer-entity-buffer-internal entity) + (mime-buffer-entity-body-start-internal entity) + (mime-buffer-entity-body-end-internal entity)) + ) + +(luna-define-method mime-write-entity ((entity mime-babyl-entity) + filename) + "Write ENTITY into FILENAME. +ENTITY is an instance of `mime-babyl-entity'." + (with-temp-buffer + (mime-insert-entity entity) + (raw-message-write-region (point-min) (point-max) filename))) + + +;;; @ entity header +;;; + + +;;; @ entity body +;;; + + +;;; @ entity content +;;; + + +;;; @ header field +;;; + +(luna-define-method mime-insert-header ((entity mime-babyl-entity) + &optional invisible-fields + visible-fields) + "Insert the header of ENTITY in the current buffer. +ENTITY is an instance of `mime-babyl-entity'. +The optional arguemnts are currently ignored." + (mime-insert-header-from-buffer + (mime-buffer-entity-buffer-internal entity) + (mime-babyl-entity-visible-header-start-internal entity) + (mime-babyl-entity-visible-header-end-internal entity) + nil nil) + ) + + +;;; @ children +;;; + +;;;%%% docstring $B9g$C$F$k!)(B + +(luna-define-method mime-entity-children ((entity mime-babyl-entity)) + "Return a list of ENTITY's children. +ENTITY is an instance of `mime-babyl-entity'." + (let* ((content-type (mime-entity-content-type entity)) + (primary-type (mime-content-type-primary-type content-type)) + sub-type) + (cond ((eq primary-type 'multipart) + (mmbuffer-parse-multipart entity 'mime-buffer-entity)) + ((eq primary-type 'message) + (setq sub-type (mime-content-type-subtype content-type)) + (cond ((eq sub-type 'external-body) + (mmbuffer-parse-encapsulated entity 'external + 'mime-buffer-entity)) + ((memq sub-type '(rfc822 news)) + (mmbuffer-parse-encapsulated entity nil + 'mime-buffer-entity))))))) + + +;;; @ end +;;; + +(provide 'mmbabyl) + +;;; mmbabyl.el ends here diff --git a/mime/mmbuffer.el b/mime/mmbuffer.el new file mode 100644 index 0000000..1447d17 --- /dev/null +++ b/mime/mmbuffer.el @@ -0,0 +1,360 @@ +;;; mmbuffer.el --- MIME entity module for binary buffer + +;; Copyright (C) 1998,1999,2000 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 'mmgeneric) +(require 'mime) + +(eval-and-compile + (luna-define-class mime-buffer-entity (mime-entity) + (buffer + header-start + header-end + body-start + body-end)) + + (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 (get-buffer (mime-entity-location-internal entity)))) + (save-excursion + (set-buffer (mime-buffer-entity-buffer-internal 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) + (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) + ) + (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) + +(luna-define-method mime-entity-name ((entity mime-buffer-entity)) + (buffer-name (mime-buffer-entity-buffer-internal entity)) + ) + + +;;; @ entity +;;; + +(luna-define-method mime-insert-entity ((entity mime-buffer-entity)) + (insert-buffer-substring (mime-buffer-entity-buffer-internal entity) + (mime-buffer-entity-header-start-internal entity) + (mime-buffer-entity-body-end-internal entity)) + ) + +(luna-define-method mime-write-entity ((entity mime-buffer-entity) filename) + (save-excursion + (set-buffer (mime-buffer-entity-buffer-internal entity)) + (let ((coding-system-for-write 'raw-text-dos)) + (write-region (mime-buffer-entity-header-start-internal entity) + (mime-buffer-entity-body-end-internal entity) + filename)))) + + +;;; @ entity header +;;; + + +;;; @ entity body +;;; + +(luna-define-method mime-entity-body ((entity mime-buffer-entity)) + (save-excursion + (set-buffer (mime-buffer-entity-buffer-internal entity)) + (buffer-substring (mime-buffer-entity-body-start-internal entity) + (mime-buffer-entity-body-end-internal entity)))) + +(luna-define-method mime-insert-entity-body ((entity mime-buffer-entity)) + (insert-buffer-substring (mime-buffer-entity-buffer-internal entity) + (mime-buffer-entity-body-start-internal entity) + (mime-buffer-entity-body-end-internal entity)) + ) + +(luna-define-method mime-write-entity-body ((entity mime-buffer-entity) + filename) + (save-excursion + (set-buffer (mime-buffer-entity-buffer-internal entity)) + (binary-write-decoded-region + (mime-buffer-entity-body-start-internal entity) + (mime-buffer-entity-body-end-internal entity) + filename))) + + +;;; @ entity content +;;; + +(luna-define-method mime-entity-content ((entity mime-buffer-entity)) + (save-excursion + (set-buffer (mime-buffer-entity-buffer-internal entity)) + (mime-decode-string + (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-entity-content ((entity mime-buffer-entity)) + (insert (with-current-buffer (mime-buffer-entity-buffer-internal entity) + (mime-decode-string + (buffer-substring (mime-buffer-entity-body-start-internal entity) + (mime-buffer-entity-body-end-internal entity)) + (mime-entity-encoding entity))))) + +(luna-define-method mime-write-entity-content ((entity mime-buffer-entity) + filename) + (save-excursion + (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")) + )) + + +;;; @ header field +;;; + +(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)))))) + +(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) + ) + + +;;; @ 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) +;; ) + + +;;; @ children +;;; + +(defun mmbuffer-parse-multipart (entity &optional representation-type) + (with-current-buffer (mime-buffer-entity-buffer-internal entity) + (or representation-type + (setq representation-type + (mime-entity-representation-type-internal entity))) + (let* ((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-buffer-entity-body-start-internal entity)) + (body-end (mime-buffer-entity-body-end-internal 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)) + (mime-entity-set-children-internal entity (nreverse children)) + ) + (mime-entity-set-content-type-internal + entity (make-mime-content-type 'message 'x-broken)) + nil) + )))) + +(defun mmbuffer-parse-encapsulated (entity &optional external + representation-type) + (mime-entity-set-children-internal + entity + (with-current-buffer (mime-buffer-entity-buffer-internal entity) + (save-restriction + (narrow-to-region (mime-buffer-entity-body-start-internal entity) + (mime-buffer-entity-body-end-internal entity)) + (list (mime-parse-message + (if external + (progn + (require 'mmexternal) + 'mime-external-entity) + (or representation-type + (mime-entity-representation-type-internal entity))) + nil + entity (cons 0 (mime-entity-node-id-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)) + sub-type) + (cond ((eq primary-type 'multipart) + (mmbuffer-parse-multipart entity)) + ((eq primary-type 'message) + (setq sub-type (mime-content-type-subtype content-type)) + (cond ((eq sub-type 'external-body) + (mmbuffer-parse-encapsulated entity 'external)) + ((memq sub-type '(rfc822 news)) + (mmbuffer-parse-encapsulated entity))))))) + + +;;; @ end +;;; + +(provide 'mmbuffer) + +;;; mmbuffer.el ends here diff --git a/mime/mmcooked.el b/mime/mmcooked.el new file mode 100644 index 0000000..f55a34a --- /dev/null +++ b/mime/mmcooked.el @@ -0,0 +1,92 @@ +;;; mmcooked.el --- MIME entity implementation for binary 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 'mmbuffer) + +(mm-define-backend cooked (buffer)) + +(mm-define-method entity-cooked-p ((entity cooked)) t) + +(mm-define-method write-entity-content ((entity cooked) filename) + (save-excursion + (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-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-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-buffer-entity-buffer-internal entity)) + (write-region (mime-buffer-entity-body-start-internal entity) + (mime-buffer-entity-body-end-internal entity) + filename) + )) + +(luna-define-method mime-insert-header ((entity mime-cooked-entity) + &optional invisible-fields + visible-fields) + (let (default-mime-charset) + (funcall (car (luna-class-find-functions + (luna-find-class 'mime-buffer-entity) + 'mime-insert-header)) + entity invisible-fields visible-fields) + )) + +(mm-define-method insert-text-content ((entity cooked)) + (let ((str (mime-entity-content entity))) + (insert + (if (member (mime-entity-encoding entity) + '(nil "7bit" "8bit" "binary")) + str + (decode-mime-charset-string str + (or (mime-content-type-parameter + (mime-entity-content-type entity) + "charset") + default-mime-charset) + 'CRLF) + )))) + + +;;; @ end +;;; + +(provide 'mmcooked) + +;;; mmcooked.el ends here diff --git a/mime/mmexternal.el b/mime/mmexternal.el new file mode 100644 index 0000000..aafddcc --- /dev/null +++ b/mime/mmexternal.el @@ -0,0 +1,187 @@ +;;; mmexternal.el --- MIME entity module for external buffer + +;; Copyright (C) 1998,1999,2000 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 'mmgeneric) +(require 'mime) + +(eval-and-compile + (luna-define-class mime-external-entity (mime-entity) + (body-buffer + body-file)) + (luna-define-internal-accessors 'mime-external-entity) + + ;; In an external entity, information of media-type or other + ;; information which are represented in a header in a non-external + ;; entity are in the body of the parent entity. + ) + +(luna-define-method mime-entity-name ((entity mime-external-entity)) + (concat "child of " + (mime-entity-name + (mime-entity-parent-internal entity)))) + + +(defun mmexternal-require-file-name (entity) + (condition-case nil + (or (mime-external-entity-body-file-internal entity) + (let* ((ct (mime-entity-content-type + (mime-entity-parent-internal entity))) + (access-type + (mime-content-type-parameter ct "access-type"))) + (if (and access-type + (string= access-type "anon-ftp")) + (let ((site (mime-content-type-parameter ct "site")) + (directory + (mime-content-type-parameter ct "directory")) + (name (mime-content-type-parameter ct "name"))) + (mime-external-entity-set-body-file-internal + entity + (expand-file-name + name + (concat "/anonymous@" site ":" + (file-name-as-directory directory)))))))) + (error (message "Can't make file-name of external-body.")))) + +(defun mmexternal-require-buffer (entity) + (unless (and (mime-external-entity-body-buffer-internal entity) + (buffer-live-p + (mime-external-entity-body-buffer-internal entity))) + (condition-case nil + (progn + (mmexternal-require-file-name entity) + (mime-external-entity-set-body-buffer-internal + entity + (with-current-buffer (get-buffer-create + (concat " *Body of " + (mime-entity-name entity) + "*")) + (binary-insert-encoded-file + (mime-external-entity-body-file-internal entity)) + (current-buffer)))) + (error (message "Can't get external-body."))))) + + +;;; @ entity +;;; + +(luna-define-method mime-insert-entity ((entity mime-external-entity)) + (mime-insert-entity-body (mime-entity-parent-internal entity)) + (insert "\n") + (mime-insert-entity-body entity)) + +(luna-define-method mime-write-entity ((entity mime-external-entity) filename) + (with-temp-buffer + (mime-insert-entity entity) + (let ((coding-system-for-write 'raw-text-dos)) + (write-region (point-min) (point-max) filename)))) + + +;;; @ entity header +;;; + + +;;; @ entity body +;;; + +(luna-define-method mime-entity-body ((entity mime-external-entity)) + (mmexternal-require-buffer entity) + (with-current-buffer (mime-external-entity-body-buffer-internal entity) + (buffer-string))) + +(luna-define-method mime-insert-entity-body ((entity mime-external-entity)) + (mmexternal-require-buffer entity) + (insert-buffer-substring + (mime-external-entity-body-buffer-internal entity))) + +(luna-define-method mime-write-entity-body ((entity mime-external-entity) + filename) + (mmexternal-require-buffer entity) + (with-current-buffer (mime-external-entity-body-buffer-internal entity) + (binary-write-decoded-region (point-min) (point-max) filename))) + + +;;; @ entity content +;;; + +(luna-define-method mime-entity-content ((entity mime-external-entity)) + (let ((ret (mime-entity-body entity))) + (if ret + (mime-decode-string ret (mime-entity-encoding entity)) + (message "Cannot get content") + nil))) + +(luna-define-method mime-insert-entity-content ((entity mime-external-entity)) + (insert (mime-entity-content entity))) + +(luna-define-method mime-write-entity-content ((entity mime-external-entity) + filename) + (mmexternal-require-buffer entity) + (with-current-buffer (mime-external-entity-body-buffer-internal entity) + (mime-write-decoded-region (point-min) (point-max) + filename + (or (mime-entity-encoding entity) "7bit")))) + + +;;; @ header field +;;; + +(luna-define-method mime-entity-fetch-field :around + ((entity mime-external-entity) field-name) + (or (luna-call-next-method) + (with-temp-buffer + (mime-insert-entity-body (mime-entity-parent-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-header ((entity mime-external-entity) + &optional invisible-fields + visible-fields) + (let ((the-buf (current-buffer)) + buf p-min p-max) + (with-temp-buffer + (mime-insert-entity-body (mime-entity-parent-internal entity)) + (setq buf (current-buffer) + p-min (point-min) + p-max (point-max)) + (set-buffer the-buf) + (mime-insert-header-from-buffer buf p-min p-max + invisible-fields visible-fields)))) + + +;;; @ end +;;; + +(provide 'mmexternal) + +;;; mmexternal.el ends here diff --git a/mime/mmgeneric.el b/mime/mmgeneric.el new file mode 100644 index 0000000..532dfd9 --- /dev/null +++ b/mime/mmgeneric.el @@ -0,0 +1,178 @@ +;;; mmgeneric.el --- MIME generic entity module + +;; Copyright (C) 1995,96,97,98,99,2000 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Keywords: definition, 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 'luna) + +(eval-when-compile + (require 'eword-decode) ; mime-find-field-presentation-method + ) + + +;;; @ MIME entity +;;; + +(autoload 'mime-entity-content-type "mime") +(autoload 'mime-parse-multipart "mime-parse") +(autoload 'mime-parse-message "mime-parse") +;; (autoload 'mime-parse-encapsulated "mime-parse") +;; (autoload 'mime-parse-external "mime-parse") +(autoload 'mime-entity-content "mime") + +(eval-and-compile + (luna-define-class mime-entity () + (location + content-type children parent + node-id + content-disposition encoding + ;; for other fields + original-header parsed-header)) + + (luna-define-internal-accessors 'mime-entity) + ) + +(defalias 'mime-entity-representation-type-internal 'luna-class-name) +(defalias 'mime-entity-set-representation-type-internal 'luna-set-class-name) + +(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)))) + +(luna-define-method mime-insert-text-content ((entity mime-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) + )) + + +;;; @ 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)) + + +;;; @ header filter +;;; + +;; [tomo] We should think about specification of better filtering +;; mechanism. Please discuss in the emacs-mime mailing lists. + +(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") + ))))))) + + +;;; @ end +;;; + +(provide 'mmgeneric) + +;;; mmgeneric.el ends here diff --git a/mime/pgg-def.el b/mime/pgg-def.el new file mode 100644 index 0000000..7630f95 --- /dev/null +++ b/mime/pgg-def.el @@ -0,0 +1,78 @@ +;;; pgg-def.el --- functions/macros for defining PGG functions + +;; Copyright (C) 1999 Free Software Foundation, Inc. + +;; Author: Daiki Ueno +;; Created: 1999/11/02 +;; Keywords: PGP, OpenPGP, GnuPG + +;; This file is part of SEMI (Secure Emacs MIME Interface). + +;; 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 'custom) + +(defgroup pgg () + "Glue for the various PGP implementations." + :group 'mime) + +(defcustom pgg-default-scheme 'gpg + "Default PGP scheme." + :group 'pgg + :type '(choice (const :tag "GnuPG" gpg) + (const :tag "PGP 5" pgp5) + (const :tag "PGP" pgp))) + +(defcustom pgg-default-user-id (user-login-name) + "User ID of your default identity." + :group 'pgg + :type 'string) + +(defcustom pgg-default-keyserver-address "wwwkeys.pgp.net" + "Host name of keyserver." + :group 'pgg + :type 'string) + +(defcustom pgg-encrypt-for-me nil + "If t, encrypt all outgoing messages with user's public key." + :group 'pgg + :type 'boolean) + +(defcustom pgg-cache-passphrase t + "If t, cache passphrase." + :group 'pgg + :type 'boolean) + +(defvar pgg-messages-coding-system nil + "Coding system used when reading from a PGP external process.") + +(defvar pgg-status-buffer " *PGG status*") +(defvar pgg-errors-buffer " *PGG errors*") +(defvar pgg-output-buffer " *PGG output*") + +(defvar pgg-echo-buffer "*PGG-echo*") + +(defvar pgg-scheme nil + "Current scheme of PGP implementation.") + +(defmacro pgg-truncate-key-identifier (key) + `(if (> (length ,key) 8) (substring ,key 8) ,key)) + +(provide 'pgg-def) + +;;; pgg-def.el ends here diff --git a/mime/pgg-gpg.el b/mime/pgg-gpg.el new file mode 100644 index 0000000..dc6c5ae --- /dev/null +++ b/mime/pgg-gpg.el @@ -0,0 +1,242 @@ +;;; pgg-gpg.el --- GnuPG support for PGG. + +;; Copyright (C) 1999,2000 Free Software Foundation, Inc. + +;; Author: Daiki Ueno +;; Created: 1999/10/28 +;; Keywords: PGP, OpenPGP, GnuPG + +;; This file is part of SEMI (Secure Emacs MIME Interface). + +;; 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 'mel) ; binary-to-text-funcall +(eval-when-compile (require 'pgg)) + +(defgroup pgg-gpg () + "GnuPG interface" + :group 'pgg) + +(defcustom pgg-gpg-program "gpg" + "The GnuPG executable." + :group 'pgg-gpg + :type 'string) + +(defcustom pgg-gpg-extra-args nil + "Extra arguments for every GnuPG invocation." + :group 'pgg-gpg + :type 'string) + +(eval-and-compile + (luna-define-class pgg-scheme-gpg (pgg-scheme))) + +(defvar pgg-gpg-user-id nil + "GnuPG ID of your default identity.") + +(defvar pgg-gpg-messages-coding-system pgg-messages-coding-system + "Coding system used when reading from a GnuPG external process.") + +(defvar pgg-scheme-gpg-instance nil) + +;;;###autoload +(defun pgg-make-scheme-gpg () + (or pgg-scheme-gpg-instance + (setq pgg-scheme-gpg-instance + (luna-make-entity 'pgg-scheme-gpg)))) + +(defun pgg-gpg-process-region (start end passphrase program args) + (let* ((output-file-name + (concat temporary-file-directory (make-temp-name "pgg-output"))) + (args + `("--status-fd" "2" + ,@(if passphrase '("--passphrase-fd" "0")) + "--output" ,output-file-name + ,@pgg-gpg-extra-args ,@args)) + (output-buffer pgg-output-buffer) + (errors-buffer pgg-errors-buffer) + (orig-mode (default-file-modes)) + (process-connection-type nil) + process status exit-status) + (with-current-buffer (get-buffer-create errors-buffer) + (buffer-disable-undo) + (erase-buffer)) + (unwind-protect + (progn + (set-default-file-modes 448) + (setq process + (apply #'binary-to-text-funcall + pgg-gpg-messages-coding-system + #'start-process "*GnuPG*" errors-buffer + program args)) + (set-process-sentinel process #'ignore) + (when passphrase + (process-send-string process (concat passphrase "\n"))) + (process-send-region process start end) + (process-send-eof process) + (while (eq 'run (process-status process)) + (accept-process-output process 5)) + (setq status (process-status process) + exit-status (process-exit-status process)) + (delete-process process) + (with-current-buffer (get-buffer-create output-buffer) + (buffer-disable-undo) + (erase-buffer) + (if (file-exists-p output-file-name) + (let ((coding-system-for-read 'raw-text-dos)) + (insert-file-contents output-file-name))) + (set-buffer errors-buffer) + (if (memq status '(stop signal)) + (error "%s exited abnormally: '%s'" program exit-status)) + (if (= 127 exit-status) + (error "%s could not be found" program)))) + (if (and process (eq 'run (process-status process))) + (interrupt-process process)) + (if (file-exists-p output-file-name) + (delete-file output-file-name)) + (set-default-file-modes orig-mode)))) + +(defun pgg-gpg-possibly-cache-passphrase (passphrase) + (if (and pgg-cache-passphrase + (progn + (goto-char (point-min)) + (re-search-forward "^\\[GNUPG:] GOOD_PASSPHRASE\\>" nil t))) + (pgg-add-passphrase-cache + (progn + (goto-char (point-min)) + (if (re-search-forward + "^\\[GNUPG:] NEED_PASSPHRASE \\w+ ?\\w*" nil t) + (substring (match-string 0) -8))) + passphrase))) + +(luna-define-method pgg-scheme-lookup-key ((scheme pgg-scheme-gpg) + string &optional type) + (let ((args (list "--with-colons" "--no-greeting" "--batch" + (if type "--list-secret-keys" "--list-keys") + string))) + (with-temp-buffer + (apply #'call-process pgg-gpg-program nil t nil args) + (goto-char (point-min)) + (if (re-search-forward "^\\(sec\\|pub\\):" nil t) + (substring + (nth 3 (split-string + (buffer-substring (match-end 0) + (progn (end-of-line)(point))) + ":")) 8))))) + +(luna-define-method pgg-scheme-encrypt-region ((scheme pgg-scheme-gpg) + start end recipients) + (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id)) + (args + `("--batch" "--armor" "--always-trust" "--encrypt" + ,@(if recipients + (apply #'nconc + (mapcar (lambda (rcpt) + (list "--remote-user" rcpt)) + (append recipients + (if pgg-encrypt-for-me + (list pgg-gpg-user-id))))))))) + (pgg-as-lbt start end 'CRLF + (pgg-gpg-process-region start end nil pgg-gpg-program args)) + (pgg-process-when-success))) + +(luna-define-method pgg-scheme-decrypt-region ((scheme pgg-scheme-gpg) + start end) + (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id)) + (passphrase + (pgg-read-passphrase + (format "GnuPG passphrase for %s: " pgg-gpg-user-id) + (pgg-scheme-lookup-key scheme pgg-gpg-user-id 'encrypt))) + (args '("--batch" "--decrypt"))) + (pgg-gpg-process-region start end passphrase pgg-gpg-program args) + (with-current-buffer pgg-errors-buffer + (pgg-gpg-possibly-cache-passphrase passphrase) + (goto-char (point-min)) + (re-search-forward "^\\[GNUPG:] DECRYPTION_OKAY\\>" nil t)))) + +(luna-define-method pgg-scheme-sign-region ((scheme pgg-scheme-gpg) + start end &optional cleartext) + (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id)) + (passphrase + (pgg-read-passphrase + (format "GnuPG passphrase for %s: " pgg-gpg-user-id) + (pgg-scheme-lookup-key scheme pgg-gpg-user-id 'sign))) + (args + (list (if cleartext "--clearsign" "--detach-sign") + "--armor" "--batch" "--verbose" + "--local-user" pgg-gpg-user-id)) + (inhibit-read-only t) + buffer-read-only) + (pgg-as-lbt start end 'CRLF + (pgg-gpg-process-region start end passphrase pgg-gpg-program args)) + (with-current-buffer pgg-errors-buffer + (pgg-gpg-possibly-cache-passphrase passphrase)) + (pgg-process-when-success))) + +(luna-define-method pgg-scheme-verify-region ((scheme pgg-scheme-gpg) + start end &optional signature) + (let ((args '("--batch" "--verify"))) + (when (stringp signature) + (setq args (append args (list signature)))) + (setq args (append args '("-"))) + (pgg-gpg-process-region start end nil pgg-gpg-program args) + (with-current-buffer pgg-errors-buffer + (goto-char (point-min)) + (while (re-search-forward "^gpg: " nil t) + (replace-match "")) + (goto-char (point-min)) + (prog1 (re-search-forward "^\\[GNUPG:] GOODSIG\\>" nil t) + (goto-char (point-min)) + (delete-matching-lines "^warning\\|\\[GNUPG:]") + (set-buffer pgg-output-buffer) + (insert-buffer-substring pgg-errors-buffer))))) + +(luna-define-method pgg-scheme-insert-key ((scheme pgg-scheme-gpg)) + (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id)) + (args (list "--batch" "--export" "--armor" + pgg-gpg-user-id))) + (pgg-gpg-process-region (point)(point) nil pgg-gpg-program args) + (insert-buffer-substring pgg-output-buffer))) + +(luna-define-method pgg-scheme-snarf-keys-region ((scheme pgg-scheme-gpg) + start end) + (let ((args '("--import" "--batch" "-")) status) + (pgg-gpg-process-region start end nil pgg-gpg-program args) + (set-buffer pgg-errors-buffer) + (goto-char (point-min)) + (when (re-search-forward "^\\[GNUPG:] IMPORT_RES\\>" nil t) + (setq status (buffer-substring (match-end 0) + (progn (end-of-line)(point))) + status (vconcat (mapcar #'string-to-int (split-string status)))) + (erase-buffer) + (insert (format "Imported %d key(s). +\tArmor contains %d key(s) [%d bad, %d old].\n" + (+ (aref status 2) + (aref status 10)) + (aref status 0) + (aref status 1) + (+ (aref status 4) + (aref status 11))) + (if (zerop (aref status 9)) + "" + "\tSecret keys are imported.\n"))) + (append-to-buffer pgg-output-buffer (point-min)(point-max)) + (pgg-process-when-success))) + +(provide 'pgg-gpg) + +;;; pgg-gpg.el ends here diff --git a/mime/pgg-parse.el b/mime/pgg-parse.el new file mode 100644 index 0000000..f3aec73 --- /dev/null +++ b/mime/pgg-parse.el @@ -0,0 +1,500 @@ +;;; pgg-parse.el --- OpenPGP packet parsing + +;; Copyright (C) 1999 Daiki Ueno + +;; Author: Daiki Ueno +;; Created: 1999/10/28 +;; Keywords: PGP, OpenPGP, GnuPG + +;; This file is part of SEMI (Secure Emacs MIME Interface). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This module is based on + +;; [OpenPGP] RFC 2440: "OpenPGP Message Format" +;; by John W. Noerenberg, II , +;; Jon Callas , Lutz Donnerhacke , +;; Hal Finney and Rodney Thayer +;; (1998/11) + +;;; Code: + +(eval-when-compile (require 'cl)) + +(eval-when-compile (require 'static)) + +(require 'pccl) +(require 'custom) +(require 'mel) + +(defgroup pgg-parse () + "OpenPGP packet parsing" + :group 'pgg) + +(defcustom pgg-parse-public-key-algorithm-alist + '((1 . RSA) (2 . RSA-E) (3 . RSA-S) (16 . ELG-E) (17 . DSA) (20 . ELG)) + "Alist of the assigned number to the public key algorithm." + :group 'pgg-parse + :type 'alist) + +(defcustom pgg-parse-symmetric-key-algorithm-alist + '((1 . IDEA) (2 . 3DES) (4 . CAST5) (5 . SAFER-SK128)) + "Alist of the assigned number to the simmetric key algorithm." + :group 'pgg-parse + :type 'alist) + +(defcustom pgg-parse-hash-algorithm-alist + '((1 . MD5) (2 . SHA1) (3 . RIPEMD160) (5 . MD2)) + "Alist of the assigned number to the cryptographic hash algorithm." + :group 'pgg-parse + :type 'alist) + +(defcustom pgg-parse-compression-algorithm-alist + '((0 . nil); Uncompressed + (1 . ZIP) + (2 . ZLIB)) + "Alist of the assigned number to the compression algorithm." + :group 'pgg-parse + :type 'alist) + +(defcustom pgg-parse-signature-type-alist + '((0 . "Signature of a binary document") + (1 . "Signature of a canonical text document") + (2 . "Standalone signature") + (16 . "Generic certification of a User ID and Public Key packet") + (17 . "Persona certification of a User ID and Public Key packet") + (18 . "Casual certification of a User ID and Public Key packet") + (19 . "Positive certification of a User ID and Public Key packet") + (24 . "Subkey Binding Signature") + (31 . "Signature directly on a key") + (32 . "Key revocation signature") + (40 . "Subkey revocation signature") + (48 . "Certification revocation signature") + (64 . "Timestamp signature.")) + "Alist of the assigned number to the signature type." + :group 'pgg-parse + :type 'alist) + +(defcustom pgg-ignore-packet-checksum t; XXX + "If non-nil checksum of each ascii armored packet will be ignored." + :group 'pgg-parse + :type 'boolean) + +(defvar pgg-armor-header-lines + '("^-----BEGIN PGP MESSAGE\\(, PART [0-9]+\\(/[0-9]+\\)?\\)?-----\r?$" + "^-----BEGIN PGP PUBLIC KEY BLOCK-----\r?$" + "^-----BEGIN PGP PRIVATE KEY BLOCK-----\r?$" + "^-----BEGIN PGP SIGNATURE-----\r?$") + "Armor headers.") + +(defmacro pgg-format-key-identifier (string) + `(mapconcat (lambda (c) (format "%02X" (char-int c))) + ,string "") + ;; `(upcase (apply #'format "%02x%02x%02x%02x%02x%02x%02x%02x" + ;; (string-to-int-list ,string))) + ) + +(defmacro pgg-parse-time-field (bytes) + `(list (logior (lsh (car ,bytes) 8) + (nth 1 ,bytes)) + (logior (lsh (nth 2 ,bytes) 8) + (nth 3 ,bytes)) + 0)) + +(defmacro pgg-byte-after (&optional pos) + `(char-int (char-after ,(or pos `(point))))) + +(defmacro pgg-read-byte () + `(char-int (char-after (prog1 (point) (forward-char))))) + +(defmacro pgg-read-bytes-string (nbytes) + `(buffer-substring + (point) (prog1 (+ ,nbytes (point)) + (forward-char ,nbytes)))) + +(defmacro pgg-read-bytes (nbytes) + `(mapcar #'char-int (pgg-read-bytes-string ,nbytes)) + ;; `(string-to-int-list (pgg-read-bytes-string ,nbytes)) + ) + +(defmacro pgg-read-body-string (ptag) + `(if (nth 1 ,ptag) + (pgg-read-bytes-string (nth 1 ,ptag)) + (pgg-read-bytes-string (- (point-max) (point))))) + +(defmacro pgg-read-body (ptag) + `(mapcar #'char-int (pgg-read-body-string ,ptag)) + ;; `(string-to-int-list (pgg-read-body-string ,ptag)) + ) + +(defalias 'pgg-skip-bytes 'forward-char) + +(defmacro pgg-skip-header (ptag) + `(pgg-skip-bytes (nth 2 ,ptag))) + +(defmacro pgg-skip-body (ptag) + `(pgg-skip-bytes (nth 1 ,ptag))) + +(defmacro pgg-set-alist (alist key value) + `(setq ,alist (nconc ,alist (list (cons ,key ,value))))) + +(unless-broken ccl-usable + (define-ccl-program pgg-parse-crc24 + '(1 + ((loop + (read r0) (r1 ^= r0) (r2 ^= 0) + (r5 = 0) + (loop + (r1 <<= 1) + (r1 += ((r2 >> 15) & 1)) + (r2 <<= 1) + (if (r1 & 256) + ((r1 ^= 390) (r2 ^= 19707))) + (if (r5 < 7) + ((r5 += 1) + (repeat)))) + (repeat))))) + + (defun pgg-parse-crc24-string (string) + (let ((h (vector nil 183 1230 nil nil nil nil nil nil))) + (ccl-execute-on-string pgg-parse-crc24 h string) + (format "%c%c%c" + (logand (aref h 1) 255) + (logand (lsh (aref h 2) -8) 255) + (logand (aref h 2) 255))))) + +(defmacro pgg-parse-length-type (c) + `(cond + ((< ,c 192) (cons ,c 1)) + ((< ,c 224) + (cons (+ (lsh (- ,c 192) 8) + (pgg-byte-after (+ 2 (point))) + 192) + 2)) + ((= ,c 255) + (cons (cons (logior (lsh (pgg-byte-after (+ 2 (point))) 8) + (pgg-byte-after (+ 3 (point)))) + (logior (lsh (pgg-byte-after (+ 4 (point))) 8) + (pgg-byte-after (+ 5 (point))))) + 5)) + (t;partial body length + '(0 . 0)))) + +(defun pgg-parse-packet-header () + (let ((ptag (pgg-byte-after)) + length-type content-tag packet-bytes header-bytes) + (if (zerop (logand 64 ptag));Old format + (progn + (setq length-type (logand ptag 3) + length-type (if (= 3 length-type) 0 (lsh 1 length-type)) + content-tag (logand 15 (lsh ptag -2)) + packet-bytes 0 + header-bytes (1+ length-type)) + (dotimes (i length-type) + (setq packet-bytes + (logior (lsh packet-bytes 8) + (pgg-byte-after (+ 1 i (point))))))) + (setq content-tag (logand 63 ptag) + length-type (pgg-parse-length-type + (pgg-byte-after (1+ (point)))) + packet-bytes (car length-type) + header-bytes (1+ (cdr length-type)))) + (list content-tag packet-bytes header-bytes))) + +(defun pgg-parse-packet (ptag) + (case (car ptag) + (1 ;Public-Key Encrypted Session Key Packet + (pgg-parse-public-key-encrypted-session-key-packet ptag)) + (2 ;Signature Packet + (pgg-parse-signature-packet ptag)) + (3 ;Symmetric-Key Encrypted Session Key Packet + (pgg-parse-symmetric-key-encrypted-session-key-packet ptag)) + ;; 4 -- One-Pass Signature Packet + ;; 5 -- Secret Key Packet + (6 ;Public Key Packet + (pgg-parse-public-key-packet ptag)) + ;; 7 -- Secret Subkey Packet + ;; 8 -- Compressed Data Packet + (9 ;Symmetrically Encrypted Data Packet + (pgg-read-body-string ptag)) + (10 ;Marker Packet + (pgg-read-body-string ptag)) + (11 ;Literal Data Packet + (pgg-read-body-string ptag)) + ;; 12 -- Trust Packet + (13 ;User ID Packet + (pgg-read-body-string ptag)) + ;; 14 -- Public Subkey Packet + ;; 60 .. 63 -- Private or Experimental Values + )) + +(defun pgg-parse-packets (&optional header-parser body-parser) + (let ((header-parser + (or header-parser + (function pgg-parse-packet-header))) + (body-parser + (or body-parser + (function pgg-parse-packet))) + result ptag) + (while (> (point-max) (1+ (point))) + (setq ptag (funcall header-parser)) + (pgg-skip-header ptag) + (push (cons (car ptag) + (save-excursion + (funcall body-parser ptag))) + result) + (if (zerop (nth 1 ptag)) + (goto-char (point-max)) + (forward-char (nth 1 ptag)))) + result)) + +(defun pgg-parse-signature-subpacket-header () + (let ((length-type (pgg-parse-length-type (pgg-byte-after)))) + (list (pgg-byte-after (+ (cdr length-type) (point))) + (1- (car length-type)) + (1+ (cdr length-type))))) + +(defun pgg-parse-signature-subpacket (ptag) + (case (car ptag) + (2 ;signature creation time + (cons 'creation-time + (let ((bytes (pgg-read-bytes 4))) + (pgg-parse-time-field bytes)))) + (3 ;signature expiration time + (cons 'signature-expiry + (let ((bytes (pgg-read-bytes 4))) + (pgg-parse-time-field bytes)))) + (4 ;exportable certification + (cons 'exportability (pgg-read-byte))) + (5 ;trust signature + (cons 'trust-level (pgg-read-byte))) + (6 ;regular expression + (cons 'regular-expression + (pgg-read-body-string ptag))) + (7 ;revocable + (cons 'revocability (pgg-read-byte))) + (9 ;key expiration time + (cons 'key-expiry + (let ((bytes (pgg-read-bytes 4))) + (pgg-parse-time-field bytes)))) + ;; 10 = placeholder for backward compatibility + (11 ;preferred symmetric algorithms + (cons 'preferred-symmetric-key-algorithm + (cdr (assq (pgg-read-byte) + pgg-parse-symmetric-key-algorithm-alist)))) + (12 ;revocation key + ) + (16 ;issuer key ID + (cons 'key-identifier + (pgg-format-key-identifier (pgg-read-body-string ptag)))) + (20 ;notation data + (pgg-skip-bytes 4) + (cons 'notation + (let ((name-bytes (pgg-read-bytes 2)) + (value-bytes (pgg-read-bytes 2))) + (cons (pgg-read-bytes-string + (logior (lsh (car name-bytes) 8) + (nth 1 name-bytes))) + (pgg-read-bytes-string + (logior (lsh (car value-bytes) 8) + (nth 1 value-bytes))))))) + (21 ;preferred hash algorithms + (cons 'preferred-hash-algorithm + (cdr (assq (pgg-read-byte) + pgg-parse-hash-algorithm-alist)))) + (22 ;preferred compression algorithms + (cons 'preferred-compression-algorithm + (cdr (assq (pgg-read-byte) + pgg-parse-compression-algorithm-alist)))) + (23 ;key server preferences + (cons 'key-server-preferences + (pgg-read-body ptag))) + (24 ;preferred key server + (cons 'preferred-key-server + (pgg-read-body-string ptag))) + ;; 25 = primary user id + (26 ;policy URL + (cons 'policy-url (pgg-read-body-string ptag))) + ;; 27 = key flags + ;; 28 = signer's user id + ;; 29 = reason for revocation + ;; 100 to 110 = internal or user-defined + )) + +(defun pgg-parse-signature-packet (ptag) + (let* ((signature-version (pgg-byte-after)) + (result (list (cons 'version signature-version))) + hashed-material field n) + (cond + ((= signature-version 3) + (pgg-skip-bytes 2) + (setq hashed-material (pgg-read-bytes 5)) + (pgg-set-alist result + 'signature-type + (cdr (assq (pop hashed-material) + pgg-parse-signature-type-alist))) + (pgg-set-alist result + 'creation-time + (pgg-parse-time-field hashed-material)) + (pgg-set-alist result + 'key-identifier + (pgg-format-key-identifier + (pgg-read-bytes-string 8))) + (pgg-set-alist result + 'public-key-algorithm (pgg-read-byte)) + (pgg-set-alist result + 'hash-algorithm (pgg-read-byte))) + ((= signature-version 4) + (pgg-skip-bytes 1) + (pgg-set-alist result + 'signature-type + (cdr (assq (pgg-read-byte) + pgg-parse-signature-type-alist))) + (pgg-set-alist result + 'public-key-algorithm + (pgg-read-byte)) + (pgg-set-alist result + 'hash-algorithm (pgg-read-byte)) + (when (>= 10000 (setq n (pgg-read-bytes 2) + n (logior (lsh (car n) 8) + (nth 1 n)))) + (save-restriction + (narrow-to-region (point)(+ n (point))) + (nconc result + (mapcar (function cdr) ;remove packet types + (pgg-parse-packets + #'pgg-parse-signature-subpacket-header + #'pgg-parse-signature-subpacket))) + (goto-char (point-max)))) + (when (>= 10000 (setq n (pgg-read-bytes 2) + n (logior (lsh (car n) 8) + (nth 1 n)))) + (save-restriction + (narrow-to-region (point)(+ n (point))) + (nconc result + (mapcar (function cdr) ;remove packet types + (pgg-parse-packets + #'pgg-parse-signature-subpacket-header + #'pgg-parse-signature-subpacket))))))) + + (setcdr (setq field (assq 'public-key-algorithm + result)) + (cdr (assq (cdr field) + pgg-parse-public-key-algorithm-alist))) + (setcdr (setq field (assq 'hash-algorithm + result)) + (cdr (assq (cdr field) + pgg-parse-hash-algorithm-alist))) + result)) + +(defun pgg-parse-public-key-encrypted-session-key-packet (ptag) + (let (result) + (pgg-set-alist result + 'version (pgg-read-byte)) + (pgg-set-alist result + 'key-identifier + (pgg-format-key-identifier + (pgg-read-bytes-string 8))) + (pgg-set-alist result + 'public-key-algorithm + (cdr (assq (pgg-read-byte) + pgg-parse-public-key-algorithm-alist))) + result)) + +(defun pgg-parse-symmetric-key-encrypted-session-key-packet (ptag) + (let (result) + (pgg-set-alist result + 'version + (pgg-read-byte)) + (pgg-set-alist result + 'symmetric-key-algorithm + (cdr (assq (pgg-read-byte) + pgg-parse-symmetric-key-algorithm-alist))) + result)) + +(defun pgg-parse-public-key-packet (ptag) + (let* ((key-version (pgg-read-byte)) + (result (list (cons 'version key-version))) + field) + (cond + ((= 3 key-version) + (pgg-set-alist result + 'creation-time + (let ((bytes (pgg-read-bytes 4))) + (pgg-parse-time-field bytes))) + (pgg-set-alist result + 'key-expiry (pgg-read-bytes 2)) + (pgg-set-alist result + 'public-key-algorithm (pgg-read-byte))) + ((= 4 key-version) + (pgg-set-alist result + 'creation-time + (let ((bytes (pgg-read-bytes 4))) + (pgg-parse-time-field bytes))) + (pgg-set-alist result + 'public-key-algorithm (pgg-read-byte)))) + + (setcdr (setq field (assq 'public-key-algorithm + result)) + (cdr (assq (cdr field) + pgg-parse-public-key-algorithm-alist))) + result)) + +(defun pgg-decode-packets () + (let* ((marker + (set-marker (make-marker) + (and (re-search-forward "^=") + (match-beginning 0)))) + (checksum (buffer-substring (point) (+ 4 (point))))) + (delete-region marker (point-max)) + (mime-decode-region (point-min) marker "base64") + (static-when (fboundp 'pgg-parse-crc24-string ) + (or pgg-ignore-packet-checksum + (string-equal + (funcall (mel-find-function 'mime-encode-string "base64") + (pgg-parse-crc24-string + (buffer-substring (point-min)(point-max)))) + checksum) + (error "PGP packet checksum does not match"))))) + +(defun pgg-decode-armor-region (start end) + (save-restriction + (narrow-to-region start end) + (goto-char (point-min)) + (re-search-forward "^-+BEGIN PGP" nil t) + (delete-region (point-min) + (and (search-forward "\n\n") + (match-end 0))) + (pgg-decode-packets) + (goto-char (point-min)) + (pgg-parse-packets))) + +(defun pgg-parse-armor (string) + (with-temp-buffer + (buffer-disable-undo) + (set-buffer-multibyte nil) + (insert string) + (pgg-decode-armor-region (point-min)(point)))) + +(defun pgg-parse-armor-region (start end) + (pgg-parse-armor (string-as-unibyte (buffer-substring start end)))) + +(provide 'pgg-parse) + +;;; pgg-parse.el ends here diff --git a/mime/pgg-pgp.el b/mime/pgg-pgp.el new file mode 100644 index 0000000..91f6134 --- /dev/null +++ b/mime/pgg-pgp.el @@ -0,0 +1,246 @@ +;;; pgg-pgp.el --- PGP 2.* and 6.* support for PGG. + +;; Copyright (C) 1999,2000 Daiki Ueno + +;; Author: Daiki Ueno +;; Created: 1999/11/02 +;; Keywords: PGP, OpenPGP + +;; This file is part of SEMI (Secure Emacs MIME Interface). + +;; 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 'mel) ; binary-to-text-funcall, binary-write-decoded-region +(eval-when-compile (require 'pgg)) + +(defgroup pgg-pgp () + "PGP 2.* and 6.* interface" + :group 'pgg) + +(defcustom pgg-pgp-program "pgp" + "PGP 2.* and 6.* executable." + :group 'pgg-pgp + :type 'string) + +(defcustom pgg-pgp-shell-file-name "/bin/sh" + "File name to load inferior shells from. +Bourne shell or its equivalent \(not tcsh) is needed for \"2>\"." + :group 'pgg-pgp + :type 'string) + +(defcustom pgg-pgp-shell-command-switch "-c" + "Switch used to have the shell execute its command line argument." + :group 'pgg-pgp + :type 'string) + +(defcustom pgg-pgp-extra-args nil + "Extra arguments for every PGP invocation." + :group 'pgg-pgp + :type 'string) + +(eval-and-compile + (luna-define-class pgg-scheme-pgp (pgg-scheme))) + +(defvar pgg-pgp-user-id nil + "PGP ID of your default identity.") + +(defvar pgg-scheme-pgp-instance nil) + +;;;###autoload +(defun pgg-make-scheme-pgp () + (or pgg-scheme-pgp-instance + (setq pgg-scheme-pgp-instance + (luna-make-entity 'pgg-scheme-pgp)))) + +(defun pgg-pgp-process-region (start end passphrase program args) + (let* ((errors-file-name + (concat temporary-file-directory + (make-temp-name "pgg-errors"))) + (args + (append args + pgg-pgp-extra-args + (list (concat "2>" errors-file-name)))) + (shell-file-name pgg-pgp-shell-file-name) + (shell-command-switch pgg-pgp-shell-command-switch) + (process-environment process-environment) + (output-buffer pgg-output-buffer) + (errors-buffer pgg-errors-buffer) + (process-connection-type nil) + process status exit-status) + (with-current-buffer (get-buffer-create output-buffer) + (buffer-disable-undo) + (erase-buffer)) + (when passphrase + (setenv "PGPPASSFD" "0")) + (unwind-protect + (progn + (setq process + (apply #'binary-funcall + #'start-process-shell-command "*PGP*" output-buffer + program args)) + (set-process-sentinel process #'ignore) + (when passphrase + (process-send-string process (concat passphrase "\n"))) + (process-send-region process start end) + (process-send-eof process) + (while (eq 'run (process-status process)) + (accept-process-output process 5)) + (setq status (process-status process) + exit-status (process-exit-status process)) + (delete-process process) + (with-current-buffer output-buffer + (pgg-convert-lbt-region (point-min)(point-max) 'LF) + + (if (memq status '(stop signal)) + (error "%s exited abnormally: '%s'" program exit-status)) + (if (= 127 exit-status) + (error "%s could not be found" program)) + + (set-buffer (get-buffer-create errors-buffer)) + (buffer-disable-undo) + (erase-buffer) + (insert-file-contents errors-file-name))) + (if (and process (eq 'run (process-status process))) + (interrupt-process process)) + (condition-case nil + (delete-file errors-file-name) + (file-error nil))))) + +(luna-define-method pgg-scheme-lookup-key ((scheme pgg-scheme-pgp) + string &optional type) + (let ((args (list "+batchmode" "+language=en" "-kv" string))) + (with-current-buffer (get-buffer-create pgg-output-buffer) + (buffer-disable-undo) + (erase-buffer) + (apply #'call-process pgg-pgp-program nil t nil args) + (goto-char (point-min)) + (cond + ((re-search-forward "^pub\\s +[0-9]+/" nil t);PGP 2.* + (buffer-substring (point)(+ 8 (point)))) + ((re-search-forward "^Type" nil t);PGP 6.* + (beginning-of-line 2) + (substring + (nth 2 (split-string + (buffer-substring (point)(progn (end-of-line) (point))))) + 2)))))) + +(luna-define-method pgg-scheme-encrypt-region ((scheme pgg-scheme-pgp) + start end recipients) + (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id)) + (args + `("+encrypttoself=off +verbose=1" "+batchmode" + "+language=us" "-fate" + ,@(if recipients + (mapcar (lambda (rcpt) (concat "\"" rcpt "\"")) + (append recipients + (if pgg-encrypt-for-me + (list pgg-pgp-user-id)))))))) + (pgg-pgp-process-region start end nil pgg-pgp-program args) + (pgg-process-when-success nil))) + +(luna-define-method pgg-scheme-decrypt-region ((scheme pgg-scheme-pgp) + start end) + (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id)) + (passphrase + (pgg-read-passphrase + (format "PGP passphrase for %s: " pgg-pgp-user-id) + (pgg-scheme-lookup-key scheme pgg-pgp-user-id 'encrypt))) + (args + '("+verbose=1" "+batchmode" "+language=us" "-f"))) + (pgg-pgp-process-region start end passphrase pgg-pgp-program args) + (pgg-process-when-success nil))) + +(luna-define-method pgg-scheme-sign-region ((scheme pgg-scheme-pgp) + start end &optional clearsign) + (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id)) + (passphrase + (pgg-read-passphrase + (format "PGP passphrase for %s: " pgg-pgp-user-id) + (pgg-scheme-lookup-key scheme pgg-pgp-user-id 'sign))) + (args + (list (if clearsign "-fast" "-fbast") + "+verbose=1" "+language=us" "+batchmode" + "-u" pgg-pgp-user-id))) + (pgg-pgp-process-region start end passphrase pgg-pgp-program args) + (pgg-process-when-success + (goto-char (point-min)) + (when (re-search-forward "^-+BEGIN PGP" nil t);XXX + (let ((packet + (cdr (assq 2 (pgg-parse-armor-region + (progn (beginning-of-line 2) + (point)) + (point-max)))))) + (if pgg-cache-passphrase + (pgg-add-passphrase-cache + (cdr (assq 'key-identifier packet)) + passphrase))))))) + +(luna-define-method pgg-scheme-verify-region ((scheme pgg-scheme-pgp) + start end &optional signature) + (let* ((basename (expand-file-name "pgg" temporary-file-directory)) + (orig-file (make-temp-name basename)) + (args '("+verbose=1" "+batchmode" "+language=us")) + (orig-mode (default-file-modes))) + (unwind-protect + (progn + (set-default-file-modes 448) + (binary-write-decoded-region start end orig-file)) + (set-default-file-modes orig-mode)) + (when (stringp signature) + (copy-file signature (setq signature (concat orig-file ".asc"))) + (setq args (append args (list signature orig-file)))) + (pgg-pgp-process-region (point)(point) nil pgg-pgp-program args) + (delete-file orig-file) + (if signature (delete-file signature)) + (pgg-process-when-success + (goto-char (point-min)) + (let ((case-fold-search t)) + (while (re-search-forward "^warning: " nil t) + (delete-region (match-beginning 0) + (progn (beginning-of-line 2) (point))))) + (goto-char (point-min)) + (when (re-search-forward "^\\.$" nil t) + (delete-region (point-min) + (progn (beginning-of-line 2) + (point))))))) + +(luna-define-method pgg-scheme-insert-key ((scheme pgg-scheme-pgp)) + (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id)) + (args + (list "+verbose=1" "+batchmode" "+language=us" "-kxaf" + (concat "\"" pgg-pgp-user-id "\"")))) + (pgg-pgp-process-region (point)(point) nil pgg-pgp-program args) + (insert-buffer-substring pgg-output-buffer))) + +(luna-define-method pgg-scheme-snarf-keys-region ((scheme pgg-scheme-pgp) + start end) + (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id)) + (basename (expand-file-name "pgg" temporary-file-directory)) + (key-file (make-temp-name basename)) + (args + (list "+verbose=1" "+batchmode" "+language=us" "-kaf" + key-file))) + (let ((coding-system-for-write 'raw-text-dos)) + (write-region start end key-file)) + (pgg-pgp-process-region start end nil pgg-pgp-program args) + (delete-file key-file) + (pgg-process-when-success nil))) + +(provide 'pgg-pgp) + +;;; pgg-pgp.el ends here diff --git a/mime/pgg-pgp5.el b/mime/pgg-pgp5.el new file mode 100644 index 0000000..58c3309 --- /dev/null +++ b/mime/pgg-pgp5.el @@ -0,0 +1,255 @@ +;;; pgg-pgp5.el --- PGP 5.* support for PGG. + +;; Copyright (C) 1999,2000 Daiki Ueno + +;; Author: Daiki Ueno +;; Created: 1999/11/02 +;; Keywords: PGP, OpenPGP + +;; This file is part of SEMI (Secure Emacs MIME Interface). + +;; 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 'mel) ; binary-to-text-funcall, binary-write-decoded-region +(eval-when-compile (require 'pgg)) + +(defgroup pgg-pgp5 () + "PGP 5.* interface" + :group 'pgg) + +(defcustom pgg-pgp5-pgpe-program "pgpe" + "PGP 5.* 'pgpe' executable." + :group 'pgg-pgp5 + :type 'string) + +(defcustom pgg-pgp5-pgps-program "pgps" + "PGP 5.* 'pgps' executable." + :group 'pgg-pgp5 + :type 'string) + +(defcustom pgg-pgp5-pgpk-program "pgpk" + "PGP 5.* 'pgpk' executable." + :group 'pgg-pgp5 + :type 'string) + +(defcustom pgg-pgp5-pgpv-program "pgpv" + "PGP 5.* 'pgpv' executable." + :group 'pgg-pgp5 + :type 'string) + +(defcustom pgg-pgp5-shell-file-name "/bin/sh" + "File name to load inferior shells from. +Bourne shell or its equivalent \(not tcsh) is needed for \"2>\"." + :group 'pgg-pgp5 + :type 'string) + +(defcustom pgg-pgp5-shell-command-switch "-c" + "Switch used to have the shell execute its command line argument." + :group 'pgg-pgp5 + :type 'string) + +(defcustom pgg-pgp5-extra-args nil + "Extra arguments for every PGP 5.* invocation." + :group 'pgg-pgp5 + :type 'string) + +(eval-and-compile + (luna-define-class pgg-scheme-pgp5 (pgg-scheme))) + +(defvar pgg-pgp5-user-id nil + "PGP 5.* ID of your default identity.") + +(defvar pgg-scheme-pgp5-instance nil) + +;;;###autoload +(defun pgg-make-scheme-pgp5 () + (or pgg-scheme-pgp5-instance + (setq pgg-scheme-pgp5-instance + (luna-make-entity 'pgg-scheme-pgp5)))) + +(defun pgg-pgp5-process-region (start end passphrase program args) + (let* ((errors-file-name + (concat temporary-file-directory + (make-temp-name "pgg-errors"))) + (args + (append args + pgg-pgp5-extra-args + (list (concat "2>" errors-file-name)))) + (shell-file-name pgg-pgp5-shell-file-name) + (shell-command-switch pgg-pgp5-shell-command-switch) + (process-environment process-environment) + (output-buffer pgg-output-buffer) + (errors-buffer pgg-errors-buffer) + (process-connection-type nil) + process status exit-status) + (with-current-buffer (get-buffer-create output-buffer) + (buffer-disable-undo) + (erase-buffer)) + (when passphrase + (setenv "PGPPASSFD" "0")) + (unwind-protect + (progn + (setq process + (apply #'binary-funcall + #'start-process-shell-command "*PGP*" output-buffer + program args)) + (set-process-sentinel process #'ignore) + (when passphrase + (process-send-string process (concat passphrase "\n"))) + (process-send-region process start end) + (process-send-eof process) + (while (eq 'run (process-status process)) + (accept-process-output process 5)) + (setq status (process-status process) + exit-status (process-exit-status process)) + (delete-process process) + (with-current-buffer output-buffer + (pgg-convert-lbt-region (point-min)(point-max) 'LF) + + (if (memq status '(stop signal)) + (error "%s exited abnormally: '%s'" program exit-status)) + (if (= 127 exit-status) + (error "%s could not be found" program)) + + (set-buffer (get-buffer-create errors-buffer)) + (buffer-disable-undo) + (erase-buffer) + (insert-file-contents errors-file-name))) + (if (and process (eq 'run (process-status process))) + (interrupt-process process)) + (condition-case nil + (delete-file errors-file-name) + (file-error nil))))) + +(luna-define-method pgg-scheme-lookup-key ((scheme pgg-scheme-pgp5) + string &optional type) + (let ((args (list "+language=en" "-l" string))) + (with-current-buffer (get-buffer-create pgg-output-buffer) + (buffer-disable-undo) + (erase-buffer) + (apply #'call-process pgg-pgp5-pgpk-program nil t nil args) + (goto-char (point-min)) + (when (re-search-forward "^sec" nil t) + (substring + (nth 2 (split-string + (buffer-substring (match-end 0)(progn (end-of-line)(point))))) + 2))))) + +(luna-define-method pgg-scheme-encrypt-region ((scheme pgg-scheme-pgp5) + start end recipients) + (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) + (args + `("+NoBatchInvalidKeys=off" "-fat" "+batchmode=1" + ,@(if recipients + (apply #'append + (mapcar (lambda (rcpt) + (list "-r" + (concat "\"" rcpt "\""))) + (append recipients + (if pgg-encrypt-for-me + (list pgg-pgp5-user-id))))))))) + (pgg-pgp5-process-region start end nil pgg-pgp5-pgpe-program args) + (pgg-process-when-success nil))) + +(luna-define-method pgg-scheme-decrypt-region ((scheme pgg-scheme-pgp5) + start end) + (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) + (passphrase + (pgg-read-passphrase + (format "PGP passphrase for %s: " pgg-pgp5-user-id) + (pgg-scheme-lookup-key scheme pgg-pgp5-user-id 'encrypt))) + (args + '("+verbose=1" "+batchmode=1" "+language=us" "-f"))) + (pgg-pgp5-process-region start end passphrase pgg-pgp5-pgpv-program args) + (pgg-process-when-success nil))) + +(luna-define-method pgg-scheme-sign-region ((scheme pgg-scheme-pgp5) + start end &optional clearsign) + (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) + (passphrase + (pgg-read-passphrase + (format "PGP passphrase for %s: " pgg-pgp5-user-id) + (pgg-scheme-lookup-key scheme pgg-pgp5-user-id 'sign))) + (args + (list (if clearsign "-fat" "-fbat") + "+verbose=1" "+language=us" "+batchmode=1" + "-u" pgg-pgp5-user-id))) + (pgg-pgp5-process-region start end passphrase pgg-pgp5-pgps-program args) + (pgg-process-when-success + (when (re-search-forward "^-+BEGIN PGP SIGNATURE" nil t);XXX + (let ((packet + (cdr (assq 2 (pgg-parse-armor-region + (progn (beginning-of-line 2) + (point)) + (point-max)))))) + (if pgg-cache-passphrase + (pgg-add-passphrase-cache + (cdr (assq 'key-identifier packet)) + passphrase))))))) + +(luna-define-method pgg-scheme-verify-region ((scheme pgg-scheme-pgp5) + start end &optional signature) + (let* ((basename (expand-file-name "pgg" temporary-file-directory)) + (orig-file (make-temp-name basename)) + (args '("+verbose=1" "+batchmode=1" "+language=us")) + (orig-mode (default-file-modes))) + (unwind-protect + (progn + (set-default-file-modes 448) + (binary-write-decoded-region start end orig-file)) + (set-default-file-modes orig-mode)) + (when (stringp signature) + (copy-file signature (setq signature (concat orig-file ".asc"))) + (setq args (append args (list signature)))) + (pgg-pgp5-process-region (point)(point) nil pgg-pgp5-pgpv-program args) + (delete-file orig-file) + (if signature (delete-file signature)) + (with-current-buffer pgg-errors-buffer + (goto-char (point-min)) + (if (re-search-forward "^Good signature" nil t) + (progn + (set-buffer pgg-output-buffer) + (insert-buffer-substring pgg-errors-buffer) + t) + nil)))) + +(luna-define-method pgg-scheme-insert-key ((scheme pgg-scheme-pgp5)) + (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) + (args + (list "+verbose=1" "+batchmode=1" "+language=us" "-x" + (concat "\"" pgg-pgp5-user-id "\"")))) + (pgg-pgp5-process-region (point)(point) nil pgg-pgp5-pgpk-program args) + (insert-buffer-substring pgg-output-buffer))) + +(luna-define-method pgg-scheme-snarf-keys-region ((scheme pgg-scheme-pgp5) + start end) + (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) + (basename (expand-file-name "pgg" temporary-file-directory)) + (key-file (make-temp-name basename)) + (args + (list "+verbose=1" "+batchmode=1" "+language=us" "-a" + key-file))) + (let ((coding-system-for-write 'raw-text-dos)) + (write-region start end key-file)) + (pgg-pgp5-process-region start end nil pgg-pgp5-pgpk-program args) + (delete-file key-file) + (pgg-process-when-success nil))) + +(provide 'pgg-pgp5) + +;;; pgg-pgp5.el ends here diff --git a/mime/pgg.el b/mime/pgg.el new file mode 100644 index 0000000..1b40d48 --- /dev/null +++ b/mime/pgg.el @@ -0,0 +1,421 @@ +;;; pgg.el --- glue for the various PGP implementations. + +;; Copyright (C) 1999,2000 Free Software Foundation, Inc. + +;; Author: Daiki Ueno +;; Created: 1999/10/28 +;; Keywords: PGP + +;; This file is part of SEMI (Secure Emacs MIME Interface). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + + +;;; Commentary: +;; + +;;; Code: + +(require 'calist) + +(eval-and-compile (require 'luna)) + +(require 'pgg-def) +(require 'pgg-parse) + +(eval-when-compile + (ignore-errors + (require 'w3) + (require 'url))) + +(in-calist-package 'pgg) + +(defun pgg-field-match-method-with-containment + (calist field-type field-value) + (let ((s-field (assq field-type calist))) + (cond ((null s-field) + (cons (cons field-type field-value) calist)) + ((memq (cdr s-field) field-value) + calist)))) + +(define-calist-field-match-method 'signature-version + #'pgg-field-match-method-with-containment) + +(define-calist-field-match-method 'symmetric-key-algorithm + #'pgg-field-match-method-with-containment) + +(define-calist-field-match-method 'public-key-algorithm + #'pgg-field-match-method-with-containment) + +(define-calist-field-match-method 'hash-algorithm + #'pgg-field-match-method-with-containment) + +(defvar pgg-verify-condition nil + "Condition-tree about which PGP implementation is used for verifying.") + +(defvar pgg-decrypt-condition nil + "Condition-tree about which PGP implementation is used for decrypting.") + +(ctree-set-calist-strictly + 'pgg-verify-condition + '((signature-version 3)(public-key-algorithm RSA)(hash-algorithm MD5) + (scheme . pgp))) + +(ctree-set-calist-strictly + 'pgg-decrypt-condition + '((public-key-algorithm RSA)(symmetric-key-algorithm IDEA) + (scheme . pgp))) + +(ctree-set-calist-strictly + 'pgg-verify-condition + '((signature-version 3 4) + (public-key-algorithm RSA ELG DSA) + (hash-algorithm MD5 SHA1 RIPEMD160) + (scheme . pgp5))) + +(ctree-set-calist-strictly + 'pgg-decrypt-condition + '((public-key-algorithm RSA ELG DSA) + (symmetric-key-algorithm 3DES CAST5 IDEA) + (scheme . pgp5))) + +(ctree-set-calist-strictly + 'pgg-verify-condition + '((signature-version 3 4) + (public-key-algorithm ELG-E DSA ELG) + (hash-algorithm MD5 SHA1 RIPEMD160) + (scheme . gpg))) + +(ctree-set-calist-strictly + 'pgg-decrypt-condition + '((public-key-algorithm ELG-E DSA ELG) + (symmetric-key-algorithm 3DES CAST5 BLOWFISH TWOFISH) + (scheme . gpg))) + +;;; @ definition of the implementation scheme +;;; + +(eval-and-compile + (luna-define-class pgg-scheme ()) + + (luna-define-internal-accessors 'pgg-scheme)) + +(luna-define-generic pgg-scheme-lookup-key (scheme string &optional type) + "Search keys associated with STRING.") + +(luna-define-generic pgg-scheme-encrypt-region (scheme start end recipients) + "Encrypt the current region between START and END.") + +(luna-define-generic pgg-scheme-decrypt-region (scheme start end) + "Decrypt the current region between START and END.") + +(luna-define-generic pgg-scheme-sign-region + (scheme start end &optional cleartext) + "Make detached signature from text between START and END.") + +(luna-define-generic pgg-scheme-verify-region + (scheme start end &optional signature) + "Verify region between START and END as the detached signature SIGNATURE.") + +(luna-define-generic pgg-scheme-insert-key (scheme) + "Insert public key at point.") + +(luna-define-generic pgg-scheme-snarf-keys-region (scheme start end) + "Add all public keys in region between START and END to the keyring.") + +;;; @ utility functions +;;; + +(defvar pgg-fetch-key-function (function pgg-fetch-key-with-w3)) + +(defmacro pgg-make-scheme (scheme) + `(progn + (require (intern (format "pgg-%s" ,scheme))) + (funcall (intern (format "pgg-make-scheme-%s" + ,scheme))))) + +(put 'pgg-save-coding-system 'lisp-indent-function 2) + +(defmacro pgg-save-coding-system (start end &rest body) + `(if (interactive-p) + (let ((buffer (current-buffer))) + (with-temp-buffer + (let (buffer-undo-list) + (insert-buffer-substring buffer ,start ,end) + (encode-coding-region (point-min)(point-max) + buffer-file-coding-system) + (prog1 (save-excursion ,@body) + (push nil buffer-undo-list) + (ignore-errors (undo)))))) + (save-restriction + (narrow-to-region ,start ,end) + ,@body))) + +(defun pgg-temp-buffer-show-function (buffer) + (let ((window (split-window-vertically))) + (set-window-buffer window buffer) + (shrink-window-if-larger-than-buffer window))) + +(defun pgg-display-output-buffer (start end status) + (if status + (progn + (delete-region start end) + (insert-buffer-substring pgg-output-buffer) + (decode-coding-region start (point) buffer-file-coding-system)) + (let ((temp-buffer-show-function + (function pgg-temp-buffer-show-function))) + (with-output-to-temp-buffer pgg-echo-buffer + (set-buffer standard-output) + (insert-buffer-substring pgg-errors-buffer))))) + +(defvar pgg-passphrase-cache-expiry 16) +(defvar pgg-passphrase-cache (make-vector 7 0)) + +(defvar pgg-read-passphrase nil) +(defun pgg-read-passphrase (prompt &optional key) + (if (not pgg-read-passphrase) + (if (functionp 'read-passwd) + (setq pgg-read-passphrase 'read-passwd) + (if (load "passwd" t) + (setq pgg-read-passphrase 'read-passwd) + (autoload 'ange-ftp-read-passwd "ange-ftp") + (setq pgg-read-passphrase 'ange-ftp-read-passwd)))) + (or (and pgg-cache-passphrase + key (setq key (pgg-truncate-key-identifier key)) + (symbol-value (intern-soft key pgg-passphrase-cache))) + (funcall pgg-read-passphrase prompt))) + +(defun pgg-add-passphrase-cache (key passphrase) + (setq key (pgg-truncate-key-identifier key)) + (set (intern key pgg-passphrase-cache) + passphrase) + (run-at-time pgg-passphrase-cache-expiry nil + #'pgg-remove-passphrase-cache + key)) + +(defun pgg-remove-passphrase-cache (key) + (let ((passphrase (symbol-value (intern-soft key pgg-passphrase-cache)))) + (when passphrase + (fillarray passphrase ?_) + (unintern key pgg-passphrase-cache)))) + +(defmacro pgg-convert-lbt-region (start end lbt) + `(let ((pgg-conversion-end (set-marker (make-marker) ,end))) + (goto-char ,start) + (case ,lbt + (CRLF + (while (progn + (end-of-line) + (> (marker-position pgg-conversion-end) (point))) + (insert "\r") + (forward-line 1))) + (LF + (while (re-search-forward "\r$" pgg-conversion-end t) + (replace-match "")))))) + +(put 'pgg-as-lbt 'lisp-indent-function 3) + +(defmacro pgg-as-lbt (start end lbt &rest body) + `(let ((inhibit-read-only t) + buffer-read-only + buffer-undo-list) + (pgg-convert-lbt-region ,start ,end ,lbt) + (let ((,end (point))) + ,@body) + (push nil buffer-undo-list) + (ignore-errors (undo)))) + +(put 'pgg-process-when-success 'lisp-indent-function 0) + +(defmacro pgg-process-when-success (&rest body) + `(with-current-buffer pgg-output-buffer + (if (zerop (buffer-size)) nil ,@body t))) + + +;;; @ interface functions +;;; + +;;;###autoload +(defun pgg-encrypt-region (start end rcpts) + "Encrypt the current region between START and END for RCPTS." + (interactive + (list (region-beginning)(region-end) + (split-string (read-string "Recipients: ") "[ \t,]+"))) + (let* ((entity (pgg-make-scheme pgg-default-scheme)) + (status + (pgg-save-coding-system start end + (pgg-scheme-encrypt-region entity (point-min)(point-max) rcpts)))) + (when (interactive-p) + (pgg-display-output-buffer start end status)) + status)) + +;;;###autoload +(defun pgg-decrypt-region (start end) + "Decrypt the current region between START and END." + (interactive "r") + (let* ((packet (cdr (assq 1 (pgg-parse-armor-region start end)))) + (scheme + (or pgg-scheme + (cdr (assq 'scheme + (progn + (in-calist-package 'pgg) + (ctree-match-calist pgg-decrypt-condition + packet)))) + pgg-default-scheme)) + (entity (pgg-make-scheme scheme)) + (status + (pgg-save-coding-system start end + (pgg-scheme-decrypt-region entity (point-min)(point-max))))) + (when (interactive-p) + (pgg-display-output-buffer start end status)) + status)) + +;;;###autoload +(defun pgg-sign-region (start end &optional cleartext) + "Make the signature from text between START and END. +If the optional 3rd argument CLEARTEXT is non-nil, it does not create +a detached signature." + (interactive "r") + (let* ((entity (pgg-make-scheme pgg-default-scheme)) + (status (pgg-save-coding-system start end + (pgg-scheme-sign-region entity (point-min)(point-max) + (or (interactive-p) cleartext))))) + (when (interactive-p) + (pgg-display-output-buffer start end status)) + status)) + +;;;###autoload +(defun pgg-verify-region (start end &optional signature fetch) + "Verify the current region between START and END. +If the optional 3rd argument SIGNATURE is non-nil, it is treated as +the detached signature of the current region. + +If the optional 4th argument FETCH is non-nil, we attempt to fetch the +signer's public key from `pgg-default-keyserver-address'." + (interactive "r") + (let* ((packet + (if (null signature) nil + (with-temp-buffer + (buffer-disable-undo) + (set-buffer-multibyte nil) + (insert-file-contents signature) + (cdr (assq 2 (pgg-decode-armor-region + (point-min)(point-max))))))) + (scheme + (or pgg-scheme + (cdr (assq 'scheme + (progn + (in-calist-package 'pgg) + (ctree-match-calist pgg-verify-condition + packet)))) + pgg-default-scheme)) + (entity (pgg-make-scheme scheme)) + (key (cdr (assq 'key-identifier packet))) + status keyserver) + (and (stringp key) + (setq key (concat "0x" (pgg-truncate-key-identifier key))) + (null (let ((pgg-scheme scheme)) + (pgg-lookup-key key))) + (or fetch (interactive-p)) + (y-or-n-p (format "Key %s not found; attempt to fetch? " key)) + (setq keyserver + (or (cdr (assq 'preferred-key-server packet)) + pgg-default-keyserver-address)) + (pgg-fetch-key keyserver key)) + (setq status (pgg-save-coding-system start end + (pgg-scheme-verify-region entity (point-min)(point-max) + signature))) + (when (interactive-p) + (let ((temp-buffer-show-function + (function pgg-temp-buffer-show-function))) + (with-output-to-temp-buffer pgg-echo-buffer + (set-buffer standard-output) + (insert-buffer-substring (if status pgg-output-buffer + pgg-errors-buffer))))) + status)) + +;;;###autoload +(defun pgg-insert-key () + "Insert the ASCII armored public key." + (interactive) + (let ((entity (pgg-make-scheme (or pgg-scheme pgg-default-scheme)))) + (pgg-scheme-insert-key entity))) + +;;;###autoload +(defun pgg-snarf-keys-region (start end) + "Import public keys in the current region between START and END." + (interactive "r") + (let ((entity (pgg-make-scheme (or pgg-scheme pgg-default-scheme)))) + (pgg-save-coding-system start end + (pgg-scheme-snarf-keys-region entity start end)))) + +(defun pgg-lookup-key (string &optional type) + (let ((entity (pgg-make-scheme (or pgg-scheme pgg-default-scheme)))) + (pgg-scheme-lookup-key entity string type))) + +(defvar pgg-insert-url-function (function pgg-insert-url-with-w3)) + +(defun pgg-insert-url-with-w3 (url) + (require 'w3) + (require 'url) + (let (buffer-file-name) + (url-insert-file-contents url))) + +(defvar pgg-insert-url-extra-arguments nil) +(defvar pgg-insert-url-program nil) + +(defun pgg-insert-url-with-program (url) + (let ((args (copy-sequence pgg-insert-url-extra-arguments)) + process) + (insert + (with-temp-buffer + (setq process + (apply #'start-process " *PGG url*" (current-buffer) + pgg-insert-url-program (nconc args (list url)))) + (set-process-sentinel process #'ignore) + (while (eq 'run (process-status process)) + (accept-process-output process 5)) + (delete-process process) + (if (and process (eq 'run (process-status process))) + (interrupt-process process)) + (buffer-string))))) + +(defun pgg-fetch-key (keyserver key) + "Attempt to fetch a KEY from KEYSERVER for addition to PGP or GnuPG keyring." + (with-current-buffer (get-buffer-create pgg-output-buffer) + (buffer-disable-undo) + (erase-buffer) + (let ((proto (if (string-match "^[a-zA-Z\\+\\.\\\\-]+:" keyserver) + (substring keyserver 0 (1- (match-end 0)))))) + (save-excursion + (funcall pgg-insert-url-function + (if proto keyserver + (format "http://%s:11371/pks/lookup?op=get&search=%s" + keyserver key)))) + (when (re-search-forward "^-+BEGIN" nil 'last) + (delete-region (point-min) (match-beginning 0)) + (when (re-search-forward "^-+END" nil t) + (delete-region (progn (end-of-line) (point)) + (point-max))) + (insert "\n") + (with-temp-buffer + (insert-buffer-substring pgg-output-buffer) + (pgg-snarf-keys-region (point-min)(point-max))))))) + + +(provide 'pgg) + +;;; pgg.el ends here diff --git a/mime/postpet.el b/mime/postpet.el new file mode 100644 index 0000000..4284cf6 --- /dev/null +++ b/mime/postpet.el @@ -0,0 +1,153 @@ +;;; postpet.el --- Postpet support for GNU Emacs + +;; Copyright (C) 1999,2000 Free Software Foundation, Inc. + +;; Author: Tanaka Akira +;; Keywords: Postpet, MIME, multimedia, mail, news + +;; This file is part of SEMI (Sample of Elastic MIME Interfaces). + +;; 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 'alist) + +(put 'unpack 'lisp-indent-function 1) +(defmacro unpack (string &rest body) + `(let* ((*unpack*string* (string-as-unibyte ,string)) + (*unpack*index* 0)) + ,@body)) + +(defun unpack-skip (len) + (setq *unpack*index* (+ len *unpack*index*))) + +(defun unpack-fixed (len) + (prog1 + (substring *unpack*string* *unpack*index* (+ *unpack*index* len)) + (unpack-skip len))) + +(defun unpack-byte () + (char-int (aref (unpack-fixed 1) 0))) + +(defun unpack-short () + (let* ((b0 (unpack-byte)) + (b1 (unpack-byte))) + (+ (* 256 b0) b1))) + +(defun unpack-long () + (let* ((s0 (unpack-short)) + (s1 (unpack-short))) + (+ (* 65536 s0) s1))) + +(defun unpack-string () + (let ((len (unpack-byte))) + (unpack-fixed len))) + +(defun unpack-string-sjis () + (decode-mime-charset-string (unpack-string) 'shift_jis)) + +;;;###autoload +(defun postpet-decode (string) + (condition-case nil + (unpack string + (let (res) + (unpack-skip 4) + (set-alist 'res 'carryingcount (unpack-long)) + (unpack-skip 8) + (set-alist 'res 'sentyear (unpack-short)) + (set-alist 'res 'sentmonth (unpack-short)) + (set-alist 'res 'sentday (unpack-short)) + (unpack-skip 8) + (set-alist 'res 'petname (unpack-string-sjis)) + (set-alist 'res 'owner (unpack-string-sjis)) + (set-alist 'res 'pettype (unpack-fixed 4)) + (set-alist 'res 'health (unpack-short)) + (unpack-skip 2) + (set-alist 'res 'sex (unpack-long)) + (unpack-skip 1) + (set-alist 'res 'brain (unpack-byte)) + (unpack-skip 39) + (set-alist 'res 'happiness (unpack-byte)) + (unpack-skip 14) + (set-alist 'res 'petbirthyear (unpack-short)) + (set-alist 'res 'petbirthmonth (unpack-short)) + (set-alist 'res 'petbirthday (unpack-short)) + (unpack-skip 8) + (set-alist 'res 'from (unpack-string)) + (unpack-skip 5) + (unpack-skip 160) + (unpack-skip 4) + (unpack-skip 8) + (unpack-skip 8) + (unpack-skip 26) + (set-alist 'res 'treasure (unpack-short)) + (set-alist 'res 'money (unpack-long)) + res)) + (error nil))) + +;;;###autoload +(defun mime-display-application/x-postpet (entity situation) + (save-restriction + (narrow-to-region (point-max)(point-max)) + (let ((pet (postpet-decode (mime-entity-content entity)))) + (if pet + (insert + "Petname: " (cdr (assq 'petname pet)) + "\n" + "Owner: " (cdr (assq 'owner pet)) + "\n" + "Pettype: " (cdr (assq 'pettype pet)) + "\n" + "From: " (cdr (assq 'from pet)) + "\n" + "CarryingCount: " (int-to-string (cdr (assq 'carryingcount pet))) + "\n" + "SentYear: " (int-to-string (cdr (assq 'sentyear pet))) + "\n" + "SentMonth: " (int-to-string (cdr (assq 'sentmonth pet))) + "\n" + "SentDay: " (int-to-string (cdr (assq 'sentday pet))) + "\n" + "PetbirthYear: " (int-to-string (cdr (assq 'petbirthyear pet))) + "\n" + "PetbirthMonth: " (int-to-string (cdr (assq 'petbirthmonth pet))) + "\n" + "PetbirthDay: " (int-to-string (cdr (assq 'petbirthday pet))) + "\n" + "Health: " (int-to-string (cdr (assq 'health pet))) + "\n" + "Sex: " (int-to-string (cdr (assq 'sex pet))) + "\n" + "Brain: " (int-to-string (cdr (assq 'brain pet))) + "\n" + "Happiness: " (int-to-string (cdr (assq 'happiness pet))) + "\n" + "Treasure: " (int-to-string (cdr (assq 'treasure pet))) + "\n" + "Money: " (int-to-string (cdr (assq 'money pet))) + "\n") + (insert "Invalid format\n")) + (run-hooks 'mime-display-application/x-postpet-hook)))) + + +;;; @ end +;;; + +(provide 'postpet) + +;;; postpet.el ends here diff --git a/mime/semi-def.el b/mime/semi-def.el new file mode 100644 index 0000000..5e6fa0f --- /dev/null +++ b/mime/semi-def.el @@ -0,0 +1,208 @@ +;;; semi-def.el --- definition module for SEMI -*- coding: iso-8859-4; -*- + +;; Copyright (C) 1995,96,97,98,99,2000 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Keywords: definition, MIME, multimedia, mail, news + +;; This file is part of SEMI (Sample of Emacs MIME Implementation). + +;; 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)) + +(require 'custom) + +(defconst mime-user-interface-product ["SEMI" (1 14 3) "Ushinoya"] + "Product name, version number and code name of MIME-kernel package.") + +(autoload 'mule-caesar-region "mule-caesar" + "Caesar rotation of current region." t) + + +;;; @ constants +;;; + +(defconst mime-echo-buffer-name "*MIME-echo*" + "Name of buffer to display MIME-playing information.") + +(defconst mime-temp-buffer-name " *MIME-temp*") + + +;;; @ button +;;; + +(defcustom mime-button-face 'bold + "Face used for content-button or URL-button of MIME-Preview buffer." + :group 'mime + :type 'face) + +(defcustom mime-button-mouse-face 'highlight + "Face used for MIME-preview buffer mouse highlighting." + :group 'mime + :type 'face) + +(defsubst mime-add-button (from to function &optional data) + "Create a button between FROM and TO with callback FUNCTION and DATA." + (and mime-button-face + (put-text-property from to 'face mime-button-face)) + (and mime-button-mouse-face + (put-text-property from to 'mouse-face mime-button-mouse-face)) + (put-text-property from to 'mime-button-callback function) + (and data + (put-text-property from to 'mime-button-data data)) + ) + +(defsubst mime-insert-button (string function &optional data) + "Insert STRING as button with callback FUNCTION and DATA." + (save-restriction + (narrow-to-region (point)(point)) + (insert (concat "[" string "]\n")) + (mime-add-button (point-min)(point-max) function data) + )) + +(defvar mime-button-mother-dispatcher nil) + +(defun mime-button-dispatcher (event) + "Select the button under point." + (interactive "e") + (let (buf point func data) + (save-window-excursion + (mouse-set-point event) + (setq buf (current-buffer) + point (point) + func (get-text-property (point) 'mime-button-callback) + data (get-text-property (point) 'mime-button-data) + )) + (save-excursion + (set-buffer buf) + (goto-char point) + (if func + (apply func data) + (if (fboundp mime-button-mother-dispatcher) + (funcall mime-button-mother-dispatcher event) + ))))) + + +;;; @ for URL +;;; + +(defcustom mime-browse-url-regexp + (concat "\\(http\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):" + "\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?" + "[-a-zA-Z0-9_=?#$@~`%&*+|\\/.,]*[-a-zA-Z0-9_=#$@~`%&*+|\\/]") + "*Regexp to match URL in text body." + :group 'mime + :type 'regexp) + +(defcustom mime-browse-url-function (function browse-url) + "*Function to browse URL." + :group 'mime + :type 'function) + +(defsubst mime-add-url-buttons () + "Add URL-buttons for text body." + (goto-char (point-min)) + (while (re-search-forward mime-browse-url-regexp nil t) + (let ((beg (match-beginning 0)) + (end (match-end 0))) + (mime-add-button beg end mime-browse-url-function + (list (buffer-substring beg end)))))) + + +;;; @ menu +;;; + +(if window-system + (if (featurep 'xemacs) + (defun select-menu-alist (title menu-alist) + (let (ret) + (popup-menu + (list* title + "---" + (mapcar (function + (lambda (cell) + (vector (car cell) + `(progn + (setq ret ',(cdr cell)) + (throw 'exit nil) + ) + t) + )) + menu-alist) + )) + (recursive-edit) + ret)) + (defun select-menu-alist (title menu-alist) + (x-popup-menu + (list '(1 1) (selected-window)) + (list title (cons title menu-alist)) + )) + ) + (defun select-menu-alist (title menu-alist) + (cdr + (assoc (completing-read (concat title " : ") menu-alist) + menu-alist) + )) + ) + + +;;; @ Other Utility +;;; + +(defvar mime-condition-type-alist + '((preview . mime-preview-condition) + (action . mime-acting-condition))) + +(defvar mime-condition-mode-alist + '((with-default . ctree-set-calist-with-default) + (t . ctree-set-calist-strictly))) + +(defun mime-add-condition (target-type condition &optional mode file) + "Add CONDITION to database specified by TARGET-TYPE. +TARGET-TYPE must be 'preview or 'action. +If optional argument MODE is 'strict or nil (omitted), CONDITION is +added strictly. +If optional argument MODE is 'with-default, CONDITION is added with +default rule. +If optional argument FILE is specified, it is loaded when CONDITION is +activate." + (let ((sym (cdr (assq target-type mime-condition-type-alist)))) + (if sym + (let ((func (cdr (or (assq mode mime-condition-mode-alist) + (assq t mime-condition-mode-alist))))) + (if (fboundp func) + (progn + (funcall func sym condition) + (if file + (let ((method (cdr (assq 'method condition)))) + (autoload method file) + )) + ) + (error "Function for mode `%s' is not found." mode) + )) + (error "Variable for target-type `%s' is not found." target-type) + ))) + + +;;; @ end +;;; + +(provide 'semi-def) + +;;; semi-def.el ends here diff --git a/mime/semi-setup.el b/mime/semi-setup.el new file mode 100644 index 0000000..ecdf2ae --- /dev/null +++ b/mime/semi-setup.el @@ -0,0 +1,208 @@ +;;; semi-setup.el --- setup file for MIME-View. + +;; Copyright (C) 1994,95,96,97,98,99,2000 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Keywords: mail, news, MIME, multimedia, multilingual, encoded-word + +;; This file is part of SEMI (Setting for Emacs MIME Interfaces). + +;; 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 'semi-def) +(require 'path-util) + +(defun call-after-loaded (module func &optional hook-name) + "If MODULE is provided, then FUNC is called. +Otherwise func is set to MODULE-load-hook. +If optional argument HOOK-NAME is specified, +it is used as hook to set." + (if (featurep module) + (funcall func) + (or hook-name + (setq hook-name (intern (concat (symbol-name module) "-load-hook"))) + ) + (add-hook hook-name func) + )) + + +;; for image/* +(defvar mime-setup-enable-inline-image + (and window-system + (or (featurep 'xemacs)(featurep 'mule))) + "*If it is non-nil, semi-setup sets up to use mime-image.") + +(if mime-setup-enable-inline-image + (eval-after-load "mime-view" + '(require 'mime-image))) + +;; for text/html +(defvar mime-setup-enable-inline-html + (module-installed-p 'w3) + "*If it is non-nil, semi-setup sets up to use mime-w3.") + +(if mime-setup-enable-inline-html + (eval-after-load "mime-view" + '(progn + (autoload 'mime-preview-text/html "mime-w3") + + (ctree-set-calist-strictly + 'mime-preview-condition + '((type . text)(subtype . html) + (body . visible) + (body-presentation-method . mime-preview-text/html))) + + (set-alist 'mime-view-type-subtype-score-alist + '(text . html) 3) + ))) + + +;; for PGP +(defvar mime-setup-enable-pgp t + "*If it is non-nil, semi-setup sets uf to use mime-pgp.") + +(if mime-setup-enable-pgp + (eval-after-load "mime-view" + '(progn + (mime-add-condition + 'preview '((type . application)(subtype . pgp) + (message-button . visible))) + (mime-add-condition + 'action '((type . application)(subtype . pgp) + (method . mime-view-application/pgp)) + 'strict "mime-pgp") + (mime-add-condition + 'action '((type . text)(subtype . x-pgp) + (method . mime-view-application/pgp))) + + (mime-add-condition + 'action '((type . multipart)(subtype . signed) + (method . mime-verify-multipart/signed)) + 'strict "mime-pgp") + + (mime-add-condition + 'action + '((type . application)(subtype . pgp-signature) + (method . mime-verify-application/pgp-signature)) + 'strict "mime-pgp") + + (mime-add-condition + 'action + '((type . application)(subtype . pgp-encrypted) + (method . mime-decrypt-application/pgp-encrypted)) + 'strict "mime-pgp") + + (mime-add-condition + 'action + '((type . application)(subtype . pgp-keys) + (method . mime-add-application/pgp-keys)) + 'strict "mime-pgp") + + (mime-add-condition + 'action + '((type . application)(subtype . pkcs7-signature) + (method . mime-verify-application/pkcs7-signature)) + 'strict "mime-pgp") + + (mime-add-condition + 'action + '((type . application)(subtype . x-pkcs7-signature) + (method . mime-verify-application/pkcs7-signature)) + 'strict "mime-pgp") + + (mime-add-condition + 'action + '((type . application)(subtype . pkcs7-mime) + (method . mime-view-application/pkcs7-mime)) + 'strict "mime-pgp") + + (mime-add-condition + 'action + '((type . application)(subtype . x-pkcs7-mime) + (method . mime-view-application/pkcs7-mime)) + 'strict "mime-pgp") + )) + ) + + +;;; @ for mime-edit +;;; + +;; (defun mime-setup-decode-message-header () +;; (save-excursion +;; (save-restriction +;; (goto-char (point-min)) +;; (narrow-to-region +;; (point-min) +;; (if (re-search-forward +;; (concat "^" (regexp-quote mail-header-separator) "$") +;; nil t) +;; (match-beginning 0) +;; (point-max) +;; )) +;; (mime-decode-header-in-buffer) +;; (set-buffer-modified-p nil) +;; ))) + +;; (add-hook 'mime-edit-mode-hook 'mime-setup-decode-message-header) + + +;;; @@ variables +;;; + +(defvar mime-setup-use-signature t + "If it is not nil, mime-setup sets up to use signature.el.") + +(defvar mime-setup-default-signature-key "\C-c\C-s" + "*Key to insert signature.") + +(defvar mime-setup-signature-key-alist '((mail-mode . "\C-c\C-w")) + "Alist of major-mode vs. key to insert signature.") + + +;;; @@ for signature +;;; + +(defun mime-setup-set-signature-key () + (let ((keymap (current-local-map))) + (if keymap + (let ((key + (or (cdr (assq major-mode mime-setup-signature-key-alist)) + mime-setup-default-signature-key))) + (define-key keymap key (function insert-signature)) + )))) + +(when mime-setup-use-signature + (autoload 'insert-signature "signature" "Insert signature" t) + (add-hook 'mime-edit-mode-hook 'mime-setup-set-signature-key) + ;; (setq message-signature nil) + ) + + +;;; @ for mu-cite +;;; + +;; (add-hook 'mu-cite/pre-cite-hook 'eword-decode-header) + + +;;; @ end +;;; + +(provide 'semi-setup) + +;;; semi-setup.el ends here diff --git a/mime/signature.el b/mime/signature.el new file mode 100644 index 0000000..6bd81c3 --- /dev/null +++ b/mime/signature.el @@ -0,0 +1,158 @@ +;;; signature.el --- a signature utility for GNU Emacs + +;; Copyright (C) 1994,1995,1996,1997,2000 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; OKABE Yasuo +;; Shuhei KOBAYASHI +;; Maintainer: Shuhei KOBAYASHI +;; Created: 1994/7/11 +;; Keywords: mail, news, signature + +;; This file is part of SEMI (SEMI is Emacs MIME Interfaces). + +;; 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 this program; 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 'std11) + + +;;; @ valiables +;;; + +(defvar signature-insert-at-eof nil + "*If non-nil, insert signature at the end of file.") + +(defvar signature-delete-blank-lines-at-eof nil + "*If non-nil, signature-insert-at-eof deletes blank lines at the end +of file.") + +(defvar signature-load-hook nil + "*List of functions called after signature.el is loaded.") + +(defvar signature-separator "-- \n" + "*String to separate contents and signature. +It is inserted when signature is inserted at end of file.") + +(defvar signature-file-name "~/.signature" + "*Name of file containing the user's signature.") + +(defvar signature-file-alist nil + "*Alist of the form: + (((FIELD . PATTERN) . FILENAME) + ...) +PATTERN is a string or list of string. If PATTERN matches the contents of +FIELD, the contents of FILENAME is inserted.") + +(defvar signature-file-prefix nil + "*String containing optional prefix for the signature file names") + +(defvar signature-insert-hook nil + "*List of functions called before inserting a signature.") + +(defvar signature-use-bbdb nil + "*If non-nil, Register sigtype to BBDB.") + +(autoload 'signature/get-sigtype-from-bbdb "mime-bbdb") + +(defun signature/get-sigtype-interactively (&optional default) + (read-file-name "Insert your signature: " + (or default (concat signature-file-name "-")) + (or default signature-file-name) + nil)) + +(defun signature/get-signature-file-name () + (save-excursion + (save-restriction + (narrow-to-region + (goto-char (point-min)) + (if (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "$") + nil t) + (match-beginning 0) + (point-max) + )) + (catch 'found + (let ((alist signature-file-alist) cell field value) + (while alist + (setq cell (car alist) + field (std11-field-body (car (car cell))) + value (cdr (car cell))) + (cond ((functionp value) + (let ((name (apply value field (cdr cell)))) + (if name + (throw 'found + (concat signature-file-prefix name)) + ))) + ((stringp field) + (cond ((consp value) + (while value + (if (string-match (car value) field) + (throw 'found + (concat + signature-file-prefix (cdr cell))) + (setq value (cdr value)) + ))) + ((stringp value) + (if (string-match value field) + (throw 'found + (concat + signature-file-prefix (cdr cell))) + ))))) + (setq alist (cdr alist)) + )) + signature-file-name)))) + +(defun insert-signature (&optional arg) + "Insert the file named by signature-file-name. +It is inserted at the end of file if signature-insert-at-eof is non-nil, +and otherwise at the current point. A prefix argument enables user to +specify a file named -DISTRIBUTION interactively." + (interactive "P") + (let ((signature-file-name + (expand-file-name + (or (and signature-use-bbdb + (signature/get-sigtype-from-bbdb arg)) + (and arg + (signature/get-sigtype-interactively)) + (signature/get-signature-file-name)) + ))) + (or (file-readable-p signature-file-name) + (error "Cannot open signature file: %s" signature-file-name)) + (if signature-insert-at-eof + (progn + (goto-char (point-max)) + (or (bolp) (insert "\n")) + (if signature-delete-blank-lines-at-eof (delete-blank-lines)) + )) + (run-hooks 'signature-insert-hook) + (if (= (point)(point-max)) + (insert signature-separator) + ) + (insert-file-contents signature-file-name) + (force-mode-line-update) + signature-file-name)) + + +;;; @ end +;;; + +(provide 'signature) + +(run-hooks 'signature-load-hook) + +;;; signature.el ends here diff --git a/mime/smime.el b/mime/smime.el new file mode 100644 index 0000000..839c715 --- /dev/null +++ b/mime/smime.el @@ -0,0 +1,322 @@ +;;; smime.el --- S/MIME interface. + +;; Copyright (C) 1999 Daiki Ueno + +;; Author: Daiki Ueno +;; Created: 1999/12/08 +;; Keywords: S/MIME, OpenSSL + +;; This file is part of SEMI (Secure Emacs MIME Interface). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + + +;;; Commentary: + +;; This module is based on + +;; [SMIMEV3] RFC 2633: "S/MIME Version 3 Message Specification" +;; by Crocker, D., Flanigan, B., Hoffman, P., Housley, R., +;; Pawling, J. and Schaad, J. (1999/06) + +;; [SMIMEV2] RFC 2311: "S/MIME Version 2 Message Specification" +;; by Dusse, S., Hoffman, P., Ramsdell, B., Lundblade, L. +;; and L. Repka. (1998/03) + +;;; Code: + +(require 'path-util) +(require 'mel) +;; binary-funcall, binary-write-decoded-region, binary-insert-encoded-file +(eval-when-compile (require 'static)) + +(defgroup smime () + "S/MIME interface" + :group 'mime) + +(defcustom smime-program "smime" + "The S/MIME executable." + :group 'smime + :type 'string) + +(defcustom smime-shell-file-name "/bin/sh" + "File name to load inferior shells from. Bourne shell or its equivalent +\(not tcsh) is needed for \"2>\"." + :group 'smime + :type 'string) + +(defcustom smime-shell-command-switch "-c" + "Switch used to have the shell execute its command line argument." + :group 'smime + :type 'string) + +(defcustom smime-x509-program + (let ((file (exec-installed-p "openssl"))) + (and file (list file "x509" "-noout"))) + "External program for x509 parser." + :group 'smime + :type 'string) + +(defcustom smime-cache-passphrase t + "Cache passphrase." + :group 'smime + :type 'boolean) + +(defcustom smime-certificate-directory "~/.w3/certs" + "Certificate directory." + :group 'smime + :type 'directory) + +(defcustom smime-public-key-file nil + "Public key file." + :group 'smime + :type 'boolean) + +(defcustom smime-private-key-file nil + "Private key file." + :group 'smime + :type 'boolean) + +(defvar smime-errors-buffer " *S/MIME errors*") +(defvar smime-output-buffer " *S/MIME output*") + +;;; @ utility functions +;;; +(put 'smime-process-when-success 'lisp-indent-function 0) + +(defmacro smime-process-when-success (&rest body) + `(with-current-buffer smime-output-buffer + (if (zerop (buffer-size)) nil ,@body t))) + +(defvar smime-passphrase-cache-expiry 16) +(defvar smime-passphrase-cache (make-vector 7 0)) + +(defvar smime-read-passphrase nil) +(defun smime-read-passphrase (prompt &optional key) + (if (not smime-read-passphrase) + (if (functionp 'read-passwd) + (setq smime-read-passphrase 'read-passwd) + (if (load "passwd" t) + (setq smime-read-passphrase 'read-passwd) + (autoload 'ange-ftp-read-passwd "ange-ftp") + (setq smime-read-passphrase 'ange-ftp-read-passwd)))) + (or (and smime-cache-passphrase + (symbol-value (intern-soft key smime-passphrase-cache))) + (funcall smime-read-passphrase prompt))) + +(defun smime-add-passphrase-cache (key passphrase) + (set (intern key smime-passphrase-cache) + passphrase) + (run-at-time smime-passphrase-cache-expiry nil + #'smime-remove-passphrase-cache + key)) + +(defun smime-remove-passphrase-cache (key) + (let ((passphrase (symbol-value (intern-soft key smime-passphrase-cache)))) + (when passphrase + (fillarray passphrase ?_) + (unintern key smime-passphrase-cache)))) + +(defsubst smime-parse-attribute (string) + (delq nil (mapcar + (lambda (attr) + (if (string-match "=" attr) + (cons (intern (substring attr 0 (match-beginning 0))) + (substring attr (match-end 0))) + nil)) + (split-string string "/")))) + +(defsubst smime-query-signer (start end) + (smime-process-region start end smime-program (list "-qs")) + (with-current-buffer smime-output-buffer + (if (zerop (buffer-size)) nil + (goto-char (point-min)) + (when (re-search-forward "^/" nil t) + (smime-parse-attribute + (buffer-substring (point) (progn (end-of-line)(point))))) + ))) + +(defsubst smime-x509-hash (cert-file) + (with-current-buffer (get-buffer-create smime-output-buffer) + (buffer-disable-undo) + (erase-buffer) + (apply #'call-process (car smime-x509-program) nil t nil + (append (cdr smime-x509-program) + (list "-hash" "-in" cert-file))) + (if (zerop (buffer-size)) nil + (buffer-substring (point-min) (1- (point-max)))))) + +(defsubst smime-x509-subject (cert-file) + (with-current-buffer (get-buffer-create smime-output-buffer) + (buffer-disable-undo) + (erase-buffer) + (apply #'call-process (car smime-x509-program) nil t nil + (append (cdr smime-x509-program) + (list "-subject" "-in" cert-file))) + (if (zerop (buffer-size)) nil + (goto-char (point-min)) + (when (re-search-forward "^subject=" nil t) + (smime-parse-attribute + (buffer-substring (point)(progn (end-of-line)(point)))))))) + +(defsubst smime-find-certificate (attr) + (let ((files + (and (file-directory-p smime-certificate-directory) + (delq nil (mapcar (lambda (file) + (if (file-directory-p file) nil + file)) + (directory-files + smime-certificate-directory + 'full)))))) + (catch 'found + (while files + (if (or (string-equal + (cdr (assq 'CN (smime-x509-subject (car files)))) + (cdr (assq 'CN attr))) + (string-equal + (cdr (assq 'Email (smime-x509-subject (car files)))) + (cdr (assq 'Email attr)))) + (throw 'found (car files))) + (pop files))))) + +(defun smime-process-region (start end program args) + (let* ((errors-file-name + (concat temporary-file-directory + (make-temp-name "smime-errors"))) + (args (append args (list (concat "2>" errors-file-name)))) + (shell-file-name smime-shell-file-name) + (shell-command-switch smime-shell-command-switch) + (process-connection-type nil) + process status exit-status) + (with-current-buffer (get-buffer-create smime-output-buffer) + (buffer-disable-undo) + (erase-buffer)) + (setq process + (apply #'binary-funcall #'start-process-shell-command + "*S/MIME*" smime-output-buffer + program args)) + (set-process-sentinel process 'ignore) + (process-send-region process start end) + (process-send-eof process) + (while (eq 'run (process-status process)) + (accept-process-output process 5)) + (setq status (process-status process) + exit-status (process-exit-status process)) + (delete-process process) + (with-current-buffer smime-output-buffer + (goto-char (point-min)) + (while (re-search-forward "\r$" (point-max) t) + (replace-match "")) + + (if (memq status '(stop signal)) + (error "%s exited abnormally: '%s'" program exit-status)) + (if (= 127 exit-status) + (error "%s could not be found" program)) + + (set-buffer (get-buffer-create smime-errors-buffer)) + (buffer-disable-undo) + (erase-buffer) + (insert-file-contents errors-file-name) + (delete-file errors-file-name) + + (if (and process (eq 'run (process-status process))) + (interrupt-process process)) + ) + )) + +;;; @ interface functions +;;; + +;;;###autoload +(defun smime-encrypt-region (start end) + "Encrypt the current region between START and END." + (let* ((key-file + (or smime-private-key-file + (expand-file-name (read-file-name "Public key file: ")))) + (args (list "-e" key-file))) + (smime-process-region start end smime-program args) + (smime-process-when-success + (goto-char (point-min)) + (delete-region (point-min) (progn + (re-search-forward "^$" nil t) + (1+ (point))))))) + +;;;###autoload +(defun smime-decrypt-region (start end) + "Decrypt the current region between START and END." + (let* ((key-file + (or smime-private-key-file + (expand-file-name (read-file-name "Private key file: ")))) + (hash (smime-x509-hash key-file)) + (passphrase (smime-read-passphrase + (format "S/MIME passphrase for %s: " hash) + hash)) + (args (list "-d" key-file passphrase))) + (smime-process-region start end smime-program args) + (smime-process-when-success + (when smime-cache-passphrase + (smime-add-passphrase-cache hash passphrase))))) + +;;;###autoload +(defun smime-sign-region (start end &optional cleartext) + "Make the signature from text between START and END. +If the optional 3rd argument CLEARTEXT is non-nil, it does not create +a detached signature." + (let* ((key-file + (or smime-private-key-file + (expand-file-name (read-file-name "Private key file: ")))) + (hash (smime-x509-hash key-file)) + (passphrase (smime-read-passphrase + (format "S/MIME passphrase for %s: " hash) + hash)) + (args (list "-ds" key-file passphrase))) + (smime-process-region start end smime-program args) + (smime-process-when-success + (goto-char (point-min)) + (delete-region (point-min) (progn + (re-search-forward "^$" nil t) + (1+ (point)))) + (when smime-cache-passphrase + (smime-add-passphrase-cache hash passphrase))))) + +;;;###autoload +(defun smime-verify-region (start end signature) + "Verify the current region between START and END. +If the optional 3rd argument SIGNATURE is non-nil, it is treated as +the detached signature of the current region." + (let* ((basename (expand-file-name "smime" temporary-file-directory)) + (orig-file (make-temp-name basename)) + (orig-mode (default-file-modes))) + (unwind-protect + (progn + (set-default-file-modes 448) + (binary-write-decoded-region start end orig-file)) + (set-default-file-modes orig-mode)) + (with-temp-buffer + (binary-insert-encoded-file signature) + (goto-char (point-max)) + (binary-insert-encoded-file + (or (smime-find-certificate + (smime-query-signer (point-min)(point-max))) + (expand-file-name + (read-file-name "Certificate file: ")))) + (smime-process-region (point-min)(point-max) smime-program + (list "-dv" orig-file))) + (smime-process-when-success nil))) + +(provide 'smime) + +;;; smime.el ends here diff --git a/mime/std11.el b/mime/std11.el new file mode 100644 index 0000000..051d45a --- /dev/null +++ b/mime/std11.el @@ -0,0 +1,925 @@ +;;; std11.el --- STD 11 functions for GNU Emacs + +;; Copyright (C) 1995,1996,1997,1998,1999,2000 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Keywords: mail, news, RFC 822, STD 11 + +;; 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 'custom) ; std11-lexical-analyzer + + +;;; @ fetch +;;; + +(defconst std11-field-name-regexp "[!-9;-~]+") +(defconst std11-field-head-regexp + (concat "^" std11-field-name-regexp ":")) +(defconst std11-next-field-head-regexp + (concat "\n" std11-field-name-regexp ":")) + +(defun std11-field-end (&optional bound) + "Move to end of field and return this point. +The optional argument BOUNDs the search; it is a buffer position." + (if (re-search-forward std11-next-field-head-regexp bound t) + (goto-char (match-beginning 0)) + (if (re-search-forward "^$" bound t) + (goto-char (1- (match-beginning 0))) + (end-of-line) + )) + (point) + ) + +;;;###autoload +(defun std11-fetch-field (name) + "Return the value of the header field NAME. +The buffer is expected to be narrowed to just the headers of the message." + (save-excursion + (goto-char (point-min)) + (let ((case-fold-search t)) + (if (re-search-forward (concat "^" name ":[ \t]*") nil t) + (buffer-substring-no-properties (match-end 0) (std11-field-end)) + )))) + +;;;###autoload +(defun std11-narrow-to-header (&optional boundary) + "Narrow to the message header. +If BOUNDARY is not nil, it is used as message header separator." + (narrow-to-region + (goto-char (point-min)) + (if (re-search-forward + (concat "^\\(" (regexp-quote (or boundary "")) "\\)?$") + nil t) + (match-beginning 0) + (point-max) + ))) + +;;;###autoload +(defun std11-field-body (name &optional boundary) + "Return the value of the header field NAME. +If BOUNDARY is not nil, it is used as message header separator." + (save-excursion + (save-restriction + (inline (std11-narrow-to-header boundary) + (std11-fetch-field name)) + ))) + +(defun std11-find-field-body (field-names &optional boundary) + "Return the first found field-body specified by FIELD-NAMES +of the message header in current buffer. If BOUNDARY is not nil, it is +used as message header separator." + (save-excursion + (save-restriction + (std11-narrow-to-header boundary) + (let ((case-fold-search t) + field-name) + (catch 'tag + (while (setq field-name (car field-names)) + (goto-char (point-min)) + (if (re-search-forward (concat "^" field-name ":[ \t]*") nil t) + (throw 'tag + (buffer-substring-no-properties + (match-end 0) (std11-field-end))) + ) + (setq field-names (cdr field-names)) + )))))) + +(defun std11-field-bodies (field-names &optional default-value boundary) + "Return list of each field-bodies of FIELD-NAMES of the message header +in current buffer. If BOUNDARY is not nil, it is used as message +header separator." + (save-excursion + (save-restriction + (std11-narrow-to-header boundary) + (let* ((case-fold-search t) + (dest (make-list (length field-names) default-value)) + (s-rest field-names) + (d-rest dest) + field-name) + (while (setq field-name (car s-rest)) + (goto-char (point-min)) + (if (re-search-forward (concat "^" field-name ":[ \t]*") nil t) + (setcar d-rest + (buffer-substring-no-properties + (match-end 0) (std11-field-end))) + ) + (setq s-rest (cdr s-rest) + d-rest (cdr d-rest)) + ) + dest)))) + +(defun std11-header-string (regexp &optional boundary) + "Return string of message header fields matched by REGEXP. +If BOUNDARY is not nil, it is used as message header separator." + (let ((case-fold-search t)) + (save-excursion + (save-restriction + (std11-narrow-to-header boundary) + (goto-char (point-min)) + (let (field header) + (while (re-search-forward std11-field-head-regexp nil t) + (setq field + (buffer-substring (match-beginning 0) (std11-field-end))) + (if (string-match regexp field) + (setq header (concat header field "\n")) + )) + header) + )))) + +(defun std11-header-string-except (regexp &optional boundary) + "Return string of message header fields not matched by REGEXP. +If BOUNDARY is not nil, it is used as message header separator." + (let ((case-fold-search t)) + (save-excursion + (save-restriction + (std11-narrow-to-header boundary) + (goto-char (point-min)) + (let (field header) + (while (re-search-forward std11-field-head-regexp nil t) + (setq field + (buffer-substring (match-beginning 0) (std11-field-end))) + (if (not (string-match regexp field)) + (setq header (concat header field "\n")) + )) + header) + )))) + +(defun std11-collect-field-names (&optional boundary) + "Return list of all field-names of the message header in current buffer. +If BOUNDARY is not nil, it is used as message header separator." + (save-excursion + (save-restriction + (std11-narrow-to-header boundary) + (goto-char (point-min)) + (let (dest name) + (while (re-search-forward std11-field-head-regexp nil t) + (setq name (buffer-substring-no-properties + (match-beginning 0)(1- (match-end 0)))) + (or (member name dest) + (setq dest (cons name dest)) + ) + ) + dest)))) + + +;;; @ unfolding +;;; + +;;;###autoload +(defun std11-unfold-string (string) + "Unfold STRING as message header field." + (let ((dest "") + (p 0)) + (while (string-match "\n\\([ \t]\\)" string p) + (setq dest (concat dest + (substring string p (match-beginning 0)) + (substring string + (match-beginning 1) + (setq p (match-end 0))) + )) + ) + (concat dest (substring string p)) + )) + + +;;; @ quoted-string +;;; + +(defun std11-wrap-as-quoted-pairs (string specials) + (let (dest + (i 0) + (b 0) + (len (length string)) + ) + (while (< i len) + (let ((chr (aref string i))) + (if (memq chr specials) + (setq dest (concat dest (substring string b i) "\\") + b i) + )) + (setq i (1+ i)) + ) + (concat dest (substring string b)) + )) + +(defconst std11-non-qtext-char-list '(?\" ?\\ ?\r ?\n)) + +(defun std11-wrap-as-quoted-string (string) + "Wrap STRING as RFC 822 quoted-string." + (concat "\"" + (std11-wrap-as-quoted-pairs string std11-non-qtext-char-list) + "\"")) + +(defun std11-strip-quoted-pair (string) + "Strip quoted-pairs in STRING." + (let (dest + (b 0) + (i 0) + (len (length string)) + ) + (while (< i len) + (let ((chr (aref string i))) + (if (eq chr ?\\) + (setq dest (concat dest (substring string b i)) + b (1+ i) + i (+ i 2)) + (setq i (1+ i)) + ))) + (concat dest (substring string b)) + )) + +(defun std11-strip-quoted-string (string) + "Strip quoted-string STRING." + (let ((len (length string))) + (or (and (>= len 2) + (let ((max (1- len))) + (and (eq (aref string 0) ?\") + (eq (aref string max) ?\") + (std11-strip-quoted-pair (substring string 1 max)) + ))) + string))) + + +;;; @ lexical analyze +;;; + +(defcustom std11-lexical-analyzer + '(std11-analyze-quoted-string + std11-analyze-domain-literal + std11-analyze-comment + std11-analyze-spaces + std11-analyze-special + std11-analyze-atom) + "*List of functions to return result of lexical analyze. +Each function must have two arguments: STRING and START. +STRING is the target string to be analyzed. +START is start position of STRING to analyze. + +Previous function is preferred to next function. If a function +returns nil, next function is used. Otherwise the return value will +be the result." + :group 'news + :group 'mail + :type '(repeat function)) + +(eval-and-compile + (defconst std11-space-char-list '(? ?\t ?\n)) + (defconst std11-special-char-list '(?\] ?\[ + ?\( ?\) ?< ?> ?@ + ?, ?\; ?: ?\\ ?\" + ?.)) + ) +;; (defconst std11-spaces-regexp +;; (eval-when-compile (concat "[" std11-space-char-list "]+"))) +(defconst std11-atom-regexp + (eval-when-compile + (concat "[^" std11-special-char-list std11-space-char-list "]+"))) + +(defun std11-analyze-spaces (string start) + (if (and (string-match (eval-when-compile + (concat "[" std11-space-char-list "]+")) + string start) + (= (match-beginning 0) start)) + (let ((end (match-end 0))) + (cons (cons 'spaces (substring string start end)) + ;;(substring string end) + end) + ))) + +(defun std11-analyze-special (string start) + (if (and (> (length string) start) + (memq (aref string start) std11-special-char-list)) + (cons (cons 'specials (substring string start (1+ start))) + ;;(substring string 1) + (1+ start)) + )) + +(defun std11-analyze-atom (string start) + (if (and (string-match std11-atom-regexp string start) + (= (match-beginning 0) start)) + (let ((end (match-end 0))) + (cons (cons 'atom (substring string start end)) + ;;(substring string end) + end) + ))) + +(defun std11-check-enclosure (string open close &optional recursive from) + (let ((len (length string)) + (i (or from 0)) + ) + (if (and (> len i) + (eq (aref string i) open)) + (let (p chr) + (setq i (1+ i)) + (catch 'tag + (while (< i len) + (setq chr (aref string i)) + (cond ((eq chr ?\\) + (setq i (1+ i)) + (if (>= i len) + (throw 'tag nil) + ) + (setq i (1+ i)) + ) + ((eq chr close) + (throw 'tag (1+ i)) + ) + ((eq chr open) + (if (and recursive + (setq p (std11-check-enclosure + string open close recursive i)) + ) + (setq i p) + (throw 'tag nil) + )) + (t + (setq i (1+ i)) + )) + )))))) + +(defun std11-analyze-quoted-string (string start) + (let ((p (std11-check-enclosure string ?\" ?\" nil start))) + (if p + (cons (cons 'quoted-string (substring string (1+ start) (1- p))) + ;;(substring string p)) + p) + ))) + +(defun std11-analyze-domain-literal (string start) + (let ((p (std11-check-enclosure string ?\[ ?\] nil start))) + (if p + (cons (cons 'domain-literal (substring string (1+ start) (1- p))) + ;;(substring string p)) + p) + ))) + +(defun std11-analyze-comment (string start) + (let ((p (std11-check-enclosure string ?\( ?\) t start))) + (if p + (cons (cons 'comment (substring string (1+ start) (1- p))) + ;;(substring string p)) + p) + ))) + +;;;###autoload +(defun std11-lexical-analyze (string &optional analyzer start) + "Analyze STRING as lexical tokens of STD 11." + (or analyzer + (setq analyzer std11-lexical-analyzer)) + (or start + (setq start 0)) + (let ((len (length string)) + dest ret) + (while (< start len) + (setq ret + (let ((rest analyzer) + func r) + (while (and (setq func (car rest)) + (null (setq r (funcall func string start)))) + (setq rest (cdr rest))) + (or r + (list (cons 'error (substring string start)) (1+ len))) + )) + (setq dest (cons (car ret) dest) + start (cdr ret)) + ) + (nreverse dest) + )) + + +;;; @ parser +;;; + +(defun std11-ignored-token-p (token) + (let ((type (car token))) + (or (eq type 'spaces)(eq type 'comment)) + )) + +(defun std11-parse-token (lal) + (let (token itl) + (while (and lal + (progn + (setq token (car lal)) + (std11-ignored-token-p token) + )) + (setq lal (cdr lal)) + (setq itl (cons token itl)) + ) + (cons (nreverse (cons token itl)) + (cdr lal)) + )) + +(defun std11-parse-ascii-token (lal) + (let (token itl parsed token-value) + (while (and lal + (setq token (car lal)) + (or (std11-ignored-token-p token) + (if (and (setq token-value (cdr token)) + (delq 'ascii (find-charset-string token-value))) + (setq token nil) + ))) + (setq lal (cdr lal)) + (setq itl (cons token itl)) + ) + (if (and token + (setq parsed (nreverse (cons token itl))) + ) + (cons parsed (cdr lal)) + ))) + +(defun std11-parse-token-or-comment (lal) + (let (token itl) + (while (and lal + (progn + (setq token (car lal)) + (eq (car token) 'spaces) + )) + (setq lal (cdr lal)) + (setq itl (cons token itl)) + ) + (cons (nreverse (cons token itl)) + (cdr lal)) + )) + +(defun std11-parse-word (lal) + (let ((ret (std11-parse-ascii-token lal))) + (if ret + (let ((elt (car ret)) + (rest (cdr ret)) + ) + (if (or (assq 'atom elt) + (assq 'quoted-string elt)) + (cons (cons 'word elt) rest) + ))))) + +(defun std11-parse-word-or-comment (lal) + (let ((ret (std11-parse-token-or-comment lal))) + (if ret + (let ((elt (car ret)) + (rest (cdr ret)) + ) + (cond ((or (assq 'atom elt) + (assq 'quoted-string elt)) + (cons (cons 'word elt) rest) + ) + ((assq 'comment elt) + (cons (cons 'comment-word elt) rest) + )) + )))) + +(defun std11-parse-phrase (lal) + (let (ret phrase) + (while (setq ret (std11-parse-word-or-comment lal)) + (setq phrase (append phrase (cdr (car ret)))) + (setq lal (cdr ret)) + ) + (if phrase + (cons (cons 'phrase phrase) lal) + ))) + +(defun std11-parse-local-part (lal) + (let ((ret (std11-parse-word lal))) + (if ret + (let ((local-part (cdr (car ret))) dot) + (setq lal (cdr ret)) + (while (and (setq ret (std11-parse-ascii-token lal)) + (setq dot (car ret)) + (string-equal (cdr (assq 'specials dot)) ".") + (setq ret (std11-parse-word (cdr ret))) + (setq local-part + (append local-part dot (cdr (car ret))) + ) + (setq lal (cdr ret)) + )) + (cons (cons 'local-part local-part) lal) + )))) + +(defun std11-parse-sub-domain (lal) + (let ((ret (std11-parse-ascii-token lal))) + (if ret + (let ((sub-domain (car ret))) + (if (or (assq 'atom sub-domain) + (assq 'domain-literal sub-domain) + ) + (cons (cons 'sub-domain sub-domain) + (cdr ret) + ) + ))))) + +(defun std11-parse-domain (lal) + (let ((ret (std11-parse-sub-domain lal))) + (if ret + (let ((domain (cdr (car ret))) dot) + (setq lal (cdr ret)) + (while (and (setq ret (std11-parse-ascii-token lal)) + (setq dot (car ret)) + (string-equal (cdr (assq 'specials dot)) ".") + (setq ret (std11-parse-sub-domain (cdr ret))) + (setq domain + (append domain dot (cdr (car ret))) + ) + (setq lal (cdr ret)) + )) + (cons (cons 'domain domain) lal) + )))) + +(defun std11-parse-at-domain (lal) + (let ((ret (std11-parse-ascii-token lal)) at-sign) + (if (and ret + (setq at-sign (car ret)) + (string-equal (cdr (assq 'specials at-sign)) "@") + (setq ret (std11-parse-domain (cdr ret))) + ) + (cons (cons 'at-domain (append at-sign (cdr (car ret)))) + (cdr ret)) + ))) + +(defun std11-parse-addr-spec (lal) + (let ((ret (std11-parse-local-part lal)) + addr) + (if (and ret + (prog1 + (setq addr (cdr (car ret))) + (setq lal (cdr ret)) + (and (setq ret (std11-parse-at-domain lal)) + (setq addr (append addr (cdr (car ret)))) + (setq lal (cdr ret)) + ))) + (cons (cons 'addr-spec addr) lal) + ))) + +(defun std11-parse-route (lal) + (let ((ret (std11-parse-at-domain lal)) + route comma colon) + (if (and ret + (progn + (setq route (cdr (car ret))) + (setq lal (cdr ret)) + (while (and (setq ret (std11-parse-ascii-token lal)) + (setq comma (car ret)) + (string-equal (cdr (assq 'specials comma)) ",") + (setq ret (std11-parse-at-domain (cdr ret))) + ) + (setq route (append route comma (cdr (car ret)))) + (setq lal (cdr ret)) + ) + (and (setq ret (std11-parse-ascii-token lal)) + (setq colon (car ret)) + (string-equal (cdr (assq 'specials colon)) ":") + (setq route (append route colon)) + ) + )) + (cons (cons 'route route) + (cdr ret) + ) + ))) + +(defun std11-parse-route-addr (lal) + (let ((ret (std11-parse-ascii-token lal)) + < route addr-spec >) + (if (and ret + (setq < (car ret)) + (string-equal (cdr (assq 'specials <)) "<") + (setq lal (cdr ret)) + (progn (and (setq ret (std11-parse-route lal)) + (setq route (cdr (car ret))) + (setq lal (cdr ret)) + ) + (setq ret (std11-parse-addr-spec lal)) + ) + (setq addr-spec (cdr (car ret))) + (setq lal (cdr ret)) + (setq ret (std11-parse-ascii-token lal)) + (setq > (car ret)) + (string-equal (cdr (assq 'specials >)) ">") + ) + (cons (cons 'route-addr (append route addr-spec)) + (cdr ret) + ) + ))) + +(defun std11-parse-phrase-route-addr (lal) + (let ((ret (std11-parse-phrase lal)) phrase) + (if ret + (progn + (setq phrase (cdr (car ret))) + (setq lal (cdr ret)) + )) + (if (setq ret (std11-parse-route-addr lal)) + (cons (list 'phrase-route-addr + phrase + (cdr (car ret))) + (cdr ret)) + ))) + +(defun std11-parse-mailbox (lal) + (let ((ret (or (std11-parse-phrase-route-addr lal) + (std11-parse-addr-spec lal))) + mbox comment) + (if (and ret + (prog1 + (setq mbox (car ret)) + (setq lal (cdr ret)) + (if (and (setq ret (std11-parse-token-or-comment lal)) + (setq comment (cdr (assq 'comment (car ret)))) + ) + (setq lal (cdr ret)) + ))) + (cons (list 'mailbox mbox comment) + lal) + ))) + +(defun std11-parse-group (lal) + (let ((ret (std11-parse-phrase lal)) + phrase colon comma mbox semicolon) + (if (and ret + (setq phrase (cdr (car ret))) + (setq lal (cdr ret)) + (setq ret (std11-parse-ascii-token lal)) + (setq colon (car ret)) + (string-equal (cdr (assq 'specials colon)) ":") + (setq lal (cdr ret)) + (progn + (and (setq ret (std11-parse-mailbox lal)) + (setq mbox (list (car ret))) + (setq lal (cdr ret)) + (progn + (while (and (setq ret (std11-parse-ascii-token lal)) + (setq comma (car ret)) + (string-equal + (cdr (assq 'specials comma)) ",") + (setq lal (cdr ret)) + (setq ret (std11-parse-mailbox lal)) + (setq mbox (cons (car ret) mbox)) + (setq lal (cdr ret)) + ) + ))) + (and (setq ret (std11-parse-ascii-token lal)) + (setq semicolon (car ret)) + (string-equal (cdr (assq 'specials semicolon)) ";") + ))) + (cons (list 'group phrase (nreverse mbox)) + (cdr ret) + ) + ))) + +(defun std11-parse-address (lal) + (or (std11-parse-group lal) + (std11-parse-mailbox lal) + )) + +(defun std11-parse-addresses (lal) + (let ((ret (std11-parse-address lal))) + (if ret + (let ((dest (list (car ret)))) + (setq lal (cdr ret)) + (while (and (setq ret (std11-parse-ascii-token lal)) + (string-equal (cdr (assq 'specials (car ret))) ",") + (setq ret (std11-parse-address (cdr ret))) + ) + (setq dest (cons (car ret) dest)) + (setq lal (cdr ret)) + ) + (nreverse dest) + )))) + +(defun std11-parse-msg-id (lal) + (let ((ret (std11-parse-ascii-token lal)) + < addr-spec >) + (if (and ret + (setq < (car ret)) + (string-equal (cdr (assq 'specials <)) "<") + (setq lal (cdr ret)) + (setq ret (std11-parse-addr-spec lal)) + (setq addr-spec (car ret)) + (setq lal (cdr ret)) + (setq ret (std11-parse-ascii-token lal)) + (setq > (car ret)) + (string-equal (cdr (assq 'specials >)) ">") + ) + (cons (cons 'msg-id (cdr addr-spec)) + (cdr ret)) + ))) + +(defun std11-parse-msg-ids (tokens) + "Parse lexical TOKENS as `*(phrase / msg-id)', and return the result." + (let ((ret (or (std11-parse-msg-id tokens) + (std11-parse-phrase tokens)))) + (if ret + (let ((dest (list (car ret)))) + (setq tokens (cdr ret)) + (while (setq ret (or (std11-parse-msg-id tokens) + (std11-parse-phrase tokens))) + (setq dest (cons (car ret) dest)) + (setq tokens (cdr ret)) + ) + (nreverse dest) + )))) + +(defalias 'std11-parse-in-reply-to 'std11-parse-msg-ids) +(make-obsolete 'std11-parse-in-reply-to 'std11-parse-msg-ids) + + +;;; @ composer +;;; + +(defun std11-addr-to-string (seq) + "Return string from lexical analyzed list SEQ +represents addr-spec of RFC 822." + (mapconcat (function + (lambda (token) + (let ((name (car token))) + (cond + ((eq name 'spaces) "") + ((eq name 'comment) "") + ((eq name 'quoted-string) + (concat "\"" (cdr token) "\"")) + (t (cdr token))) + ))) + seq "") + ) + +;;;###autoload +(defun std11-address-string (address) + "Return string of address part from parsed ADDRESS of RFC 822." + (cond ((eq (car address) 'group) + (mapconcat (function std11-address-string) + (nth 2 address) + ", ") + ) + ((eq (car address) 'mailbox) + (let ((addr (nth 1 address))) + (std11-addr-to-string + (if (eq (car addr) 'phrase-route-addr) + (nth 2 addr) + (cdr addr) + ) + ))))) + +(defun std11-comment-value-to-string (value) + (if (stringp value) + (std11-strip-quoted-pair value) + (let ((dest "")) + (while value + (setq dest + (concat dest + (if (stringp (car value)) + (car value) + (concat "(" + (std11-comment-value-to-string + (cdr (car value))) + ")") + )) + value (cdr value)) + ) + dest))) + +;;;###autoload +(defun std11-full-name-string (address) + "Return string of full-name part from parsed ADDRESS of RFC 822." + (cond ((eq (car address) 'group) + (mapconcat (function + (lambda (token) + (cdr token) + )) + (nth 1 address) "") + ) + ((eq (car address) 'mailbox) + (let ((addr (nth 1 address)) + (comment (nth 2 address)) + phrase) + (if (eq (car addr) 'phrase-route-addr) + (setq phrase + (mapconcat + (function + (lambda (token) + (let ((type (car token))) + (cond ((eq type 'quoted-string) + (std11-strip-quoted-pair (cdr token)) + ) + ((eq type 'comment) + (concat "(" + (std11-comment-value-to-string + (cdr token)) + ")") + ) + (t + (cdr token) + ))))) + (nth 1 addr) "")) + ) + (cond ((> (length phrase) 0) phrase) + (comment (std11-comment-value-to-string comment)) + ) + )))) + +;;;###autoload +(defun std11-msg-id-string (msg-id) + "Return string from parsed MSG-ID of RFC 822." + (concat "<" (std11-addr-to-string (cdr msg-id)) ">") + ) + +;;;###autoload +(defun std11-fill-msg-id-list-string (string &optional column) + "Fill list of msg-id in STRING, and return the result." + (or column + (setq column 12)) + (let ((lal (std11-lexical-analyze string)) + dest) + (let ((ret (std11-parse-msg-id lal))) + (if ret + (let* ((str (std11-msg-id-string (car ret))) + (len (length str))) + (setq lal (cdr ret)) + (if (> (+ len column) 76) + (setq dest (concat dest "\n " str) + column (1+ len)) + (setq dest str + column (+ column len)) + )) + (setq dest (concat dest (cdr (car lal))) + lal (cdr lal)) + )) + (while lal + (let ((ret (std11-parse-msg-id lal))) + (if ret + (let* ((str (std11-msg-id-string (car ret))) + (len (1+ (length str)))) + (setq lal (cdr ret)) + (if (> (+ len column) 76) + (setq dest (concat dest "\n " str) + column len) + (setq dest (concat dest " " str) + column (+ column len)) + )) + (setq dest (concat dest (cdr (car lal))) + lal (cdr lal)) + ))) + dest)) + + +;;; @ parser with lexical analyzer +;;; + +;;;###autoload +(defun std11-parse-address-string (string) + "Parse STRING as mail address." + (std11-parse-address (std11-lexical-analyze string)) + ) + +;;;###autoload +(defun std11-parse-addresses-string (string) + "Parse STRING as mail address list." + (std11-parse-addresses (std11-lexical-analyze string)) + ) + +;;;###autoload +(defun std11-parse-msg-id-string (string) + "Parse STRING as msg-id." + (std11-parse-msg-id (std11-lexical-analyze string)) + ) + +;;;###autoload +(defun std11-parse-msg-ids-string (string) + "Parse STRING as `*(phrase / msg-id)'." + (std11-parse-msg-ids (std11-lexical-analyze string)) + ) + +;;;###autoload +(defun std11-extract-address-components (string) + "Extract full name and canonical address from STRING. +Returns a list of the form (FULL-NAME CANONICAL-ADDRESS). +If no name can be extracted, FULL-NAME will be nil." + (let* ((structure (car (std11-parse-address-string + (std11-unfold-string string)))) + (phrase (std11-full-name-string structure)) + (address (std11-address-string structure)) + ) + (list phrase address) + )) + + +;;; @ end +;;; + +(provide 'std11) + +;;; std11.el ends here diff --git a/poe/apel-ver.el b/poe/apel-ver.el new file mode 100644 index 0000000..93d09ca --- /dev/null +++ b/poe/apel-ver.el @@ -0,0 +1,58 @@ +;;; apel-ver.el --- Declare APEL version. + +;; Copyright (C) 1999 Free Software Foundation, Inc. + +;; Author: Shuhei KOBAYASHI +;; Keiichi Suzuki +;; Keywords: compatibility + +;; This file is part of APEL (A Portable Emacs Library). + +;; 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 this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Put the following lines to each file of APEL package. +;; +;; (require 'product) +;; (product-provide (provide FEATURE) (require 'apel-ver)) + +;;; Code: + +(require 'product) ; beware of circular dependency. +(provide 'apel-ver) ; these two files depend on each other. + +(product-provide 'apel-ver + ;; (product-define "APEL" nil '(9 23)) ; comment. + ;; (product-define "APEL" nil '(10 0)) ; Released 24 December 1999 + ;; (product-define "APEL" nil '(10 1)) ; Released 20 January 2000 + (product-define "APEL" nil '(10 2)) ; Released 01 March 2000 + ;; (product-define "APEL" nil '(10 3)) + ) + +(defun apel-version () + "Print APEL version." + (interactive) + (let ((product-info (product-string-1 'apel-ver t))) + (if (interactive-p) + (message "%s" product-info) + product-info))) + + +;;; @ End. +;;; + +;;; apel-ver.el ends here diff --git a/poe/inv-19.el b/poe/inv-19.el new file mode 100644 index 0000000..287a007 --- /dev/null +++ b/poe/inv-19.el @@ -0,0 +1,61 @@ +;;; inv-19.el --- invisible feature implementation for Emacs 19 or later + +;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Keywords: invisible, text-property, region, Emacs 19 + +;; This file is part of APEL (A Portable Emacs Library). + +;; 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 'poe) + +(defun enable-invisible ()) +(defun disable-invisible ()) +(defalias 'end-of-invisible 'disable-invisible) +(make-obsolete 'end-of-invisible 'disable-invisible) + +(defun invisible-region (start end) + (if (save-excursion + (goto-char (1- end)) + (eq (following-char) ?\n)) + (setq end (1- end))) + (put-text-property start end 'invisible t)) + +(defun visible-region (start end) + (put-text-property start end 'invisible nil)) + +(defun invisible-p (pos) + (get-text-property pos 'invisible)) + +(defun next-visible-point (pos) + (save-excursion + (goto-char (next-single-property-change pos 'invisible)) + (if (eq (following-char) ?\n) + (forward-char)) + (point))) + + +;;; @ end +;;; + +(require 'product) +(product-provide (provide 'inv-19) (require 'apel-ver)) + +;;; inv-19.el ends here diff --git a/poe/invisible.el b/poe/invisible.el new file mode 100644 index 0000000..d472e15 --- /dev/null +++ b/poe/invisible.el @@ -0,0 +1,42 @@ +;;; invisible.el --- hide region + +;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Keywords: invisible, text-property, region + +;; This file is part of APEL (A Portable Emacs Library). + +;; 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: + +(cond + ((featurep 'xemacs) + (require 'inv-xemacs)) + ((>= emacs-major-version 19) + (require 'inv-19)) + (t + (require 'inv-18))) + + +;;; @ end +;;; + +(require 'product) +(product-provide (provide 'invisible) (require 'apel-ver)) + +;;; invisible.el ends here diff --git a/poe/pccl-20.el b/poe/pccl-20.el new file mode 100644 index 0000000..b95244a --- /dev/null +++ b/poe/pccl-20.el @@ -0,0 +1,155 @@ +;;; pccl-20.el --- Portable CCL utility for Emacs 20 and XEmacs-21-mule + +;; Copyright (C) 1998 Free Software Foundation, Inc. +;; Copyright (C) 1998 Tanaka Akira + +;; Author: Tanaka Akira +;; Keywords: emulation, compatibility, Mule + +;; This file is part of APEL (A Portable Emacs Library). + +;; 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 'ccl)) +(require 'broken) + +(broken-facility ccl-accept-symbol-as-program + "Emacs does not accept symbol as CCL program." + (progn + (define-ccl-program test-ccl-identity + '(1 ((read r0) (loop (write-read-repeat r0))))) + (condition-case nil + (progn + (funcall + (if (fboundp 'ccl-vector-execute-on-string) + 'ccl-vector-execute-on-string + 'ccl-execute-on-string) + 'test-ccl-identity + (make-vector 9 nil) + "") + t) + (error nil))) + t) + +(eval-and-compile + + (if (featurep 'xemacs) + (defun make-ccl-coding-system (name mnemonic docstring decoder encoder) + "\ +Define a new CODING-SYSTEM by CCL programs DECODER and ENCODER. + +CODING-SYSTEM, DECODER and ENCODER must be symbol." + (make-coding-system + name 'ccl docstring + (list 'mnemonic (char-to-string mnemonic) + 'decode (symbol-value decoder) + 'encode (symbol-value encoder)))) + (defun make-ccl-coding-system + (coding-system mnemonic docstring decoder encoder) + "\ +Define a new CODING-SYSTEM by CCL programs DECODER and ENCODER. + +CODING-SYSTEM, DECODER and ENCODER must be symbol." + (when-broken ccl-accept-symbol-as-program + (setq decoder (symbol-value decoder)) + (setq encoder (symbol-value encoder))) + (make-coding-system coding-system 4 mnemonic docstring + (cons decoder encoder))) + ) + + (when-broken ccl-accept-symbol-as-program + + (when (subrp (symbol-function 'ccl-execute)) + (fset 'ccl-vector-program-execute + (symbol-function 'ccl-execute)) + (defun ccl-execute (ccl-prog reg) + "\ +Execute CCL-PROG with registers initialized by REGISTERS. +If CCL-PROG is symbol, it is dereferenced." + (ccl-vector-program-execute + (if (symbolp ccl-prog) (symbol-value ccl-prog) ccl-prog) + reg))) + + (when (subrp (symbol-function 'ccl-execute-on-string)) + (fset 'ccl-vector-program-execute-on-string + (symbol-function 'ccl-execute-on-string)) + (defun ccl-execute-on-string (ccl-prog status string &optional contin) + "\ +Execute CCL-PROG with initial STATUS on STRING. +If CCL-PROG is symbol, it is dereferenced." + (ccl-vector-program-execute-on-string + (if (symbolp ccl-prog) (symbol-value ccl-prog) ccl-prog) + status string contin))) + ) + ) + +(eval-when-compile + (define-ccl-program test-ccl-eof-block + '(1 + ((read r0) + (write r0) + (read r0)) + (write "[EOF]"))) + + (make-ccl-coding-system + 'test-ccl-eof-block-cs ?T "CCL_EOF_BLOCK tester" + 'test-ccl-eof-block 'test-ccl-eof-block) + ) + +(broken-facility ccl-execute-eof-block-on-encoding-null + "Emacs forgets executing CCL_EOF_BLOCK with encoding on empty input. (Fixed on Emacs 20.4)" + (equal (encode-coding-string "" 'test-ccl-eof-block-cs) "[EOF]")) + +(broken-facility ccl-execute-eof-block-on-encoding-some + "Emacs forgets executing CCL_EOF_BLOCK with encoding on non-empty input. (Fixed on Emacs 20.3)" + (equal (encode-coding-string "a" 'test-ccl-eof-block-cs) "a[EOF]")) + +(broken-facility ccl-execute-eof-block-on-decoding-null + "Emacs forgets executing CCL_EOF_BLOCK with decoding on empty input. (Fixed on Emacs 20.4)" + (equal (decode-coding-string "" 'test-ccl-eof-block-cs) "[EOF]")) + +(broken-facility ccl-execute-eof-block-on-decoding-some + "Emacs forgets executing CCL_EOF_BLOCK with decoding on non-empty input. (Fixed on Emacs 20.4)" + (equal (decode-coding-string "a" 'test-ccl-eof-block-cs) "a[EOF]")) + +(broken-facility ccl-execute-eof-block-on-encoding + "Emacs may forget executing CCL_EOF_BLOCK with encoding." + (not (or (broken-p 'ccl-execute-eof-block-on-encoding-null) + (broken-p 'ccl-execute-eof-block-on-encoding-some))) + t) + +(broken-facility ccl-execute-eof-block-on-decoding + "Emacs may forget executing CCL_EOF_BLOCK with decoding." + (not (or (broken-p 'ccl-execute-eof-block-on-decoding-null) + (broken-p 'ccl-execute-eof-block-on-decoding-some))) + t) + +(broken-facility ccl-execute-eof-block + "Emacs may forget executing CCL_EOF_BLOCK." + (not (or (broken-p 'ccl-execute-eof-block-on-encoding) + (broken-p 'ccl-execute-eof-block-on-decoding))) + t) + + +;;; @ end +;;; + +(require 'product) +(product-provide (provide 'pccl-20) (require 'apel-ver)) + +;;; pccl-20.el ends here diff --git a/poe/pccl.el b/poe/pccl.el new file mode 100644 index 0000000..c696f75 --- /dev/null +++ b/poe/pccl.el @@ -0,0 +1,77 @@ +;;; pccl.el --- Portable CCL utility for Mule 2.* + +;; Copyright (C) 1998 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Keywords: emulation, compatibility, Mule + +;; This file is part of APEL (A Portable Emacs Library). + +;; 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 'broken) + +(broken-facility ccl-usable + "Emacs has not CCL." + (and (featurep 'mule) + (if (featurep 'xemacs) + (>= emacs-major-version 21) + (>= emacs-major-version 19)))) + +(unless-broken ccl-usable + (require 'ccl) + (require 'advice) + + (if (featurep 'mule) + (if (featurep 'xemacs) + (if (>= emacs-major-version 21) + ;; for XEmacs 21 with mule + (require 'pccl-20)) + (if (>= emacs-major-version 20) + ;; for Emacs 20 + (require 'pccl-20) + ;; for Mule 2.* + (require 'pccl-om)))) + + (defadvice define-ccl-program + (before accept-long-ccl-program activate) + "When CCL-PROGRAM is too long, internal buffer is extended automaticaly." + (let ((try-ccl-compile t) + (prog (eval (ad-get-arg 1)))) + (ad-set-arg 1 (` '(, prog))) + (while try-ccl-compile + (setq try-ccl-compile nil) + (condition-case sig + (ccl-compile prog) + (args-out-of-range + (if (and (eq (car (cdr sig)) ccl-program-vector) + (= (car (cdr (cdr sig))) (length ccl-program-vector))) + (setq ccl-program-vector + (make-vector (* 2 (length ccl-program-vector)) 0) + try-ccl-compile t) + (signal (car sig) (cdr sig)))))))) + ) + + +;;; @ end +;;; + +(require 'product) +(product-provide (provide 'pccl) (require 'apel-ver)) + +;;; pccl.el ends here diff --git a/poe/product.el b/poe/product.el new file mode 100644 index 0000000..c9aeaab --- /dev/null +++ b/poe/product.el @@ -0,0 +1,424 @@ +;;; product.el --- Functions for product version information. + +;; Copyright (C) 1999 Free Software Foundation, Inc. + +;; Author: Shuhei KOBAYASHI +;; Keiichi Suzuki +;; Keywords: compatibility, User-Agent + +;; This file is part of APEL (A Portable Emacs Library). + +;; 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 this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This module defines some utility functions for product information, +;; used for User-Agent header field. +;; +;; User-Agent header field first appeared in HTTP [RFC 1945, RFC 2616] +;; and adopted to News Article Format draft [USEFOR]. +;; +;; [RFC 1945] Hypertext Transfer Protocol -- HTTP/1.0. +;; T. Berners-Lee, R. Fielding & H. Frystyk. May 1996. +;; +;; [RFC 2616] Hypertext Transfer Protocol -- HTTP/1.1. +;; R. Fielding, J. Gettys, J. Mogul, H. Frystyk, L. Masinter, P. Leach, +;; T. Berners-Lee. June 1999. +;; +;; [USEFOR] News Article Format, . +;; USEFOR Working Group. March 1999. + +;;; Code: + +(defvar product-obarray (make-vector 13 0)) + +(defvar product-ignore-checkers nil) + +(defun product-define (name &optional family version code-name) + "Define a product as a set of NAME, FAMILY, VERSION, and CODE-NAME. +NAME is a string. Optional 2nd argument FAMILY is a string of +family product name. Optional 3rd argument VERSION is a list of +numbers. Optional 4th argument CODE-NAME is a string." + (and family + (product-add-to-family family name)) + (set (intern name product-obarray) + (vector name family version code-name nil nil nil nil))) + +(defun product-name (product) + "Return the name of PRODUCT, a string." + (aref product 0)) +(defun product-family (product) + "Return the family name of PRODUCT, a string." + (aref product 1)) +(defun product-version (product) + "Return the version of PRODUCT, a list of numbers." + (aref product 2)) +(defun product-code-name (product) + "Return the code-name of PRODUCT, a string." + (aref product 3)) +(defun product-checkers (product) + "Return the checkers of PRODUCT, a list of functions." + (aref product 4)) +(defun product-family-products (product) + "Return the family products of PRODUCT, a list of strings." + (aref product 5)) +(defun product-features (product) + "Return the features of PRODUCT, a list of feature." + (aref product 6)) +(defun product-version-string (product) + "Return the version string of PRODUCT, a string." + (aref product 7)) + +(defun product-set-name (product name) + "Set name of PRODUCT to NAME." + (aset product 0 name)) +(defun product-set-family (product family) + "Set family name of PRODUCT to FAMILY." + (aset product 1 family)) +(defun product-set-version (product version) + "Set version of PRODUCT to VERSION." + (aset product 2 version)) +;; Some people want to translate code-name. +(defun product-set-code-name (product code-name) + "Set code-name of PRODUCT to CODE-NAME." + (aset product 3 code-name)) +(defun product-set-checkers (product checkers) + "Set ckecker functions of PRODUCT to CHECKERS." + (aset product 4 checkers)) +(defun product-set-family-products (product products) + "Set family products of PRODUCT to PRODUCTS." + (aset product 5 products)) +(defun product-set-features (product features) + "Set features of PRODUCT to FEATURES." + (aset product 6 features)) +(defun product-set-version-string (product version-string) + "Set version string of PRODUCT to VERSION-STRING." + (aset product 7 version-string)) + +(defun product-add-to-family (family product-name) + "Add a product to a family. +FAMILY is a product structure which returned by `product-define'. +PRODUCT-NAME is a string of the product's name ." + (let ((family-product (product-find-by-name family))) + (if family-product + (let ((dest (product-family-products family-product))) + (or (member product-name dest) + (product-set-family-products + family-product (cons product-name dest)))) + (error "Family product `%s' is not defined" family)))) + +(defun product-remove-from-family (family product-name) + "Remove a product from a family. +FAMILY is a product string which returned by `product-define'. +PRODUCT-NAME is a string of the product's name." + (let ((family-product (product-find-by-name family))) + (if family-product + (product-set-family-products + family-product + (delete product-name (product-family-products family-product))) + (error "Family product `%s' is not defined" family)))) + +(defun product-add-checkers (product &rest checkers) + "Add checker function(s) to a product. +PRODUCT is a product structure which returned by `product-define'. +The rest arguments CHECKERS should be functions. These functions +are regist to the product's checkers list, and will be called by + `product-run-checkers'. +If a checker is `ignore' will be ignored all checkers after this." + (setq product (product-find product)) + (or product-ignore-checkers + (let ((dest (product-checkers product)) + checker) + (while checkers + (setq checker (car checkers) + checkers (cdr checkers)) + (or (memq checker dest) + (setq dest (cons checker dest)))) + (product-set-checkers product dest)))) + +(defun product-remove-checkers (product &rest checkers) + "Remove checker function(s) from a product. +PRODUCT is a product structure which returned by `product-define'. +The rest arguments CHECKERS should be functions. These functions removed +from the product's checkers list." + (setq product (product-find product)) + (let ((dest (product-checkers product))) + (while checkers + (setq checkers (cdr checkers) + dest (delq (car checkers) dest))) + (product-set-checkers product dest))) + +(defun product-add-feature (product feature) + "Add a feature to the features list of a product. +PRODUCT is a product structure which returned by `product-define'. +FEATURE is a feature in the PRODUCT's." + (setq product (product-find product)) + (let ((dest (product-features product))) + (or (memq feature dest) + (product-set-features product (cons feature dest))))) + +(defun product-remove-feature (product feature) + "Remove a feature from the features list of a product. +PRODUCT is a product structure which returned by `product-define'. +FEATURE is a feature which registered in the products list of PRODUCT." + (setq product (product-find product)) + (product-set-features product + (delq feature (product-features product)))) + +(defun product-run-checkers (product version &optional force) + "Run checker functions of product. +PRODUCT is a product structure which returned by `product-define'. +VERSION is target version. +If optional 3rd argument FORCE is non-nil then do not ignore +all checkers." + (let ((checkers (product-checkers product))) + (if (or force + (not (memq 'ignore checkers))) + (let ((version (or version + (product-version product)))) + (while checkers + (funcall (car checkers) version version) + (setq checkers (cdr checkers))))))) + +(defun product-find-by-name (name) + "Find product by name and return a product structure. +NAME is a string of the product's name." + (symbol-value (intern-soft name product-obarray))) + +(defun product-find-by-feature (feature) + "Get a product structure of a feature's product. +FEATURE is a symbol of the feature." + (get feature 'product)) + +(defun product-find (product) + "Find product information. +If PROCUCT is a product structure, then return PRODUCT itself. +If PRODUCT is a string, then find product by name and return a +product structure. If PRODUCT is symbol of feature, then return +the feature's product." + (cond + ((and (symbolp product) + (featurep product)) + (product-find-by-feature product)) + ((stringp product) + (product-find-by-name product)) + ((vectorp product) + product) + (t + (error "Invalid product %s" product)))) + +(put 'product-provide 'lisp-indent-function 1) +(defmacro product-provide (feature-def product-def) + "Declare a feature as a part of product. +FEATURE-DEF is a definition of the feature. +PRODUCT-DEF is a definition of the product." + (let* ((feature feature-def) + (product (product-find (eval product-def))) + (product-name (product-name product)) + (product-family (product-family product)) + (product-version (product-version product)) + (product-code-name (product-code-name product)) + (product-version-string (product-version-string product))) + (` (progn + (, product-def) + (put (, feature) 'product + (let ((product (product-find-by-name (, product-name)))) + (product-run-checkers product '(, product-version)) + (and (, product-family) + (product-add-to-family (, product-family) + (, product-name))) + (product-add-feature product (, feature)) + (if (equal '(, product-version) (product-version product)) + product + (vector (, product-name) (, product-family) + '(, product-version) (, product-code-name) + nil nil nil (, product-version-string))))) + (, feature-def))))) + +(defun product-string-1 (product &optional verbose) + "Return information of product as a string of \"NAME/VERSION\". +PRODUCT is a product structure which returned by `product-define'. +If optional argument VERBOSE is non-nil, then return string of +\"NAME/VERSION (CODE-NAME)\"." + (setq product (product-find product)) + (concat (product-name product) + (cond + ((product-version-string product) + (concat "/" (product-version-string product))) + ((product-version product) + (concat "/" + (product-set-version-string + product + (mapconcat (function int-to-string) + (product-version product) + ".")))) + ("")) + (if (and verbose (product-code-name product)) + (concat " (" (product-code-name product) ")") + ""))) + +(defun product-for-each (product all function &rest args) + "Apply a function to a product and the product's family with args. +PRODUCT is a product structure which returned by `product-define'. +If ALL is nil, apply function to only products which provided feature. +FUNCTION is a function. The function called with following arguments. +The 1st argument is a product structure. The rest arguments are ARGS." + (setq product (product-find product)) + (let ((family (product-family-products product))) + (and (or all (product-features product)) + (apply function product args)) + (while family + (apply 'product-for-each (car family) all function args) + (setq family (cdr family))))) + +(defun product-string (product) + "Return information of product as a string of \"NAME/VERSION\". +PRODUCT is a product structure which returned by `product-define'." + (let (dest) + (product-for-each product nil + (function + (lambda (product) + (let ((str (product-string-1 product nil))) + (if str + (setq dest (if dest + (concat dest " " str) + str))))))) + dest)) + +(defun product-string-verbose (product) + "Return information of product as a string of \"NAME/VERSION (CODE-NAME)\". +PRODUCT is a product structure which returned by `product-define'." + (let (dest) + (product-for-each product nil + (function + (lambda (product) + (let ((str (product-string-1 product t))) + (if str + (setq dest (if dest + (concat dest " " str) + str))))))) + dest)) + +(defun product-version-compare (v1 v2) + "Compare two versions. +Return an integer greater than, equal to, or less than 0, +according as the version V1 is greater than, equal to, or less +than the version V2. +Both V1 and V2 are a list of integer(s) respectively." + (while (and v1 v2 (= (car v1) (car v2))) + (setq v1 (cdr v1) + v2 (cdr v2))) + (if v1 (if v2 (- (car v1) (car v2)) 1) (if v2 -1 0))) + +(defun product-version>= (product require-version) + "Compare product version with required version. +PRODUCT is a product structure which returned by `product-define'. +REQUIRE-VERSION is a list of integer." + (>= (product-version-compare (product-version (product-find product)) + require-version) + 0)) + +(defun product-list-products () + "List all products information." + (let (dest) + (mapatoms + (function + (lambda (sym) + (setq dest (cons (symbol-value sym) dest)))) + product-obarray) + dest)) + +(defun product-parse-version-string (verstr) + "Parse version string \".*v1.v2... (CODE-NAME)\". +Return list of version, code-name, and version-string. +VERSTR is a string." + (let (version version-string code-name) + (and (string-match "\\(\\([0-9.]+\\)[^ ]*\\)[^(]*\\((\\(.+\\))\\)?" verstr) + (let ((temp (substring verstr (match-beginning 2) (match-end 2)))) + (setq version-string (substring verstr + (match-beginning 1) + (match-end 1)) + code-name (and (match-beginning 4) + (substring verstr + (match-beginning 4) + (match-end 4)))) + (while (string-match "^\\([0-9]+\\)\\.?" temp) + (setq version (cons (string-to-number + (substring temp + (match-beginning 1) + (match-end 1))) + version) + temp (substring temp (match-end 0)))))) + (list (nreverse version) code-name version-string))) + + +;;; @ End. +;;; + +(provide 'product) ; beware of circular dependency. +(require 'apel-ver) ; these two files depend on each other. +(product-provide 'product 'apel-ver) + + +;;; @ Define emacs versions. +;;; + +;; (require 'pym) + +;; (defconst-maybe emacs-major-version +;; (progn (string-match "^[0-9]+" emacs-version) +;; (string-to-int (substring emacs-version +;; (match-beginning 0)(match-end 0)))) +;; "Major version number of this version of Emacs.") +;; (defconst-maybe emacs-minor-version +;; (progn (string-match "^[0-9]+\\.\\([0-9]+\\)" emacs-version) +;; (string-to-int (substring emacs-version +;; (match-beginning 1)(match-end 1)))) +;; "Minor version number of this version of Emacs.") + +;;(or (product-find "emacs") +;; (progn +;; (product-define "emacs") +;; (cond +;; ((featurep 'meadow) +;; (let* ((info (product-parse-version-string (Meadow-version))) +;; (version (nth 0 info)) +;; (code-name (nth 1 info)) +;; (version-string (nth 2 info))) +;; (product-set-version-string +;; (product-define "Meadow" "emacs" version code-name) +;; version-string) +;; (product-provide 'Meadow "Meadow")) +;; (and (featurep 'mule) +;; (let* ((info (product-parse-version-string mule-version)) +;; (version (nth 0 info)) +;; (code-name (nth 1 info)) +;; (version-string (nth 2 info))) +;; (product-set-version-string +;; (product-define "MULE" "Meadow" version code-name) +;; version-string) +;; (product-provide 'mule "MULE"))) +;; (let* ((info (product-parse-version-string emacs-version)) +;; (version (nth 0 info)) +;; (code-name (nth 1 info)) +;; (version-string (nth 2 info))) +;; (product-set-version-string +;; (product-define "Emacs" "Meadow" version code-name) +;; version-string) +;; (product-provide 'emacs "Emacs"))) +;; ))) + +;;; product.el ends here diff --git a/richtext.el b/richtext.el new file mode 100644 index 0000000..8b1718c --- /dev/null +++ b/richtext.el @@ -0,0 +1,185 @@ +;;; richtext.el -- read and save files in text/richtext format + +;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Created: 1995/7/15 +;; Version: $Id: richtext.el,v 1.1.2.1 2000/02/03 05:01:36 tomo Exp $ +;; Keywords: wp, faces, MIME, multimedia + +;; This file is not part of GNU Emacs yet. + +;; 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 'enriched) + + +;;; @ variables +;;; + +(defconst richtext-initial-annotation + (lambda () + (format "Content-Type: text/richtext\nText-Width: %d\n\n" + (enriched-text-width))) + "What to insert at the start of a text/richtext file. +If this is a string, it is inserted. If it is a list, it should be a lambda +expression, which is evaluated to get the string to insert.") + +(defconst richtext-annotation-regexp + "[ \t\n]*\\(<\\(/\\)?\\([-A-za-z0-9]+\\)>\\)[ \t\n]*" + "Regular expression matching richtext annotations.") + +(defconst richtext-translations + '((face (bold-italic "bold" "italic") + (bold "bold") + (italic "italic") + (underline "underline") + (fixed "fixed") + (excerpt "excerpt") + (default ) + (nil enriched-encode-other-face)) + (invisible (t "comment")) + (left-margin (4 "indent")) + (right-margin (4 "indentright")) + (justification (right "flushright") + (left "flushleft") + (full "flushboth") + (center "center")) + ;; The following are not part of the standard: + (FUNCTION (enriched-decode-foreground "x-color") + (enriched-decode-background "x-bg-color")) + (read-only (t "x-read-only")) + (unknown (nil format-annotate-value)) +; (font-size (2 "bigger") ; unimplemented +; (-2 "smaller")) +) + "List of definitions of text/richtext annotations. +See `format-annotate-region' and `format-deannotate-region' for the definition +of this structure.") + + +;;; @ encoder +;;; + +;;;###autoload +(defun richtext-encode (from to) + (if enriched-verbose (message "Richtext: encoding document...")) + (save-restriction + (narrow-to-region from to) + (delete-to-left-margin) + (unjustify-region) + (goto-char from) + (format-replace-strings '(("<" . ""))) + (format-insert-annotations + (format-annotate-region from (point-max) richtext-translations + 'enriched-make-annotation enriched-ignore)) + (goto-char from) + (insert (if (stringp enriched-initial-annotation) + richtext-initial-annotation + (funcall richtext-initial-annotation))) + (enriched-map-property-regions 'hard + (lambda (v b e) + (goto-char b) + (if (eolp) + (while (search-forward "\n" nil t) + (replace-match "\n") + ))) + (point) nil) + (if enriched-verbose (message nil)) + ;; Return new end. + (point-max))) + + +;;; @ decoder +;;; + +(defun richtext-next-annotation () + "Find and return next text/richtext annotation. +Return value is \(begin end name positive-p), or nil if none was found." + (catch 'tag + (while (re-search-forward richtext-annotation-regexp nil t) + (let* ((beg0 (match-beginning 0)) + (end0 (match-end 0)) + (beg (match-beginning 1)) + (end (match-end 1)) + (name (downcase (buffer-substring + (match-beginning 3) (match-end 3)))) + (pos (not (match-beginning 2))) + ) + (cond ((equal name "lt") + (delete-region beg end) + (goto-char beg) + (insert "<") + ) + ((equal name "comment") + (if pos + (throw 'tag (list beg0 end name pos)) + (throw 'tag (list beg end0 name pos)) + ) + ) + (t + (throw 'tag (list beg end name pos)) + )) + )))) + +;;;###autoload +(defun richtext-decode (from to) + (if enriched-verbose (message "Richtext: decoding document...")) + (save-excursion + (save-restriction + (narrow-to-region from to) + (goto-char from) + (let ((file-width (enriched-get-file-width)) + (use-hard-newlines t)) + (enriched-remove-header) + + (goto-char from) + (while (re-search-forward "\n\n+" nil t) + (replace-match "\n") + ) + + ;; Deal with newlines + (goto-char from) + (while (re-search-forward "[ \t\n]*[ \t\n]*" nil t) + (replace-match "\n") + (put-text-property (match-beginning 0) (point) 'hard t) + (put-text-property (match-beginning 0) (point) 'front-sticky nil) + ) + + ;; Translate annotations + (format-deannotate-region from (point-max) richtext-translations + 'richtext-next-annotation) + + ;; Fill paragraphs + (if (and file-width ; possible reasons not to fill: + (= file-width (enriched-text-width))) ; correct wd. + ;; Minimally, we have to insert indentation and justification. + (enriched-insert-indentation) + (if enriched-verbose (message "Filling paragraphs...")) + (fill-region (point-min) (point-max)))) + (if enriched-verbose (message nil)) + (point-max)))) + + +;;; @ end +;;; + +(require 'product) +(product-provide (provide 'richtext) (require 'apel-ver)) + +;;; richtext.el ends here -- 1.7.10.4