From f336bbd25b9187dd8305f88b5694afa5373cdf5e Mon Sep 17 00:00:00 2001 From: Lars Magne Ingebrigtsen Date: Wed, 1 Dec 1999 20:58:20 +0000 Subject: [PATCH] * message.el (message-mode-map): Changed keystroke for message-yank-buffer. 1999-11-26 Hrvoje Niksic * message.el (message-shorten-references): Cut references to 31 elements, then either fold them or shorten them to 988 characters. (message-shorten-1): New function. (message-cater-to-broken-inn): New variable. 1999-12-01 21:47:10 Eric Marsden * nnslashdot.el (nnslashdot-lose): New function. 1999-12-01 21:08:48 Lars Magne Ingebrigtsen * mm-view.el (mm-inline-message): Not the right type of charset is being fetched here. Let the group charset rule. (mm-inline-message): Ignore us-ascii. --- lisp/ChangeLog | 50 +++++++++++++ lisp/gnus-art.el | 4 +- lisp/gnus-cache.el | 1 + lisp/gnus-msg.el | 2 + lisp/gnus-sum.el | 3 +- lisp/mail-source.el | 2 +- lisp/message.el | 86 +++++++++++++++++----- lisp/mm-bodies.el | 5 +- lisp/mm-view.el | 7 +- lisp/mml.el | 4 +- lisp/nnmh.el | 2 +- lisp/nnslashdot.el | 174 +++++++++++++++++++++++--------------------- 12 files changed, 228 insertions(+), 112 deletions(-) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index fe07849df..e2b5cc0fd 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,50 @@ +1999-12-01 21:59:36 Lars Magne Ingebrigtsen + + * message.el (message-mode-map): Changed keystroke for + message-yank-buffer. + +1999-11-26 Hrvoje Niksic + + * message.el (message-shorten-references): Cut references to 31 + elements, then either fold them or shorten them to 988 characters. + (message-shorten-1): New function. + (message-cater-to-broken-inn): New variable. + +1999-12-01 21:47:10 Eric Marsden + + * nnslashdot.el (nnslashdot-lose): New function. + +1999-12-01 21:08:48 Lars Magne Ingebrigtsen + + * mm-view.el (mm-inline-message): Not the right type of charset is + being fetched here. Let the group charset rule. + (mm-inline-message): Ignore us-ascii. + +1999-11-24 Carsten Leonhardt + + * mail-source.el (mail-source-fetch-maildir): work around the + ommitted "file-regular-p" in efs/ange-ftp + +1999-12-01 19:59:25 Lars Magne Ingebrigtsen + + * mml.el (mml-generate-mime-1): Don't insert extra empty line. + (mml-generate-mime-1): Use the encoding param. + + * gnus-sum.el (gnus-summary-show-article): Don't bind gnus-visual. + + * gnus-cache.el (gnus-cache-possibly-enter-article): Require + gnus-art before binding its variables. + + * gnus-art.el (gnus-article-prepare-display): Run the prepare + after the MIME. + +1999-12-01 19:48:14 Rupa Schomaker + + * message.el (message-clone-locals): Use it. + + * gnus-msg.el (gnus-configure-posting-styles): Make + user-mail-address local. + 1999-11-20 Simon Josefsson * gnus-start.el (gnus-get-unread-articles): Scan each method only @@ -5,6 +52,9 @@ 1999-12-01 17:37:18 Lars Magne Ingebrigtsen + * message.el (message-generate-new-buffer-clone-locals): Use varstr. + (message-clone-locals): Ditto. + * gnus-sum.el (gnus-summary-enter-digest-group): Have the digest group inherit reply-to or from. diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index 809169de9..f582da360 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -2724,9 +2724,9 @@ If ALL-HEADERS is non-nil, no headers are hidden." (setq buffer-read-only nil gnus-article-wash-types nil) (gnus-run-hooks 'gnus-tmp-internal-hook) - (gnus-run-hooks 'gnus-article-prepare-hook) (when gnus-display-mime-function - (funcall gnus-display-mime-function)))) + (funcall gnus-display-mime-function)) + (gnus-run-hooks 'gnus-article-prepare-hook))) ;;; ;;; Gnus MIME viewing functions diff --git a/lisp/gnus-cache.el b/lisp/gnus-cache.el index fcb8bb52a..0cc99b571 100644 --- a/lisp/gnus-cache.el +++ b/lisp/gnus-cache.el @@ -175,6 +175,7 @@ it's not cached." t ; The article already is saved. (save-excursion (set-buffer nntp-server-buffer) + (require 'gnus-art) (let ((gnus-use-cache nil) (gnus-article-decode-hook nil)) (gnus-request-article-this-buffer number group)) diff --git a/lisp/gnus-msg.el b/lisp/gnus-msg.el index 4bd55a69c..0af7f10c4 100644 --- a/lisp/gnus-msg.el +++ b/lisp/gnus-msg.el @@ -1216,6 +1216,8 @@ this is a reply." (when (or name address) (add-hook 'message-setup-hook `(lambda () + (set (make-local-variable 'user-mail-address) + ,(or (cdr address) user-mail-address)) (let ((user-full-name ,(or (cdr name) (user-full-name))) (user-mail-address ,(or (cdr address) user-mail-address))) diff --git a/lisp/gnus-sum.el b/lisp/gnus-sum.el index bd05317bc..fc4ea23c0 100644 --- a/lisp/gnus-sum.el +++ b/lisp/gnus-sum.el @@ -7153,8 +7153,7 @@ without any article massaging functions being run." gnus-article-prepare-hook gnus-article-decode-hook gnus-display-mime-function - gnus-break-pages - gnus-visual) + gnus-break-pages) ;; Destroy any MIME parts. (when (gnus-buffer-live-p gnus-article-buffer) (save-excursion diff --git a/lisp/mail-source.el b/lisp/mail-source.el index f2d09f207..22a9da336 100644 --- a/lisp/mail-source.el +++ b/lisp/mail-source.el @@ -439,7 +439,7 @@ If ARGS, PROMPT is used as an argument to `format'." (let ((found 0) (mail-source-string (format "maildir:%s" path))) (dolist (file (directory-files path t)) - (when (and (file-regular-p file) + (when (and (not (file-directory-p file)) (not (if function (funcall function file mail-source-crash-box) (rename-file file mail-source-crash-box)))) diff --git a/lisp/message.el b/lisp/message.el index 4929c84e7..20f430c06 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -407,6 +407,11 @@ might set this variable to '(\"-f\" \"you@some.where\")." :group 'message-sending :type '(repeat string)) +(defvar message-cater-to-broken-inn t + "Non-nil means Gnus should not fold the `References' header. +Folding `References' makes ancient versions of INN create incorrect +NOV lines.") + (defvar gnus-post-method) (defvar gnus-select-method) (defcustom message-post-method @@ -1300,7 +1305,7 @@ Point is left at the beginning of the narrowed-to region." (define-key message-mode-map "\C-c\C-n" 'message-insert-newsgroups) (define-key message-mode-map "\C-c\C-y" 'message-yank-original) - (define-key message-mode-map "\C-c\C-Y" 'message-yank-buffer) + (define-key message-mode-map "\C-c\M-\C-y" 'message-yank-buffer) (define-key message-mode-map "\C-c\C-q" 'message-fill-yanked-message) (define-key message-mode-map "\C-c\C-w" 'message-insert-signature) (define-key message-mode-map "\C-c\M-h" 'message-insert-headers) @@ -2173,7 +2178,7 @@ the user from the mailer." (defun message-send-mail-with-sendmail () "Send off the prepared buffer with sendmail." (let ((errbuf (if message-interactive - (generate-new-buffer " sendmail errors") + (message-generate-new-buffer-clone-locals " sendmail errors") 0)) resend-to-addresses delimline) (let ((case-fold-search t)) @@ -2210,7 +2215,11 @@ the user from the mailer." ;; But some systems are more broken with -f, so ;; we'll let users override this. (if (null message-sendmail-f-is-evil) - (list "-f" (user-login-name))) + (list "-f" + (if (null user-mail-address) + (user-login-name) + (user-mail-address)) + )) ;; These mean "report errors by mail" ;; and "deliver in background". (if (null message-interactive) '("-oem" "-odb")) @@ -3175,7 +3184,7 @@ Headers already prepared in the buffer are not modified." (defun message-fill-header (header value) (let ((begin (point)) - (fill-column 990) + (fill-column 78) (fill-prefix "\t")) (insert (capitalize (symbol-name header)) ": " @@ -3194,23 +3203,60 @@ Headers already prepared in the buffer are not modified." (replace-match " " t t)) (goto-char (point-max))))) +(defun message-shorten-1 (list cut surplus) + ;; Cut SURPLUS elements out of LIST, beginning with CUTth one. + (setcdr (nthcdr (- cut 2) refs) + (nthcdr (+ (- cut 2) surplus 1) refs))) + (defun message-shorten-references (header references) - "Limit REFERENCES to be shorter than 988 characters." - (let ((max 988) - (cut 4) + "Trim REFERENCES to be less than 31 Message-ID long, and fold them. +If folding is disallowed, also check that the REFERENCES are less +than 988 characters long, and if they are not, trim them until they are." + (let ((maxcount 31) + (count 0) + (cut 6) refs) (with-temp-buffer (insert references) (goto-char (point-min)) + ;; Cons a list of valid references. (while (re-search-forward "<[^>]+>" nil t) (push (match-string 0) refs)) - (setq refs (nreverse refs)) - (while (> (length (mapconcat 'identity refs " ")) max) - (when (< (length refs) (1+ cut)) - (decf cut)) - (setcdr (nthcdr cut refs) (cddr (nthcdr cut refs))))) - (insert (capitalize (symbol-name header)) ": " - (mapconcat 'identity refs " ") "\n"))) + (setq refs (nreverse refs) + count (length refs))) + + ;; If the list has more than MAXCOUNT elements, trim it by + ;; removing the CUTth element and the required number of + ;; elements that follow. + (when (> count maxcount) + (let ((surplus (- count maxcount))) + (message-shorten-1 refs cut surplus) + (decf count surplus))) + + ;; If folding is disallowed, make sure the total length (including + ;; the spaces between) will be less than MAXSIZE characters. + (when message-cater-to-broken-inn + (let ((maxsize 988) + (totalsize (+ (apply #'+ (mapcar #'length refs)) + (1- count))) + (surplus 0) + (ptr (nthcdr (1- cut) refs))) + ;; Decide how many elements to cut off... + (while (> totalsize maxsize) + (decf totalsize (1+ (length (car ptr)))) + (incf surplus) + (setq ptr (cdr ptr))) + ;; ...and do it. + (when (> surplus 0) + (message-shorten-1 refs cut surplus)))) + + ;; Finally, collect the references back into a string and insert + ;; it into the buffer. + (let ((refstring (mapconcat #'identity refs " "))) + (if message-cater-to-broken-inn + (insert (capitalize (symbol-name header)) ": " + refstring "\n") + (message-fill-header header refstring))))) (defun message-position-point () "Move point to where the user probably wants to find it." @@ -4138,20 +4184,22 @@ regexp varstr." (let ((oldbuf (current-buffer))) (save-excursion (set-buffer (generate-new-buffer name)) - (message-clone-locals oldbuf) + (message-clone-locals oldbuf varstr) (current-buffer)))) -(defun message-clone-locals (buffer) +(defun message-clone-locals (buffer &optional varstr) "Clone the local variables from BUFFER to the current buffer." (let ((locals (save-excursion (set-buffer buffer) (buffer-local-variables))) - (regexp "^gnus\\|^nn\\|^message")) + (regexp "^gnus\\|^nn\\|^message\\|^user-mail-address")) (mapcar (lambda (local) (when (and (consp local) (car local) - (string-match regexp (symbol-name (car local)))) + (string-match regexp (symbol-name (car local))) + (or (null varstr) + (string-match varstr (symbol-name (car local))))) (ignore-errors (set (make-local-variable (car local)) (cdr local))))) @@ -4197,7 +4245,7 @@ regexp varstr." (delete-char 1) (search-forward "\n\n") (setq lines (buffer-substring (point-min) (1- (point)))) - (delete-region (point-min) (point)))))) + (delete-region (point-min) (point)))))) (save-restriction (message-narrow-to-headers-or-head) (message-remove-header "Mime-Version") diff --git a/lisp/mm-bodies.el b/lisp/mm-bodies.el index 8467ef7d1..64bcac3f1 100644 --- a/lisp/mm-bodies.el +++ b/lisp/mm-bodies.el @@ -95,7 +95,7 @@ If no encoding was done, nil is returned." (setq start nil))) charset))))))) -(defun mm-body-encoding (charset) +(defun mm-body-encoding (charset &optional encoding) "Do Content-Transfer-Encoding and return the encoding of the current buffer." (let ((bits (mm-body-7-or-8))) (cond @@ -104,7 +104,8 @@ If no encoding was done, nil is returned." ((eq charset mail-parse-charset) bits) (t - (let ((encoding (or (cdr (assq charset mm-body-charset-encoding-alist)) + (let ((encoding (or encoding + (cdr (assq charset mm-body-charset-encoding-alist)) (mm-qp-or-base64)))) (mm-encode-content-transfer-encoding encoding "text/plain") encoding))))) diff --git a/lisp/mm-view.el b/lisp/mm-view.el index 25c6773f9..a4f98300f 100644 --- a/lisp/mm-view.el +++ b/lisp/mm-view.el @@ -187,12 +187,17 @@ (charset (mail-content-type-get (mm-handle-type handle) 'charset)) gnus-displaying-mime handles) + (when charset + (setq charset (intern (downcase charset))) + (when (eq charset 'us-ascii) + (setq charset nil))) (save-excursion (save-restriction (narrow-to-region b b) (mm-insert-part handle) (let (gnus-article-mime-handles - (gnus-newsgroup-charset (or charset gnus-newsgroup-charset))) + (gnus-newsgroup-charset + (or charset gnus-newsgroup-charset))) (run-hooks 'gnus-article-decode-hook) (gnus-article-prepare-display) (setq handles gnus-article-mime-handles)) diff --git a/lisp/mml.el b/lisp/mml.el index e84e9555f..b90fc2601 100644 --- a/lisp/mml.el +++ b/lisp/mml.el @@ -241,7 +241,8 @@ called for this message.") (delete-region (+ (match-beginning 0) 2) (+ (match-beginning 0) 3)))))) (setq charset (mm-encode-body)) - (setq encoding (mm-body-encoding charset)) + (setq encoding (mm-body-encoding charset + (cdr (assq 'encoding cont)))) (setq coded (buffer-string))) (mm-with-unibyte-buffer (cond @@ -300,7 +301,6 @@ called for this message.") (let ((mml-boundary (mml-compute-boundary cont))) (insert (format "Content-Type: multipart/%s; boundary=\"%s\"\n" type mml-boundary)) - (insert "\n") (setq cont (cddr cont)) (while cont (insert "\n--" mml-boundary "\n") diff --git a/lisp/nnmh.el b/lisp/nnmh.el index 0224709fb..0adde1f0b 100644 --- a/lisp/nnmh.el +++ b/lisp/nnmh.el @@ -60,7 +60,7 @@ (defvoo nnmh-status-string "") (defvoo nnmh-group-alist nil) -(defvoo nnmh-allow-delete-final nil) +(defvar nnmh-allow-delete-final nil) diff --git a/lisp/nnslashdot.el b/lisp/nnslashdot.el index c28e35cc4..62b43b750 100644 --- a/lisp/nnslashdot.el +++ b/lisp/nnslashdot.el @@ -90,10 +90,12 @@ (deffoo nnslashdot-retrieve-headers (articles &optional group server fetch-old) (nnslashdot-possibly-change-server group server) - (unless gnus-nov-is-evil - (if nnslashdot-threaded - (nnslashdot-threaded-retrieve-headers articles group) - (nnslashdot-sane-retrieve-headers articles group)))) + (condition-case why + (unless gnus-nov-is-evil + (if nnslashdot-threaded + (nnslashdot-threaded-retrieve-headers articles group) + (nnslashdot-sane-retrieve-headers articles group))) + (search-failed (nnslashdot-lose why)))) (deffoo nnslashdot-threaded-retrieve-headers (articles group) (let ((last (car (last articles))) @@ -310,46 +312,49 @@ (deffoo nnslashdot-request-article (article &optional group server buffer) (nnslashdot-possibly-change-server group server) (let (contents) - (save-excursion - (set-buffer nnslashdot-buffer) - (let ((case-fold-search t)) - (goto-char (point-min)) - (when (and (stringp article) - (string-match "%\\([0-9]+\\)@" article)) - (setq article (string-to-number (match-string 1 article)))) - (when (numberp article) - (if (= article 1) - (progn - (re-search-forward "Posted by .* on ") - (forward-line 1) + (condition-case why + (save-excursion + (set-buffer nnslashdot-buffer) + (let ((case-fold-search t)) + (goto-char (point-min)) + (when (and (stringp article) + (string-match "%\\([0-9]+\\)@" article)) + (setq article (string-to-number (match-string 1 article)))) + (when (numberp article) + (if (= article 1) + (progn + (re-search-forward "Posted by .* on ") + (forward-line 1) + (setq contents + (buffer-substring + (point) + (progn + (re-search-forward + "

.*A href=http://slashdot.org/article.pl") + (match-beginning 0))))) + (search-forward (format "" (1- article))) (setq contents (buffer-substring - (point) - (progn - (re-search-forward - "

.*A href=http://slashdot.org/article.pl") - (match-beginning 0))))) - (search-forward (format "" (1- article))) - (setq contents - (buffer-substring - (re-search-forward "]+>") - (search-forward ""))))))) - (when contents - (save-excursion - (set-buffer (or buffer nntp-server-buffer)) - (erase-buffer) - (insert contents) - (goto-char (point-min)) - (while (search-forward "

" nil t) - (replace-match "

" t t)) - (goto-char (point-min)) - (insert "Content-Type: text/html\nMIME-Version: 1.0\n") - (insert "Newsgroups: " (caddr (assoc group nnslashdot-groups)) - "\n") - (let ((header (cdr (assq article nnslashdot-headers)))) - (nnheader-insert-header header)) - (nnheader-report 'nnslashdot "Fetched article %s" article) - (cons group article))))) + (re-search-forward "]+>") + (search-forward ""))))))) + (search-failed (nnslashdot-lose why)))) + + (when contents + (save-excursion + (set-buffer (or buffer nntp-server-buffer)) + (erase-buffer) + (insert contents) + (goto-char (point-min)) + (while (search-forward "

" nil t) + (replace-match "

" t t)) + (goto-char (point-min)) + (insert "Content-Type: text/html\nMIME-Version: 1.0\n") + (insert "Newsgroups: " (caddr (assoc group nnslashdot-groups)) + "\n") + (let ((header (cdr (assq article nnslashdot-headers)))) + (nnheader-insert-header header)) + (nnheader-report 'nnslashdot "Fetched article %s" article) + (cons group article))))) (deffoo nnslashdot-close-server (&optional server) (when (and (nnslashdot-server-opened server) @@ -363,49 +368,51 @@ (nnslashdot-possibly-change-server nil server) (let ((number 0) sid elem description articles gname) - ;; First we do the Ultramode to get info on all the latest groups. - (with-temp-buffer - (nnweb-insert "http://slashdot.org/slashdot.xml") - (goto-char (point-min)) - (while (search-forward "" nil t) - (narrow-to-region (point) (search-forward "")) - (goto-char (point-min)) - (re-search-forward "\\([^<]+\\)") - (setq description (match-string 1)) - (re-search-forward "\\([^<]+\\)") - (setq sid (match-string 1)) - (string-match "/\\([0-9/]+\\).shtml" sid) - (setq sid (match-string 1 sid)) - (re-search-forward "\\([^<]+\\)") - (setq articles (string-to-number (match-string 1))) - (setq gname (concat description " (" sid ")")) - (if (setq elem (assoc gname nnslashdot-groups)) - (setcar (cdr elem) articles) - (push (list gname articles sid) nnslashdot-groups)) - (goto-char (point-max)) - (widen))) - ;; Then do the older groups. - (while (> (- nnslashdot-group-number number) 0) - (with-temp-buffer - (let ((case-fold-search t)) - (nnweb-insert (format nnslashdot-active-url number)) - (goto-char (point-min)) - (while (re-search-forward - "article.pl\\?sid=\\([^&]+\\).*\\([^<]+\\)" nil t) - (setq sid (match-string 1) - description (match-string 2)) - (forward-line 1) - (when (re-search-forward "\\([0-9]+\\)" nil t) - (setq articles (string-to-number (match-string 1)))) - (setq gname (concat description " (" sid ")")) - (if (setq elem (assoc gname nnslashdot-groups)) - (setcar (cdr elem) articles) - (push (list gname articles sid) nnslashdot-groups))))) - (incf number 30)) + (condition-case why + ;; First we do the Ultramode to get info on all the latest groups. + (with-temp-buffer + (nnweb-insert "http://slashdot.org/slashdot.xml") + (goto-char (point-min)) + (while (search-forward "" nil t) + (narrow-to-region (point) (search-forward "")) + (goto-char (point-min)) + (re-search-forward "\\([^<]+\\)") + (setq description (match-string 1)) + (re-search-forward "\\([^<]+\\)") + (setq sid (match-string 1)) + (string-match "/\\([0-9/]+\\).shtml" sid) + (setq sid (match-string 1 sid)) + (re-search-forward "\\([^<]+\\)") + (setq articles (string-to-number (match-string 1))) + (setq gname (concat description " (" sid ")")) + (if (setq elem (assoc gname nnslashdot-groups)) + (setcar (cdr elem) articles) + (push (list gname articles sid) nnslashdot-groups)) + (goto-char (point-max)) + (widen))) + ;; Then do the older groups. + (while (> (- nnslashdot-group-number number) 0) + (with-temp-buffer + (let ((case-fold-search t)) + (nnweb-insert (format nnslashdot-active-url number)) + (goto-char (point-min)) + (while (re-search-forward + "article.pl\\?sid=\\([^&]+\\).*\\([^<]+\\)" nil t) + (setq sid (match-string 1) + description (match-string 2)) + (forward-line 1) + (when (re-search-forward "\\([0-9]+\\)" nil t) + (setq articles (string-to-number (match-string 1)))) + (setq gname (concat description " (" sid ")")) + (if (setq elem (assoc gname nnslashdot-groups)) + (setcar (cdr elem) articles) + (push (list gname articles sid) nnslashdot-groups))))) + (incf number 30)) + (search-failed (nnslashdot-lose why))) (nnslashdot-write-groups) (nnslashdot-generate-active) t)) - + (deffoo nnslashdot-request-newgroups (date &optional server) (nnslashdot-possibly-change-server nil server) (nnslashdot-generate-active) @@ -508,6 +515,9 @@ (insert (prin1-to-string (car elem)) " " (number-to-string (cadr elem)) " 1 y\n")))) +(defun nnslashdot-lose (why) + (error "Slashdot HTML has changed; please get a new version of nnslashdot")) + (provide 'nnslashdot) ;;; nnslashdot.el ends here -- 2.34.1