From cb41b76f44f608bd86d99f308e4fc1fdf8010a84 Mon Sep 17 00:00:00 2001 From: yamaoka Date: Wed, 2 Dec 1998 23:04:58 +0000 Subject: [PATCH] Sync up with Pterodactyl Gnus v0.61. --- lisp/ChangeLog | 61 +++++++++++++++++++++++++++++++++ lisp/gnus-art.el | 37 ++++++++++++++++++-- lisp/gnus-picon.el | 79 +++++++++++++++++++++++++++---------------- lisp/gnus-sum.el | 2 +- lisp/gnus.el | 6 ++-- lisp/message.el | 3 +- lisp/mml.el | 95 ++++++++++++++++++++++++++++++++++++++++++++-------- lisp/rfc2047.el | 8 ++--- 8 files changed, 236 insertions(+), 55 deletions(-) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index c93ef26..7aa0e54 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,64 @@ +Wed Dec 2 20:24:27 1998 Lars Magne Ingebrigtsen + + * gnus.el: Pterodactyl Gnus v0.61 is released. + +1998-12-02 21:12:56 Lars Magne Ingebrigtsen + + * mml.el (mml-parse-1): Skipped parts. + (mml-insert-mime-headers): Nil is a list. + (mml-generate-mime-1): Don't insert literally. + (mml-read-tag): Drop text props. + (mml-read-part): Ditto. + (mml-parse-singlepart-with-multiple-charsets): Ditto. + +Wed Dec 2 20:07:16 1998 Lars Magne Ingebrigtsen + + * gnus.el: Pterodactyl Gnus v0.60 is released. + +1998-12-02 20:11:28 Lars Magne Ingebrigtsen + + * mml.el (mml-parse-1): Don't throw contents away. + +1998-12-02 Hrvoje Niksic + + * mml.el (mml-compute-boundary-1): Regexp-quote the boundary. + +1998-12-02 18:42:24 Lars Magne Ingebrigtsen + + * mml.el (mml-parse-singlepart-with-multiple-charsets): New + function. + (mml-parse-1): Use it. + +Tue Dec 1 23:04:25 1998 Shenghuo ZHU + + * gnus-art.el (gnus-decode-with-mail-decode-encoded-word-region): + Use gnus-newsgroup-default-charset. + (article-decode-encoded-words): Remove charset codes. + * gnus-sum.el (gnus-newsgroup-default-charset): Use + gnus-default-charset. + +1998-12-02 03:14:20 Lars Magne Ingebrigtsen + + * message.el (message-send-mail): Don't encode here. + (message-send-news): Nor here. + (message-send): ... but here instead. + + * gnus-picon.el (gnus-picons-display-article-move-p): Changed + default to nil. + (gnus-article-display-picons): Replace From line. + (gnus-group-display-picons): Replace Newsgroups line. + (gnus-picons-display-glyph): Set baseline. + (gnus-group-display-picons): Piconize the entire Newsgroups line. + (gnus-picons-xbm-face): Revert to old, standard colors. + + * message.el (message-fetch-field): Remove text props. + + * gnus-art.el (gnus-article-normalized-header-length): New + variable. + (article-normalize-headers): New command and keystroke. + + * gnus-picon.el (gnus-picons-xbm-face): Changed colors. + Wed Dec 2 01:43:48 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.59 is released. diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index d8395e8..ff364b8 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -912,6 +912,37 @@ always hide." (point-max))) 'boring-headers)))) +(defvar gnus-article-normalized-header-length 40 + "Length of normalized headers.") + +(defun article-normalize-headers () + "Make all header lines 40 characters long." + (interactive) + (let ((buffer-read-only nil) + column) + (save-excursion + (save-restriction + (message-narrow-to-head) + (while (not (eobp)) + (cond + ((< (setq column (- (gnus-point-at-eol) (point))) + gnus-article-normalized-header-length) + (end-of-line) + (insert (make-string + (- gnus-article-normalized-header-length column) + ? ))) + ((> column gnus-article-normalized-header-length) + (gnus-put-text-property + (progn + (forward-char gnus-article-normalized-header-length) + (point)) + (gnus-point-at-eol) + 'invisible t)) + (t + ;; Do nothing. + )) + (forward-line 1)))))) + (defun article-treat-dumbquotes () "Translate M******** sm*rtq**t*s into proper text." (interactive) @@ -1997,6 +2028,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is article-date-lapsed article-emphasize article-treat-dumbquotes + article-normalize-headers (article-show-all . gnus-article-show-all-headers)))) ;;; @@ -4065,7 +4097,7 @@ forbidden in URL encoding." (defvar gnus-decode-header-methods '(gnus-decode-with-mail-decode-encoded-word-region) - "List of methods used to decode headers + "List of methods used to decode headers. This variable is a list of FUNCTION or (REGEXP . FUNCTION). If item is FUNCTION, FUNCTION will be apply to all newsgroups. If item is a @@ -4081,7 +4113,8 @@ 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)) + (let ((rfc2047-default-charset gnus-newsgroup-default-charset) + (mm-charset-iso-8859-1-forced gnus-newsgroup-iso-8859-1-forced)) (mail-decode-encoded-word-region start end))) (defun gnus-multi-decode-header (start end) diff --git a/lisp/gnus-picon.el b/lisp/gnus-picon.el index 26e82db..ace8fd7 100644 --- a/lisp/gnus-picon.el +++ b/lisp/gnus-picon.el @@ -117,7 +117,7 @@ Some people may want to add \"unknown\" to this list." :type '(repeat string) :group 'picons) -(defcustom gnus-picons-display-article-move-p t +(defcustom gnus-picons-display-article-move-p nil "*Whether to move point to first empty line when displaying picons. This has only an effect if `gnus-picons-display-where' has value `article'." :type 'boolean @@ -144,11 +144,7 @@ please tell me so that we can list it." (string)) :group 'picons) -(defface gnus-picons-xbm-face - '((((background dark)) - (:foreground "green" :background "black")) - (t - (:foreground "black" :background "blue"))) +(defface gnus-picons-xbm-face '((t (:foreground "black" :background "white"))) "Face to show xbm picons in." :group 'picons) @@ -313,6 +309,15 @@ To use: (setq gnus-article-x-face-command 'gnus-picons-display-x-face)" ".")))) (gnus-picons-prepare-for-annotations) (gnus-group-display-picons) + (unless gnus-picons-display-article-move-p + (save-restriction + (let ((buffer-read-only nil)) + (when (re-search-forward "^From: " nil t) + (narrow-to-region (point) (gnus-point-at-eol)) + (when (search-forward from nil t) + (gnus-put-text-property + (match-beginning 0) (match-end 0) + 'invisible t)))))) (if (null gnus-picons-piconsearch-url) (progn (gnus-picons-display-pairs (gnus-picons-lookup-pairs @@ -339,27 +344,40 @@ To use: (setq gnus-article-x-face-command 'gnus-picons-display-x-face)" (or (null gnus-picons-group-excluded-groups) (not (string-match gnus-picons-group-excluded-groups gnus-newsgroup-name)))) - (save-excursion - (gnus-picons-prepare-for-annotations) - (if (null gnus-picons-piconsearch-url) - (gnus-picons-display-pairs - (gnus-picons-lookup-pairs - (reverse (message-tokenize-header - (gnus-group-real-name gnus-newsgroup-name) - ".")) - gnus-picons-news-directories) - t ".") - (push (list 'gnus-group-annotations 'search nil - (message-tokenize-header - (gnus-group-real-name gnus-newsgroup-name) ".") - (if (listp gnus-picons-news-directories) - gnus-picons-news-directories - (list gnus-picons-news-directories)) - nil) - gnus-picons-jobs-alist) - (gnus-picons-next-job)) - - (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all)))) + (let ((groups + (if gnus-picons-display-article-move-p + (list (gnus-group-real-name gnus-newsgroup-name)) + (split-string (mail-fetch-field "newsgroups") ","))) + group) + (save-excursion + (gnus-picons-prepare-for-annotations) + (while (setq group (pop groups)) + (unless gnus-picons-display-article-move-p + (save-restriction + (let ((buffer-read-only nil)) + (goto-char (point-min)) + (when (re-search-forward "^Newsgroups:" nil t) + (narrow-to-region (point) (gnus-point-at-eol)) + (when (search-forward group nil t) + (gnus-put-text-property + (match-beginning 0) (match-end 0) + 'invisible t)))))) + (if (null gnus-picons-piconsearch-url) + (gnus-picons-display-pairs + (gnus-picons-lookup-pairs + (reverse (split-string group "\\.")) + gnus-picons-news-directories) + t ".") + (push (list 'gnus-group-annotations 'search nil + (split-string group "\\.") + (if (listp gnus-picons-news-directories) + gnus-picons-news-directories + (list gnus-picons-news-directories)) + nil) + gnus-picons-jobs-alist) + (gnus-picons-next-job)) + + (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all)))))) (defun gnus-picons-lookup-internal (addrs dir) (setq dir (expand-file-name dir gnus-picons-database)) @@ -421,7 +439,8 @@ none, and whose CDR is the corresponding element of DOMAINS." "Display picons in list PAIRS." (let ((domain-p (and gnus-picons-display-as-address dot-p)) pair picons) - (when (and bar-p domain-p right-p) + (when (and bar-p domain-p right-p + gnus-picons-display-article-move-p) (setq picons (gnus-picons-display-glyph (let ((gnus-picons-file-suffixes '("xbm"))) (gnus-picons-try-face @@ -456,6 +475,7 @@ none, and whose CDR is the corresponding element of DOMAINS." glyph)) (defun gnus-picons-display-glyph (glyph &optional part rightp) + (set-glyph-baseline glyph 70) (let ((new (gnus-picons-make-annotation glyph (point) 'text nil nil nil rightp))) (when (and part gnus-picons-display-as-address) @@ -718,7 +738,8 @@ none, and whose CDR is the corresponding element of DOMAINS." (cond ((stringp tag);; (SYM-ANN "..." RIGHT-P) (gnus-picons-network-display-internal sym-ann nil tag (pop job))) - ((eq 'bar tag) + ((and (eq 'bar tag) + gnus-picons-display-article-move-p) (gnus-picons-network-display-internal sym-ann (let ((gnus-picons-file-suffixes '("xbm"))) diff --git a/lisp/gnus-sum.el b/lisp/gnus-sum.el index e06c722..e75633b 100644 --- a/lisp/gnus-sum.el +++ b/lisp/gnus-sum.el @@ -1018,7 +1018,7 @@ variable (string, integer, character, etc).") (defvar gnus-last-article nil) (defvar gnus-newsgroup-history nil) -(defvar gnus-newsgroup-default-charset nil) +(defvar gnus-newsgroup-default-charset gnus-default-charset) (defvar gnus-newsgroup-iso-8859-1-forced nil) (defconst gnus-summary-local-variables diff --git a/lisp/gnus.el b/lisp/gnus.el index 6080f27..47c65ee 100644 --- a/lisp/gnus.el +++ b/lisp/gnus.el @@ -259,17 +259,17 @@ is restarted, and sometimes reloaded." (defconst gnus-product-name "T-gnus" "Product name of this version of gnus.") -(defconst gnus-version-number "6.10.045" +(defconst gnus-version-number "6.10.046" "Version number for this version of gnus.") -(defconst gnus-original-version-number "0.59" +(defconst gnus-original-version-number "0.61" "Version number for this version of Gnus.") (defconst gnus-original-product-name "Pterodactyl Gnus" "Product name of the original version of Gnus.") (defconst gnus-version - (format "%s %s (based on %s %s ; for SEMI 1.11/1.12, FLIM 1.12)" + (format "%s %s (based on %s %s ; for SEMI 1.12, FLIM 1.12)" gnus-product-name gnus-version-number gnus-original-product-name gnus-original-version-number) "Version string for this version of gnus.") diff --git a/lisp/message.el b/lisp/message.el index 7eaab73..bd35833 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -1238,7 +1238,8 @@ This variable is used only in non-Mule Emacsen.") (when value (while (string-match "\n[\t ]+" value) (setq value (replace-match " " t t value))) - value))) + ;; We remove all text props.delete-region + (format "%s" value)))) (defun message-narrow-to-field () "Narrow the buffer to the header on the current line." diff --git a/lisp/mml.el b/lisp/mml.el index f788a9e..5184ace 100644 --- a/lisp/mml.el +++ b/lisp/mml.el @@ -55,35 +55,100 @@ (defun mml-parse-1 () "Parse the current buffer as an MML document." - (let (struct) + (let (struct tag point contents charsets warn) (while (and (not (eobp)) (not (looking-at "<#/multipart"))) (cond ((looking-at "<#multipart") (push (nconc (mml-read-tag) (mml-parse-1)) struct)) - ((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)))) + (if (looking-at "<#part") + (setq tag (mml-read-tag)) + (setq tag (list 'part '(type . "text/plain")) + warn t)) + (setq point (point) + contents (mml-read-part) + charsets (delq 'ascii (mm-find-charset-region point (point)))) + (if (< (length charsets) 2) + (push (nconc tag (list (cons 'contents contents))) + struct) + (let ((nstruct (mml-parse-singlepart-with-multiple-charsets + tag point (point)))) + (when (and warn + (not + (y-or-n-p + (format + "Warning: Your message contains %d parts. Really send? " + (length nstruct))))) + (error "Edit your message to use only one charset")) + (setq struct (nconc nstruct struct))))))) (unless (eobp) (forward-line 1)) (nreverse struct))) +(defun mml-parse-singlepart-with-multiple-charsets (orig-tag beg end) + (save-excursion + (narrow-to-region beg end) + (goto-char (point-min)) + (let ((current (char-charset (following-char))) + charset struct space newline paragraph) + (while (not (eobp)) + (cond + ;; The charset remains the same. + ((or (eq (setq charset (char-charset (following-char))) 'ascii) + (eq charset current))) + ;; The initial charset was ascii. + ((eq current 'ascii) + (setq current charset)) + ;; We have a change in charsets. + (t + (push (append + orig-tag + (list (cons 'contents + (buffer-substring-no-properties + beg (or paragraph newline space (point)))))) + struct) + (setq beg (or paragraph newline space (point)) + current charset + space nil + newline nil + paragraph nil))) + ;; Compute places where it might be nice to break the part. + (cond + ((memq (following-char) '(? ?\t)) + (setq space (1+ (point)))) + ((eq (following-char) ?\n) + (setq newline (1+ (point)))) + ((and (eq (following-char) ?\n) + (not (bobp)) + (eq (char-after (1- (point))) ?\n)) + (setq paragraph (point)))) + (forward-char 1)) + ;; Do the final part. + (unless (= beg (point)) + (push (append orig-tag + (list (cons 'contents + (buffer-substring-no-properties + beg (point))))) + struct)) + struct))) + (defun mml-read-tag () "Read a tag and return the contents." (let (contents name elem val) (forward-char 2) - (setq name (buffer-substring (point) (progn (forward-sexp 1) (point)))) + (setq name (buffer-substring-no-properties + (point) (progn (forward-sexp 1) (point)))) (skip-chars-forward " \t\n") (while (not (looking-at ">")) - (setq elem (buffer-substring (point) (progn (forward-sexp 1) (point)))) + (setq elem (buffer-substring-no-properties + (point) (progn (forward-sexp 1) (point)))) (skip-chars-forward "= \t\n") - (setq val (buffer-substring (point) (progn (forward-sexp 1) (point)))) + (setq val (buffer-substring-no-properties + (point) (progn (forward-sexp 1) (point)))) (when (string-match "^\"\\(.*\\)\"$" val) (setq val (match-string 1 val))) (push (cons (intern elem) val) contents) @@ -100,13 +165,13 @@ (if (re-search-forward "<#\\(/\\)?\\(multipart\\|part\\|external\\)." nil t) (prog1 - (buffer-substring beg (match-beginning 0)) + (buffer-substring-no-properties beg (match-beginning 0)) (if (or (not (match-beginning 1)) (equal (match-string 2) "multipart")) (goto-char (match-beginning 0)) (when (looking-at "[ \t]*\n") (forward-line 1)))) - (buffer-substring beg (goto-char (point-max)))))) + (buffer-substring-no-properties beg (goto-char (point-max)))))) (defvar mml-boundary nil) (defvar mml-base-boundary "=-=-=") @@ -149,7 +214,7 @@ (setq coded (buffer-string))) (mm-with-unibyte-buffer (if (setq filename (cdr (assq 'filename cont))) - (insert-file-contents-literally filename) + (insert-file-contents filename) (insert (cdr (assq 'contents cont)))) (setq encoding (mm-encode-buffer type) coded (buffer-string)))) @@ -219,7 +284,8 @@ (insert-file-contents-literally filename) (insert (cdr (assq 'contents cont)))) (goto-char (point-min)) - (when (re-search-forward (concat "^--" mml-boundary) nil t) + (when (re-search-forward (concat "^--" (regexp-quote mml-boundary)) + nil t) (setq mml-boundary (mml-make-boundary)) (throw 'not-unique nil)))) ((eq (car cont) 'multipart) @@ -246,7 +312,8 @@ (mml-parameter-string cont '(name access-type expiration size permission))) (not (equal type "text/plain"))) - (when (listp charset) + (when (consp charset) + (debug) (error "Can't encode a part with several charsets. Insert a <#part>.")) (insert "Content-Type: " type) diff --git a/lisp/rfc2047.el b/lisp/rfc2047.el index 3484a04..47d1161 100644 --- a/lisp/rfc2047.el +++ b/lisp/rfc2047.el @@ -147,7 +147,7 @@ Should be called narrowed to the head of the message." found)) (defun rfc2047-dissect-region (b e) - "Dissect the region between B and E." + "Dissect the region between B and E into words." (let (words) (save-restriction (narrow-to-region b e) @@ -156,10 +156,8 @@ Should be called narrowed to the head of the message." (concat "[^" ietf-drums-tspecials " \t\n]+") nil t) (push (list (match-beginning 0) (match-end 0) - (car - (delq 'ascii - (find-charset-region (match-beginning 0) - (match-end 0))))) + (car (delq 'ascii (find-charset-region + (match-beginning 0) (match-end 0))))) words)) words))) -- 1.7.10.4