From: yamaoka Date: Sun, 29 Nov 1998 23:26:19 +0000 (+0000) Subject: Sync up with Pterodactyl Gnus v0.56. X-Git-Tag: pgnus-ichikawa-199811302358~1 X-Git-Url: http://git.chise.org/gitweb/?a=commitdiff_plain;h=20de093aaddd8a6b720d985764b9a959a8dfcf85;p=elisp%2Fgnus.git- Sync up with Pterodactyl Gnus v0.56. --- diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 1c065cd..9290684 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,43 @@ +Sun Nov 29 15:12:52 1998 Lars Magne Ingebrigtsen + + * gnus.el: Pterodactyl Gnus v0.56 is released. + +1998-11-29 00:52:53 Lars Magne Ingebrigtsen + + * gnus-art.el (gnus-mime-display-part): New function. + (gnus-mime-display-mixed): Use it. + + * mm-view.el (mm-setup-w3): Don't register. + + * message.el (message-cite-original): Cite parts. + +1998-11-28 23:51:25 Lars Magne Ingebrigtsen + + * mml.el (mml-parameter-string): New function. + (mml-insert-mime-headers): Separated into new function. + +1998-11-28 Hrvoje Niksic + + * mml.el (mml-make-boundary): Use `make-string'. + +1998-11-27 Hrvoje Niksic + + * binhex.el (binhex-insert-char): Ditto. + + * base64.el (base64-insert-char): Ditto. + + * uudecode.el (uudecode-insert-char): Code correctly. + +1998-11-28 01:08:19 Lars Magne Ingebrigtsen + + * mml.el (mml-generate-mime): Don't generate multiparts for + empties. + + * gnus-art.el (gnus-display-mime): Save excursion. + + * message.el (message-remove-first-header): New function. + (message-encode-message-body): Use it. + Fri Nov 27 12:26:10 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.55 is released. diff --git a/lisp/base64.el b/lisp/base64.el index 5abc827..d0bb0c2 100644 --- a/lisp/base64.el +++ b/lisp/base64.el @@ -25,6 +25,8 @@ ;;; Boston, MA 02111-1307, USA. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(require 'poe) + ;; For non-MULE (if (not (fboundp 'char-int)) (fset 'char-int 'identity)) @@ -98,23 +100,15 @@ base64-encoder-program.") (delete-file tempfile) (error nil))))) -(defun base64-insert-char (char &optional count ignored buffer) - (condition-case nil - (progn - (insert-char char count ignored buffer) - (fset 'base64-insert-char 'insert-char)) - (wrong-number-of-arguments - (fset 'base64-insert-char 'base64-xemacs-insert-char) - (base64-insert-char char count ignored buffer)))) - -(defun base64-xemacs-insert-char (char &optional count ignored buffer) - (if (or (null buffer) (eq buffer (current-buffer))) - (insert-char char count) - (save-excursion - (set-buffer buffer) - (insert-char char count)))) +(if (string-match "XEmacs" emacs-version) + (defalias 'base64-insert-char 'insert-char) + (defun base64-insert-char (char &optional count ignored buffer) + (if (or (null buffer) (eq buffer (current-buffer))) + (insert-char char count) + (with-current-buffer buffer + (insert-char char count))))) -(defun base64-decode-region (start end) +(defun-maybe base64-decode-region (start end) (interactive "r") ;;(message "Decoding base64...") (let ((work-buffer nil) @@ -182,7 +176,7 @@ base64-encoder-program.") ;;(message "Decoding base64... done") ) -(defun base64-encode-region (start end &optional no-line-break) +(defun-maybe base64-encode-region (start end &optional no-line-break) (interactive "r") (message "Encoding base64...") (let ((work-buffer nil) diff --git a/lisp/binhex.el b/lisp/binhex.el index 09c9b13..ab2ce39 100644 --- a/lisp/binhex.el +++ b/lisp/binhex.el @@ -3,7 +3,7 @@ ;; Author: Shenghuo Zhu ;; Create Date: Oct 1, 1998 -;; $Revision: 1.1.2.3 $ +;; $Revision: 1.1.2.4 $ ;; Time-stamp: ;; Keywords: binhex @@ -65,21 +65,13 @@ input and write the converted data to its standard output.") (defvar binhex-temporary-file-directory "/tmp/") -(defun binhex-insert-char (char &optional count ignored buffer) - (condition-case nil - (progn - (insert-char char count ignored buffer) - (fset 'binhex-insert-char 'insert-char)) - (wrong-number-of-arguments - (fset 'binhex-insert-char 'binhex-xemacs-insert-char) - (binhex-insert-char char count ignored buffer)))) - -(defun binhex-xemacs-insert-char (char &optional count ignored buffer) - (if (or (null buffer) (eq buffer (current-buffer))) - (insert-char char count) - (save-excursion - (set-buffer buffer) - (insert-char char count)))) +(if (string-match "XEmacs" emacs-version) + (defalias 'binhex-insert-char 'insert-char) + (defun binhex-insert-char (char &optional count ignored buffer) + (if (or (null buffer) (eq buffer (current-buffer))) + (insert-char char count) + (with-current-buffer buffer + (insert-char char count))))) (defvar binhex-crc-table [0 4129 8258 12387 16516 20645 24774 28903 diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index 8ccba9b..d56ad3c 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -1947,6 +1947,8 @@ If variable `gnus-use-long-file-name' is non-nil, it is (article-fill . gnus-article-word-wrap) article-remove-cr article-display-x-face + article-de-quoted-unreadable + article-mime-decode-quoted-printable article-hide-pgp article-hide-pem article-hide-signature @@ -1961,6 +1963,9 @@ If variable `gnus-use-long-file-name' is non-nil, it is article-date-iso8601 article-date-original article-date-ut + article-decode-mime-words + article-decode-charset + article-decode-encoded-words article-date-user article-date-lapsed article-emphasize @@ -2061,6 +2066,9 @@ commands: (make-local-variable 'gnus-page-broken) (make-local-variable 'gnus-button-marker-list) (make-local-variable 'gnus-article-current-summary) + (make-local-variable 'gnus-article-mime-handles) + (make-local-variable 'gnus-article-decoded-p) + (make-local-variable 'gnus-article-mime-handle-alist) (gnus-set-default-directory) (buffer-disable-undo) (setq buffer-read-only t) @@ -2077,6 +2085,7 @@ commands: (substring name (match-end 0)))))) (setq gnus-article-buffer name) (setq gnus-original-article-buffer original) + (setq gnus-article-mime-handle-alist nil) ;; This might be a variable local to the summary buffer. (unless gnus-single-article-buffer (save-excursion @@ -2332,8 +2341,8 @@ If ALL-HEADERS is non-nil, no headers are hidden." ;(gnus-mime-view-part "\M-\r" "View Interactively...") (gnus-mime-view-part "v" "View Interactively...") (gnus-mime-save-part "o" "Save...") - (gnus-mime-copy-part "c" "View In Buffer") - (gnus-mime-inline-part "i" "View Inline") + (gnus-mime-copy-part "c" "View As Text, In Other Buffer") + (gnus-mime-inline-part "i" "View As Text, In This Buffer") (gnus-mime-externalize-part "e" "View Externally") (gnus-mime-pipe-part "|" "Pipe To Command..."))) @@ -2569,34 +2578,48 @@ If ALL-HEADERS is non-nil, no headers are hidden." (defun gnus-display-mime (&optional ihandles) "Insert MIME buttons in the buffer." - (save-selected-window - (let ((window (get-buffer-window gnus-article-buffer))) - (when window - (select-window window))) - (let* ((handles (or ihandles (mm-dissect-buffer) (mm-uu-dissect))) - handle name type b e display) - (unless ihandles - ;; Top-level call; we clean up. - (mm-destroy-parts gnus-article-mime-handles) - (setq gnus-article-mime-handles handles - gnus-article-mime-handle-alist nil) - ;; We allow users to glean info from the handles. - (when gnus-article-mime-part-function - (gnus-mime-part-function handles))) - (when (and handles - (or (not (stringp (car handles))) - (cdr handles))) + (save-excursion + (save-selected-window + (let ((window (get-buffer-window gnus-article-buffer))) + (when window + (select-window window))) + (let* ((handles (or ihandles (mm-dissect-buffer) (mm-uu-dissect))) + handle name type b e display) (unless ihandles - ;; Clean up for mime parts. - (article-goto-body) - (delete-region (point) (point-max))) - (if (stringp (car handles)) - (if (equal (car handles) "multipart/alternative") - (let ((id (1+ (length gnus-article-mime-handle-alist)))) - (push (cons id handles) gnus-article-mime-handle-alist) - (gnus-mime-display-alternative (cdr handles) nil nil id)) - (gnus-mime-display-mixed (cdr handles))) - (gnus-mime-display-single handles)))))) + ;; Top-level call; we clean up. + (mm-destroy-parts gnus-article-mime-handles) + (setq gnus-article-mime-handles handles + gnus-article-mime-handle-alist nil) + ;; We allow users to glean info from the handles. + (when gnus-article-mime-part-function + (gnus-mime-part-function handles))) + (when (and handles + (or (not (stringp (car handles))) + (cdr handles))) + (unless ihandles + ;; Clean up for mime parts. + (article-goto-body) + (delete-region (point) (point-max))) + (gnus-mime-display-part handles)))))) + +(defun gnus-mime-display-part (handle) + (cond + ;; Single part. + ((not (stringp (car handle))) + (gnus-mime-display-single handle)) + ;; multipart/alternative + ((equal (car handle) "multipart/alternative") + (let ((id (1+ (length gnus-article-mime-handle-alist)))) + (push (cons id handle) gnus-article-mime-handle-alist) + (gnus-mime-display-alternative (cdr handle) nil nil id))) + ;; multipart/related + ((equal (car handle) "multipart/related") + ;;;!!!We should find the start part, but we just default + ;;;!!!to the first part. + (gnus-mime-display-part (cadr handle))) + ;; Other multiparts are handled like multipart/mixed. + (t + (gnus-mime-display-mixed (cdr handle))))) (defun gnus-mime-part-function (handles) (if (stringp (car handles)) @@ -2606,13 +2629,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." (defun gnus-mime-display-mixed (handles) (let (handle) (while (setq handle (pop handles)) - (if (stringp (car handle)) - (if (equal (car handle) "multipart/alternative") - (let ((id (1+ (length gnus-article-mime-handle-alist)))) - (push (cons id handle) gnus-article-mime-handle-alist) - (gnus-mime-display-alternative (cdr handle) nil nil id)) - (gnus-mime-display-mixed (cdr handle))) - (gnus-mime-display-single handle))))) + (gnus-mime-display-part handle)))) (defun gnus-mime-display-single (handle) (let ((type (car (mm-handle-type handle))) @@ -3995,7 +4012,7 @@ forbidden in URL encoding." (select-window win))) (defvar gnus-decode-header-methods - '(mail-decode-encoded-word-region) + '(gnus-decode-with-mail-decode-encoded-word-region) "List of methods used to decode headers This variable is a list of FUNCTION or (REGEXP . FUNCTION). If item is @@ -4011,6 +4028,10 @@ For example: (defvar gnus-decode-header-methods-cache nil) +(defun gnus-decode-with-mail-decode-encoded-word-region (start end) + (let ((rfc2047-default-charset gnus-default-charset)) + (mail-decode-encoded-word-region start end))) + (defun gnus-multi-decode-header (start end) "Apply the functions from `gnus-encoded-word-methods' that match." (unless (and gnus-decode-header-methods-cache diff --git a/lisp/gnus-sum.el b/lisp/gnus-sum.el index 98b73fd..258c5a7 100644 --- a/lisp/gnus-sum.el +++ b/lisp/gnus-sum.el @@ -810,6 +810,10 @@ which it may alter in any way.") :group 'gnus-summary :type 'regexp) +(defcustom gnus-default-charset 'iso-8859-1 + "Default charset assumed to be used when viewing non-ASCII characters. +This variable is used only in non-Mule Emacsen.") + (defcustom gnus-newsgroup-default-charset-alist '(("^hk\\>\\|^tw\\>\\|\\" . cn-big5) ("^cn\\>\\|\\" . cn-gb-2312) @@ -9184,7 +9188,7 @@ save those articles instead." (setq alist nil charset (cdr elem)))) charset))) - rfc2047-default-charset)) + gnus-default-charset)) (setq gnus-newsgroup-iso-8859-1-forced (and gnus-newsgroup-name (or (gnus-group-find-parameter diff --git a/lisp/gnus.el b/lisp/gnus.el index 17c4c8c..970a8fa 100644 --- a/lisp/gnus.el +++ b/lisp/gnus.el @@ -259,10 +259,10 @@ is restarted, and sometimes reloaded." (defconst gnus-product-name "T-gnus" "Product name of this version of gnus.") -(defconst gnus-version-number "6.10.041" +(defconst gnus-version-number "6.10.042" "Version number for this version of gnus.") -(defconst gnus-original-version-number "0.55" +(defconst gnus-original-version-number "0.56" "Version number for this version of Gnus.") (defconst gnus-original-product-name "Pterodactyl Gnus" diff --git a/lisp/message.el b/lisp/message.el index 7b21aa8..bda36b0 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -574,6 +574,11 @@ The function `message-setup' runs this hook." :group 'message-various :type 'hook) +(defcustom message-cancel-hook nil + "Hook run when cancelling articles." + :group 'message-various + :type 'hook) + (defcustom message-signature-setup-hook nil "Normal hook, run each time a new outgoing message is initialized. It is run after the headers have been inserted and before @@ -978,7 +983,7 @@ Defaults to `text-mode-abbrev-table'.") "\\([" cite-prefix "]+[" cite-suffix "]*\\)?" "[:>|}].*") (0 'message-cited-text-face)) - ("<#/?\\(multi\\)part.*>" + ("<#/?\\(multipart\\|part\\|external\\).*>" (0 'message-mml-face)))) "Additional expressions to highlight in Message mode.") @@ -1036,9 +1041,12 @@ The cdr of ech entry is a function for applying the face to a region.") 'escape-quoted 'emacs-mule) "Coding system to compose mail.") +(defvar message-default-charset 'iso-8859-1 + "Default charset assumed to be used when viewing non-ASCII characters. +This variable is used only in non-Mule Emacsen.") + ;;; Internal variables. -(defvar message-default-charset nil) (defvar message-buffer-list nil) (defvar message-this-is-news nil) (defvar message-this-is-mail nil) @@ -1322,6 +1330,18 @@ Return the number of headers removed." (goto-char (point-max))))) number)) +(defun message-remove-first-header (header) + "Remove the first instance of HEADER if there is more than one." + (let ((count 0) + (regexp (concat "^" (regexp-quote header) ":"))) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (incf count))) + (while (> count 1) + (message-remove-header header nil t) + (decf count)))) + (defun message-narrow-to-headers () "Narrow the buffer to the head of the message." (widen) @@ -2032,7 +2052,7 @@ prefix, and don't delete any headers." (list message-indent-citation-function))))) (goto-char start) ;; Quote parts. - (while (re-search-forward "<#/?!*\\(multi\\|part\\)>" end t) + (while (re-search-forward "<#/?!*\\(multipart\\|part\\|external\\)" end t) (goto-char (match-beginning 1)) (insert "!")) (goto-char end) @@ -2066,7 +2086,8 @@ prefix, and don't delete any headers." (list message-indent-citation-function))))) (goto-char start) ;; Quote parts. - (while (re-search-forward "<#/?!*\\(multi\\|part\\)>" end t) + (while (re-search-forward + "<#/?!*\\(multipart\\|part\\|external\\)" end t) (goto-char (match-beginning 1)) (insert "!")) (goto-char start) @@ -4202,6 +4223,7 @@ that further discussion should take place only in " "") mail-header-separator "\n" message-cancel-message) + (run-hooks 'message-cancel-hook) (message "Canceling your article...") (if (let ((message-syntax-checks 'dont-check-for-anything-just-trust-me) @@ -4754,7 +4776,7 @@ regexp varstr." ;;; MIME functions ;;; -(defun message-insert-mime-part (file type) +(defun message-insert-mime-part (file type description) "Insert a multipart/alternative part into the buffer." (interactive (let* ((file (read-file-name "Insert file: " nil nil t)) @@ -4764,24 +4786,45 @@ regexp varstr." (format "MIME type for %s: " file) (delete-duplicates (mapcar (lambda (m) (list (cdr m))) mailcap-mime-extensions)) + nil nil type) + (read-string "Description: ")))) + (insert (format "<#part type=%s filename=\"%s\"%s><#/part>\n" + type file + (if (zerop (length description)) + "" + (format " description=%s" + (prin1-to-string description)))))) + +(defun message-mime-insert-external (file type) + "Insert a message/external-body part into the buffer." + (interactive + (let* ((file (read-file-name "Insert file: ")) + (type (mm-default-file-encoding file))) + (list file + (completing-read + (format "MIME type for %s: " file) + (delete-duplicates + (mapcar (lambda (m) (list (cdr m))) mailcap-mime-extensions)) nil nil type)))) - (insert (format "<#part type=%s filename=\"%s\"><#/part>\n" + (insert (format "<#external type=%s name=\"%s\"><#/external>\n" type file))) (defun message-encode-message-body () - (let (lines multipart-p) + (let ((mm-default-charset message-default-charset) + lines multipart-p) (message-goto-body) (save-restriction (narrow-to-region (point) (point-max)) (let ((new (mml-generate-mime))) - (delete-region (point-min) (point-max)) - (insert new) - (goto-char (point-min)) - (if (eq (aref new 0) ?\n) - (delete-char 1) - (search-forward "\n\n") - (setq lines (buffer-substring (point-min) (1- (point)))) - (delete-region (point-min) (point))))) + (when new + (delete-region (point-min) (point-max)) + (insert new) + (goto-char (point-min)) + (if (eq (aref new 0) ?\n) + (delete-char 1) + (search-forward "\n\n") + (setq lines (buffer-substring (point-min) (1- (point)))) + (delete-region (point-min) (point)))))) (save-restriction (message-narrow-to-headers-or-head) (message-remove-header "Mime-Version") @@ -4792,6 +4835,10 @@ regexp varstr." (setq multipart-p (re-search-backward "^Content-Type: multipart/" nil t))) (when multipart-p + (save-restriction + (message-narrow-to-headers-or-head) + (message-remove-first-header "Content-Type") + (message-remove-first-header "Content-Transfer-Encoding")) (message-goto-body) (insert "This is a MIME multipart message. If you are reading\n") (insert "this, you shouldn't.\n")))) diff --git a/lisp/mm-bodies.el b/lisp/mm-bodies.el index 09a776e..2cf5a4f 100644 --- a/lisp/mm-bodies.el +++ b/lisp/mm-bodies.el @@ -33,6 +33,10 @@ (require 'qp) (require 'uudecode) +;; 8bit treatment gets any char except: 0x32 - 0x7f, CR, LF, TAB, BEL, +;; BS, vertical TAB, form feed, and ^_ +(defvar mm-8bit-char-regexp "[^\x20-\x7f\r\n\t\x7\x8\xb\xc\x1f]") + (defun mm-encode-body () "Encode a body. Should be called narrowed to the body that is to be encoded. @@ -41,7 +45,15 @@ MULE charsets are returned. If successful, the MIME charset is returned. If no encoding was done, nil is returned." (if (not (featurep 'mule)) - 'iso-8859-1 + ;; In the non-Mule case, we search for non-ASCII chars and + ;; return the value of `mm-default-charset' if any are found. + (save-excursion + (goto-char (point-min)) + (if (re-search-forward "[^\x0-\x7f]" nil t) + mm-default-charset + ;; The logic in `mml-generate-mime-1' confirms that it's OK + ;; to return nil here. + nil)) (save-excursion (goto-char (point-min)) (let ((charsets @@ -81,18 +93,24 @@ If no encoding was done, nil is returned." (defun mm-body-encoding () "Return the encoding of the current buffer." - (if (and - (featurep 'mule) - (null (delq 'ascii (find-charset-region (point-min) (point-max)))) - ;;;!!!The following is necessary because the function - ;;;!!!above seems to return the wrong result under Emacs 20.3. - ;;;!!!Sometimes. - (save-excursion - (goto-char (point-min)) - (skip-chars-forward "\0-\177") - (eobp))) - '7bit - '8bit)) + (cond ((not (featurep 'mule)) + (if (save-excursion + (goto-char (point-min)) + (re-search-forward mm-8bit-char-regexp nil t)) + '8bit + '7bit)) + (t + ;; Mule version + (if (and (null (delq 'ascii (find-charset-region (point-min) (point-max)))) + ;;!!!The following is necessary because the function + ;;!!!above seems to return the wrong result under + ;;!!!Emacs 20.3. Sometimes. + (save-excursion + (goto-char (point-min)) + (skip-chars-forward "\0-\177") + (eobp))) + '7bit + '8bit)))) ;;; ;;; Functions for decoding diff --git a/lisp/mm-decode.el b/lisp/mm-decode.el index 916a82a..106ec14 100644 --- a/lisp/mm-decode.el +++ b/lisp/mm-decode.el @@ -529,30 +529,6 @@ This overrides entries in the mailcap file." (< (glyph-height (annotation-glyph image)) (window-pixel-height))))) -(defun url-cid (url) - (set-buffer (get-buffer-create url-working-buffer)) - (let ((content-type nil) - (encoding nil) - (part nil) - (data nil)) - (if (not (string-match "^cid:\\(.*\\)" url)) - (message "Malformed CID URL: %s" url) - (setq url (url-unhex-string (match-string 1 url)) - part (mm-get-content-id url)) - (if (not part) - (message "Unknown CID encounterred: %s" url) - (setq data (buffer-string nil nil (mm-handle-buffer part)) - content-type (mm-handle-type part) - encoding (symbol-name (mm-handle-encoding part))) - (if (= 0 (length content-type)) (setq content-type "text/plain")) - (if (= 0 (length encoding)) (setq encoding "8bit")) - (setq url-current-content-length (length data) - url-current-mime-type content-type - url-current-mime-encoding encoding - url-current-mime-headers (list (cons "content-type" content-type) - (cons "content-encoding" encoding))) - (and data (insert data)))))) - (provide 'mm-decode) ;; mm-decode.el ends here diff --git a/lisp/mm-util.el b/lisp/mm-util.el index 29c65ac..b7811b2 100644 --- a/lisp/mm-util.el +++ b/lisp/mm-util.el @@ -24,8 +24,10 @@ ;;; Code: +(defvar mm-running-xemacs (string-match "XEmacs" emacs-version)) + (defvar mm-binary-coding-system - (if (string-match "XEmacs" emacs-version) + (if mm-running-xemacs 'binary 'no-conversion) "100% binary coding system.") @@ -33,7 +35,13 @@ "The default coding system to use.") (defvar mm-known-charsets '(iso-8859-1) - "List of known charsets.") + "List of known charsets. +Use this under non-Mule Emacsen to specify which charsets your Emacs +can display. Also see `mm-default-charset'.") + +(defvar mm-default-charset 'iso-8859-1 + "Default charset assumed to be used when viewing non-ASCII characters. +This variable is used only in non-Mule Emacsen.") (defvar mm-mime-mule-charset-alist '((us-ascii ascii) @@ -154,7 +162,8 @@ used as the line break code type of the coding system." (cond ;; Running in a non-MULE environment. ((and (null (mm-get-coding-system-list)) - (memq charset mm-known-charsets)) + (or (eq charset mm-default-charset) + (memq charset mm-known-charsets))) charset) ;; ascii ((eq charset 'us-ascii) diff --git a/lisp/mm-view.el b/lisp/mm-view.el index d366bdc..74a4703 100644 --- a/lisp/mm-view.el +++ b/lisp/mm-view.el @@ -45,7 +45,7 @@ (w3-do-setup) (require 'url) (require 'w3-vars) - (url-register-protocol 'cid nil 'url-identity-expander) + (load "url-misc.el") (setq mm-w3-setup t))) (defun mm-inline-text (handle) diff --git a/lisp/mml.el b/lisp/mml.el index 01c4773..a7f7ffc 100644 --- a/lisp/mml.el +++ b/lisp/mml.el @@ -27,6 +27,9 @@ (require 'mm-bodies) (require 'mm-encode) +(eval-and-compile + (autoload 'message-make-message-id "message")) + (defvar mml-syntax-table (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table))) (modify-syntax-entry ?\\ "/" table) @@ -61,6 +64,9 @@ ((looking-at "<#part") (push (nconc (mml-read-tag) (list (cons 'contents (mml-read-part)))) struct)) + ((looking-at "<#external") + (push (nconc (mml-read-tag) (list (cons 'contents (mml-read-part)))) + struct)) (t (push (list 'part '(type . "text/plain") (cons 'contents (mml-read-part))) struct)))) @@ -91,10 +97,10 @@ ;; If the tag ended at the end of the line, we go to the next line. (when (looking-at "[ \t]*\n") (forward-line 1)) - (if (re-search-forward "<#/?\\(multi\\)?part." nil t) + (if (re-search-forward "<#/?\\(multipart\\|part\\|external\\)." nil t) (prog1 (buffer-substring beg (match-beginning 0)) - (if (not (equal (match-string 0) "<#/part>")) + (if (equal (match-string 0) "<#/multipart>") (goto-char (match-beginning 0)) (when (looking-at "[ \t]*\n") (forward-line 1)))) @@ -108,18 +114,20 @@ "Generate a MIME message based on the current MML document." (let ((cont (mml-parse)) (mml-multipart-number 0)) - (with-temp-buffer - (if (and (consp (car cont)) - (= (length cont) 1)) - (mml-generate-mime-1 (car cont)) - (mml-generate-mime-1 (nconc (list 'multipart '(type . "mixed")) - cont))) - (buffer-string)))) + (if (not cont) + nil + (with-temp-buffer + (if (and (consp (car cont)) + (= (length cont) 1)) + (mml-generate-mime-1 (car cont)) + (mml-generate-mime-1 (nconc (list 'multipart '(type . "mixed")) + cont))) + (buffer-string))))) (defun mml-generate-mime-1 (cont) (cond ((eq (car cont) 'part) - (let (coded encoding charset filename type) + (let (coded encoding charset filename type parameters) (setq type (or (cdr (assq 'type cont)) "text/plain")) (if (equal (car (split-string type "/")) "text") (with-temp-buffer @@ -130,7 +138,8 @@ (insert (cdr (assq 'contents cont))) ;; Remove quotes from quoted tags. (goto-char (point-min)) - (while (re-search-forward "<#!+\\(part\\|multipart\\)" nil t) + (while (re-search-forward + "<#!+\\(part\\|multipart\\|external\\)" nil t) (delete-region (+ (match-beginning 0) 2) (+ (match-beginning 0) 3))))) (setq charset (mm-encode-body) @@ -142,16 +151,38 @@ (insert (cdr (assq 'contents cont)))) (setq encoding (mm-encode-buffer type) coded (buffer-string)))) - (when (or charset - (not (equal type "text/plain"))) - (insert "Content-Type: " type) - (when charset - (insert (format "; charset=\"%s\"" charset))) - (insert "\n")) - (unless (eq encoding '7bit) - (insert (format "Content-Transfer-Encoding: %s\n" encoding))) + (mml-insert-mime-headers cont type charset encoding) (insert "\n") (insert coded))) + ((eq (car cont) 'external) + (insert "Content-Type: message/external-body") + (let ((parameters (mml-parameter-string + cont '(expiration size permission))) + (name (cdr (assq 'name cont)))) + (when name + (setq name (mml-parse-file-name name)) + (if (stringp name) + (insert ";\n name=\"" (prin1-to-string name) + "\";\n access-type=local-file") + (insert + (format ";\n name=%S;\n site=%S;\n directory=%S" + (file-name-nondirectory (nth 2 name)) + (nth 1 name) + (file-name-directory (nth 2 name)))) + (insert ";\n access-type=" + (if (member (nth 0 name) '("ftp@" "anonymous@")) + "anon-ftp" + "ftp")))) + (when parameters + (insert parameters))) + (insert "\n\n") + (insert "Content-Type: " (cdr (assq 'type cont)) "\n") + (insert "Content-ID: " (message-make-message-id) "\n") + (insert "Content-Transfer-Encoding: " + (or (cdr (assq 'encoding cont)) "binary")) + (insert "\n\n") + (insert (or (cdr (assq 'contents cont)))) + (insert "\n")) ((eq (car cont) 'multipart) (let ((mml-boundary (mml-compute-boundary cont))) (insert (format "Content-Type: multipart/%s; boundary=\"%s\"\n" @@ -192,7 +223,7 @@ t)) (defun mml-make-boundary () - (concat (mml-make-string (% (incf mml-multipart-number) 60) "=") + (concat (make-string (% (incf mml-multipart-number) 60) ?=) (if (> mml-multipart-number 17) (format "%x" mml-multipart-number) "") @@ -204,6 +235,57 @@ (setq out (concat out string))) out)) +(defun mml-insert-mime-headers (cont type charset encoding) + (let (parameters disposition description) + (when (or charset + (setq parameters + (mml-parameter-string + cont '(name access-type expiration size permission))) + (not (equal type "text/plain"))) + (insert "Content-Type: " type) + (when charset + (insert (format "; charset=\"%s\"" charset))) + (when parameters + (insert parameters)) + (insert "\n")) + (when (or (setq disposition (cdr (assq 'disposition cont))) + (setq parameters + (mml-parameter-string + cont '(filename creation-date modification-date + read-date)))) + (insert "Content-Disposition: " (or disposition "inline")) + (when parameters + (insert parameters)) + (insert "\n")) + (unless (eq encoding '7bit) + (insert (format "Content-Transfer-Encoding: %s\n" encoding))) + (when (setq description (cdr (assq 'description cont))) + (insert "Content-Description: " description "\n")) + )) + +(defun mml-parameter-string (cont types) + (let ((string "") + value type) + (while (setq type (pop types)) + (when (setq value (cdr (assq type cont))) + (setq string (concat string ";\n " (symbol-name type) "=" + (if (string-match "[^_0-9A-Za-z]" value) + (prin1-to-string value) + value))))) + (when (not (zerop (length string))) + string))) + +(defvar ange-ftp-path-format) +(defvar efs-path-regexp) +(defun mml-parse-file-name (path) + (if (if (boundp 'efs-path-regexp) + (string-match efs-path-regexp path) + (if (boundp 'ange-ftp-path-format) + (string-match (car ange-ftp-path-format)))) + (list (match-string 1 path) (match-string 2 path) + (substring path (1+ (match-end 2)))) + path)) + (provide 'mml) ;;; mml.el ends here diff --git a/lisp/uudecode.el b/lisp/uudecode.el index 3d03c5d..eb97109 100644 --- a/lisp/uudecode.el +++ b/lisp/uudecode.el @@ -106,21 +106,13 @@ If FILE-NAME is non-nil, save the result to FILE-NAME." (error)) ))) -(defun uudecode-insert-char (char &optional count ignored buffer) - (condition-case nil - (progn - (insert-char char count ignored buffer) - (fset 'uudecode-insert-char 'insert-char)) - (wrong-number-of-arguments - (fset 'uudecode-insert-char 'uudecode-xemacs-insert-char) - (uudecode-insert-char char count ignored buffer)))) - -(defun uudecode-xemacs-insert-char (char &optional count ignored buffer) - (if (or (null buffer) (eq buffer (current-buffer))) - (insert-char char count) - (save-excursion - (set-buffer buffer) - (insert-char char count)))) +(if (string-match "XEmacs" emacs-version) + (defalias 'uudecode-insert-char 'insert-char) + (defun uudecode-insert-char (char &optional count ignored buffer) + (if (or (null buffer) (eq buffer (current-buffer))) + (insert-char char count) + (with-current-buffer buffer + (insert-char char count))))) ;;;###autoload