From: handa Date: Sat, 12 Aug 2000 02:40:11 +0000 (+0000) Subject: *** empty log message *** X-Git-Tag: semi21-2000-08-12~1 X-Git-Url: http://git.chise.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=b0a4de308365b414daaa778f22c0676fab5415ec;p=elisp%2Flemi.git *** empty log message *** --- diff --git a/mime/emh-comp.el b/mime/emh-comp.el new file mode 100644 index 0000000..1fa22f5 --- /dev/null +++ b/mime/emh-comp.el @@ -0,0 +1,529 @@ +;;; 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) + +;; 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)) + (as-binary-input-file (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)) + (prog1 + (as-binary-input-file + (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 ((msubtype "digest") + orig-from orig-subject multipart-flag + (tag-regexp + (concat "^" + (regexp-quote (mime-make-tag "message" "rfc822")))) + ) + (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-face.el b/mime/emh-face.el new file mode 100644 index 0000000..5722dc0 --- /dev/null +++ b/mime/emh-face.el @@ -0,0 +1,159 @@ +;;; emh-face.el --- header highlighting in emh. + +;; Copyright (C) 1997 MORIOKA Tomohiko + +;; Author: MORIOKA Tomohiko +;; Created: 1997/3/4 +;; Version: $Id: emh-face.el,v 1.1.2.1 2000/02/03 05:02:30 tomo Exp $ +;; 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 'emu) + +(defsubst emh-set-face-foreground (face color) + (condition-case err + (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..2d8af82 --- /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 "--------") + (eword-decode-header 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..22a2d7e --- /dev/null +++ b/mime/emh.el @@ -0,0 +1,359 @@ +;;; 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.13.0") + + +;;; @ 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) + ) + (insert-file-contents-as-raw-text 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 + (eword-decode-header) + ) + (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) + (insert-file-contents-as-raw-text 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..dd46d32 --- /dev/null +++ b/mime/eword-decode.el @@ -0,0 +1,829 @@ +;;; eword-decode.el --- RFC 2047 based encoded-word decoder for GNU Emacs + +;; Copyright (C) 1995,1996,1997,1998 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 + +(defgroup eword-decode nil + "Encoded-word decoding" + :group 'mime) + +(defcustom eword-max-size-to-decode 1000 + "*Max size to decode header field." + :group 'eword-decode + :type '(choice (integer :tag "Limit (bytes)") + (const :tag "Don't limit" nil))) + + +;;; @ 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 eword-max-size-to-decode + (> (length string) eword-max-size-to-decode)) + 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 FILED. +SPECS must be like `MODE1 DECODER1 MODE2 DECODER2 ...'. +Each mode must be `nil', `plain', `wide', `summary' or `nov'. +If mode is `nil', corresponding decoder is set up for every modes." + (when specs + (let ((mode (pop specs)) + (function (pop specs))) + (if mode + (progn + (let ((cell (assq mode mime-field-decoder-alist))) + (if cell + (setcdr cell (put-alist field function (cdr cell))) + (setq mime-field-decoder-alist + (cons (cons mode (list (cons field function))) + mime-field-decoder-alist)) + )) + (apply (function mime-set-field-decoder) field specs) + ) + (mime-set-field-decoder field + 'plain function + 'wide function + 'summary function + 'nov function) + )))) + +;;;###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)) + +(define-obsolete-function-alias '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.") + +(defcustom eword-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." + :group 'eword-decode + :type '(repeat function)) + +(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 eword-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..5735e04 --- /dev/null +++ b/mime/eword-encode.el @@ -0,0 +1,699 @@ +;;; eword-encode.el --- RFC 2047 based encoded-word encoder for GNU Emacs + +;; Copyright (C) 1995,1996,1997,1998,1999 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 +;;; + +(defgroup eword-encode nil + "Encoded-word encoding" + :group 'mime) + +(defcustom eword-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 'eword-encode + :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))))) + +(defvar eword-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") + )) + + +;;; @ 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))) + (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 (sref string 0)) + (charset (eword-encode-char-type chr)) + (i (char-length chr))) + (while (and (< i len) + (setq chr (sref string i)) + (eq charset (eword-encode-char-type chr)) + ) + (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 eword-charset-encoding-alist) + '(nil . "Q"))))) + (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 (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-non-ascii-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 (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-addresses-to-rword-list (addresses) + (let ((dest (eword-encode-mailbox-to-rword-list (car addresses)))) + (if dest + (while (setq addresses (cdr addresses)) + (setq dest + (nconc dest + (list '("," nil nil)) + ;; (list '(" " nil nil)) + (eword-encode-mailbox-to-rword-list (car addresses)) + )) + )) + dest)) + +(defsubst eword-encode-msg-id-to-rword-list (msg-id) + (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 +;;; + +(defcustom eword-encode-default-start-column 10 + "Default start column if it is omitted." + :group 'eword-encode + :type 'integer) + +(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)))) + +(defun eword-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) + )) + ))) + +(defun eword-in-subject-p () + (let ((str (std11-field-body "Subject"))) + (if (and str (string-match eword-encoded-word-regexp str)) + str))) + +(defsubst eword-find-field-encoding-method (field-name) + (setq field-name (downcase field-name)) + (let ((alist eword-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 eword-field-encoding-method-alist)) + ))) + +(defun eword-encode-header (&optional code-conversion) + "Encode header fields to network representation, such as MIME encoded-word. + +It refer variable `eword-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 (find-non-ascii-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 (eword-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) + ))) + )) + )) + ))) + + +;;; @ end +;;; + +(provide 'eword-encode) + +;;; eword-encode.el ends here diff --git a/mime/luna.el b/mime/luna.el new file mode 100644 index 0000000..48da490 --- /dev/null +++ b/mime/luna.el @@ -0,0 +1,379 @@ +;;; 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)) + +(eval-when-compile (require 'static)) + +(static-condition-case nil + :symbol-for-testing-whether-colon-keyword-is-available-or-not + (void-variable + (defconst :before ':before) + (defconst :after ':after) + (defconst :around ':around))) + + +;;; @ class +;;; + +(defmacro luna-find-class (name) + "Return the luna-class of the given NAME." + `(get ,name 'luna-class)) + +(defmacro luna-set-class (name class) + `(put ,name 'luna-class ,class)) + +(defmacro luna-class-obarray (class) + `(aref ,class 1)) + +(defmacro luna-class-parents (class) + `(aref ,class 2)) + +(defmacro luna-class-number-of-slots (class) + `(aref ,class 3)) + +(defmacro luna-define-class (type &optional parents slots) + "Define TYPE as a luna-class. +If PARENTS is specified, TYPE inherits PARENTS. +Each parent must be name of luna-class (symbol). +If SLOTS is specified, TYPE will be defined to have them." + `(luna-define-class-function ',type ',(append parents '(standard-object)) + ',slots)) + +(defun luna-define-class-function (type &optional parents slots) + (static-condition-case nil + :symbol-for-testing-whether-colon-keyword-is-available-or-not + (void-variable + (let (key) + (dolist (slot slots) + (setq key (intern (format ":%s" slot))) + (set key key))))) + (let ((oa (make-vector 31 0)) + (rest parents) + parent name + (i 2) + b j) + (while rest + (setq parent (pop rest) + b (- i 2)) + (mapatoms (lambda (sym) + (when (setq j (get sym 'luna-slot-index)) + (setq name (symbol-name sym)) + (unless (intern-soft name oa) + (put (intern name oa) 'luna-slot-index (+ j b)) + (setq i (1+ i)) + ))) + (luna-class-obarray (luna-find-class parent))) + ) + (setq rest slots) + (while rest + (setq name (symbol-name (pop rest))) + (unless (intern-soft name oa) + (put (intern name oa) 'luna-slot-index i) + (setq i (1+ i)) + )) + (luna-set-class type (vector 'class oa parents i)) + )) + +(defun luna-class-find-member (class member-name) + (or (stringp member-name) + (setq member-name (symbol-name member-name))) + (or (intern-soft member-name (luna-class-obarray class)) + (let ((parents (luna-class-parents class)) + ret) + (while (and parents + (null + (setq ret (luna-class-find-member + (luna-find-class (pop parents)) + member-name))))) + ret))) + +(defsubst luna-class-find-or-make-member (class member-name) + (or (stringp member-name) + (setq member-name (symbol-name member-name))) + (intern member-name (luna-class-obarray class))) + +(defmacro luna-class-slot-index (class slot-name) + `(get (luna-class-find-member ,class ,slot-name) 'luna-slot-index)) + +(defmacro luna-define-method (name &rest definition) + "Define NAME as a method function of a class. + +Usage of this macro follows: + + (luna-define-method NAME [METHOD-QUALIFIER] ARGLIST [DOCSTRING] BODY...) + +NAME is the name of method. + +Optional argument METHOD-QUALIFIER must be :before, :after or :around. +If it is :before / :after, the method is called before / after a +method of parent class is finished. ARGLIST is like an argument list +of lambda, but (car ARGLIST) must be specialized parameter. (car (car +ARGLIST)) is name of variable and \(nth 1 (car ARGLIST)) is name of +class. + +Optional argument DOCSTRING is the documentation of method. + +BODY is the body of method." + (let ((method-qualifier (pop definition)) + args specializer class self) + (if (memq method-qualifier '(:before :after :around)) + (setq args (pop definition)) + (setq args method-qualifier + method-qualifier nil) + ) + (setq specializer (car args) + class (nth 1 specializer) + self (car specializer)) + `(let ((func (lambda ,(if self + (cons self (cdr args)) + (cdr args)) + ,@definition)) + (sym (luna-class-find-or-make-member + (luna-find-class ',class) ',name))) + (fset sym func) + (put sym 'luna-method-qualifier ,method-qualifier) + ))) + +(put 'luna-define-method 'lisp-indent-function 'defun) + +(def-edebug-spec luna-define-method + (&define name [&optional &or ":before" ":after" ":around"] + ((arg symbolp) + [&rest arg] + [&optional ["&optional" arg &rest arg]] + &optional ["&rest" arg] + ) + def-body)) + +(defun luna-class-find-parents-functions (class service) + (let ((parents (luna-class-parents class)) + ret) + (while (and parents + (null + (setq ret (luna-class-find-functions + (luna-find-class (pop parents)) + service))))) + ret)) + +(defun luna-class-find-functions (class service) + (let ((sym (luna-class-find-member class service))) + (if (fboundp sym) + (cond ((eq (get sym 'luna-method-qualifier) :before) + (cons (symbol-function sym) + (luna-class-find-parents-functions class service)) + ) + ((eq (get sym 'luna-method-qualifier) :after) + (nconc (luna-class-find-parents-functions class service) + (list (symbol-function sym))) + ) + ((eq (get sym 'luna-method-qualifier) :around) + (cons sym (luna-class-find-parents-functions class service)) + ) + (t + (list (symbol-function sym)) + )) + (luna-class-find-parents-functions class service) + ))) + + +;;; @ 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. +LUNA-CURRENT-METHOD-ARGUMENTS is arguments of the MESSAGE." + (let ((luna-next-methods (luna-find-functions entity message)) + luna-current-method + luna-previous-return-value) + (while (and luna-next-methods + (progn + (setq luna-current-method (pop luna-next-methods) + luna-previous-return-value + (apply luna-current-method + luna-current-method-arguments)) + (if (symbolp luna-current-method) + (not (eq (get luna-current-method + 'luna-method-qualifier) :around)) + t)))) + luna-previous-return-value)) + +(eval-when-compile + (defvar luna-next-methods nil) + (defvar luna-current-method-arguments nil) + ) + +(defun luna-call-next-method () + "Call the next method in a method with :around qualifier." + (let (luna-current-method + luna-previous-return-value) + (while (and luna-next-methods + (progn + (setq luna-current-method (pop luna-next-methods) + luna-previous-return-value + (apply luna-current-method + luna-current-method-arguments)) + (if (symbolp luna-current-method) + (not (eq (get luna-current-method + 'luna-method-qualifier) :around)) + t)))) + luna-previous-return-value)) + +(defun luna-make-entity (type &rest init-args) + "Make instance of luna-class TYPE and return it. +If INIT-ARGS is specified, it is used as initial values of the slots. +It must be plist and each slot name must have prefix `:'." + (let* ((c (get type 'luna-class)) + (v (make-vector (luna-class-number-of-slots c) nil))) + (luna-set-class-name v type) + (luna-set-obarray v (make-vector 7 0)) + (apply #'luna-send v 'initialize-instance v init-args) + )) + + +;;; @ interface (generic function) +;;; + +(defsubst luna-arglist-to-arguments (arglist) + (let (dest) + (while arglist + (let ((arg (car arglist))) + (or (memq arg '(&optional &rest)) + (setq dest (cons arg dest))) + ) + (setq arglist (cdr arglist))) + (nreverse dest))) + +(defmacro luna-define-generic (name args &optional doc) + "Define generic-function NAME. +ARGS is argument of and DOC is DOC-string." + (if doc + `(defun ,(intern (symbol-name name)) ,args + ,doc + (luna-send ,(car args) ',name + ,@(luna-arglist-to-arguments args)) + ) + `(defun ,(intern (symbol-name name)) ,args + (luna-send ,(car args) ',name + ,@(luna-arglist-to-arguments args)) + ))) + +(put 'luna-define-generic 'lisp-indent-function 'defun) + + +;;; @ accessor +;;; + +(defun luna-define-internal-accessors (class-name) + "Define internal accessors for an entity of CLASS-NAME." + (let ((entity-class (luna-find-class class-name)) + parents parent-class) + (mapatoms + (lambda (slot) + (if (luna-class-slot-index entity-class slot) + (catch 'derived + (setq parents (luna-class-parents entity-class)) + (while parents + (setq parent-class (luna-find-class (car parents))) + (if (luna-class-slot-index parent-class slot) + (throw 'derived nil)) + (setq parents (cdr parents)) + ) + (eval + `(progn + (defmacro ,(intern (format "%s-%s-internal" + class-name slot)) + (entity) + (list 'aref entity + ,(luna-class-slot-index entity-class + (intern (symbol-name slot))) + )) + (defmacro ,(intern (format "%s-set-%s-internal" + class-name slot)) + (entity value) + (list 'aset entity + ,(luna-class-slot-index + entity-class (intern (symbol-name slot))) + value)) + )) + ))) + (luna-class-obarray entity-class)))) + + +;;; @ standard object +;;; + +(luna-define-class-function 'standard-object) + +(luna-define-method initialize-instance ((entity standard-object) + &rest init-args) + (let* ((c (luna-find-class (luna-class-name entity))) + (oa (luna-class-obarray c)) + s i) + (while init-args + (setq s (intern-soft (substring (symbol-name (pop init-args)) 1) oa) + i (pop init-args)) + (if s + (aset entity (get s 'luna-slot-index) i) + )) + entity)) + + +;;; @ end +;;; + +(provide 'luna) + +;; luna.el ends here diff --git a/mime/mail-mime-setup.el b/mime/mail-mime-setup.el new file mode 100644 index 0000000..710d15b --- /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 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/mailcap.el b/mime/mailcap.el new file mode 100644 index 0000000..25595f0 --- /dev/null +++ b/mime/mailcap.el @@ -0,0 +1,270 @@ +;;; mailcap.el --- mailcap parser + +;; Copyright (C) 1997,1998 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Created: 1997/6/27 +;; Keywords: mailcap, setting, configuration, MIME, multimedia + +;; 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) + + +;;; @ comment +;;; + +(defsubst mailcap-skip-comment () + (let ((chr (char-after (point)))) + (when (and chr + (or (= chr ?\n) + (= chr ?#))) + (forward-line) + t))) + + +;;; @ token +;;; + +(defsubst 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 mailcap-look-at-type-field () + (let ((type (mailcap-look-at-token))) + (if type + (if (eq (char-after (point)) ?/) + (progn + (forward-char) + (let ((subtype (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 mailcap-skip-field-separator () + (let ((ret (looking-at "\\([ \t]\\|\\\\\n\\)*;\\([ \t]\\|\\\\\n\\)*"))) + (when ret + (goto-char (match-end 0)) + t))) + + +;;; @ mtext +;;; + +(defsubst mailcap-look-at-schar () + (let ((chr (char-after (point)))) + (if (and chr + (>= chr ? ) + (/= chr ?\;) + (/= chr ?\\) + ) + (prog1 + chr + (forward-char))))) + +(defsubst mailcap-look-at-qchar () + (when (eq (char-after (point)) ?\\) + (prog2 + (forward-char) + (char-after (point)) + (forward-char)))) + +(defsubst mailcap-look-at-mtext () + (let ((beg (point))) + (while (or (mailcap-look-at-qchar) + (mailcap-look-at-schar))) + (buffer-substring beg (point)) + )) + + +;;; @ field +;;; + +(defsubst mailcap-look-at-field () + (let ((token (mailcap-look-at-token))) + (if token + (if (looking-at "[ \t]*=[ \t]*") + (let ((value (progn + (goto-char (match-end 0)) + (mailcap-look-at-mtext)))) + (if value + (cons (intern token) value) + )) + (list (intern token)) + )))) + + +;;; @ mailcap entry +;;; + +(defun mailcap-look-at-entry () + (let ((type (mailcap-look-at-type-field))) + (if (and type (mailcap-skip-field-separator)) + (let ((view (mailcap-look-at-mtext)) + fields field) + (when view + (while (and (mailcap-skip-field-separator) + (setq field (mailcap-look-at-field)) + ) + (setq fields (cons field fields)) + ) + (nconc type + (list (cons 'view view)) + fields)))))) + + +;;; @ main +;;; + +(defun mailcap-parse-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 (mailcap-skip-comment)) + (setq entry (mailcap-look-at-entry)) + ) + (setq entries (cons entry entries)) + (forward-line) + ) + (cond ((functionp order) (sort entries order)) + ((null order) (nreverse entries)) + (t entries) + )))) + + +(defcustom mailcap-file "~/.mailcap" + "*File name of user's mailcap file." + :group 'mime + :type 'file) + +(defun mailcap-parse-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 mailcap-file)) + (with-temp-buffer + (insert-file-contents filename) + (mailcap-parse-buffer (current-buffer) order) + )) + +(defun mailcap-format-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 'mailcap) + +;;; mailcap.el ends here diff --git a/mime/mcharset.el b/mime/mcharset.el new file mode 100644 index 0000000..156c34e --- /dev/null +++ b/mime/mcharset.el @@ -0,0 +1,119 @@ +;;; mcharset.el --- MIME charset API + +;; Copyright (C) 1997,1998,1999 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 'poe) +(require 'pcustom) + +(cond ((featurep 'mule) + (cond ((featurep 'xemacs) + (require 'mcs-xm) + ) + ((>= emacs-major-version 20) + (require 'mcs-e20) + ) + (t + ;; 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 (and (fboundp 'find-coding-system) + (find-coding-system 'utf-8)) + 'utf-8 + default-mime-charset) + "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..aa4743f --- /dev/null +++ b/mime/mcs-20.el @@ -0,0 +1,162 @@ +;;; mcs-20.el --- MIME charset implementation for Emacs 20 and XEmacs/mule + +;; Copyright (C) 1997,1998,1999 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 'poem) +(require 'pcustom) +(eval-when-compile (require 'wid-edit)) + + +;;; @ 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) + )))) + +(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-ctext + "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..00b621e --- /dev/null +++ b/mime/mcs-e20.el @@ -0,0 +1,185 @@ +;;; mcs-e20.el --- MIME charset implementation for Emacs 20.1 and 20.2 + +;; Copyright (C) 1996,1997,1998,1999 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) + (require 'poem) + ) + +(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-maybe coding-system-get (coding-system prop) + "Extract a value from CODING-SYSTEM's property list for property PROP." + (plist-get (coding-system-plist coding-system) prop) + ) + +(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-maybe-cond mime-charset-list () + "Return a list of all existing MIME-charset." + ((boundp 'coding-system-list) + (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)) + (t + (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) + (when (setq cs (or (coding-system-get cs 'mime-charset) + (and + (setq cs (aref + (coding-system-get cs 'coding-spec) + 2)) + (string-match "(MIME:[ \t]*\\([^,)]+\\)" cs) + (match-string 1 cs)))) + (setq cs (intern (downcase cs))) + (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 'mcs-20) + +(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..fa12483 --- /dev/null +++ b/mime/mel-b-ccl.el @@ -0,0 +1,473 @@ +;;; mel-b-ccl.el --- Base64 encoder/decoder using CCL. + +;; Copyright (C) 1998,1999 Tanaka Akira + +;; 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: ") + (insert-file-contents-as-coding-system 'mel-ccl-base64-lf-rev 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: ") + (write-region-as-coding-system 'mel-ccl-b-rev 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..16a37fd --- /dev/null +++ b/mime/mel-g.el @@ -0,0 +1,133 @@ +;;; 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 + (as-binary-process + (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 + (as-binary-process + (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: ") + (as-binary-process + (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..c71fab6 --- /dev/null +++ b/mime/mel-q-ccl.el @@ -0,0 +1,994 @@ +;;; 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: ") + (insert-file-contents-as-coding-system + 'mel-ccl-quoted-printable-lf-lf-rev 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: ") + (write-region-as-coding-system 'mel-ccl-quoted-printable-lf-lf-rev + 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-q.el b/mime/mel-q.el new file mode 100644 index 0000000..44b83c9 --- /dev/null +++ b/mime/mel-q.el @@ -0,0 +1,329 @@ +;;; mel-q.el --- Quoted-Printable encoder/decoder. + +;; Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Created: 1995/6/25 +;; 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 'mime-def) +(require 'path-util) + + +;;; @ Quoted-Printable encoder +;;; + +(defsubst quoted-printable-quote-char (character) + (concat + "=" + (char-to-string (aref quoted-printable-hex-chars (ash character -4))) + (char-to-string (aref quoted-printable-hex-chars (logand character 15))))) + +(defun quoted-printable-internal-encode-region (start end) + (save-excursion + (save-restriction + (narrow-to-region (goto-char start) end) + (let ((col 0) + chr) + (while (not (eobp)) + (cond + ((>= col 75) ; soft line break. + (insert "=\n") + (setq col 0)) + ((eolp) ; end of line. + (forward-char) + (setq col 0)) + (t + (setq chr (char-after (point))) + (cond + ((and (memq chr '(? ?\t)) ; encode WSP char before CRLF. + (eq (char-after (1+ (point))) ?\n)) + (forward-char) + (insert "=\n") + (forward-char) + (setq col 0)) + ((and (bolp) ; "^From " is not safe. + (eq chr ?F) + (eq (char-after (1+ (point))) ?r) + (eq (char-after (+ 2 (point))) ?o) + (eq (char-after (+ 3 (point))) ?m) + (eq (char-after (+ 4 (point))) ? )) + (delete-region (point)(1+ (point))) + (insert "=46") ; moved to ?r. + (forward-char 4) ; skip "rom ". + (setq col 7)) + ((or (= chr ?\t) ; skip safe char. + (and (<= 32 chr)(/= chr ?=)(< chr 127))) + (forward-char) + (setq col (1+ col))) + ((>= col 73) ; soft line break. + (insert "=\n") + (setq col 0)) + (t ; encode unsafe char. + (delete-region (point)(1+ (point))) + ;; (insert (quoted-printable-quote-char chr)) + (insert + ?= + (aref quoted-printable-hex-chars (ash chr -4)) + (aref quoted-printable-hex-chars (logand chr 15))) + (setq col (+ col 3))))))))))) + + +(defvar quoted-printable-external-encoder '("mmencode" "-q") + "*list of quoted-printable encoder program name and its arguments.") + +(defun quoted-printable-external-encode-region (start end) + (save-excursion + (save-restriction + (narrow-to-region start end) + (as-binary-process + (apply (function call-process-region) + start end (car quoted-printable-external-encoder) + t t nil + (cdr quoted-printable-external-encoder))) + ;; for OS/2 + ;; regularize line break code + (goto-char (point-min)) + (while (re-search-forward "\r$" nil t) + (replace-match ""))))) + + +(defvar quoted-printable-internal-encoding-limit + (if (and (featurep 'xemacs)(featurep 'mule)) + 0 + (require 'path-util) + (if (exec-installed-p "mmencode") + 1000 + ;; XXX: Fix this message, or simply remove it. + ;; (message "Don't found external encoder for Quoted-Printable!") + nil)) + "*limit size to use internal quoted-printable encoder. +If size of input to encode is larger than this limit, +external encoder is called.") + +(defun quoted-printable-encode-region (start end) + "Encode current region by quoted-printable. +START and END are buffer positions. +This function calls internal quoted-printable encoder if size of +region is smaller than `quoted-printable-internal-encoding-limit', +otherwise it calls external quoted-printable encoder specified by +`quoted-printable-external-encoder'. In this case, you must install +the program (maybe mmencode included in metamail or XEmacs package)." + (interactive "*r") + (if (and quoted-printable-internal-encoding-limit + (> (- end start) quoted-printable-internal-encoding-limit)) + (quoted-printable-external-encode-region start end) + (quoted-printable-internal-encode-region start end))) + +(defun quoted-printable-encode-string (string) + "Encode STRING to quoted-printable, and return the result." + (with-temp-buffer + (insert string) + (quoted-printable-encode-region (point-min)(point-max)) + (buffer-string))) + + +(mel-define-method-function + (mime-encode-string string (nil "quoted-printable")) + 'quoted-printable-encode-string) + +(mel-define-method-function + (mime-encode-region start end (nil "quoted-printable")) + 'quoted-printable-encode-region) + +(mel-define-method mime-insert-encoded-file (filename (nil "quoted-printable")) + "Encode contents of file FILENAME to quoted-printable, and insert the result. +It calls external quoted-printable encoder specified by +`quoted-printable-external-encoder'. So you must install the program +\(maybe mmencode included in metamail or XEmacs package)." + (interactive "*fInsert encoded file: ") + (apply (function call-process) + (car quoted-printable-external-encoder) + filename t nil + (cdr quoted-printable-external-encoder))) + + +;;; @ Quoted-Printable decoder +;;; + +(defsubst quoted-printable-hex-char-to-num (chr) + (cond ((<= ?a chr) (+ (- chr ?a) 10)) + ((<= ?A chr) (+ (- chr ?A) 10)) + ((<= ?0 chr) (- chr ?0)) + )) + +(defun quoted-printable-internal-decode-region (start end) + (save-excursion + (save-restriction + (narrow-to-region start end) + (goto-char (point-min)) + (while (search-forward "=" nil t) + (cond + ((eolp) + ;; unfold soft line break. + (delete-region (1- (point))(1+ (point)))) + ((and (memq (char-after (point)) + (eval-when-compile + ;; XXX: should provide char-list instead. + (string-to-char-list quoted-printable-hex-chars))) + (memq (char-after (1+ (point))) + (eval-when-compile + ;; XXX: should provide char-list instead. + (string-to-char-list quoted-printable-hex-chars)))) + ;; encoded char. + (insert + (prog1 + (logior + (ash (quoted-printable-hex-char-to-num (char-after (point))) 4) + (quoted-printable-hex-char-to-num (char-after (1+ (point))))) + (delete-region (1- (point))(+ 2 (point)))))) + (t + ;; invalid encoding. + )))))) + +(defvar quoted-printable-external-decoder '("mmencode" "-q" "-u") + "*list of quoted-printable decoder program name and its arguments.") + +(defun quoted-printable-external-decode-region (start end) + (save-excursion + (as-binary-process + (apply (function call-process-region) + start end (car quoted-printable-external-decoder) + t t nil + (cdr quoted-printable-external-decoder))))) + + +(defvar quoted-printable-internal-decoding-limit nil + "*limit size to use internal quoted-printable decoder. +If size of input to decode is larger than this limit, +external decoder is called.") + +(defun quoted-printable-decode-region (start end) + "Decode current region by quoted-printable. +START and END are buffer positions. +This function calls internal quoted-printable decoder if size of +region is smaller than `quoted-printable-internal-decoding-limit', +otherwise it calls external quoted-printable decoder specified by +`quoted-printable-external-decoder'. In this case, you must install +the program (maybe mmencode included in metamail or XEmacs package)." + (interactive "*r") + (if (and quoted-printable-internal-decoding-limit + (> (- end start) quoted-printable-internal-decoding-limit)) + (quoted-printable-external-decode-region start end) + (quoted-printable-internal-decode-region start end))) + +(defun quoted-printable-decode-string (string) + "Decode STRING which is encoded in quoted-printable, and return the result." + (with-temp-buffer + (insert string) + (quoted-printable-decode-region (point-min)(point-max)) + (buffer-string))) + + +(mel-define-method-function + (mime-decode-string string (nil "quoted-printable")) + 'quoted-printable-decode-string) + +(mel-define-method-function + (mime-decode-region start end (nil "quoted-printable")) + 'quoted-printable-decode-region) + + +(defvar quoted-printable-external-decoder-option-to-specify-file '("-o") + "*list of options of quoted-printable decoder program to specify file.") + +(mel-define-method mime-write-decoded-region (start end filename + (nil "quoted-printable")) + "Decode and write current region encoded by quoted-printable into FILENAME. +START and END are buffer positions." + (interactive "*r\nFWrite decoded region to file: ") + (as-binary-process + (apply (function call-process-region) + start end (car quoted-printable-external-decoder) + nil nil nil + (append (cdr quoted-printable-external-decoder) + quoted-printable-external-decoder-option-to-specify-file + (list filename))))) + + +;;; @ Q-encoding encode/decode string +;;; + +(defconst q-encoding-special-chars-alist + '((text ?= ?? ?_) + (comment ?= ?? ?_ ?\( ?\) ?\\) + (phrase ?= ?? ?_ ?\( ?\) ?\\ ?\" ?# ?$ ?% ?& ?' ?, ?. ?/ + ?: ?\; ?< ?> ?@ ?\[ ?\] ?^ ?` ?{ ?| ?} ?~) + )) + +(defun q-encoding-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'." + (let ((specials (cdr (or (assq mode q-encoding-special-chars-alist) + (assq 'phrase q-encoding-special-chars-alist))))) + (mapconcat (function + (lambda (chr) + (cond ((eq chr ? ) "_") + ((or (< chr 32) (< 126 chr) + (memq chr specials)) + (quoted-printable-quote-char chr)) + (t + (char-to-string chr))))) + string ""))) + +(defun q-encoding-decode-string (string) + "Decode STRING which is encoded in Q-encoding and return the result." + (let (q h l) + (mapconcat (function + (lambda (chr) + (cond ((eq chr ?_) " ") + ((eq chr ?=) + (setq q t) + "") + (q (setq h (quoted-printable-hex-char-to-num chr)) + (setq q nil) + "") + (h (setq l (quoted-printable-hex-char-to-num chr)) + (prog1 + (char-to-string (logior (ash h 4) l)) + (setq h nil))) + (t (char-to-string chr))))) + string ""))) + +(mel-define-method-function (encoded-text-encode-string string (nil "Q")) + 'q-encoding-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-decode-string string) + (error "Invalid encoded-text %s" string))) + + +;;; @ end +;;; + +(provide 'mel-q) + +;;; mel-q.el ends here. diff --git a/mime/mel-u.el b/mime/mel-u.el new file mode 100644 index 0000000..49d5733 --- /dev/null +++ b/mime/mel-u.el @@ -0,0 +1,160 @@ +;;; 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 + (as-binary-process + (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 + (as-binary-process + (apply (function call-process-region) + start end (car uuencode-external-decoder) + t nil nil + (cdr uuencode-external-decoder)) + (as-binary-input-file (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 + (as-binary-process + (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..12fff86 --- /dev/null +++ b/mime/mel.el @@ -0,0 +1,270 @@ +;;; mel.el --- A MIME encoding/decoding library. + +;; Copyright (C) 1995,1996,1997,1998,1999 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 'poem) +(require 'alist) +(require 'path-util) + +(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 +;;; + +(mel-define-backend "7bit") +(mel-define-method-function (mime-encode-string string (nil "7bit")) + 'identity) +(mel-define-method-function (mime-decode-string string (nil "7bit")) + 'identity) +(mel-define-method mime-encode-region (start end (nil "7bit"))) +(mel-define-method mime-decode-region (start end (nil "7bit"))) +(mel-define-method-function (mime-insert-encoded-file filename (nil "7bit")) + 'insert-file-contents-as-binary) +(mel-define-method-function (mime-write-decoded-region + start end filename (nil "7bit")) + 'write-region-as-binary) + +(mel-define-backend "8bit" ("7bit")) + +(mel-define-backend "binary" ("8bit")) + +(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) + (insert-file-contents-as-binary 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 (string encoding) + "Encode STRING as encoded-text using ENCODING. ENCODING must be 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-def.el b/mime/mime-def.el new file mode 100644 index 0000000..6c55e6b --- /dev/null +++ b/mime/mime-def.el @@ -0,0 +1,355 @@ +;;; 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 'poe) +(require 'poem) +(require 'pcustom) +(require 'mcharset) +(require 'alist) + +(eval-when-compile + (require 'cl) ; list* + (require 'luna) ; luna-arglist-to-arguments + ) + +(eval-and-compile + (defconst mime-library-product ["Chao" (1 14 1) "Rokujizò"] + "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 +;;; + +(require 'custom) + +(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)) + + +;;; @ required functions +;;; + +(defsubst regexp-* (regexp) + (concat regexp "*")) + +(defsubst regexp-or (&rest args) + (concat "\\(" (mapconcat (function identity) args "\\|") "\\)")) + + +;;; @ 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 primary-type of CONTENT-TYPE." + (cdr (cadr content-type))) + +(defsubst mime-content-type-parameters (content-type) + "Return primary-type 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..cd8b43b --- /dev/null +++ b/mime/mime-edit.el @@ -0,0 +1,3036 @@ +;;; 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 'eword-encode) ; eword-encode-field-body +(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" "winword" 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 nil) + +(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:" + (eword-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." + (eword-encode-header '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") + (eword-encode-header) + (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")) + (eword-encode-header) + ) + (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) + ) + + +;;; @ 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..588d228 --- /dev/null +++ b/mime/mime-image.el @@ -0,0 +1,207 @@ +;;; 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 ((instance + (make-image-instance + (if (and type (mime-image-type-available-p type)) + (vconcat + (list type (if data-p :data :file) file-or-data) + props) + file-or-data) + nil nil 'noerror))) + (if (nothing-image-instance-p instance) nil + (make-glyph instance)))) + + (defun mime-image-insert (image string &optional area) + (let ((extent (make-extent (point) (progn (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 string &optional area) + (insert image))) + (error + (defalias 'mime-image-read-xbm-buffer + 'mime-image-normalize-xbm-buffer) + (defun mime-image-insert (image string &optional 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 "x") + (insert "\n") + (save-window-excursion + (set-window-buffer (selected-window)(current-buffer)) + (sit-for 0)) + (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..4aeb30c --- /dev/null +++ b/mime/mime-parse.el @@ -0,0 +1,357 @@ +;;; 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 '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..e43b872 --- /dev/null +++ b/mime/mime-play.el @@ -0,0 +1,519 @@ +;;; 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.") + + +;;; @ 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 + (mailcap-format-command + method + (cons (cons 'filename name) situation)))) + (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) + (insert-file-contents-as-binary 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) + ) + (as-binary-input-file (insert-file-contents file)) + (goto-char (point-max)) + (setq i (1+ i)) + )) + (write-region-as-binary (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..24678d0 --- /dev/null +++ b/mime/mime-view.el @@ -0,0 +1,1827 @@ +;;; 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 'emu) +(require 'mime) +(require 'semi-def) +(require 'calist) +(require 'alist) +(require 'mailcap) + + +;;; @ 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))) + + +;;; @ 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-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-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.") + +(if (file-readable-p mailcap-file) + (let ((entries (mailcap-parse-file))) + (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)) + ))) + +(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) + ) + (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]) + )) + +(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) + ) + )) + (use-local-map mime-view-mode-map) + (run-hooks 'mime-view-define-keymap-hook) + )) + +(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) + "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." + (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) + (mime-view-define-keymap default-keymap-or-function) + (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) + +(let ((file mime-situation-examples-file)) + (if (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))) + (eval-buffer) + ;; 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)))))) + +;;; mime-view.el ends here diff --git a/mime/mime-w3.el b/mime/mime-w3.el new file mode 100644 index 0000000..ff2aecc --- /dev/null +++ b/mime/mime-w3.el @@ -0,0 +1,84 @@ +;;; 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: + +(require 'w3) +(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..328d599 --- /dev/null +++ b/mime/mime.el @@ -0,0 +1,414 @@ +;;; 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 'eword-encode-header "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.") + +) + +;;; @ 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) + (or (mime-entity-children-internal entity) + (luna-send entity 'mime-entity-children entity))) + +(defun mime-entity-node-id (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) + (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) + (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) + (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) + (mime-content-type-primary-type (mime-entity-content-type entity))) +(defsubst mime-entity-media-subtype (entity) + (mime-content-type-subtype (mime-entity-content-type entity))) +(defsubst mime-entity-parameters (entity) + (mime-content-type-parameters (mime-entity-content-type entity))) +(defsubst mime-entity-type/subtype (entity-info) + (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) + (mime-entity-set-content-type-internal entity content-type)) + +(defun mime-entity-set-encoding (entity encoding) + (mime-entity-set-encoding-internal entity encoding)) + + +;;; @ end +;;; + +(provide 'mime) + +;;; mime.el ends here diff --git a/mime/mmbuffer.el b/mime/mmbuffer.el new file mode 100644 index 0000000..97fc783 --- /dev/null +++ b/mime/mmbuffer.el @@ -0,0 +1,358 @@ +;;; 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)) + (write-region-as-raw-text-CRLF + (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)) + (write-region-as-binary (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) + (with-current-buffer (mime-buffer-entity-buffer-internal 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-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) + (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) + (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/mmdbuffer.el b/mime/mmdbuffer.el new file mode 100644 index 0000000..5a1ae20 --- /dev/null +++ b/mime/mmdbuffer.el @@ -0,0 +1,187 @@ +;;; mmdual.el --- MIME entity module for dual buffers + +;; 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 'mime) + +(eval-and-compile + (luna-define-class mime-dual-entity (mime-entity) + (header-buffer + body-buffer)) + + (luna-define-internal-accessors 'mime-dual-entity) + ) + +(luna-define-method initialize-instance :after ((entity mime-dual-entity) + &rest init-args) + (let ((buf (mime-dual-entity-header-buffer-internal entity))) + (if buf + (with-current-buffer buf + (or (mime-entity-content-type-internal entity) + (mime-entity-set-content-type-internal + entity + (let ((str (std11-fetch-field "Content-Type"))) + (if str + (mime-parse-Content-Type str) + ))))))) + entity) + +(luna-define-method mime-entity-name ((entity mime-dual-entity)) + (buffer-name (mime-dual-entity-header-buffer-internal entity)) + ) + + +(luna-define-method mime-insert-header ((entity mime-dual-entity) + &optional invisible-fields + visible-fields) + (let* ((buf (mime-dual-entity-header-buffer-internal entity)) + header-start header-end) + (with-current-buffer buf + (setq header-start (point-min) + header-end (point-max))) + (mime-insert-header-from-buffer buf header-start header-end + invisible-fields visible-fields) + )) + +(luna-define-method mime-entity-content ((entity mime-dual-entity)) + (mime-decode-string + (with-current-buffer (mime-dual-entity-body-buffer-internal entity) + (buffer-string)) + (mime-entity-encoding entity))) + +(luna-define-method mime-entity-fetch-field :around + ((entity mime-dual-entity) field-name) + (or (luna-call-next-method) + (with-current-buffer (mime-dual-entity-header-buffer-internal entity) + (let ((ret (std11-fetch-field field-name))) + (when ret + (or (symbolp field-name) + (setq field-name + (intern (capitalize (capitalize field-name))))) + (mime-entity-set-original-header-internal + entity + (put-alist field-name ret + (mime-entity-original-header-internal entity))) + ret))))) + +(luna-define-method mime-insert-entity-content ((entity mime-dual-entity)) + (insert + (mime-decode-string + (with-current-buffer (mime-dual-entity-body-buffer-internal entity) + (buffer-substring (point-min)(point-max))) + (mime-entity-encoding entity)))) + +(luna-define-method mime-write-entity-content ((entity mime-dual-entity) + filename) + (with-current-buffer (mime-dual-entity-body-buffer-internal entity) + (mime-write-decoded-region (point-min) + (point-max) + filename + (or (mime-entity-encoding entity) "7bit")))) + +(luna-define-method mime-insert-entity ((entity mime-dual-entity)) + (let (buf) + (setq buf (mime-dual-entity-header-buffer-internal entity)) + (when buf + (insert-buffer (mime-dual-entity-header-buffer-internal entity)) + (setq buf (mime-dual-entity-body-buffer-internal entity)) + (when buf + (insert "\n") + (insert-buffer buf))))) + +(luna-define-method mime-write-entity ((entity mime-dual-entity) filename) + (let (buf) + (setq buf (mime-dual-entity-header-buffer-internal entity)) + (if (null buf) + (error "No header buffer.") + (with-current-buffer buf + (write-region-as-raw-text-CRLF + (point-min)(point-max) filename)) + (setq buf (mime-dual-entity-body-buffer-internal entity)) + (when buf + (with-temp-buffer + (insert "\n") + (write-region-as-raw-text-CRLF + (point-min)(point-max) + filename 'append)) + (with-current-buffer buf + (write-region-as-raw-text-CRLF + (point-min)(point-max) + filename 'append)))))) + +(luna-define-method mime-write-entity-body ((entity mime-dual-entity) filename) + (with-current-buffer (mime-dual-entity-body-buffer-internal entity) + (write-region-as-binary (point-min)(point-max) + filename))) + + +;;; @ buffer +;;; + +(luna-define-method mime-entity-header-buffer ((entity mime-dual-entity)) + (mime-dual-entity-header-buffer-internal entity)) + +(luna-define-method mime-entity-body-buffer ((entity mime-dual-entity)) + (mime-dual-entity-body-buffer-internal entity)) + +(luna-define-method mime-entity-buffer ((entity mime-dual-entity)) + (message "mime-dual-entity does not have mime-entity-buffer.") + nil) + +(luna-define-method mime-entity-body-start-point ((entity mime-dual-entity)) + (with-current-buffer (mime-entity-body-buffer entity) + (point-min))) + +(luna-define-method mime-entity-body-end-point ((entity mime-dual-entity)) + (with-current-buffer (mime-entity-body-buffer entity) + (point-max))) + +(luna-define-method mime-entity-point-min ((entity mime-dual-entity)) + (message "mime-dual-entity does not have mime-entity-point-min.") + nil) + +(luna-define-method mime-entity-point-max ((entity mime-dual-entity)) + (message "mime-dual-entity does not have mime-entity-point-max.") + nil) + +(luna-define-method mime-goto-header-start-point ((entity mime-dual-entity)) + (set-buffer (mime-dual-entity-header-buffer-internal entity)) + (goto-char (point-min))) + +(luna-define-method mime-goto-body-start-point ((entity mime-dual-entity)) + (set-buffer (mime-dual-entity-body-buffer-internal entity)) + (goto-char (point-min))) + +(luna-define-method mime-goto-body-end-point ((entity mime-dual-entity)) + (set-buffer (mime-dual-entity-body-buffer-internal entity)) + (goto-char (point-max))) + + +;;; @ end +;;; + +(provide 'mmdual) + +;;; mmdual.el ends here diff --git a/mime/mmexternal.el b/mime/mmexternal.el new file mode 100644 index 0000000..04e5649 --- /dev/null +++ b/mime/mmexternal.el @@ -0,0 +1,186 @@ +;;; 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 'mime) +(require 'pces) + +(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) + "*")) + (insert-file-contents-as-binary + (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) + (write-region-as-raw-text-CRLF (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) + (write-region-as-binary (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..5bd9686 --- /dev/null +++ b/mime/mmgeneric.el @@ -0,0 +1,174 @@ +;;; 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) + + +;;; @ 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..1227996 --- /dev/null +++ b/mime/pgg-def.el @@ -0,0 +1,75 @@ +;;; pgg-def.el --- functions/macros for defining PGG functions + +;; Copyright (C) 1999 Daiki Ueno + +;; 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 'pcustom) + +(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-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..0a715db --- /dev/null +++ b/mime/pgg-gpg.el @@ -0,0 +1,272 @@ +;;; pgg-gpg.el --- GnuPG support for PGG. + +;; Copyright (C) 1999,2000 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. + +;;; Code: + +(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-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-gpg + :type 'string) + +(defcustom pgg-gpg-shell-command-switch "-c" + "Switch used to have the shell execute its command line argument." + :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-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* ((errors-file-name + (concat temporary-file-directory + (make-temp-name "pgg-errors"))) + (status-file-name + (concat temporary-file-directory + (make-temp-name "pgg-status"))) + (args + (append + `("--status-fd" "3" + ,@(if passphrase '("--passphrase-fd" "0")) + ,@pgg-gpg-extra-args) + args + (list (concat "2>" errors-file-name) + (concat "3>" status-file-name)))) + (shell-file-name pgg-gpg-shell-file-name) + (shell-command-switch pgg-gpg-shell-command-switch) + (output-buffer pgg-output-buffer) + (errors-buffer pgg-errors-buffer) + (status-buffer pgg-status-buffer) + (process-connection-type nil) + process status exit-status) + (with-current-buffer (get-buffer-create output-buffer) + (buffer-disable-undo) + (erase-buffer)) + (unwind-protect + (progn + (as-binary-process + (setq process + (apply #'start-process-shell-command "*GnuPG*" 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) + + (set-buffer (get-buffer-create status-buffer)) + (buffer-disable-undo) + (erase-buffer) + (insert-file-contents status-file-name))) + (if (and process (eq 'run (process-status process))) + (interrupt-process process)) + (condition-case nil + (progn + (delete-file status-file-name) + (delete-file errors-file-name)) + (file-error nil))))) + +(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-current-buffer (get-buffer-create pgg-output-buffer) + (buffer-disable-undo) + (erase-buffer) + (apply #'call-process pgg-gpg-program nil t nil args) + (goto-char (point-min)) + (when (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 #'append + (mapcar (lambda (rcpt) + (list "--remote-user" + (concat "\"" 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 + (pgg-convert-lbt-region (point-min)(point-max) 'LF)))) + +(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) + (pgg-process-when-success nil))) + +(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)) + (pgg-process-when-success + (pgg-convert-lbt-region (point-min)(point-max) 'LF) + (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-gpg) + start end &optional signature) + (let ((args '("--batch" "--verify"))) + (when (stringp signature) + (setq args (append args (list signature)))) + (pgg-gpg-process-region start end nil pgg-gpg-program args) + (save-excursion + (set-buffer pgg-errors-buffer) + (goto-char (point-min)) + (while (re-search-forward "^gpg: " nil t) + (replace-match "")) + (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))))) + (set-buffer pgg-status-buffer) + (goto-char (point-min)) + (if (re-search-forward "^\\[GNUPG:] +GOODSIG +" 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-gpg)) + (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id)) + (args (list "--batch" "--export" "--armor" + (concat "\"" 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-status-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 nil))) + +(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..910b0ff --- /dev/null +++ b/mime/pgg-parse.el @@ -0,0 +1,494 @@ +;;; 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 'poem) +(require 'pccl) +(require 'pcustom) +(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) + `(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) + `(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) + `(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..4b033e5 --- /dev/null +++ b/mime/pgg-pgp.el @@ -0,0 +1,243 @@ +;;; 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: + +(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) + (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 + (as-binary-process + (setq process + (apply #'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) + (write-region-as-binary 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))) + (write-region-as-raw-text-CRLF 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..cde2b6f --- /dev/null +++ b/mime/pgg-pgp5.el @@ -0,0 +1,252 @@ +;;; 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: + +(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) + (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 + (as-binary-process + (setq process + (apply #'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) + (write-region-as-binary 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))) + (write-region-as-raw-text-CRLF 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..6975eef --- /dev/null +++ b/mime/pgg.el @@ -0,0 +1,421 @@ +;;; pgg.el --- glue for the various PGP implementations. + +;; Copyright (C) 1999,2000 Daiki Ueno + +;; 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..f8730bb --- /dev/null +++ b/mime/postpet.el @@ -0,0 +1,152 @@ +;;; 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 '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..483fd1b --- /dev/null +++ b/mime/semi-def.el @@ -0,0 +1,210 @@ +;;; 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: + +(require 'poe) + +(eval-when-compile (require 'cl)) + +(require 'custom) + +(defconst mime-user-interface-product ["REMI" (1 14 3) "Matsudai"] + "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..d01ee0d --- /dev/null +++ b/mime/smime.el @@ -0,0 +1,320 @@ +;;; 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) +(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)) + (as-binary-process + (setq process + (apply #'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) + (write-region-as-binary start end orig-file)) + (set-default-file-modes orig-mode)) + (with-temp-buffer + (insert-file-contents-as-binary signature) + (goto-char (point-max)) + (insert-file-contents-as-binary + (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..982b895 --- /dev/null +++ b/mime/std11.el @@ -0,0 +1,928 @@ +;;; std11.el --- STD 11 functions for GNU Emacs + +;; Copyright (C) 1995,1996,1997,1998,1999 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 'poe) +(require 'poem) ; find-non-ascii-charset-string +(require 'pcustom) ; 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)) + (find-non-ascii-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) + (car (cdr 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/broken.el b/poe/broken.el new file mode 100644 index 0000000..c74eb63 --- /dev/null +++ b/poe/broken.el @@ -0,0 +1,114 @@ +;;; 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) +(require 'poe) + +(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/poe/emu.el b/poe/emu.el new file mode 100644 index 0000000..d610c53 --- /dev/null +++ b/poe/emu.el @@ -0,0 +1,233 @@ +;;; emu.el --- Emulation module for each Emacs variants + +;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Keywords: emulation, compatibility, NEmacs, MULE, Emacs/mule, XEmacs + +;; This file is part of emu. + +;; 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) + +(defvar running-emacs-18 (<= emacs-major-version 18)) +(defvar running-xemacs (featurep 'xemacs)) + +(defvar running-mule-merged-emacs (and (not (boundp 'MULE)) + (not running-xemacs) (featurep 'mule))) +(defvar running-xemacs-with-mule (and running-xemacs (featurep 'mule))) + +(defvar running-emacs-19 (and (not running-xemacs) (= emacs-major-version 19))) +(defvar running-emacs-19_29-or-later + (or (and running-emacs-19 (>= emacs-minor-version 29)) + (and (not running-xemacs)(>= emacs-major-version 20)))) + +(defvar running-xemacs-19 (and running-xemacs + (= emacs-major-version 19))) +(defvar running-xemacs-20-or-later (and running-xemacs + (>= emacs-major-version 20))) +(defvar running-xemacs-19_14-or-later + (or (and running-xemacs-19 (>= emacs-minor-version 14)) + running-xemacs-20-or-later)) + +(cond (running-xemacs + ;; for XEmacs + (defvar mouse-button-1 'button1) + (defvar mouse-button-2 'button2) + (defvar mouse-button-3 'button3) + ) + ((>= emacs-major-version 19) + ;; mouse + (defvar mouse-button-1 [mouse-1]) + (defvar mouse-button-2 [mouse-2]) + (defvar mouse-button-3 [down-mouse-3]) + ) + (t + ;; mouse + (defvar mouse-button-1 nil) + (defvar mouse-button-2 nil) + (defvar mouse-button-3 nil) + )) + +;; for tm-7.106 +(unless (fboundp 'tl:make-overlay) + (defalias 'tl:make-overlay 'make-overlay) + (make-obsolete 'tl:make-overlay 'make-overlay) + ) +(unless (fboundp 'tl:overlay-put) + (defalias 'tl:overlay-put 'overlay-put) + (make-obsolete 'tl:overlay-put 'overlay-put) + ) +(unless (fboundp 'tl:overlay-put) + (defalias 'tl:overlay-buffer 'overlay-buffer) + (make-obsolete 'tl:overlay-buffer 'overlay-buffer) + ) + +(require 'poem) +(require 'mcharset) +(require 'invisible) + +(defsubst char-list-to-string (char-list) + "Convert list of character CHAR-LIST to string." + (apply (function string) char-list)) + +(cond ((featurep 'mule) + (cond ((featurep 'xemacs) ; for XEmacs with MULE + ;; old Mule emulating aliases + + ;;(defalias 'char-leading-char 'char-charset) + + (defun char-category (character) + "Return string of category mnemonics for CHAR in TABLE. +CHAR can be any multilingual character +TABLE defaults to the current buffer's category table." + (mapconcat (lambda (chr) + (char-to-string (int-char chr))) + (char-category-list character) + "")) + ) + ((>= emacs-major-version 20) ; for Emacs 20 + (defalias 'insert-binary-file-contents-literally + 'insert-file-contents-literally) + + ;; old Mule emulating aliases + (defun char-category (character) + "Return string of category mnemonics for CHAR in TABLE. +CHAR can be any multilingual character +TABLE defaults to the current buffer's category table." + (category-set-mnemonics (char-category-set character))) + ) + (t ; for MULE 1.* and 2.* + (require 'emu-mule) + )) + ) + ((boundp 'NEMACS) + ;; for NEmacs and NEpoch + + ;; old MULE emulation + (defconst *noconv* 0) + (defconst *sjis* 1) + (defconst *junet* 2) + (defconst *ctext* 2) + (defconst *internal* 3) + (defconst *euc-japan* 3) + + (defun code-convert-string (str ic oc) + "Convert code in STRING from SOURCE code to TARGET code, +On successful converion, returns the result string, +else returns nil." + (if (not (eq ic oc)) + (convert-string-kanji-code str ic oc) + str)) + + (defun code-convert-region (beg end ic oc) + "Convert code of the text between BEGIN and END from SOURCE +to TARGET. On successful conversion returns t, +else returns nil." + (if (/= ic oc) + (save-excursion + (save-restriction + (narrow-to-region beg end) + (convert-region-kanji-code beg end ic oc))) + )) + ) + (t + ;; for Emacs 19 and XEmacs without MULE + + ;; old MULE emulation + (defconst *internal* nil) + (defconst *ctext* nil) + (defconst *noconv* nil) + + (defun code-convert-string (str ic oc) + "Convert code in STRING from SOURCE code to TARGET code, +On successful converion, returns the result string, +else returns nil. [emu-latin1.el; old MULE emulating function]" + str) + + (defun code-convert-region (beg end ic oc) + "Convert code of the text between BEGIN and END from SOURCE +to TARGET. On successful conversion returns t, +else returns nil. [emu-latin1.el; old MULE emulating function]" + t) + )) + + +;;; @ Mule emulating aliases +;;; +;;; You should not use it. + +(or (boundp '*noconv*) + (defconst *noconv* 'binary + "Coding-system for binary. +This constant is defined to emulate old MULE anything older than MULE 2.3. +It is obsolete, so don't use it.")) + + +;;; @ without code-conversion +;;; + +(defalias 'insert-binary-file-contents 'insert-file-contents-as-binary) +(make-obsolete 'insert-binary-file-contents 'insert-file-contents-as-binary) + +(defun-maybe insert-binary-file-contents-literally (filename + &optional visit + beg end replace) + "Like `insert-file-contents-literally', q.v., but don't code conversion. +A buffer may be modified in several ways after reading into the buffer due +to advanced Emacs features, such as file-name-handlers, format decoding, +find-file-hooks, etc. + This function ensures that none of these modifications will take place." + (as-binary-input-file + ;; Returns list absolute file name and length of data inserted. + (insert-file-contents-literally filename visit beg end replace))) + + +;;; @ for text/richtext and text/enriched +;;; + +(cond ((fboundp 'richtext-decode) + ;; have richtext.el + ) + ((or running-emacs-19_29-or-later running-xemacs-19_14-or-later) + ;; have enriched.el + (autoload 'richtext-decode "richtext") + (or (assq 'text/richtext format-alist) + (setq format-alist + (cons + (cons 'text/richtext + '("Extended MIME text/richtext format." + "Content-[Tt]ype:[ \t]*text/richtext" + richtext-decode richtext-encode t enriched-mode)) + format-alist))) + ) + (t + ;; don't have enriched.el + (autoload 'richtext-decode "tinyrich") + (autoload 'enriched-decode "tinyrich") + )) + + +;;; @ end +;;; + +(require 'product) +(product-provide (provide 'emu) (require 'apel-ver)) + +;;; emu.el ends here diff --git a/poe/inv-19.el b/poe/inv-19.el new file mode 100644 index 0000000..11074bf --- /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/pces-20.el b/poe/pces-20.el new file mode 100644 index 0000000..6531710 --- /dev/null +++ b/poe/pces-20.el @@ -0,0 +1,239 @@ +;;; -*-byte-compile-dynamic: t;-*- +;;; pces-20.el --- pces submodule for Emacs 20 and XEmacs with coding-system + +;; Copyright (C) 1997,1998,1999 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: + +;; (defun-maybe-cond multibyte-string-p (object) +;; "Return t if OBJECT is a multibyte string." +;; ((featurep 'mule) (stringp object)) +;; (t nil)) + + +;;; @ without code-conversion +;;; + +(defmacro as-binary-process (&rest body) + `(let (selective-display ; Disable ^M to nl translation. + (coding-system-for-read 'binary) + (coding-system-for-write 'binary)) + ,@body)) + +(defmacro as-binary-input-file (&rest body) + `(let ((coding-system-for-read 'binary)) + ,@body)) + +(defmacro as-binary-output-file (&rest body) + `(let ((coding-system-for-write 'binary)) + ,@body)) + +(defun write-region-as-binary (start end filename + &optional append visit lockname) + "Like `write-region', q.v., but don't encode." + (let ((coding-system-for-write 'binary) + jka-compr-compression-info-list jam-zcat-filename-list) + (write-region start end filename append visit lockname))) + +(require 'broken) + +(broken-facility insert-file-contents-literally-treats-binary + "Function `insert-file-contents-literally' decodes text." + (let* ((str "\r\n") + (coding-system-for-write 'binary) + (coding-system-for-read 'raw-text-dos) + ;; (default-enable-multibyte-characters (multibyte-string-p str)) + ) + (with-temp-buffer + (insert str) + (write-region (point-min)(point-max) "literal-test-file") + ) + (string= + (with-temp-buffer + (let (file-name-handler-alist) + (insert-file-contents-literally "literal-test-file") + ) + (buffer-string) + ) + str))) + +(broken-facility insert-file-contents-literally-treats-file-name-handler + "Function `insert-file-contents' doesn't call file-name-handler." + (let (called) + (with-temp-buffer + (let ((file-name-handler-alist + '(("literal-test-file" . (lambda (operation &rest args) + (setq called t) + (let (file-name-handler-alist) + (apply operation args) + )))))) + (insert-file-contents-literally "literal-test-file") + ) + (delete-file "literal-test-file") + ) + called)) + +(static-if + (or (broken-p 'insert-file-contents-literally-treats-binary) + (broken-p 'insert-file-contents-literally-treats-file-name-handler)) + (defun insert-file-contents-as-binary (filename + &optional visit beg end replace) + "Like `insert-file-contents', but only reads in the file literally. +A buffer may be modified in several ways after reading into the buffer, +to Emacs features such as format decoding, character code +conversion, find-file-hooks, automatic uncompression, etc. + +This function ensures that none of these modifications will take place." + (let ((format-alist nil) + (after-insert-file-functions nil) + (coding-system-for-read 'binary) + (coding-system-for-write 'binary) + (jka-compr-compression-info-list nil) + (jam-zcat-filename-list nil) + (find-buffer-file-type-function + (if (fboundp 'find-buffer-file-type) + (symbol-function 'find-buffer-file-type) + nil))) + (unwind-protect + (progn + (fset 'find-buffer-file-type (lambda (filename) t)) + (insert-file-contents filename visit beg end replace)) + (if find-buffer-file-type-function + (fset 'find-buffer-file-type find-buffer-file-type-function) + (fmakunbound 'find-buffer-file-type))))) + (defalias 'insert-file-contents-as-binary 'insert-file-contents-literally) + ) + +(defun insert-file-contents-as-raw-text (filename + &optional visit beg end replace) + "Like `insert-file-contents', q.v., but don't code and format conversion. +Like `insert-file-contents-literary', but it allows find-file-hooks, +automatic uncompression, etc. +Like `insert-file-contents-as-binary', but it converts line-break +code." + (let ((coding-system-for-read 'raw-text) + format-alist) + ;; Returns list of absolute file name and length of data inserted. + (insert-file-contents filename visit beg end replace))) + +(defun insert-file-contents-as-raw-text-CRLF (filename + &optional visit beg end replace) + "Like `insert-file-contents', q.v., but don't code and format conversion. +Like `insert-file-contents-literary', but it allows find-file-hooks, +automatic uncompression, etc. +Like `insert-file-contents-as-binary', but it converts line-break code +from CRLF to LF." + (let ((coding-system-for-read 'raw-text-dos) + format-alist) + ;; Returns list of absolute file name and length of data inserted. + (insert-file-contents filename visit beg end replace))) + +(defun write-region-as-raw-text-CRLF (start end filename + &optional append visit lockname) + "Like `write-region', q.v., but write as network representation." + (let ((coding-system-for-write 'raw-text-dos)) + (write-region start end filename append visit lockname))) + +(defun find-file-noselect-as-binary (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 find-file-noselect-as-raw-text (filename &optional nowarn rawfile) + "Like `find-file-noselect', q.v., but it does not code and format conversion +except for line-break code." + (let ((coding-system-for-read 'raw-text) + format-alist) + (find-file-noselect filename nowarn rawfile))) + +(defun find-file-noselect-as-raw-text-CRLF (filename &optional nowarn rawfile) + "Like `find-file-noselect', q.v., but it does not code and format conversion +except for line-break code." + (let ((coding-system-for-read 'raw-text-dos) + format-alist) + (find-file-noselect filename nowarn rawfile))) + +(defun save-buffer-as-binary (&optional args) + "Like `save-buffer', q.v., but don't encode." + (let ((coding-system-for-write 'binary)) + (save-buffer args))) + +(defun save-buffer-as-raw-text-CRLF (&optional args) + "Like `save-buffer', q.v., but save as network representation." + (let ((coding-system-for-write 'raw-text-dos)) + (save-buffer args))) + +(defun open-network-stream-as-binary (name buffer host service) + "Like `open-network-stream', q.v., but don't code conversion." + (let ((coding-system-for-read 'binary) + (coding-system-for-write 'binary)) + (open-network-stream name buffer host service))) + + +;;; @ with code-conversion +;;; + +(defun insert-file-contents-as-coding-system + (coding-system filename &optional visit beg end replace) + "Like `insert-file-contents', q.v., but CODING-SYSTEM the first arg will +be applied to `coding-system-for-read'." + (let ((coding-system-for-read coding-system) + format-alist) + (insert-file-contents filename visit beg end replace))) + +(defun write-region-as-coding-system + (coding-system start end filename &optional append visit lockname) + "Like `write-region', q.v., but CODING-SYSTEM the first arg will be +applied to `coding-system-for-write'." + (let ((coding-system-for-write coding-system) + jka-compr-compression-info-list jam-zcat-filename-list) + (write-region start end filename append visit lockname))) + +(defun find-file-noselect-as-coding-system + (coding-system filename &optional nowarn rawfile) + "Like `find-file-noselect', q.v., but CODING-SYSTEM the first arg will +be applied to `coding-system-for-read'." + (let ((coding-system-for-read coding-system) + format-alist) + (find-file-noselect filename nowarn rawfile))) + +(defun save-buffer-as-coding-system (coding-system &optional args) + "Like `save-buffer', q.v., but CODING-SYSTEM the first arg will be +applied to `coding-system-for-write'." + (let ((coding-system-for-write coding-system)) + (save-buffer args))) + + +;;; @ end +;;; + +(require 'product) +(product-provide (provide 'pces-20) (require 'apel-ver)) + +;;; pces-20.el ends here diff --git a/poe/pces-e20.el b/poe/pces-e20.el new file mode 100644 index 0000000..724f8af --- /dev/null +++ b/poe/pces-e20.el @@ -0,0 +1,48 @@ +;;; pces-e20.el --- pces submodule for Emacs 20 + +;; Copyright (C) 1998,1999 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 'pces-20) + +(unless (and (fboundp 'set-buffer-multibyte) + (subrp (symbol-function 'set-buffer-multibyte))) + (require 'pces-e20_2) ; for Emacs 20.1 and 20.2 + ) + +(defsubst-maybe find-coding-system (obj) + "Return OBJ if it is a coding-system." + (if (coding-system-p obj) + obj)) + +(defalias 'set-process-input-coding-system 'set-process-coding-system) + + +;;; @ end +;;; + +(require 'product) +(product-provide (provide 'pces-e20) (require 'apel-ver)) + +;;; pces-e20.el ends here diff --git a/poe/pces.el b/poe/pces.el new file mode 100644 index 0000000..85bce8c --- /dev/null +++ b/poe/pces.el @@ -0,0 +1,59 @@ +;;; pces.el --- Portable Character Encoding Scheme (coding-system) features + +;; Copyright (C) 1998,1999 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Keywords: coding-system, 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 'poe) + +(eval-and-compile + (unless (fboundp 'open-network-stream) + (require 'tcp))) + +(cond ((featurep 'xemacs) + (if (featurep 'file-coding) + (require 'pces-xfc) + (require 'pces-raw) + )) + ((featurep 'mule) + (if (>= emacs-major-version 20) + (require 'pces-e20) + ;; for MULE 1.* and 2.* + (require 'pces-om) + )) + ((boundp 'NEMACS) + ;; for Nemacs and Nepoch + (require 'pces-nemacs) + ) + (t + (require 'pces-raw) + )) + + +;;; @ end +;;; + +(require 'product) +(product-provide (provide 'pces) (require 'apel-ver)) + +;;; pces.el ends here diff --git a/poe/pcustom.el b/poe/pcustom.el new file mode 100644 index 0000000..4d023f1 --- /dev/null +++ b/poe/pcustom.el @@ -0,0 +1,65 @@ +;;; pcustom.el -- a portable custom.el. + +;; Copyright (C) 1999 Free Software Foundation, Inc. +;; Copyright (C) 1999 Mikio Nakajima + +;; Author: Mikio Nakajima +;; Shuhei KOBAYASHI +;; Keywords: emulating, custom + +;; 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: + +;;; Code: + +(require 'poe) +(eval-when-compile (require 'static)) + +(static-if (condition-case nil + ;; compile-time check. + (if (and (require 'custom) + (fboundp 'custom-declare-variable)) + ;; you have "new custom". + t + ;; you have custom, but it is "old". + (message "\ + ** \"old custom\" is loaded. See README if you want to use \"new custom\".") + (sleep-for 1) + nil) + ;; you don't have custom. + (error nil)) + ;; you have "new custom". no load-time check. + (require 'custom) + ;; your custom is "old custom", + ;; or you don't have custom library at compile-time. + (or (condition-case nil + ;; load-time check. + ;; load "custom" if exists. + (and (require 'custom) + (fboundp 'custom-declare-variable)) + (error nil)) + ;; your custom is "old custom", + ;; or you don't have custom library. + ;; load emulation version of "new custom". + (require 'tinycustom))) + +(require 'product) +(product-provide (provide 'pcustom) (require 'apel-ver)) + +;;; pcustom.el ends here diff --git a/poe/poe.el b/poe/poe.el new file mode 100644 index 0000000..c324dde --- /dev/null +++ b/poe/poe.el @@ -0,0 +1,1673 @@ +;;; poe.el --- Portable Outfit for Emacsen + +;; Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Shuhei KOBAYASHI +;; Keywords: emulation, compatibility, Nemacs, MULE, Emacs/mule, XEmacs + +;; 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: + +;;; Code: + +(require 'product) +(product-provide (provide 'poe) (require 'apel-ver)) + +(require 'pym) + + +;;; @ Version information. +;;; + +(static-when (= emacs-major-version 18) + (require 'poe-18)) + +;; Some ancient version of XEmacs did not provide 'xemacs. +(static-when (string-match "XEmacs" emacs-version) + (provide 'xemacs)) + +;; `file-coding' was appeared in the spring of 1998, just before XEmacs +;; 21.0. Therefore it is not provided in XEmacs with MULE versions 20.4 +;; or earlier. +(static-when (featurep 'xemacs) + ;; must be load-time check to share .elc between w/ MULE and w/o MULE. + (when (featurep 'mule) + (provide 'file-coding))) + +(static-when (featurep 'xemacs) + (require 'poe-xemacs)) + +;; must be load-time check to share .elc between different systems. +(or (fboundp 'open-network-stream) + (require 'tcp)) + + +;;; @ C primitives emulation. +;;; + +;; Emacs 20.3 and earlier: (require FEATURE &optional FILENAME) +;; Emacs 20.4 and later: (require FEATURE &optional FILENAME NOERROR) +(static-condition-case nil + ;; compile-time check. + (progn + (require 'nofeature "nofile" 'noerror) + (if (get 'require 'defun-maybe) + (error "`require' is already redefined"))) + (error + ;; load-time check. + (or (fboundp 'si:require) + (progn + (fset 'si:require (symbol-function 'require)) + (put 'require 'defun-maybe t) + (defun require (feature &optional filename noerror) + "\ +If feature FEATURE is not loaded, load it from FILENAME. +If FEATURE is not a member of the list `features', then the feature +is not loaded; so load the file FILENAME. +If FILENAME is omitted, the printname of FEATURE is used as the file name, +but in this case `load' insists on adding the suffix `.el' or `.elc'. +If the optional third argument NOERROR is non-nil, +then return nil if the file is not found. +Normally the return value is FEATURE." + (if noerror + (condition-case nil + (si:require feature filename) + (file-error)) + (si:require feature filename))))))) + +;; Emacs 19.29 and later: (plist-get PLIST PROP) +;; (defun-maybe plist-get (plist prop) +;; (while (and plist +;; (not (eq (car plist) prop))) +;; (setq plist (cdr (cdr plist)))) +;; (car (cdr plist))) +(static-unless (and (fboundp 'plist-get) + (not (get 'plist-get 'defun-maybe))) + (or (fboundp 'plist-get) + (progn + (defvar plist-get-internal-symbol) + (defun plist-get (plist prop) + "\ +Extract a value from a property list. +PLIST is a property list, which is a list of the form +\(PROP1 VALUE1 PROP2 VALUE2...\). This function returns the value +corresponding to the given PROP, or nil if PROP is not +one of the properties on the list." + (setplist 'plist-get-internal-symbol plist) + (get 'plist-get-internal-symbol prop)) + ;; for `load-history'. + (setq current-load-list (cons 'plist-get current-load-list)) + (put 'plist-get 'defun-maybe t)))) + +;; Emacs 19.29 and later: (plist-put PLIST PROP VAL) +;; (defun-maybe plist-put (plist prop val) +;; (catch 'found +;; (let ((tail plist) +;; (prev nil)) +;; (while (and tail (cdr tail)) +;; (if (eq (car tail) prop) +;; (progn +;; (setcar (cdr tail) val) +;; (throw 'found plist)) +;; (setq prev tail +;; tail (cdr (cdr tail))))) +;; (if prev +;; (progn +;; (setcdr (cdr prev) (list prop val)) +;; plist) +;; (list prop val))))) +(static-unless (and (fboundp 'plist-put) + (not (get 'plist-put 'defun-maybe))) + (or (fboundp 'plist-put) + (progn + (defvar plist-put-internal-symbol) + (defun plist-put (plist prop val) + "\ +Change value in PLIST of PROP to VAL. +PLIST is a property list, which is a list of the form +\(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol and VAL is any object. +If PROP is already a property on the list, its value is set to VAL, +otherwise the new PROP VAL pair is added. The new plist is returned; +use `\(setq x \(plist-put x prop val\)\)' to be sure to use the new value. +The PLIST is modified by side effects." + (setplist 'plist-put-internal-symbol plist) + (put 'plist-put-internal-symbol prop val) + (symbol-plist 'plist-put-internal-symbol)) + ;; for `load-history'. + (setq current-load-list (cons 'plist-put current-load-list)) + (put 'plist-put 'defun-maybe t)))) + +;; Emacs 19.23 and later: (minibuffer-prompt-width) +(defun-maybe minibuffer-prompt-width () + "Return the display width of the minibuffer prompt." + (save-excursion + (set-buffer (window-buffer (minibuffer-window))) + (current-column))) + +;; (read-string PROMPT &optional INITIAL-INPUT HISTORY) +;; Emacs 19.29/XEmacs 19.14(?) and later takes optional 3rd arg HISTORY. +(static-unless (or (featurep 'xemacs) + (>= emacs-major-version 20) + (and (= emacs-major-version 19) + (>= emacs-minor-version 29))) + (or (fboundp 'si:read-string) + (progn + (fset 'si:read-string (symbol-function 'read-string)) + (defun read-string (prompt &optional initial-input history) + "\ +Read a string from the minibuffer, prompting with string PROMPT. +If non-nil, second arg INITIAL-INPUT is a string to insert before reading. +The third arg HISTORY, is dummy for compatibility. +See `read-from-minibuffer' for details of HISTORY argument." + (si:read-string prompt initial-input))))) + +;; (completing-read prompt table &optional +;; FSF Emacs +;; --19.7 : predicate require-match init +;; 19.7 --19.34 : predicate require-match init hist +;; 20.1 -- : predicate require-match init hist def inherit-input-method +;; XEmacs +;; --19.(?): predicate require-match init +;; --21.2 : predicate require-match init hist +;; 21.2 -- : predicate require-match init hist def +;; ) + +;; We support following API. +;; (completing-read prompt table +;; &optional predicate require-match init hist def) +(static-cond + ;; add 'hist' and 'def' argument. + ((< emacs-major-version 19) + (or (fboundp 'si:completing-read) + (progn + (fset 'si:completing-read (symbol-function 'completing-read)) + (defun completing-read + (prompt table &optional predicate require-match init + hist def) + "Read a string in the minibuffer, with completion. +PROMPT is a string to prompt with; normally it ends in a colon and a space. +TABLE is an alist whose elements' cars are strings, or an obarray. +PREDICATE limits completion to a subset of TABLE. +See `try-completion' and `all-completions' for more details + on completion, TABLE, and PREDICATE. + +If REQUIRE-MATCH is non-nil, the user is not allowed to exit unless + the input is (or completes to) an element of TABLE or is null. + If it is also not t, Return does not exit if it does non-null completion. +If the input is null, `completing-read' returns an empty string, + regardless of the value of REQUIRE-MATCH. + +If INIT is non-nil, insert it in the minibuffer initially. + If it is (STRING . POSITION), the initial input + is STRING, but point is placed POSITION characters into the string. +HIST is ignored in this implementation. +DEF, if non-nil, is the default value. + +Completion ignores case if the ambient value of + `completion-ignore-case' is non-nil." + (let ((string (si:completing-read prompt table predicate + require-match init))) + (if (and (string= string "") def) + def string)))))) + ;; add 'def' argument. + ((or (and (featurep 'xemacs) + (or (and (eq emacs-major-version 21) + (< emacs-minor-version 2)) + (< emacs-major-version 21))) + (< emacs-major-version 20)) + (or (fboundp 'si:completing-read) + (progn + (fset 'si:completing-read (symbol-function 'completing-read)) + (defun completing-read + (prompt table &optional predicate require-match init + hist def) + "Read a string in the minibuffer, with completion. +PROMPT is a string to prompt with; normally it ends in a colon and a space. +TABLE is an alist whose elements' cars are strings, or an obarray. +PREDICATE limits completion to a subset of TABLE. +See `try-completion' and `all-completions' for more details + on completion, TABLE, and PREDICATE. + +If REQUIRE-MATCH is non-nil, the user is not allowed to exit unless + the input is (or completes to) an element of TABLE or is null. + If it is also not t, Return does not exit if it does non-null completion. +If the input is null, `completing-read' returns an empty string, + regardless of the value of REQUIRE-MATCH. + +If INIT is non-nil, insert it in the minibuffer initially. + If it is (STRING . POSITION), the initial input + is STRING, but point is placed POSITION characters into the string. +HIST, if non-nil, specifies a history list + and optionally the initial position in the list. + It can be a symbol, which is the history list variable to use, + or it can be a cons cell (HISTVAR . HISTPOS). + In that case, HISTVAR is the history list variable to use, + and HISTPOS is the initial position (the position in the list + which INIT corresponds to). + Positions are counted starting from 1 at the beginning of the list. +DEF, if non-nil, is the default value. + +Completion ignores case if the ambient value of + `completion-ignore-case' is non-nil." + (let ((string (si:completing-read prompt table predicate + require-match init hist))) + (if (and (string= string "") def) + def string))))))) + +;; v18: (string-to-int STRING) +;; v19: (string-to-number STRING) +;; v20: (string-to-number STRING &optional BASE) +;; +;; XXX: `string-to-number' of Emacs 20.3 and earlier is broken. +;; (string-to-number "1e1" 16) => 10.0, should be 481. +(static-condition-case nil + ;; compile-time check. + (if (= (string-to-number "1e1" 16) 481) + (if (get 'string-to-number 'defun-maybe) + (error "`string-to-number' is already redefined")) + (error "`string-to-number' is broken")) + (error + ;; load-time check. + (or (fboundp 'si:string-to-number) + (progn + (if (fboundp 'string-to-number) + (fset 'si:string-to-number (symbol-function 'string-to-number)) + (fset 'si:string-to-number (symbol-function 'string-to-int)) + ;; XXX: In v18, this causes infinite loop while bytecompiling. + ;; (defalias 'string-to-int 'string-to-number) + ) + (put 'string-to-number 'defun-maybe t) + (defun string-to-number (string &optional base) + "\ +Convert STRING to a number by parsing it as a decimal number. +This parses both integers and floating point numbers. +It ignores leading spaces and tabs. + +If BASE, interpret STRING as a number in that base. If BASE isn't +present, base 10 is used. BASE must be between 2 and 16 (inclusive). +If the base used is not 10, floating point is not recognized." + (if (or (null base) (= base 10)) + (si:string-to-number string) + (if (or (< base 2)(> base 16)) + (signal 'args-out-of-range (cons base nil))) + (let ((len (length string)) + (pos 0)) + ;; skip leading whitespace. + (while (and (< pos len) + (memq (aref string pos) '(?\ ?\t))) + (setq pos (1+ pos))) + (if (= pos len) + 0 + (let ((number 0)(negative 1) + chr num) + (if (eq (aref string pos) ?-) + (setq negative -1 + pos (1+ pos)) + (if (eq (aref string pos) ?+) + (setq pos (1+ pos)))) + (while (and (< pos len) + (setq chr (aref string pos) + num (cond + ((and (<= ?0 chr)(<= chr ?9)) + (- chr ?0)) + ((and (<= ?A chr)(<= chr ?F)) + (+ (- chr ?A) 10)) + ((and (<= ?a chr)(<= chr ?f)) + (+ (- chr ?a) 10)) + (t nil))) + (< num base)) + (setq number (+ (* number base) num) + pos (1+ pos))) + (* negative number)))))))))) + +;; Emacs 20.1 and 20.2: (concat-chars &rest CHARS) +;; Emacs 20.3/XEmacs 21.0 and later: (string &rest CHARS) +(static-cond + ((and (fboundp 'string) + (subrp (symbol-function 'string))) + ;; Emacs 20.3/XEmacs 21.0 and later. + ) + ((and (fboundp 'concat-chars) + (subrp (symbol-function 'concat-chars))) + ;; Emacs 20.1 and 20.2. + (defalias 'string 'concat-chars)) + (t + ;; Use `defun-maybe' to update `load-history'. + (defun-maybe string (&rest chars) + "Concatenate all the argument characters and make the result a string." + ;; We cannot use (apply 'concat chars) here because `concat' does not + ;; work with multibyte chars on Mule 1.* and 2.*. + (mapconcat (function char-to-string) chars "")))) + +;; Mule: (char-before POS) +;; v20: (char-before &optional POS) +(static-condition-case nil + ;; compile-time check. + (progn + (char-before) + (if (get 'char-before 'defun-maybe) + (error "`char-before' is already defined"))) + (wrong-number-of-arguments ; Mule. + ;; load-time check. + (or (fboundp 'si:char-before) + (progn + (fset 'si:char-before (symbol-function 'char-before)) + (put 'char-before 'defun-maybe t) + ;; takes IGNORED for backward compatibility. + (defun char-before (&optional pos ignored) + "\ +Return character in current buffer preceding position POS. +POS is an integer or a buffer pointer. +If POS is out of range, the value is nil." + (si:char-before (or pos (point))))))) + (void-function ; non-Mule. + ;; load-time check. + (defun-maybe char-before (&optional pos) + "\ +Return character in current buffer preceding position POS. +POS is an integer or a buffer pointer. +If POS is out of range, the value is nil." + (if pos + (save-excursion + (and (= (goto-char pos) (point)) + (not (bobp)) + (preceding-char))) + (and (not (bobp)) + (preceding-char))))) + (error ; found our definition at compile-time. + ;; load-time check. + (condition-case nil + (char-before) + (wrong-number-of-arguments ; Mule. + (or (fboundp 'si:char-before) + (progn + (fset 'si:char-before (symbol-function 'char-before)) + (put 'char-before 'defun-maybe t) + ;; takes IGNORED for backward compatibility. + (defun char-before (&optional pos ignored) + "\ +Return character in current buffer preceding position POS. +POS is an integer or a buffer pointer. +If POS is out of range, the value is nil." + (si:char-before (or pos (point))))))) + (void-function ; non-Mule. + (defun-maybe char-before (&optional pos) + "\ +Return character in current buffer preceding position POS. +POS is an integer or a buffer pointer. +If POS is out of range, the value is nil." + (if pos + (save-excursion + (and (= (goto-char pos) (point)) + (not (bobp)) + (preceding-char))) + (and (not (bobp)) + (preceding-char)))))))) + +;; v18, v19: (char-after POS) +;; v20: (char-after &optional POS) +(static-condition-case nil + ;; compile-time check. + (progn + (char-after) + (if (get 'char-after 'defun-maybe) + (error "`char-after' is already redefined"))) + (wrong-number-of-arguments ; v18, v19 + ;; load-time check. + (or (fboundp 'si:char-after) + (progn + (fset 'si:char-after (symbol-function 'char-after)) + (put 'char-after 'defun-maybe t) + (defun char-after (&optional pos) + "\ +Return character in current buffer at position POS. +POS is an integer or a buffer pointer. +If POS is out of range, the value is nil." + (si:char-after (or pos (point))))))) + (void-function ; NEVER happen? + ;; load-time check. + (defun-maybe char-after (&optional pos) + "\ +Return character in current buffer at position POS. +POS is an integer or a buffer pointer. +If POS is out of range, the value is nil." + (if pos + (save-excursion + (and (= (goto-char pos) (point)) + (not (eobp)) + (following-char))) + (and (not (eobp)) + (following-char))))) + (error ; found our definition at compile-time. + ;; load-time check. + (condition-case nil + (char-after) + (wrong-number-of-arguments ; v18, v19 + (or (fboundp 'si:char-after) + (progn + (fset 'si:char-after (symbol-function 'char-after)) + (put 'char-after 'defun-maybe t) + (defun char-after (&optional pos) + "\ +Return character in current buffer at position POS. +POS is an integer or a buffer pointer. +If POS is out of range, the value is nil." + (si:char-after (or pos (point))))))) + (void-function ; NEVER happen? + (defun-maybe char-after (&optional pos) + "\ +Return character in current buffer at position POS. +POS is an integer or a buffer pointer. +If POS is out of range, the value is nil." + (if pos + (save-excursion + (and (= (goto-char pos) (point)) + (not (eobp)) + (following-char))) + (and (not (eobp)) + (following-char)))))))) + +;; Emacs 19.29 and later: (buffer-substring-no-properties START END) +(defun-maybe buffer-substring-no-properties (start end) + "Return the characters of part of the buffer, without the text properties. +The two arguments START and END are character positions; +they can be in either order." + (let ((string (buffer-substring start end))) + (set-text-properties 0 (length string) nil string) + string)) + +;; Emacs 19.31 and later: (buffer-live-p OBJECT) +(defun-maybe buffer-live-p (object) + "Return non-nil if OBJECT is a buffer which has not been killed. +Value is nil if OBJECT is not a buffer or if it has been killed." + (and object + (get-buffer object) + (buffer-name (get-buffer object)) + t)) + +;; Emacs 20: (line-beginning-position &optional N) +(defun-maybe line-beginning-position (&optional n) + "Return the character position of the first character on the current line. +With argument N not nil or 1, move forward N - 1 lines first. +If scan reaches end of buffer, return that position. +This function does not move point." + (save-excursion + (forward-line (1- (or n 1))) + (point))) + +;; Emacs 20: (line-end-position &optional N) +(defun-maybe line-end-position (&optional n) + "Return the character position of the last character on the current line. +With argument N not nil or 1, move forward N - 1 lines first. +If scan reaches end of buffer, return that position. +This function does not move point." + (save-excursion + (end-of-line (or n 1)) + (point))) + +;; FSF Emacs 19.29 and later +;; (read-file-name PROMPT &optional DIR DEFAULT-FILENAME MUSTMATCH INITIAL) +;; XEmacs 19.14 and later: +;; (read-file-name (PROMPT &optional DIR DEFAULT MUST-MATCH INITIAL-CONTENTS +;; HISTORY) + +;; In FSF Emacs 19.28 and earlier (except for v18) or XEmacs 19.13 and +;; earlier, this function is incompatible with the other Emacsen. +;; For instance, if DEFAULT-FILENAME is nil, INITIAL is not and user +;; enters a null string, it returns the visited file name of the current +;; buffer if it is non-nil. + +;; It does not assimilate the different numbers of the optional arguments +;; on various Emacsen (yet). +(static-cond + ((and (not (featurep 'xemacs)) + (eq emacs-major-version 19) + (< emacs-minor-version 29)) + (if (fboundp 'si:read-file-name) + nil + (fset 'si:read-file-name (symbol-function 'read-file-name)) + (defun read-file-name (prompt &optional dir default-filename mustmatch + initial) + "Read file name, prompting with PROMPT and completing in directory DIR. +Value is not expanded---you must call `expand-file-name' yourself. +Default name to DEFAULT-FILENAME if user enters a null string. + (If DEFAULT-FILENAME is omitted, the visited file name is used, + except that if INITIAL is specified, that combined with DIR is used.) +Fourth arg MUSTMATCH non-nil means require existing file's name. + Non-nil and non-t means also require confirmation after completion. +Fifth arg INITIAL specifies text to start with. +DIR defaults to current buffer's directory default." + (si:read-file-name prompt dir + (or default-filename + (if initial + (expand-file-name initial dir))) + mustmatch initial)))) + ((and (featurep 'xemacs) + (eq emacs-major-version 19) + (< emacs-minor-version 14)) + (if (fboundp 'si:read-file-name) + nil + (fset 'si:read-file-name (symbol-function 'read-file-name)) + (defun read-file-name (prompt &optional dir default must-match + initial-contents history) + "Read file name, prompting with PROMPT and completing in directory DIR. +This will prompt with a dialog box if appropriate, according to + `should-use-dialog-box-p'. +Value is not expanded---you must call `expand-file-name' yourself. +Value is subject to interpreted by substitute-in-file-name however. +Default name to DEFAULT if user enters a null string. + (If DEFAULT is omitted, the visited file name is used, + except that if INITIAL-CONTENTS is specified, that combined with DIR is + used.) +Fourth arg MUST-MATCH non-nil means require existing file's name. + Non-nil and non-t means also require confirmation after completion. +Fifth arg INITIAL-CONTENTS specifies text to start with. +Sixth arg HISTORY specifies the history list to use. Default is + `file-name-history'. +DIR defaults to current buffer's directory default." + (si:read-file-name prompt dir + (or default + (if initial-contents + (expand-file-name initial-contents dir))) + must-match initial-contents history))))) + + +;;; @ Basic lisp subroutines emulation. (lisp/subr.el) +;;; + +;;; @@ Lisp language features. + +(defmacro-maybe push (newelt listname) + "Add NEWELT to the list stored in the symbol LISTNAME. +This is equivalent to (setq LISTNAME (cons NEWELT LISTNAME)). +LISTNAME must be a symbol." + (list 'setq listname + (list 'cons newelt listname))) + +(defmacro-maybe pop (listname) + "Return the first element of LISTNAME's value, and remove it from the list. +LISTNAME must be a symbol whose value is a list. +If the value is nil, `pop' returns nil but does not actually +change the list." + (list 'prog1 (list 'car listname) + (list 'setq listname (list 'cdr listname)))) + +(defmacro-maybe when (cond &rest body) + "If COND yields non-nil, do BODY, else return nil." + (list 'if cond (cons 'progn body))) +;; (def-edebug-spec when (&rest form)) + +(defmacro-maybe unless (cond &rest body) + "If COND yields nil, do BODY, else return nil." + (cons 'if (cons cond (cons nil body)))) +;; (def-edebug-spec unless (&rest form)) + +(defsubst-maybe caar (x) + "Return the car of the car of X." + (car (car x))) + +(defsubst-maybe cadr (x) + "Return the car of the cdr of X." + (car (cdr x))) + +(defsubst-maybe cdar (x) + "Return the cdr of the car of X." + (cdr (car x))) + +(defsubst-maybe cddr (x) + "Return the cdr of the cdr of X." + (cdr (cdr x))) + +(defun-maybe last (x &optional n) + "Return the last link of the list X. Its car is the last element. +If X is nil, return nil. +If N is non-nil, return the Nth-to-last link of X. +If N is bigger than the length of X, return X." + (if n + (let ((m 0) (p x)) + (while (consp p) + (setq m (1+ m) p (cdr p))) + (if (<= n 0) p + (if (< n m) (nthcdr (- m n) x) x))) + (while (cdr x) + (setq x (cdr x))) + x)) + +;; Actually, `butlast' and `nbutlast' are defined in lisp/cl.el. +(defun-maybe butlast (x &optional n) + "Returns a copy of LIST with the last N elements removed." + (if (and n (<= n 0)) x + (nbutlast (copy-sequence x) n))) + +(defun-maybe nbutlast (x &optional n) + "Modifies LIST to remove the last N elements." + (let ((m (length x))) + (or n (setq n 1)) + (and (< n m) + (progn + (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil)) + x)))) + +;; Emacs 20.3 and later: (assoc-default KEY ALIST &optional TEST DEFAULT) +(defun-maybe assoc-default (key alist &optional test default) + "Find object KEY in a pseudo-alist ALIST. +ALIST is a list of conses or objects. Each element (or the element's car, +if it is a cons) is compared with KEY by evaluating (TEST (car elt) KEY). +If that is non-nil, the element matches; +then `assoc-default' returns the element's cdr, if it is a cons, +or DEFAULT if the element is not a cons. + +If no element matches, the value is nil. +If TEST is omitted or nil, `equal' is used." + (let (found (tail alist) value) + (while (and tail (not found)) + (let ((elt (car tail))) + (when (funcall (or test 'equal) (if (consp elt) (car elt) elt) key) + (setq found t value (if (consp elt) (cdr elt) default)))) + (setq tail (cdr tail))) + value)) + +;; The following two function use `compare-strings', which we don't +;; support yet. +;; (defun assoc-ignore-case (key alist)) +;; (defun assoc-ignore-representation (key alist)) + +;; Emacs 19.29/XEmacs 19.13 and later: (rassoc KEY LIST) +;; Actually, `rassoc' is defined in src/fns.c. +(defun-maybe rassoc (key list) + "Return non-nil if KEY is `equal' to the cdr of an element of LIST. +The value is actually the element of LIST whose cdr equals KEY. +Elements of LIST that are not conses are ignored." + (catch 'found + (while list + (cond ((not (consp (car list)))) + ((equal (cdr (car list)) key) + (throw 'found (car list)))) + (setq list (cdr list))))) + +;; XEmacs 19.13 and later: (remassq KEY LIST) +(defun-maybe remassq (key list) + "Delete by side effect any elements of LIST whose car is `eq' to KEY. +The modified LIST is returned. If the first member of LIST has a car +that is `eq' to KEY, there is no way to remove it by side effect; +therefore, write `(setq foo (remassq key foo))' to be sure of changing +the value of `foo'." + (if (setq key (assq key list)) + (delq key list) + list)) + +;; XEmacs 19.13 and later: (remassoc KEY LIST) +(defun-maybe remassoc (key list) + "Delete by side effect any elements of LIST whose car is `equal' to KEY. +The modified LIST is returned. If the first member of LIST has a car +that is `equal' to KEY, there is no way to remove it by side effect; +therefore, write `(setq foo (remassoc key foo))' to be sure of changing +the value of `foo'." + (if (setq key (assoc key list)) + (delq key list) + list)) + +;; XEmacs 19.13 and later: (remrassq VALUE LIST) +(defun-maybe remrassq (value list) + "Delete by side effect any elements of LIST whose cdr is `eq' to VALUE. +The modified LIST is returned. If the first member of LIST has a car +that is `eq' to VALUE, there is no way to remove it by side effect; +therefore, write `(setq foo (remrassq value foo))' to be sure of changing +the value of `foo'." + (if (setq value (rassq value list)) + (delq value list) + list)) + +;; XEmacs 19.13 and later: (remrassoc VALUE LIST) +(defun-maybe remrassoc (value list) + "Delete by side effect any elements of LIST whose cdr is `equal' to VALUE. +The modified LIST is returned. If the first member of LIST has a car +that is `equal' to VALUE, there is no way to remove it by side effect; +therefore, write `(setq foo (remrassoc value foo))' to be sure of changing +the value of `foo'." + (if (setq value (rassoc value list)) + (delq value list) + list)) + +;;; Define `functionp' here because "localhook" uses it. + +;; Emacs 20.1/XEmacs 20.3 (but first appeared in Epoch?): (functionp OBJECT) +(defun-maybe 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)))) + +;;; @@ Hook manipulation functions. + +;; "localhook" package is written for Emacs 19.28 and earlier. +;; `run-hooks' was a lisp function in Emacs 19.29 and earlier. +;; So, in Emacs 19.29, `run-hooks' and others will be overrided. +;; But, who cares it? +(static-unless (subrp (symbol-function 'run-hooks)) + (require 'localhook)) + +;; Emacs 19.29/XEmacs 19.14(?) and later: (add-to-list LIST-VAR ELEMENT) +(defun-maybe add-to-list (list-var element) + "Add to the value of LIST-VAR the element ELEMENT if it isn't there yet. +The test for presence of ELEMENT is done with `equal'. +If you want to use `add-to-list' on a variable that is not defined +until a certain package is loaded, you should put the call to `add-to-list' +into a hook function that will be run only after loading the package. +`eval-after-load' provides one way to do this. In some cases +other hooks, such as major mode hooks, can do the job." + (or (member element (symbol-value list-var)) + (set list-var (cons element (symbol-value list-var))))) + +;; (eval-after-load FILE FORM) +;; Emacs 19.28 and earlier do not evaluate FORM if FILE is already loaded. +;; XEmacs 20.2 and earlier have `after-load-alist', but refuse to support +;; `eval-after-load'. (see comments in XEmacs/lisp/subr.el.) +(static-cond + ((featurep 'xemacs) + ;; for XEmacs 20.2 and earlier. + (defun-maybe eval-after-load (file form) + "Arrange that, if FILE is ever loaded, FORM will be run at that time. +This makes or adds to an entry on `after-load-alist'. +If FILE is already loaded, evaluate FORM right now. +It does nothing if FORM is already on the list for FILE. +FILE should be the name of a library, with no directory name." + ;; Make sure there is an element for FILE. + (or (assoc file after-load-alist) + (setq after-load-alist (cons (list file) after-load-alist))) + ;; Add FORM to the element if it isn't there. + (let ((elt (assoc file after-load-alist))) + (or (member form (cdr elt)) + (progn + (nconc elt (list form)) + ;; If the file has been loaded already, run FORM right away. + (and (assoc file load-history) + (eval form))))) + form)) + ((>= emacs-major-version 20)) + ((and (= emacs-major-version 19) + (< emacs-minor-version 29)) + ;; for Emacs 19.28 and earlier. + (defun eval-after-load (file form) + "Arrange that, if FILE is ever loaded, FORM will be run at that time. +This makes or adds to an entry on `after-load-alist'. +If FILE is already loaded, evaluate FORM right now. +It does nothing if FORM is already on the list for FILE. +FILE should be the name of a library, with no directory name." + ;; Make sure there is an element for FILE. + (or (assoc file after-load-alist) + (setq after-load-alist (cons (list file) after-load-alist))) + ;; Add FORM to the element if it isn't there. + (let ((elt (assoc file after-load-alist))) + (or (member form (cdr elt)) + (progn + (nconc elt (list form)) + ;; If the file has been loaded already, run FORM right away. + (and (assoc file load-history) + (eval form))))) + form)) + (t + ;; should emulate for v18? + )) + +(defun-maybe eval-next-after-load (file) + "Read the following input sexp, and run it whenever FILE is loaded. +This makes or adds to an entry on `after-load-alist'. +FILE should be the name of a library, with no directory name." + (eval-after-load file (read))) + +;;; @@ Input and display facilities. + +;; XXX: (defun read-passwd (prompt &optional confirm default)) + +;;; @@ Miscellanea. + +;; Avoid compiler warnings about this variable, +;; which has a special meaning on certain system types. +(defvar-maybe buffer-file-type nil + "Non-nil if the visited file is a binary file. +This variable is meaningful on MS-DOG and Windows NT. +On those systems, it is automatically local in every buffer. +On other systems, this variable is normally always nil.") + +;; Emacs 20.1/XEmacs 20.3(?) and later: (save-current-buffer &rest BODY) +;; +;; v20 defines `save-current-buffer' as a C primitive (in src/editfns.c) +;; and introduces a new bytecode Bsave_current_buffer(_1), replacing an +;; obsolete bytecode Bread_char. To make things worse, Emacs 20.1 and +;; 20.2 have a bug that it will restore the current buffer without +;; confirming that it is alive. +;; +;; This is a source of incompatibility of .elc between v18/v19 and v20. +;; (XEmacs compiler takes care of it if compatibility mode is enabled.) +(defmacro-maybe save-current-buffer (&rest body) + "Save the current buffer; execute BODY; restore the current buffer. +Executes BODY just like `progn'." + (` (let ((orig-buffer (current-buffer))) + (unwind-protect + (progn (,@ body)) + (if (buffer-live-p orig-buffer) + (set-buffer orig-buffer)))))) + +;; Emacs 20.1/XEmacs 20.3(?) and later: (with-current-buffer BUFFER &rest BODY) +(defmacro-maybe with-current-buffer (buffer &rest body) + "Execute the forms in BODY with BUFFER as the current buffer. +The value returned is the value of the last form in BODY. +See also `with-temp-buffer'." + (` (save-current-buffer + (set-buffer (, buffer)) + (,@ body)))) + +;; Emacs 20.1/XEmacs 20.3(?) and later: (with-temp-file FILE &rest FORMS) +(defmacro-maybe with-temp-file (file &rest forms) + "Create a new buffer, evaluate FORMS there, and write the buffer to FILE. +The value of the last form in FORMS is returned, like `progn'. +See also `with-temp-buffer'." + (let ((temp-file (make-symbol "temp-file")) + (temp-buffer (make-symbol "temp-buffer"))) + (` (let (((, temp-file) (, file)) + ((, temp-buffer) + (get-buffer-create (generate-new-buffer-name " *temp file*")))) + (unwind-protect + (prog1 + (with-current-buffer (, temp-buffer) + (,@ forms)) + (with-current-buffer (, temp-buffer) + (widen) + (write-region (point-min) (point-max) (, temp-file) nil 0))) + (and (buffer-name (, temp-buffer)) + (kill-buffer (, temp-buffer)))))))) + +;; Emacs 20.4 and later: (with-temp-message MESSAGE &rest BODY) +;; This macro uses `current-message', which appears in v20. +(static-when (and (fboundp 'current-message) + (subrp (symbol-function 'current-message))) + (defmacro-maybe with-temp-message (message &rest body) + "\ +Display MESSAGE temporarily if non-nil while BODY is evaluated. +The original message is restored to the echo area after BODY has finished. +The value returned is the value of the last form in BODY. +MESSAGE is written to the message log buffer if `message-log-max' is non-nil. +If MESSAGE is nil, the echo area and message log buffer are unchanged. +Use a MESSAGE of \"\" to temporarily clear the echo area." + (let ((current-message (make-symbol "current-message")) + (temp-message (make-symbol "with-temp-message"))) + (` (let (((, temp-message) (, message)) + ((, current-message))) + (unwind-protect + (progn + (when (, temp-message) + (setq (, current-message) (current-message)) + (message "%s" (, temp-message)) + (,@ body)) + (and (, temp-message) (, current-message) + (message "%s" (, current-message)))))))))) + +;; Emacs 20.1/XEmacs 20.3(?) and later: (with-temp-buffer &rest FORMS) +(defmacro-maybe with-temp-buffer (&rest forms) + "Create a temporary buffer, and evaluate FORMS there like `progn'. +See also `with-temp-file' and `with-output-to-string'." + (let ((temp-buffer (make-symbol "temp-buffer"))) + (` (let (((, temp-buffer) + (get-buffer-create (generate-new-buffer-name " *temp*")))) + (unwind-protect + (with-current-buffer (, temp-buffer) + (,@ forms)) + (and (buffer-name (, temp-buffer)) + (kill-buffer (, temp-buffer)))))))) + +;; Emacs 20.1/XEmacs 20.3(?) and later: (with-output-to-string &rest BODY) +(defmacro-maybe with-output-to-string (&rest body) + "Execute BODY, return the text it sent to `standard-output', as a string." + (` (let ((standard-output + (get-buffer-create (generate-new-buffer-name " *string-output*")))) + (let ((standard-output standard-output)) + (,@ body)) + (with-current-buffer standard-output + (prog1 + (buffer-string) + (kill-buffer nil)))))) + +;; Emacs 20.1 and later: (combine-after-change-calls &rest BODY) +(defmacro-maybe combine-after-change-calls (&rest body) + "Execute BODY, but don't call the after-change functions till the end. +If BODY makes changes in the buffer, they are recorded +and the functions on `after-change-functions' are called several times +when BODY is finished. +The return value is the value of the last form in BODY. + +If `before-change-functions' is non-nil, then calls to the after-change +functions can't be deferred, so in that case this macro has no effect. + +Do not alter `after-change-functions' or `before-change-functions' +in BODY. + +This emulating macro does not support after-change functions at all, +just execute BODY." + (cons 'progn body)) + +;; Emacs 19.29/XEmacs 19.14(?) and later: (match-string NUM &optional STRING) +(defun-maybe match-string (num &optional string) + "Return string of text matched by last search. +NUM specifies which parenthesized expression in the last regexp. + Value is nil if NUMth pair didn't match, or there were less than NUM pairs. +Zero means the entire text matched by the whole regexp or whole string. +STRING should be given if the last search was by `string-match' on STRING." + (if (match-beginning num) + (if string + (substring string (match-beginning num) (match-end num)) + (buffer-substring (match-beginning num) (match-end num))))) + +;; Emacs 20.3 and later: (match-string-no-properties NUM &optional STRING) +(defun-maybe match-string-no-properties (num &optional string) + "Return string of text matched by last search, without text properties. +NUM specifies which parenthesized expression in the last regexp. + Value is nil if NUMth pair didn't match, or there were less than NUM pairs. +Zero means the entire text matched by the whole regexp or whole string. +STRING should be given if the last search was by `string-match' on STRING." + (if (match-beginning num) + (if string + (let ((result + (substring string (match-beginning num) (match-end num)))) + (set-text-properties 0 (length result) nil result) + result) + (buffer-substring-no-properties (match-beginning num) + (match-end num))))) + +;; Emacs 19.28 and earlier +;; (replace-match NEWTEXT &optional FIXEDCASE LITERAL) +;; Emacs 20.x (?) and later +;; (replace-match NEWTEXT &optional FIXEDCASE LITERAL STRING SUBEXP) +;; XEmacs 21: +;; (replace-match NEWTEXT &optional FIXEDCASE LITERAL STRING STRBUFFER) +;; We support following API. +;; (replace-match NEWTEXT &optional FIXEDCASE LITERAL STRING) +(static-condition-case nil + ;; compile-time check + (progn + (string-match "" "") + (replace-match "" nil nil "") + (if (get 'replace-match 'defun-maybe) + (error "`replace-match' is already defined"))) + (wrong-number-of-arguments ; Emacs 19.28 and earlier + ;; load-time check. + (or (fboundp 'si:replace-match) + (progn + (fset 'si:replace-match (symbol-function 'replace-match)) + (put 'replace-match 'defun-maybe t) + (defun replace-match (newtext &optional fixedcase literal string) + "Replace text matched by last search with NEWTEXT. +If second arg FIXEDCASE is non-nil, do not alter case of replacement text. +Otherwise maybe capitalize the whole text, or maybe just word initials, +based on the replaced text. +If the replaced text has only capital letters +and has at least one multiletter word, convert NEWTEXT to all caps. +If the replaced text has at least one word starting with a capital letter, +then capitalize each word in NEWTEXT. + +If third arg LITERAL is non-nil, insert NEWTEXT literally. +Otherwise treat `\' as special: + `\&' in NEWTEXT means substitute original matched text. + `\N' means substitute what matched the Nth `\(...\)'. + If Nth parens didn't match, substitute nothing. + `\\' means insert one `\'. +FIXEDCASE and LITERAL are optional arguments. +Leaves point at end of replacement text. + +The optional fourth argument STRING can be a string to modify. +In that case, this function creates and returns a new string +which is made by replacing the part of STRING that was matched." + (if string + (with-temp-buffer + (save-match-data + (insert string) + (let* ((matched (match-data)) + (beg (nth 0 matched)) + (end (nth 1 matched))) + (store-match-data + (list + (if (markerp beg) + (move-marker beg (1+ (match-beginning 0))) + (1+ (match-beginning 0))) + (if (markerp end) + (move-marker end (1+ (match-end 0))) + (1+ (match-end 0)))))) + (si:replace-match newtext fixedcase literal) + (buffer-string))) + (si:replace-match newtext fixedcase literal)))))) + (error ; found our definition at compile-time. + ;; load-time check. + (condition-case nil + (progn + (string-match "" "") + (replace-match "" nil nil "")) + (wrong-number-of-arguments ; Emacs 19.28 and earlier + ;; load-time check. + (or (fboundp 'si:replace-match) + (progn + (fset 'si:replace-match (symbol-function 'replace-match)) + (put 'replace-match 'defun-maybe t) + (defun replace-match (newtext &optional fixedcase literal string) + "Replace text matched by last search with NEWTEXT. +If second arg FIXEDCASE is non-nil, do not alter case of replacement text. +Otherwise maybe capitalize the whole text, or maybe just word initials, +based on the replaced text. +If the replaced text has only capital letters +and has at least one multiletter word, convert NEWTEXT to all caps. +If the replaced text has at least one word starting with a capital letter, +then capitalize each word in NEWTEXT. + +If third arg LITERAL is non-nil, insert NEWTEXT literally. +Otherwise treat `\' as special: + `\&' in NEWTEXT means substitute original matched text. + `\N' means substitute what matched the Nth `\(...\)'. + If Nth parens didn't match, substitute nothing. + `\\' means insert one `\'. +FIXEDCASE and LITERAL are optional arguments. +Leaves point at end of replacement text. + +The optional fourth argument STRING can be a string to modify. +In that case, this function creates and returns a new string +which is made by replacing the part of STRING that was matched." + (if string + (with-temp-buffer + (save-match-data + (insert string) + (let* ((matched (match-data)) + (beg (nth 0 matched)) + (end (nth 1 matched))) + (store-match-data + (list + (if (markerp beg) + (move-marker beg (1+ (match-beginning 0))) + (1+ (match-beginning 0))) + (if (markerp end) + (move-marker end (1+ (match-end 0))) + (1+ (match-end 0)))))) + (si:replace-match newtext fixedcase literal) + (buffer-string))) + (si:replace-match newtext fixedcase literal))))))))) + +;; Emacs 20: (format-time-string) +;; The the third optional argument universal is yet to be implemented. +;; Those format constructs are yet to be implemented. +;; %c, %C, %j, %U, %W, %x, %X +;; Not fully compatible especially when invalid format is specified. +(static-unless (and (fboundp 'format-time-string) + (not (get 'format-time-string 'defun-maybe))) + (or (fboundp 'format-time-string) + (progn + (defconst format-time-month-list + '(( "Zero" . ("Zero" . 0)) + ("Jan" . ("January" . 1)) ("Feb" . ("February" . 2)) + ("Mar" . ("March" . 3)) ("Apr" . ("April" . 4)) ("May" . ("May" . 5)) + ("Jun" . ("June" . 6))("Jul" . ("July" . 7)) ("Aug" . ("August" . 8)) + ("Sep" . ("September" . 9)) ("Oct" . ("October" . 10)) + ("Nov" . ("November" . 11)) ("Dec" . ("December" . 12))) + "Alist of months and their number.") + + (defconst format-time-week-list + '(("Sun" . ("Sunday" . 0)) ("Mon" . ("Monday" . 1)) + ("Tue" . ("Tuesday" . 2)) ("Wed" . ("Wednesday" . 3)) + ("Thu" . ("Thursday" . 4)) ("Fri" . ("Friday" . 5)) + ("Sat" . ("Saturday" . 6))) + "Alist of weeks and their number.") + + (defun format-time-string (format &optional time universal) + "Use FORMAT-STRING to format the time TIME, or now if omitted. +TIME is specified as (HIGH LOW . IGNORED) or (HIGH . LOW), as returned by +`current-time' or `file-attributes'. +The third, optional, argument UNIVERSAL, if non-nil, means describe TIME +as Universal Time; nil means describe TIME in the local time zone. +The value is a copy of FORMAT-STRING, but with certain constructs replaced +by text that describes the specified date and time in TIME: + +%Y is the year, %y within the century, %C the century. +%G is the year corresponding to the ISO week, %g within the century. +%m is the numeric month. +%b and %h are the locale's abbreviated month name, %B the full name. +%d is the day of the month, zero-padded, %e is blank-padded. +%u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6. +%a is the locale's abbreviated name of the day of week, %A the full name. +%U is the week number starting on Sunday, %W starting on Monday, + %V according to ISO 8601. +%j is the day of the year. + +%H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H + only blank-padded, %l is like %I blank-padded. +%p is the locale's equivalent of either AM or PM. +%M is the minute. +%S is the second. +%Z is the time zone name, %z is the numeric form. +%s is the number of seconds since 1970-01-01 00:00:00 +0000. + +%c is the locale's date and time format. +%x is the locale's \"preferred\" date format. +%D is like \"%m/%d/%y\". + +%R is like \"%H:%M\", %T is like \"%H:%M:%S\", %r is like \"%I:%M:%S %p\". +%X is the locale's \"preferred\" time format. + +Finally, %n is a newline, %t is a tab, %% is a literal %. + +Certain flags and modifiers are available with some format controls. +The flags are `_' and `-'. For certain characters X, %_X is like %X, +but padded with blanks; %-X is like %X, but without padding. +%NX (where N stands for an integer) is like %X, +but takes up at least N (a number) positions. +The modifiers are `E' and `O'. For certain characters X, +%EX is a locale's alternative version of %X; +%OX is like %X, but uses the locale's number symbols. + +For example, to produce full ISO 8601 format, use \"%Y-%m-%dT%T%z\". + +Compatibility Note. + +The the third optional argument universal is yet to be implemented. +Those format constructs are yet to be implemented. + %c, %C, %j, %U, %W, %x, %X +Not fully compatible especially when invalid format is specified." + (let ((fmt-len (length format)) + (ind 0) + prev-ind + cur-char + (prev-char nil) + strings-so-far + (result "") + field-width + field-result + pad-left change-case + (paren-level 0) + hour + (time-string (current-time-string time))) + (setq hour (string-to-int (substring time-string 11 13))) + (while (< ind fmt-len) + (setq cur-char (aref format ind)) + (setq + result + (concat result + (cond + ((eq cur-char ?%) + ;; eat any additional args to allow for future expansion, not!! + (setq pad-left nil change-case nil field-width "" prev-ind ind + strings-so-far "") +; (catch 'invalid + (while (progn + (setq ind (1+ ind)) + (setq cur-char (if (< ind fmt-len) + (aref format ind) + ?\0)) + (or (eq ?- cur-char) ; pad on left + (eq ?# cur-char) ; case change + (if (and (string-equal field-width "") + (<= ?0 cur-char) (>= ?9 cur-char)) + ;; get format width + (let ((field-index ind)) + (while (progn + (setq ind (1+ ind)) + (setq cur-char (if (< ind fmt-len) + (aref format ind) + ?\0)) + (and (<= ?0 cur-char) (>= ?9 cur-char)))) + (setq field-width + (substring format field-index ind)) + (setq ind (1- ind) + cur-char nil) + t)))) + (setq prev-char cur-char + strings-so-far (concat strings-so-far + (if cur-char + (char-to-string cur-char) + field-width))) + ;; characters we actually use + (cond ((eq cur-char ?-) + ;; padding to left must be specified before field-width + (setq pad-left (string-equal field-width ""))) + ((eq cur-char ?#) + (setq change-case t)))) + (setq field-result + (cond + ((eq cur-char ?%) + "%") + ;; the abbreviated name of the day of week. + ((eq cur-char ?a) + (substring time-string 0 3)) + ;; the full name of the day of week + ((eq cur-char ?A) + (cadr (assoc (substring time-string 0 3) + format-time-week-list))) + ;; the abbreviated name of the month + ((eq cur-char ?b) + (substring time-string 4 7)) + ;; the full name of the month + ((eq cur-char ?B) + (cadr (assoc (substring time-string 4 7) + format-time-month-list))) + ;; a synonym for `%x %X' (yet to come) + ((eq cur-char ?c) + "") + ;; locale specific (yet to come) + ((eq cur-char ?C) + "") + ;; the day of month, zero-padded + ((eq cur-char ?d) + (format "%02d" (string-to-int (substring time-string 8 10)))) + ;; a synonym for `%m/%d/%y' + ((eq cur-char ?D) + (format "%02d/%02d/%s" + (cddr (assoc (substring time-string 4 7) + format-time-month-list)) + (string-to-int (substring time-string 8 10)) + (substring time-string -2))) + ;; the day of month, blank-padded + ((eq cur-char ?e) + (format "%2d" (string-to-int (substring time-string 8 10)))) + ;; a synonym for `%b' + ((eq cur-char ?h) + (substring time-string 4 7)) + ;; the hour (00-23) + ((eq cur-char ?H) + (substring time-string 11 13)) + ;; the hour (00-12) + ((eq cur-char ?I) + (format "%02d" (if (> hour 12) (- hour 12) hour))) + ;; the day of the year (001-366) (yet to come) + ((eq cur-char ?j) + "") + ;; the hour (0-23), blank padded + ((eq cur-char ?k) + (format "%2d" hour)) + ;; the hour (1-12), blank padded + ((eq cur-char ?l) + (format "%2d" (if (> hour 12) (- hour 12) hour))) + ;; the month (01-12) + ((eq cur-char ?m) + (format "%02d" (cddr (assoc (substring time-string 4 7) + format-time-month-list)))) + ;; the minute (00-59) + ((eq cur-char ?M) + (substring time-string 14 16)) + ;; a newline + ((eq cur-char ?n) + "\n") + ;; `AM' or `PM', as appropriate + ((eq cur-char ?p) + (setq change-case (not change-case)) + (if (> hour 12) "pm" "am")) + ;; a synonym for `%I:%M:%S %p' + ((eq cur-char ?r) + (format "%02d:%s:%s %s" + (if (> hour 12) (- hour 12) hour) + (substring time-string 14 16) + (substring time-string 17 19) + (if (> hour 12) "PM" "AM"))) + ;; a synonym for `%H:%M' + ((eq cur-char ?R) + (format "%s:%s" + (substring time-string 11 13) + (substring time-string 14 16))) + ;; the seconds (00-60) + ((eq cur-char ?S) + (substring time-string 17 19)) + ;; a tab character + ((eq cur-char ?t) + "\t") + ;; a synonym for `%H:%M:%S' + ((eq cur-char ?T) + (format "%s:%s:%s" + (substring time-string 11 13) + (substring time-string 14 16) + (substring time-string 17 19))) + ;; the week of the year (01-52), assuming that weeks + ;; start on Sunday (yet to come) + ((eq cur-char ?U) + "") + ;; the numeric day of week (0-6). Sunday is day 0 + ((eq cur-char ?w) + (format "%d" (cddr (assoc (substring time-string 0 3) + format-time-week-list)))) + ;; the week of the year (01-52), assuming that weeks + ;; start on Monday (yet to come) + ((eq cur-char ?W) + "") + ;; locale specific (yet to come) + ((eq cur-char ?x) + "") + ;; locale specific (yet to come) + ((eq cur-char ?X) + "") + ;; the year without century (00-99) + ((eq cur-char ?y) + (substring time-string -2)) + ;; the year with century + ((eq cur-char ?Y) + (substring time-string -4)) + ;; the time zone abbreviation + ((eq cur-char ?Z) + (setq change-case (not change-case)) + (downcase (cadr (current-time-zone)))) + (t + (concat + "%" + strings-so-far + (char-to-string cur-char))))) +; (setq ind prev-ind) +; (throw 'invalid "%")))) + (if (string-equal field-width "") + (if change-case (upcase field-result) field-result) + (let ((padded-result + (format (format "%%%s%s%c" + "" ; pad on left is ignored +; (if pad-left "-" "") + field-width + ?s) + (or field-result "")))) + (let ((initial-length (length padded-result)) + (desired-length (string-to-int field-width))) + (when (and (string-match "^0" field-width) + (string-match "^ +" padded-result)) + (setq padded-result + (replace-match + (make-string + (length (match-string 0 padded-result)) ?0) + nil nil padded-result))) + (if (> initial-length desired-length) + ;; truncate strings on right, years on left + (if (stringp field-result) + (substring padded-result 0 desired-length) + (if (eq cur-char ?y) + (substring padded-result (- desired-length)) + padded-result))) ;non-year numbers don't truncate + (if change-case (upcase padded-result) padded-result))))) ;) + (t + (char-to-string cur-char))))) + (setq ind (1+ ind))) + result)) + ;; for `load-history'. + (setq current-load-list (cons 'format-time-string current-load-list)) + (put 'format-time-string 'defun-maybe t)))) + +;; Emacs 20.1/XEmacs 20.3(?) and later: (split-string STRING &optional PATTERN) +;; Here is a XEmacs version. +(defun-maybe split-string (string &optional pattern) + "Return a list of substrings of STRING which are separated by PATTERN. +If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." + (or pattern + (setq pattern "[ \f\t\n\r\v]+")) + ;; The FSF version of this function takes care not to cons in case + ;; of infloop. Maybe we should synch? + (let (parts (start 0)) + (while (string-match pattern string start) + (setq parts (cons (substring string start (match-beginning 0)) parts) + start (match-end 0))) + (nreverse (cons (substring string start) parts)))) + + +;;; @ Window commands emulation. (lisp/window.el) +;;; + +(defmacro-maybe save-selected-window (&rest body) + "Execute BODY, then select the window that was selected before BODY." + (list 'let + '((save-selected-window-window (selected-window))) + (list 'unwind-protect + (cons 'progn body) + (list 'select-window 'save-selected-window-window)))) + +;; Emacs 19.31 and later: +;; (get-buffer-window-list &optional BUFFER MINIBUF FRAME) +(defun-maybe get-buffer-window-list (buffer &optional minibuf frame) + "Return windows currently displaying BUFFER, or nil if none. +See `walk-windows' for the meaning of MINIBUF and FRAME." + (let ((buffer (if (bufferp buffer) buffer (get-buffer buffer))) windows) + (walk-windows + (function (lambda (window) + (if (eq (window-buffer window) buffer) + (setq windows (cons window windows))))) + minibuf frame) + windows)) + + +;;; @ Frame commands emulation. (lisp/frame.el) +;;; + +;; XEmacs 21.0 and later: +;; (save-selected-frame &rest BODY) +(defmacro-maybe save-selected-frame (&rest body) + "Execute forms in BODY, then restore the selected frame." + (list 'let + '((save-selected-frame-frame (selected-frame))) + (list 'unwind-protect + (cons 'progn body) + (list 'select-frame 'save-selected-frame-frame)))) + + +;;; @ Basic editing commands emulation. (lisp/simple.el) +;;; + + +;;; @ File input and output commands emulation. (lisp/files.el) +;;; + +(defvar-maybe temporary-file-directory + (file-name-as-directory + (cond ((memq system-type '(ms-dos windows-nt)) + (or (getenv "TEMP") (getenv "TMPDIR") (getenv "TMP") "c:/temp")) + ((memq system-type '(vax-vms axp-vms)) + (or (getenv "TMPDIR") (getenv "TMP") (getenv "TEMP") "SYS$SCRATCH:")) + (t + (or (getenv "TMPDIR") (getenv "TMP") (getenv "TEMP") "/tmp")))) + "The directory for writing temporary files.") + +;; Actually, `path-separator' is defined in src/emacs.c and overrided +;; in dos-w32.el. +(defvar-maybe path-separator ":" + "The directory separator in search paths, as a string.") + +;; `convert-standard-filename' is defined in lisp/files.el and overrided +;; in lisp/dos-fns.el and lisp/w32-fns.el for each environment. +(cond + ;; must be load-time check to share .elc between different systems. + ((fboundp 'convert-standard-filename)) + ((memq system-type '(windows-nt ms-dos)) + ;; should we do (require 'filename) at load-time ? + ;; (require 'filename) + ;; filename.el requires many modules, so we do not want to load it + ;; at compile-time. Instead, suppress warnings by these autoloads. + (eval-when-compile + (autoload 'filename-maybe-truncate-by-size "filename") + (autoload 'filename-special-filter "filename")) + (defun convert-standard-filename (filename) + "Convert a standard file's name to something suitable for the current OS. +This function's standard definition is trivial; it just returns the argument. +However, on some systems, the function is redefined +with a definition that really does change some file names. +Under `windows-nt' or `ms-dos', it refers `filename-replacement-alist' and +`filename-limit-length' for the basic filename and each parent directory name." + (require 'filename) + (let* ((names (split-string filename "/")) + (drive-name (car names)) + (filter (function + (lambda (string) + (filename-maybe-truncate-by-size + (filename-special-filter string)))))) + (cond + ((eq 1 (length names)) + (funcall filter drive-name)) + ((string-match "^[^/]:$" drive-name) + (concat drive-name "/" (mapconcat filter (cdr names) "/"))) + (t + (mapconcat filter names "/")))))) + (t + (defun convert-standard-filename (filename) + "Convert a standard file's name to something suitable for the current OS. +This function's standard definition is trivial; it just returns the argument. +However, on some systems, the function is redefined +with a definition that really does change some file names. +Under `windows-nt' or `ms-dos', it refers `filename-replacement-alist' and +`filename-limit-length' for the basic filename and each parent directory name." + filename))) + +(static-cond + ((fboundp 'insert-file-contents-literally)) + ((boundp 'file-name-handler-alist) + ;; Use `defun-maybe' to update `load-history'. + (defun-maybe insert-file-contents-literally (filename &optional visit + beg end replace) + "Like `insert-file-contents', q.v., but only reads in the file. +A buffer may be modified in several ways after reading into the buffer due +to advanced Emacs features, such as file-name-handlers, format decoding, +find-file-hooks, etc. + This function ensures that none of these modifications will take place." + (let (file-name-handler-alist) + (insert-file-contents filename visit beg end replace)))) + (t + (defalias 'insert-file-contents-literally 'insert-file-contents))) + +(defun-maybe file-name-sans-extension (filename) + "Return FILENAME sans final \"extension\". +The extension, in a file name, is the part that follows the last `.'." + (save-match-data + (let ((file (file-name-sans-versions (file-name-nondirectory filename))) + directory) + (if (string-match "\\.[^.]*\\'" file) + (if (setq directory (file-name-directory filename)) + (expand-file-name (substring file 0 (match-beginning 0)) + directory) + (substring file 0 (match-beginning 0))) + filename)))) + + +;;; @ XEmacs emulation. +;;; + +(defun-maybe 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)))) + +;; Emacs 21.1 defines this as an alias for `line-beginning-position'. +;; Therefore, optional 2nd arg BUFFER is not portable. +(defun-maybe point-at-bol (&optional n buffer) + "Return the character position of the first character on the current line. +With argument N not nil or 1, move forward N - 1 lines first. +If scan reaches end of buffer, return that position. +This function does not move point." + (save-excursion + (if buffer (set-buffer buffer)) + (forward-line (1- (or n 1))) + (point))) + +;; Emacs 21.1 defines this as an alias for `line-end-position'. +;; Therefore, optional 2nd arg BUFFER is not portable. +(defun-maybe point-at-eol (&optional n buffer) + "Return the character position of the last character on the current line. +With argument N not nil or 1, move forward N - 1 lines first. +If scan reaches end of buffer, return that position. +This function does not move point." + (save-excursion + (if buffer (set-buffer buffer)) + (end-of-line (or n 1)) + (point))) + +(defsubst-maybe define-obsolete-function-alias (oldfun newfun) + "Define OLDFUN as an obsolete alias for function NEWFUN. +This makes calling OLDFUN equivalent to calling NEWFUN and marks OLDFUN +as obsolete." + (defalias oldfun newfun) + (make-obsolete oldfun newfun)) + +;; XEmacs 21: (character-to-event CH &optional EVENT DEVICE) +(defun-maybe character-to-event (ch) + "Convert keystroke CH into an event structure, replete with bucky bits. +Note that CH (the keystroke specifier) can be an integer, a character +or a symbol such as 'clear." + ch) + +;; XEmacs 21: (event-to-character EVENT +;; &optional ALLOW-EXTRA-MODIFIERS ALLOW-META ALLOW-NON-ASCII) +(defun-maybe-cond event-to-character (event) + "Return the character approximation to the given event object. +If the event isn't a keypress, this returns nil." + ((and (fboundp 'read-event) + (subrp (symbol-function 'read-event))) + ;; Emacs 19 and later. + (cond + ((symbolp event) + ;; mask is (BASE-TYPE MODIFIER-BITS) or nil. + (let ((mask (get event 'event-symbol-element-mask))) + (if mask + (let ((base (get (car mask) 'ascii-character))) + (if base + (logior base (car (cdr mask)))))))) + ((integerp event) event))) + (t + ;; v18. Is this correct? + event)) + +;; v18: no event; (read-char) +;; Emacs 19, 20.1 and 20.2: (read-event) +;; Emacs 20.3: (read-event &optional PROMPT SUPPRESS-INPUT-METHOD) +;; Emacs 20.4: (read-event &optional PROMPT INHERIT-INPUT-METHOD) +;; XEmacs: (next-event &optional EVENT PROMPT), +;; (next-command-event &optional EVENT PROMPT) +(defun-maybe-cond next-command-event (&optional event prompt) + "Read an event object from the input stream. +If EVENT is non-nil, it should be an event object and will be filled +in and returned; otherwise a new event object will be created and +returned. +If PROMPT is non-nil, it should be a string and will be displayed in +the echo area while this function is waiting for an event." + ((and (>= emacs-major-version 20) + (>= emacs-minor-version 4)) + ;; Emacs 20.4 and later. + (read-event prompt)) ; should specify 2nd arg? + ((and (= emacs-major-version 20) + (= emacs-minor-version 3)) + ;; Emacs 20.3. + (read-event prompt)) ; should specify 2nd arg? + ((and (fboundp 'read-event) + (subrp (symbol-function 'read-event))) + ;; Emacs 19, 20.1 and 20.2. + (if prompt (message prompt)) + (read-event)) + (t + (if prompt (message prompt)) + (read-char))) + + +;;; @ MULE 2 emulation. +;;; + +(defun-maybe-cond cancel-undo-boundary () + "Cancel undo boundary." + ((boundp 'buffer-undo-list) + ;; for Emacs 19 and later. + (if (and (consp buffer-undo-list) + (null (car buffer-undo-list))) + (setq buffer-undo-list (cdr buffer-undo-list))))) + + +;;; @ End. +;;; + +;;; poe.el ends here diff --git a/poe/poem-e20.el b/poe/poem-e20.el new file mode 100644 index 0000000..ac2a17e --- /dev/null +++ b/poe/poem-e20.el @@ -0,0 +1,65 @@ +;;; poem-e20.el --- poem submodule for Emacs 20; -*-byte-compile-dynamic: t;-*- + +;; 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: + +(defun fontset-pixel-size (fontset) + (let* ((info (fontset-info fontset)) + (height (aref info 1)) + ) + (cond ((> height 0) height) + ((string-match "-\\([0-9]+\\)-" fontset) + (string-to-number + (substring fontset (match-beginning 1)(match-end 1)))) + (t 0)))) + + +;;; @ character set +;;; + +;; (defalias 'charset-columns 'charset-width) + +(defun find-non-ascii-charset-string (string) + "Return a list of charsets in the STRING except ascii." + (delq 'ascii (find-charset-string string))) + +(defun find-non-ascii-charset-region (start end) + "Return a list of charsets except ascii +in the region between START and END." + (delq 'ascii (find-charset-string (buffer-substring start end)))) + + +;;; @ end +;;; + +(if (and (fboundp 'set-buffer-multibyte) + (subrp (symbol-function 'set-buffer-multibyte))) + (require 'poem-e20_3) ; for Emacs 20.3 + (require 'poem-e20_2) ; for Emacs 20.1 and 20.2 + ) + +(require 'product) +(product-provide (provide 'poem-e20) (require 'apel-ver)) + +;;; poem-e20.el ends here diff --git a/poe/poem-e20_3.el b/poe/poem-e20_3.el new file mode 100644 index 0000000..5a72faa --- /dev/null +++ b/poe/poem-e20_3.el @@ -0,0 +1,68 @@ +;;; -*-byte-compile-dynamic: t;-*- +;;; poem-e20_3.el --- poem submodule for Emacs 20.3 + +;; Copyright (C) 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.2.91 or later. + +;;; Code: + +(require 'pym) + +;;; @ character +;;; + +(defsubst char-length (char) + "Return indexing length of multi-byte form of CHAR." + 1) + +(defmacro char-next-index (char index) + "Return index of character succeeding CHAR whose index is INDEX." + `(1+ ,index)) + +(defalias-maybe 'characterp 'char-valid-p) + + +;;; @ string +;;; + +(defalias 'sset 'store-substring) + +(defun string-to-char-list (string) + "Return a list of which elements are characters in the STRING." + (mapcar #'identity string)) + +(defalias 'string-to-int-list 'string-to-char-list) + +(defalias 'looking-at-as-unibyte 'looking-at) + + +;;; @ end +;;; + +(require 'product) +(product-provide (provide 'poem-e20_3) (require 'apel-ver)) + +;;; poem-e20_3.el ends here diff --git a/poe/poem.el b/poe/poem.el new file mode 100644 index 0000000..ec752a3 --- /dev/null +++ b/poe/poem.el @@ -0,0 +1,100 @@ +;;; poem.el --- Emulate latest MULE features; -*-byte-compile-dynamic: t;-*- + +;; Copyright (C) 1998,1999 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 'pces) + +(cond ((featurep 'mule) + (cond ((featurep 'xemacs) + (require 'poem-xm) + ) + ((>= emacs-major-version 20) + (require 'poem-e20) + ) + (t + ;; for MULE 1.* and 2.* + (require 'poem-om) + )) + ) + ((boundp 'NEMACS) + ;; for Nemacs and Nepoch + (require 'poem-nemacs) + ) + (t + (require 'poem-ltn1) + )) + + +;;; @ Emacs 20.3 emulation +;;; + +(defsubst-maybe string-as-unibyte (string) + "Return a unibyte string with the same individual bytes as STRING. +If STRING is unibyte, the result is STRING itself. +\[Emacs 20.3 emulating macro]" + string) + +(defsubst-maybe string-as-multibyte (string) + "Return a multibyte string with the same individual bytes as STRING. +If STRING is multibyte, the result is STRING itself. +\[Emacs 20.3 emulating macro]" + string) + +(defun-maybe charset-after (&optional pos) + "Return charset of a character in current buffer at position POS. +If POS is nil, it defauls to the current point. +If POS is out of range, the value is nil. +\[Emacs 20.3 emulating function]" + (char-charset (char-after pos)) + ) + +;;; @ XEmacs-mule emulation +;;; + +(defalias-maybe 'char-int 'identity) + +(defalias-maybe 'int-char 'identity) + +(defalias-maybe 'characterp 'integerp) + +(defalias-maybe 'char-or-char-int-p 'integerp) + +(defun-maybe char-octet (ch &optional n) + "Return the octet numbered N (should be 0 or 1) of char CH. +N defaults to 0 if omitted. [XEmacs-mule emulating function]" + (or (nth (if n + (1+ n) + 1) + (split-char ch)) + 0)) + + +;;; @ end +;;; + +(require 'product) +(product-provide (provide 'poem) (require 'apel-ver)) + +;;; poem.el ends here diff --git a/poe/product.el b/poe/product.el new file mode 100644 index 0000000..6b7d389 --- /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/poe/pym.el b/poe/pym.el new file mode 100644 index 0000000..692ffcd --- /dev/null +++ b/poe/pym.el @@ -0,0 +1,293 @@ +;;; pym.el --- Macros for Your Poe. + +;; Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Shuhei KOBAYASHI +;; Keywords: byte-compile, evaluation, edebug, internal + +;; 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 provides `def*-maybe' macros for conditional definition. +;; +;; Many APEL modules use these macros to provide emulation version of +;; Emacs builtins (both C primitives and lisp subroutines) for backward +;; compatibility. While compilation time, if `def*-maybe' find that +;; functions/variables being defined is already provided by Emacs used +;; for compilation, it does not leave the definitions in compiled code +;; and resulting .elc will be highly specialized for your environment. + +;; For `find-function' lovers, the following definitions may work with +;; `def*-maybe'. +;; +;; (setq find-function-regexp +;; "^\\s-*(def[^cgvW]\\(\\w\\|-\\)+\\*?\\s-+'?%s\\(\\s-\\|$\\)") +;; (setq find-variable-regexp +;; "^\\s-*(def[^umaW]\\(\\w\\|-\\)+\\*?\\s-+%s\\(\\s-\\|$\\)") +;; +;; I'm too lazy to write better regexps, sorry. -- shuhei + +;;; Code: + +;; for `load-history'. +(or (boundp 'current-load-list) (setq current-load-list nil)) + +(require 'static) + + +;;; Conditional define. + +(put 'defun-maybe 'lisp-indent-function 'defun) +(defmacro defun-maybe (name &rest everything-else) + "Define NAME as a function if NAME is not defined. +See also the function `defun'." + (or (and (fboundp name) + (not (get name 'defun-maybe))) + (` (or (fboundp (quote (, name))) + (prog1 + (defun (, name) (,@ everything-else)) + ;; This `defun' will be compiled to `fset', + ;; which does not update `load-history'. + ;; We must update `current-load-list' explicitly. + (setq current-load-list + (cons (quote (, name)) current-load-list)) + (put (quote (, name)) 'defun-maybe t)))))) + +(put 'defmacro-maybe 'lisp-indent-function 'defun) +(defmacro defmacro-maybe (name &rest everything-else) + "Define NAME as a macro if NAME is not defined. +See also the function `defmacro'." + (or (and (fboundp name) + (not (get name 'defmacro-maybe))) + (` (or (fboundp (quote (, name))) + (prog1 + (defmacro (, name) (,@ everything-else)) + ;; This `defmacro' will be compiled to `fset', + ;; which does not update `load-history'. + ;; We must update `current-load-list' explicitly. + (setq current-load-list + (cons (quote (, name)) current-load-list)) + (put (quote (, name)) 'defmacro-maybe t)))))) + +(put 'defsubst-maybe 'lisp-indent-function 'defun) +(defmacro defsubst-maybe (name &rest everything-else) + "Define NAME as an inline function if NAME is not defined. +See also the macro `defsubst'." + (or (and (fboundp name) + (not (get name 'defsubst-maybe))) + (` (or (fboundp (quote (, name))) + (prog1 + (defsubst (, name) (,@ everything-else)) + ;; This `defsubst' will be compiled to `fset', + ;; which does not update `load-history'. + ;; We must update `current-load-list' explicitly. + (setq current-load-list + (cons (quote (, name)) current-load-list)) + (put (quote (, name)) 'defsubst-maybe t)))))) + +(defmacro defalias-maybe (symbol definition) + "Define SYMBOL as an alias for DEFINITION if SYMBOL is not defined. +See also the function `defalias'." + (setq symbol (eval symbol)) + (or (and (fboundp symbol) + (not (get symbol 'defalias-maybe))) + (` (or (fboundp (quote (, symbol))) + (prog1 + (defalias (quote (, symbol)) (, definition)) + ;; `defalias' updates `load-history' internally. + (put (quote (, symbol)) 'defalias-maybe t)))))) + +(defmacro defvar-maybe (name &rest everything-else) + "Define NAME as a variable if NAME is not defined. +See also the function `defvar'." + (or (and (boundp name) + (not (get name 'defvar-maybe))) + (` (or (boundp (quote (, name))) + (prog1 + (defvar (, name) (,@ everything-else)) + ;; byte-compiler will generate code to update + ;; `load-history'. + (put (quote (, name)) 'defvar-maybe t)))))) + +(defmacro defconst-maybe (name &rest everything-else) + "Define NAME as a constant variable if NAME is not defined. +See also the function `defconst'." + (or (and (boundp name) + (not (get name 'defconst-maybe))) + (` (or (boundp (quote (, name))) + (prog1 + (defconst (, name) (,@ everything-else)) + ;; byte-compiler will generate code to update + ;; `load-history'. + (put (quote (, name)) 'defconst-maybe t)))))) + +(defmacro defun-maybe-cond (name args &optional doc &rest clauses) + "Define NAME as a function if NAME is not defined. +CLAUSES are like those of `cond' expression, but each condition is evaluated +at compile-time and, if the value is non-nil, the body of the clause is used +for function definition of NAME. +See also the function `defun'." + (or (stringp doc) + (setq clauses (cons doc clauses) + doc nil)) + (or (and (fboundp name) + (not (get name 'defun-maybe))) + (` (or (fboundp (quote (, name))) + (prog1 + (static-cond + (,@ (mapcar + (function + (lambda (case) + (list (car case) + (if doc + (` (defun (, name) (, args) + (, doc) + (,@ (cdr case)))) + (` (defun (, name) (, args) + (,@ (cdr case)))))))) + clauses))) + ;; This `defun' will be compiled to `fset', + ;; which does not update `load-history'. + ;; We must update `current-load-list' explicitly. + (setq current-load-list + (cons (quote (, name)) current-load-list)) + (put (quote (, name)) 'defun-maybe t)))))) + +(defmacro defmacro-maybe-cond (name args &optional doc &rest clauses) + "Define NAME as a macro if NAME is not defined. +CLAUSES are like those of `cond' expression, but each condition is evaluated +at compile-time and, if the value is non-nil, the body of the clause is used +for macro definition of NAME. +See also the function `defmacro'." + (or (stringp doc) + (setq clauses (cons doc clauses) + doc nil)) + (or (and (fboundp name) + (not (get name 'defmacro-maybe))) + (` (or (fboundp (quote (, name))) + (prog1 + (static-cond + (,@ (mapcar + (function + (lambda (case) + (list (car case) + (if doc + (` (defmacro (, name) (, args) + (, doc) + (,@ (cdr case)))) + (` (defmacro (, name) (, args) + (,@ (cdr case)))))))) + clauses))) + ;; This `defmacro' will be compiled to `fset', + ;; which does not update `load-history'. + ;; We must update `current-load-list' explicitly. + (setq current-load-list + (cons (quote (, name)) current-load-list)) + (put (quote (, name)) 'defmacro-maybe t)))))) + +(defmacro defsubst-maybe-cond (name args &optional doc &rest clauses) + "Define NAME as an inline function if NAME is not defined. +CLAUSES are like those of `cond' expression, but each condition is evaluated +at compile-time and, if the value is non-nil, the body of the clause is used +for function definition of NAME. +See also the macro `defsubst'." + (or (stringp doc) + (setq clauses (cons doc clauses) + doc nil)) + (or (and (fboundp name) + (not (get name 'defsubst-maybe))) + (` (or (fboundp (quote (, name))) + (prog1 + (static-cond + (,@ (mapcar + (function + (lambda (case) + (list (car case) + (if doc + (` (defsubst (, name) (, args) + (, doc) + (,@ (cdr case)))) + (` (defsubst (, name) (, args) + (,@ (cdr case)))))))) + clauses))) + ;; This `defsubst' will be compiled to `fset', + ;; which does not update `load-history'. + ;; We must update `current-load-list' explicitly. + (setq current-load-list + (cons (quote (, name)) current-load-list)) + (put (quote (, name)) 'defsubst-maybe t)))))) + + +;;; Edebug spec. + +;; `def-edebug-spec' is an autoloaded macro in v19 and later. +;; (Note that recent XEmacs provides "edebug" as a separate package.) +(defmacro-maybe def-edebug-spec (symbol spec) + "Set the edebug-form-spec property of SYMBOL according to SPEC. +Both SYMBOL and SPEC are unevaluated. The SPEC can be 0, t, a symbol +\(naming a function\), or a list." + (` (put (quote (, symbol)) 'edebug-form-spec (quote (, spec))))) + +;; edebug-spec for `def*-maybe' macros. +(def-edebug-spec defun-maybe defun) +(def-edebug-spec defmacro-maybe defmacro) +(def-edebug-spec defsubst-maybe defun) +(def-edebug-spec defun-maybe-cond + (&define name lambda-list + [&optional stringp] + [&rest ([¬ eval] [&rest sexp])] + [&optional (eval [&optional ("interactive" interactive)] def-body)] + &rest (&rest sexp))) +(def-edebug-spec defmacro-maybe-cond + (&define name lambda-list + [&rest ([¬ eval] [&rest sexp])] + [&optional (eval def-body)] + &rest (&rest sexp))) +(def-edebug-spec defsubst-maybe-cond + (&define name lambda-list + [&optional stringp] + [&rest ([¬ eval] [&rest sexp])] + [&optional (eval [&optional ("interactive" interactive)] def-body)] + &rest (&rest sexp))) + +;; edebug-spec for `static-*' macros are also defined here. +(def-edebug-spec static-if if) +(def-edebug-spec static-when when) +(def-edebug-spec static-unless unless) +(def-edebug-spec static-condition-case condition-case) +(def-edebug-spec static-defconst defconst) +(def-edebug-spec static-cond cond) + + +;;; for backward compatibility. + +(defun subr-fboundp (symbol) + "Return t if SYMBOL's function definition is a built-in function." + (and (fboundp symbol) + (subrp (symbol-function symbol)))) +;; (make-obsolete 'subr-fboundp "don't use it.") + + +;;; End. + +(require 'product) +(product-provide (provide 'pym) (require 'apel-ver)) + +;;; pym.el ends here diff --git a/poe/static.el b/poe/static.el new file mode 100644 index 0000000..b64440d --- /dev/null +++ b/poe/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) + "`if' expression but COND is evaluated at compile-time." + (if (eval cond) + then + (` (progn (,@ else))))) + +(put 'static-when 'lisp-indent-function 1) +(defmacro static-when (cond &rest body) + "`when' expression but COND is evaluated at compile-time." + (if (eval cond) + (` (progn (,@ body))))) + +(put 'static-unless 'lisp-indent-function 1) +(defmacro static-unless (cond &rest body) + "`unless' expression but COND is evaluated 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) + "`condition-case' expression but BODYFORM is evaluated 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) + "`defconst' expression but INITVALUE is evaluated at compile-time. + +The variable SYMBOL can be referenced at either compile-time or run-time." + (let ((value (eval initvalue))) + (eval (` (defconst (, symbol) (quote (, value)) (, docstring)))) + (` (defconst (, symbol) (quote (, value)) (, docstring))))) + +(defmacro static-cond (&rest clauses) + "`cond' expression but the car of each clause is evaluated 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