*** pub/pgnus/lisp/base64.el Sat Aug 29 22:25:14 1998 --- pgnus/lisp/base64.el Sun Aug 30 17:47:59 1998 *************** *** 237,244 **** (base64-insert-char (aref alphabet (logand (lsh bits -6) 63)) 1 nil work-buffer) (base64-insert-char ?= 1 nil work-buffer))) ! (if (> cols 0) ! (base64-insert-char ?\n 1 nil work-buffer))) (or (markerp end) (setq end (set-marker (make-marker) end))) (goto-char start) (insert-buffer-substring work-buffer) --- 237,247 ---- (base64-insert-char (aref alphabet (logand (lsh bits -6) 63)) 1 nil work-buffer) (base64-insert-char ?= 1 nil work-buffer))) ! ;;;!!! LMI removed this, because he didn't like having ! ;;;!!! newlines added to the end of the encoding. ! ;;(if (> cols 0) ! ;; (base64-insert-char ?\n 1 nil work-buffer)) ! ) (or (markerp end) (setq end (set-marker (make-marker) end))) (goto-char start) (insert-buffer-substring work-buffer) *** pub/pgnus/lisp/gnus-art.el Sun Aug 30 15:28:12 1998 --- pgnus/lisp/gnus-art.el Sun Aug 30 17:47:59 1998 *************** *** 962,968 **** (buffer-read-only nil)) (save-restriction (message-narrow-to-head) ! (mm-decode-words-region (point-min) (point-max))))) (defun article-de-quoted-unreadable (&optional force) "Translate a quoted-printable-encoded article. --- 962,968 ---- (buffer-read-only nil)) (save-restriction (message-narrow-to-head) ! (rfc1522-decode-region (point-min) (point-max))))) (defun article-de-quoted-unreadable (&optional force) "Translate a quoted-printable-encoded article. *** pub/pgnus/lisp/gnus-sum.el Sat Aug 29 22:25:17 1998 --- pgnus/lisp/gnus-sum.el Sun Aug 30 17:48:00 1998 *************** *** 3057,3064 **** (setq header (make-full-mail-header number ; number ! (mm-decode-words-string (gnus-nov-field)) ; subject ! (mm-decode-words-string (gnus-nov-field)) ; from (gnus-nov-field) ; date (or (gnus-nov-field) (nnheader-generate-fake-message-id)) ; id --- 3057,3064 ---- (setq header (make-full-mail-header number ; number ! (rfc1522-decode-string (gnus-nov-field)) ; subject ! (rfc1522-decode-string (gnus-nov-field)) ; from (gnus-nov-field) ; date (or (gnus-nov-field) (nnheader-generate-fake-message-id)) ; id *************** *** 4400,4412 **** (progn (goto-char p) (if (search-forward "\nsubject: " nil t) ! (mm-decode-words-string (nnheader-header-value)) "(none)")) ;; From. (progn (goto-char p) (if (search-forward "\nfrom: " nil t) ! (mm-decode-words-string (nnheader-header-value)) "(nobody)")) ;; Date. (progn --- 4400,4412 ---- (progn (goto-char p) (if (search-forward "\nsubject: " nil t) ! (rfc1522-decode-string (nnheader-header-value)) "(none)")) ;; From. (progn (goto-char p) (if (search-forward "\nfrom: " nil t) ! (rfc1522-decode-string (nnheader-header-value)) "(nobody)")) ;; Date. (progn *** pub/pgnus/lisp/gnus.el Sun Aug 30 15:28:13 1998 --- pgnus/lisp/gnus.el Sun Aug 30 17:48:00 1998 *************** *** 250,256 **** :link '(custom-manual "(gnus)Exiting Gnus") :group 'gnus) ! (defconst gnus-version-number "0.8" "Version number for this version of Gnus.") (defconst gnus-version (format "Pterodactyl Gnus v%s" gnus-version-number) --- 250,256 ---- :link '(custom-manual "(gnus)Exiting Gnus") :group 'gnus) ! (defconst gnus-version-number "0.9" "Version number for this version of Gnus.") (defconst gnus-version (format "Pterodactyl Gnus v%s" gnus-version-number) *************** *** 1571,1577 **** ("info" Info-goto-node) ("pp" pp pp-to-string pp-eval-expression) ("qp" quoted-printable-decode-region quoted-printable-decode-string) ! ("mm-decode" mm-decode-words-region mm-decode-words-string) ("ps-print" ps-print-preprint) ("mail-extr" mail-extract-address-components) ("browse-url" browse-url) --- 1571,1577 ---- ("info" Info-goto-node) ("pp" pp pp-to-string pp-eval-expression) ("qp" quoted-printable-decode-region quoted-printable-decode-string) ! ("rfc1522" rfc1522-decode-region rfc1522-decode-string) ("ps-print" ps-print-preprint) ("mail-extr" mail-extract-address-components) ("browse-url" browse-url) *** pub/pgnus/lisp/message.el Sun Aug 30 15:28:13 1998 --- pgnus/lisp/message.el Sun Aug 30 17:48:00 1998 *************** *** 39,45 **** (if (string-match "XEmacs\\|Lucid" emacs-version) (require 'mail-abbrevs) (require 'mailabbrev)) ! (require 'mm-encode) (defgroup message '((user-mail-address custom-variable) (user-full-name custom-variable)) --- 39,45 ---- (if (string-match "XEmacs\\|Lucid" emacs-version) (require 'mail-abbrevs) (require 'mailabbrev)) ! (require 'rfc1522) (defgroup message '((user-mail-address custom-variable) (user-full-name custom-variable)) *************** *** 2020,2026 **** (let ((message-deletable-headers (if news nil message-deletable-headers))) (message-generate-headers message-required-mail-headers)) ! (mm-encode-message-header) ;; Let the user do all of the above. (run-hooks 'message-header-hook)) (unwind-protect --- 2020,2026 ---- (let ((message-deletable-headers (if news nil message-deletable-headers))) (message-generate-headers message-required-mail-headers)) ! (rfc1522-encode-message-header) ;; Let the user do all of the above. (run-hooks 'message-header-hook)) (unwind-protect *************** *** 2191,2197 **** (message-narrow-to-headers) ;; Insert some headers. (message-generate-headers message-required-news-headers) ! (mm-encode-message-header) ;; Let the user do all of the above. (run-hooks 'message-header-hook)) (message-cleanup-headers) --- 2191,2197 ---- (message-narrow-to-headers) ;; Insert some headers. (message-generate-headers message-required-news-headers) ! (rfc1522-encode-message-header) ;; Let the user do all of the above. (run-hooks 'message-header-hook)) (message-cleanup-headers) *** pub/pgnus/lisp/mm-decode.el Sun Aug 30 15:28:13 1998 --- pgnus/lisp/mm-decode.el Sun Aug 30 17:48:01 1998 *************** *** 3,9 **** ;; Author: Lars Magne Ingebrigtsen ;; MORIOKA Tomohiko ! ;; This file is not yet part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by --- 3,9 ---- ;; Author: Lars Magne Ingebrigtsen ;; MORIOKA Tomohiko ! ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by *************** *** 24,149 **** ;;; Code: - (require 'base64) - (require 'qp) - (require 'nnheader) - - (defvar mm-charset-regexp (concat "[^" "][\000-\040()<>@,\;:\\\"/?.=" "]+")) - - (defvar mm-encoded-word-regexp - (concat "=\\?\\(" mm-charset-regexp "\\)\\?\\(B\\|Q\\)\\?" - "\\([!->@-~]+\\)\\?=")) - - (defun mm-decode-words-region (start end) - "Decode MIME-encoded words in region between START and END." - (interactive "r") - (save-excursion - (save-restriction - (narrow-to-region start end) - (goto-char (point-min)) - ;; Remove whitespace between encoded words. - (while (re-search-forward - (concat "\\(" mm-encoded-word-regexp "\\)" - "\\(\n?[ \t]\\)+" - "\\(" mm-encoded-word-regexp "\\)") - nil t) - (delete-region (goto-char (match-end 1)) (match-beginning 6))) - ;; Decode the encoded words. - (goto-char (point-min)) - (while (re-search-forward mm-encoded-word-regexp nil t) - (insert (mm-decode-word - (prog1 - (match-string 0) - (delete-region (match-beginning 0) (match-end 0))))))))) - - (defun mm-decode-words-string (string) - "Decode the quoted-printable-encoded STRING and return the results." - (with-temp-buffer - (insert string) - (inline - (mm-decode-words-region (point-min) (point-max))) - (buffer-string))) - - (defun mm-decode-word (word) - "Decode WORD and return it if it is an encoded word. - Return WORD if not." - (if (not (string-match mm-encoded-word-regexp word)) - word - (or - (condition-case nil - (mm-decode-text - (match-string 1 word) - (upcase (match-string 2 word)) - (match-string 3 word)) - (error word)) - word))) - - (eval-and-compile - (if (fboundp 'decode-coding-string) - (fset 'mm-decode-coding-string 'decode-coding-string) - (fset 'mm-decode-coding-string (lambda (s a) s)))) - - (eval-and-compile - (if (fboundp 'coding-system-list) - (fset 'mm-coding-system-list 'coding-system-list) - (fset 'mm-coding-system-list 'ignore))) - - (defun mm-decode-text (charset encoding string) - "Decode STRING as an encoded text. - Valid ENCODINGs are \"B\" and \"Q\". - If your Emacs implementation can't decode CHARSET, it returns nil." - (let ((cs (mm-charset-to-coding-system charset))) - (when cs - (mm-decode-coding-string - (cond - ((equal "B" encoding) - (base64-decode string)) - ((equal "Q" encoding) - (quoted-printable-decode-string - (nnheader-replace-chars-in-string string ?_ ? ))) - (t (error "Invalid encoding: %s" encoding))) - cs)))) - - (defvar mm-charset-coding-system-alist - (let ((rest - '((us-ascii . iso-8859-1) - (gb2312 . cn-gb-2312) - (iso-2022-jp-2 . iso-2022-7bit-ss2) - (x-ctext . ctext))) - (systems (mm-coding-system-list)) - dest) - (while rest - (let ((pair (car rest))) - (unless (memq (car pair) systems) - (setq dest (cons pair dest)))) - (setq rest (cdr rest))) - dest) - "Charset/coding system alist.") - - (defun mm-charset-to-coding-system (charset &optional lbt) - "Return coding-system corresponding to CHARSET. - CHARSET is a symbol naming a MIME charset. - If optional argument LBT (`unix', `dos' or `mac') is specified, it is - used as the line break code type of the coding system." - (when (stringp charset) - (setq charset (intern (downcase charset)))) - (setq charset - (or (cdr (assq charset mm-charset-coding-system-alist)) - charset)) - (when lbt - (setq charset (intern (format "%s-%s" charset lbt)))) - (cond - ;; Running in a non-MULE environment. - ((and (null (mm-coding-system-list)) - (eq charset 'iso-8859-1)) - charset) - ;; Check to see whether we can handle this charset. - ((memq charset (mm-coding-system-list)) - charset) - ;; Nope. - (t - nil))) - (provide 'mm-decode) ! ;; qp.el ends here --- 24,29 ---- ;;; Code: (provide 'mm-decode) ! ;; mm-decode.el ends here *** pub/pgnus/lisp/mm-encode.el Sun Aug 30 15:28:13 1998 --- pgnus/lisp/mm-encode.el Sun Aug 30 17:48:01 1998 *************** *** 3,9 **** ;; Author: Lars Magne Ingebrigtsen ;; MORIOKA Tomohiko ! ;; This file is not yet part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by --- 3,9 ---- ;; Author: Lars Magne Ingebrigtsen ;; MORIOKA Tomohiko ! ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by *************** *** 23,201 **** ;;; Commentary: ;;; Code: - - (defvar mm-header-encoding-alist - '(("X-Nsubject" . iso-2022-jp-2) - ("Newsgroups" . nil) - ("Message-ID" . nil) - (t . mime)) - "*Header/encoding method alist. - The list is traversed sequentially. The keys can either be a - header regexp or `t'. - - The values can be: - - 1) nil, in which case no encoding is done; - 2) `mime', in which case the header will be encoded according to RFC1522; - 3) a charset, in which case it will be encoded as that charse; - 4) `default', in which case the field will be encoded as the rest - of the article.") - - (defvar mm-mime-mule-charset-alist - '((us-ascii ascii) - (iso-8859-1 latin-iso8859-1) - (iso-8859-2 latin-iso8859-2) - (iso-8859-3 latin-iso8859-3) - (iso-8859-4 latin-iso8859-4) - (iso-8859-5 cyrillic-iso8859-5) - (koi8-r cyrillic-iso8859-5) - (iso-8859-6 arabic-iso8859-6) - (iso-8859-7 greek-iso8859-7) - (iso-8859-8 hebrew-iso8859-8) - (iso-8859-9 latin-iso8859-9) - (iso-2022-jp latin-jisx0201 - japanese-jisx0208-1978 japanese-jisx0208) - (euc-kr korean-ksc5601) - (cn-gb-2312 chinese-gb2312) - (cn-big5 chinese-big5-1 chinese-big5-2) - (iso-2022-jp-2 latin-iso8859-1 greek-iso8859-7 - latin-jisx0201 japanese-jisx0208-1978 - chinese-gb2312 japanese-jisx0208 - korean-ksc5601 japanese-jisx0212) - (iso-2022-int-1 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 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)) - "Alist of MIME-charset/MULE-charsets.") - - (defvar mm-mime-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-kr . B) - (gb2312 . B) - (cn-gb . B) - (cn-gb-2312 . B) - (euc-kr . B) - (iso-2022-jp-2 . B) - (iso-2022-int-1 . B)) - "Alist of MIME charsets to MIME encodings. - Valid encodings are nil, `Q' and `B'.") - - (defvar mm-mime-encoding-function-alist - '((Q . quoted-printable-encode-region) - (B . base64-encode-region) - (nil . ignore)) - "Alist of MIME encodings to encoding functions.") - - (defun mm-encode-message-header () - "Encode the message header according to `mm-header-encoding-alist'." - (when (featurep 'mule) - (save-excursion - (save-restriction - (message-narrow-to-headers) - (let ((alist mm-header-encoding-alist) - elem method) - (while (not (eobp)) - (save-restriction - (message-narrow-to-field) - (when (find-non-ascii-charset-region (point-min) (point-max)) - ;; We found something that may perhaps be encoded. - (while (setq elem (pop alist)) - (when (or (and (stringp (car elem)) - (looking-at (car elem))) - (eq (car elem) t)) - (setq alist nil - method (cdr elem)))) - (when method - (cond - ((eq method 'mime) - (mm-encode-words-region (point-min) (point-max))) - ;; Hm. - (t)))) - (goto-char (point-max))))))))) - - (defun mm-encode-words-region (b e) - "Encode all encodable words in REGION." - (let (prev c start qstart qprev qend) - (save-excursion - (goto-char b) - (while (re-search-forward "[^ \t\n]+" nil t) - (save-restriction - (narrow-to-region (match-beginning 0) (match-end 0)) - (goto-char (setq start (point-min))) - (setq prev nil) - (while (not (eobp)) - (unless (eq (setq c (char-charset (following-char))) 'ascii) - (cond - ((eq c prev) - ) - ((null prev) - (setq qstart (or qstart start) - qend (point-max) - qprev c) - (setq prev c)) - (t - ;(mm-encode-word-region start (setq start (point)) prev) - (setq prev c) - ))) - (forward-char 1))) - (when (and (not prev) qstart) - (mm-encode-word-region qstart qend qprev) - (setq qstart nil))) - (when qstart - (mm-encode-word-region qstart qend qprev) - (setq qstart nil))))) - - (defun mm-encode-words-string (string) - "Encode words in STRING." - (with-temp-buffer - (insert string) - (mm-encode-words-region (point-min) (point-max)) - (buffer-string))) - - (defun mm-mule-charset-to-mime-charset (charset) - "Return the MIME charset corresponding to MULE CHARSET." - (let ((alist mm-mime-mule-charset-alist) - out) - (while alist - (when (memq charset (cdar alist)) - (setq out (caar alist) - alist nil)) - (pop alist)) - out)) - - (defun mm-encode-word-region (b e charset) - "Encode the word in the region with CHARSET." - (let* ((mime-charset (mm-mule-charset-to-mime-charset charset)) - (encoding (cdr (assq mime-charset mm-mime-charset-encoding-alist)))) - (save-restriction - (narrow-to-region b e) - (funcall (cdr (assq encoding mm-mime-encoding-function-alist)) - b e) - (goto-char (point-min)) - (insert "=?" (upcase (symbol-name mime-charset)) "?" - (symbol-name encoding) "?") - (goto-char (point-max)) - (insert "?=")))) (provide 'mm-encode) --- 23,28 ---- *** pub/pgnus/lisp/mm-util.el Sun Aug 30 17:48:04 1998 --- pgnus/lisp/mm-util.el Sun Aug 30 17:48:01 1998 *************** *** 0 **** --- 1,144 ---- + ;;; mm-util.el --- Utility functions for MIME things + ;; Copyright (C) 1998 Free Software Foundation, Inc. + + ;; Author: Lars Magne Ingebrigtsen + ;; MORIOKA Tomohiko + ;; This file is part of GNU Emacs. + + ;; GNU Emacs is free software; you can redistribute it and/or modify + ;; it under the terms of the GNU General Public License as published by + ;; the Free Software Foundation; either version 2, or (at your option) + ;; any later version. + + ;; GNU Emacs is distributed in the hope that it will be useful, + ;; but WITHOUT ANY WARRANTY; without even the implied warranty of + ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;; GNU General Public License for more details. + + ;; 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: + + (eval-and-compile + (if (fboundp 'decode-coding-string) + (fset 'mm-decode-coding-string 'decode-coding-string) + (fset 'mm-decode-coding-string (lambda (s a) s)))) + + (eval-and-compile + (if (fboundp 'encode-coding-string) + (fset 'mm-encode-coding-string 'encode-coding-string) + (fset 'mm-encode-coding-string (lambda (s a) s)))) + + (eval-and-compile + (if (fboundp 'coding-system-list) + (fset 'mm-coding-system-list 'coding-system-list) + (fset 'mm-coding-system-list 'ignore))) + + (defvar mm-mime-mule-charset-alist + '((us-ascii ascii) + (iso-8859-1 latin-iso8859-1) + (iso-8859-2 latin-iso8859-2) + (iso-8859-3 latin-iso8859-3) + (iso-8859-4 latin-iso8859-4) + (iso-8859-5 cyrillic-iso8859-5) + (koi8-r cyrillic-iso8859-5) + (iso-8859-6 arabic-iso8859-6) + (iso-8859-7 greek-iso8859-7) + (iso-8859-8 hebrew-iso8859-8) + (iso-8859-9 latin-iso8859-9) + (iso-2022-jp latin-jisx0201 + japanese-jisx0208-1978 japanese-jisx0208) + (euc-kr korean-ksc5601) + (cn-gb-2312 chinese-gb2312) + (cn-big5 chinese-big5-1 chinese-big5-2) + (iso-2022-jp-2 latin-iso8859-1 greek-iso8859-7 + latin-jisx0201 japanese-jisx0208-1978 + chinese-gb2312 japanese-jisx0208 + korean-ksc5601 japanese-jisx0212) + (iso-2022-int-1 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 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)) + "Alist of MIME-charset/MULE-charsets.") + + (defvar mm-charset-coding-system-alist + (let ((rest + '((us-ascii . iso-8859-1) + (gb2312 . cn-gb-2312) + (iso-2022-jp-2 . iso-2022-7bit-ss2) + (x-ctext . ctext))) + (systems (mm-coding-system-list)) + dest) + (while rest + (let ((pair (car rest))) + (unless (memq (car pair) systems) + (setq dest (cons pair dest)))) + (setq rest (cdr rest))) + dest) + "Charset/coding system alist.") + + (defun mm-mule-charset-to-mime-charset (charset) + "Return the MIME charset corresponding to MULE CHARSET." + (let ((alist mm-mime-mule-charset-alist) + out) + (while alist + (when (memq charset (cdar alist)) + (setq out (caar alist) + alist nil)) + (pop alist)) + out)) + + (defun mm-charset-to-coding-system (charset &optional lbt) + "Return coding-system corresponding to CHARSET. + CHARSET is a symbol naming a MIME charset. + If optional argument LBT (`unix', `dos' or `mac') is specified, it is + used as the line break code type of the coding system." + (when (stringp charset) + (setq charset (intern (downcase charset)))) + (setq charset + (or (cdr (assq charset mm-charset-coding-system-alist)) + charset)) + (when lbt + (setq charset (intern (format "%s-%s" charset lbt)))) + (cond + ;; Running in a non-MULE environment. + ((and (null (mm-coding-system-list)) + (eq charset 'iso-8859-1)) + charset) + ;; Check to see whether we can handle this charset. + ((memq charset (mm-coding-system-list)) + charset) + ;; Nope. + (t + nil))) + + (defun mm-replace-chars-in-string (string from to) + "Replace characters in STRING from FROM to TO." + (let ((string (substring string 0)) ;Copy string. + (len (length string)) + (idx 0)) + ;; Replace all occurrences of FROM with TO. + (while (< idx len) + (when (= (aref string idx) from) + (aset string idx to)) + (setq idx (1+ idx))) + string)) + + (provide 'mm-util) + + ;;; mm-util.el ends here *** pub/pgnus/lisp/qp.el Sun Aug 30 15:28:14 1998 --- pgnus/lisp/qp.el Sun Aug 30 17:48:01 1998 *************** *** 56,70 **** (quoted-printable-decode-region (point-min) (point-max)) (buffer-string))) ! (defun quoted-printable-encode-region (from to &optional fold) "QP-encode the region between FROM and TO. ! If FOLD, fold long lines." (interactive "r") (save-excursion (save-restriction (narrow-to-region from to) (goto-char (point-min)) ! (while (re-search-forward "[\000-\007\013\015-\037\200-\377_=]" nil t) (insert (prog1 (upcase (format "=%x" (char-after (1- (point))))) --- 56,72 ---- (quoted-printable-decode-region (point-min) (point-max)) (buffer-string))) ! (defun quoted-printable-encode-region (from to &optional fold class) "QP-encode the region between FROM and TO. ! If FOLD, fold long lines. If CLASS, translate the characters ! matched by that regexp." (interactive "r") (save-excursion (save-restriction (narrow-to-region from to) (goto-char (point-min)) ! (while (re-search-forward ! (or class "[\000-\007\013\015-\037\200-\377=]") nil t) (insert (prog1 (upcase (format "=%x" (char-after (1- (point))))) *** pub/pgnus/lisp/rfc1522.el Sun Aug 30 17:48:05 1998 --- pgnus/lisp/rfc1522.el Sun Aug 30 17:48:01 1998 *************** *** 0 **** --- 1,276 ---- + ;;; rfc1522.el --- Functions for encoding and decoding rfc1522 messages + ;; Copyright (C) 1998 Free Software Foundation, Inc. + + ;; Author: Lars Magne Ingebrigtsen + ;; MORIOKA Tomohiko + ;; This file is part of GNU Emacs. + + ;; GNU Emacs is free software; you can redistribute it and/or modify + ;; it under the terms of the GNU General Public License as published by + ;; the Free Software Foundation; either version 2, or (at your option) + ;; any later version. + + ;; GNU Emacs is distributed in the hope that it will be useful, + ;; but WITHOUT ANY WARRANTY; without even the implied warranty of + ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;; GNU General Public License for more details. + + ;; 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 'base64) + (require 'qp) + (require 'mm-util) + + (defvar rfc1522-header-encoding-alist + '(("Newsgroups" . nil) + ("Message-ID" . nil) + (t . mime)) + "*Header/encoding method alist. + The list is traversed sequentially. The keys can either be + header regexps or `t'. + + The values can be: + + 1) nil, in which case no encoding is done; + 2) `mime', in which case the header will be encoded according to RFC1522; + 3) a charset, in which case it will be encoded as that charse; + 4) `default', in which case the field will be encoded as the rest + of the article.") + + (defvar rfc1522-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-kr . B) + (gb2312 . B) + (cn-gb . B) + (cn-gb-2312 . B) + (euc-kr . B) + (iso-2022-jp-2 . B) + (iso-2022-int-1 . B)) + "Alist of MIME charsets to RFC1522 encodings. + Valid encodings are nil, `Q' and `B'.") + + (defvar rfc1522-encoding-function-alist + '((Q . rfc1522-q-encode-region) + (B . base64-encode-region) + (nil . ignore)) + "Alist of RFC1522 encodings to encoding functions.") + + (defvar rfc1522-q-encoding-alist + '(("\\(From\\|Cc\\|To\\|Bcc\||Reply-To\\):" . "[^-A-Za-z0-9!*+/=_]") + ("." . "[\000-\007\013\015-\037\200-\377=_?]")) + "Alist of header regexps and valid Q characters.") + + ;;; + ;;; Functions for encoding RFC1522 messages + ;;; + + (defun rfc1522-narrow-to-field () + "Narrow the buffer to the header on the current line." + (beginning-of-line) + (narrow-to-region + (point) + (progn + (forward-line 1) + (if (re-search-forward "^[^ \n\t]" nil t) + (progn + (beginning-of-line) + (point)) + (point-max)))) + (goto-char (point-min))) + + ;;;###autoload + (defun rfc1522-encode-message-header () + "Encode the message header according to `rfc1522-header-encoding-alist'. + Should be called narrowed to the head of the message." + (interactive "*") + (when (featurep 'mule) + (save-excursion + (let ((alist rfc1522-header-encoding-alist) + elem method) + (while (not (eobp)) + (save-restriction + (rfc1522-narrow-to-field) + (when (find-non-ascii-charset-region (point-min) (point-max)) + ;; We found something that may perhaps be encoded. + (while (setq elem (pop alist)) + (when (or (and (stringp (car elem)) + (looking-at (car elem))) + (eq (car elem) t)) + (setq alist nil + method (cdr elem)))) + (when method + (cond + ((eq method 'mime) + (rfc1522-encode-region (point-min) (point-max))) + ;; Hm. + (t)))) + (goto-char (point-max)))))))) + + (defun rfc1522-encode-region (b e) + "Encode all encodable words in REGION." + (let (prev c start qstart qprev qend) + (save-excursion + (goto-char b) + (while (re-search-forward "[^ \t\n]+" nil t) + (save-restriction + (narrow-to-region (match-beginning 0) (match-end 0)) + (goto-char (setq start (point-min))) + (setq prev nil) + (while (not (eobp)) + (unless (eq (setq c (char-charset (following-char))) 'ascii) + (cond + ((eq c prev) + ) + ((null prev) + (setq qstart (or qstart start) + qend (point-max) + qprev c) + (setq prev c)) + (t + ;(rfc1522-encode start (setq start (point)) prev) + (setq prev c)))) + (forward-char 1))) + (when (and (not prev) qstart) + (rfc1522-encode qstart qend qprev) + (setq qstart nil))) + (when qstart + (rfc1522-encode qstart qend qprev) + (setq qstart nil))))) + + (defun rfc1522-encode-string (string) + "Encode words in STRING." + (with-temp-buffer + (insert string) + (rfc1522-encode-region (point-min) (point-max)) + (buffer-string))) + + (defun rfc1522-encode (b e charset) + "Encode the word in the region with CHARSET." + (let* ((mime-charset (mm-mule-charset-to-mime-charset charset)) + (encoding (cdr (assq mime-charset + rfc1522-charset-encoding-alist))) + (start (concat + "=?" (downcase (symbol-name mime-charset)) "?" + (downcase (symbol-name encoding)) "?"))) + (save-restriction + (narrow-to-region b e) + (insert + (prog1 + (mm-encode-coding-string (buffer-string) mime-charset) + (delete-region (point-min) (point-max)))) + (funcall (cdr (assq encoding rfc1522-encoding-function-alist)) + (point-min) (point-max)) + (goto-char (point-min)) + (insert start) + (goto-char (point-max)) + (insert "?=") + ;; Encoded words can't be more than 75 chars long, so we have to + ;; split the long ones up. + (end-of-line) + (while (> (current-column) 74) + (beginning-of-line) + (forward-char 73) + (insert "?=\n " start) + (end-of-line))))) + + (defun rfc1522-q-encode-region (b e) + "Encode the header contained in REGION with the Q encoding." + (save-excursion + (save-restriction + (narrow-to-region (goto-char b) e) + (let ((alist rfc1522-q-encoding-alist)) + (while alist + (when (looking-at (caar alist)) + (quoted-printable-encode-region b e nil (cdar alist)) + (subst-char-in-region (point-min) (point-max) ? ?_)) + (pop alist)))))) + + ;;; + ;;; Functions for decoding RFC1522 messages + ;;; + + (defvar rfc1522-encoded-word-regexp + "=\\?\\([^][\000-\040()<>@,\;:\\\"/?.=]+\\)\\?\\(B\\|Q\\)\\?\\([!->@-~]+\\)\\?=") + + ;;;###autoload + (defun rfc1522-decode-region (start end) + "Decode MIME-encoded words in region between START and END." + (interactive "r") + (save-excursion + (save-restriction + (narrow-to-region start end) + (goto-char (point-min)) + ;; Remove whitespace between encoded words. + (while (re-search-forward + (concat "\\(" rfc1522-encoded-word-regexp "\\)" + "\\(\n?[ \t]\\)+" + "\\(" rfc1522-encoded-word-regexp "\\)") + nil t) + (delete-region (goto-char (match-end 1)) (match-beginning 6))) + ;; Decode the encoded words. + (goto-char (point-min)) + (while (re-search-forward rfc1522-encoded-word-regexp nil t) + (insert (rfc1522-parse-and-decode + (prog1 + (match-string 0) + (delete-region (match-beginning 0) (match-end 0))))))))) + + ;;;###autoload + (defun rfc1522-decode-string (string) + "Decode the quoted-printable-encoded STRING and return the results." + (with-temp-buffer + (insert string) + (inline + (rfc1522-decode-region (point-min) (point-max))) + (buffer-string))) + + (defun rfc1522-parse-and-decode (word) + "Decode WORD and return it if it is an encoded word. + Return WORD if not." + (if (not (string-match rfc1522-encoded-word-regexp word)) + word + (or + (condition-case nil + (rfc1522-decode + (match-string 1 word) + (upcase (match-string 2 word)) + (match-string 3 word)) + (error word)) + word))) + + (defun rfc1522-decode (charset encoding string) + "Decode STRING as an encoded text. + Valid ENCODINGs are \"B\" and \"Q\". + If your Emacs implementation can't decode CHARSET, it returns nil." + (let ((cs (mm-charset-to-coding-system charset))) + (when cs + (mm-decode-coding-string + (cond + ((equal "B" encoding) + (base64-decode string)) + ((equal "Q" encoding) + (quoted-printable-decode-string + (mm-replace-chars-in-string string ?_ ? ))) + (t (error "Invalid encoding: %s" encoding))) + cs)))) + + (provide 'rfc1522) + + ;;; rfc1522.el ends here *** pub/pgnus/lisp/ChangeLog Sun Aug 30 15:28:12 1998 --- pgnus/lisp/ChangeLog Sun Aug 30 17:47:59 1998 *************** *** 1,3 **** --- 1,31 ---- + Sun Aug 30 17:46:01 1998 Lars Magne Ingebrigtsen + + * gnus.el: Pterodactyl Gnus v0.9 is released. + + 1998-08-30 16:13:08 Lars Magne Ingebrigtsen + + * mm-util.el: Shadow encode-coding-string. + + * base64.el (base64-encode-region): Don't add newline. + + * rfc1522.el (rfc1522-narrow-to-field): Copied here. + + * mm-util.el: New file. + + * mm-decode.el: Somewhat depleted. + * mm-encode.el: Ditto. + + * rfc1522.el: New file. + + * mm-util.el (mm-replace-chars-in-string): Copied here. + + * mm-encode.el (mm-q-encode-region): New function. + + * qp.el (quoted-printable-encode-region): Take an optional CLASS + param. + + * mm-encode.el (mm-encode-word-region): Downcase. + Sun Aug 30 15:28:01 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.8 is released. *** pub/pgnus/texi/gnus.texi Sun Aug 30 15:28:14 1998 --- pgnus/texi/gnus.texi Sun Aug 30 17:48:02 1998 *************** *** 1,7 **** \input texinfo @c -*-texinfo-*- @setfilename gnus ! @settitle Pterodactyl Gnus 0.8 Manual @synindex fn cp @synindex vr cp @synindex pg cp --- 1,7 ---- \input texinfo @c -*-texinfo-*- @setfilename gnus ! @settitle Pterodactyl Gnus 0.9 Manual @synindex fn cp @synindex vr cp @synindex pg cp *************** *** 318,324 **** @tex @titlepage ! @title Pterodactyl Gnus 0.8 Manual @author by Lars Magne Ingebrigtsen @page --- 318,324 ---- @tex @titlepage ! @title Pterodactyl Gnus 0.9 Manual @author by Lars Magne Ingebrigtsen @page *************** *** 354,360 **** spool or your mbox file. All at the same time, if you want to push your luck. ! This manual corresponds to Pterodactyl Gnus 0.8. @end ifinfo --- 354,360 ---- spool or your mbox file. All at the same time, if you want to push your luck. ! This manual corresponds to Pterodactyl Gnus 0.9. @end ifinfo *** pub/pgnus/texi/message.texi Sun Aug 30 15:28:15 1998 --- pgnus/texi/message.texi Sun Aug 30 17:48:02 1998 *************** *** 1,7 **** \input texinfo @c -*-texinfo-*- @setfilename message ! @settitle Pterodactyl Message 0.8 Manual @synindex fn cp @synindex vr cp @synindex pg cp --- 1,7 ---- \input texinfo @c -*-texinfo-*- @setfilename message ! @settitle Pterodactyl Message 0.9 Manual @synindex fn cp @synindex vr cp @synindex pg cp *************** *** 42,48 **** @tex @titlepage ! @title Pterodactyl Message 0.8 Manual @author by Lars Magne Ingebrigtsen @page --- 42,48 ---- @tex @titlepage ! @title Pterodactyl Message 0.9 Manual @author by Lars Magne Ingebrigtsen @page *************** *** 83,89 **** * Key Index:: List of Message mode keys. @end menu ! This manual corresponds to Pterodactyl Message 0.8. Message is distributed with the Gnus distribution bearing the same version number as this manual has. --- 83,89 ---- * Key Index:: List of Message mode keys. @end menu ! This manual corresponds to Pterodactyl Message 0.9. Message is distributed with the Gnus distribution bearing the same version number as this manual has.