Mercurial > emacs
changeset 24357:15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
line wrap: on
line diff
--- a/lisp/gnus/gnus-art.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/gnus-art.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ ;;; gnus-art.el --- article mode commands for Gnus -;; Copyright (C) 1996,97 Free Software Foundation, Inc. +;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news ;; This file is part of GNU Emacs. @@ -27,6 +27,8 @@ (eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl)) + (require 'custom) (require 'gnus) (require 'gnus-sum) @@ -91,11 +93,26 @@ :group 'gnus-article) (defcustom gnus-ignored-headers - '("^Path:" "^Posting-Version:" "^Article-I.D.:" "^Expires:" - "^Date-Received:" "^References:" "^Control:" "^Xref:" "^Lines:" - "^Posted:" "^Relay-Version:" "^Message-ID:" "^Nf-ID:" "^Nf-From:" - "^Approved:" "^Sender:" "^Received:" "^Mail-from:") - "All headers that match this regexp will be hidden. + '("^Path:" "^Expires:" "^Date-Received:" "^References:" "^Xref:" "^Lines:" + "^Relay-Version:" "^Message-ID:" "^Approved:" "^Sender:" "^Received:" + "^X-UIDL:" "^MIME-Version:" "^Return-Path:" "^In-Reply-To:" + "^Content-Type:" "^Content-Transfer-Encoding:" "^X-WebTV-Signature:" + "^X-MimeOLE:" "^X-MSMail-Priority:" "^X-Priority:" "^X-Loop:" + "^X-Authentication-Warning:" "^X-MIME-Autoconverted:" "^X-Face:" + "^X-Attribution:" "^X-Originating-IP:" "^Delivered-To:" + "^NNTP-[-A-Za-z]+:" "^Distribution:" "^X-no-archive:" "^X-Trace:" + "^X-Complaints-To:" "^X-NNTP-Posting-Host:" "^X-Orig.*:" + "^Abuse-Reports-To:" "^Cache-Post-Path:" "^X-Article-Creation-Date:" + "^X-Poster:" "^X-Mail2News-Path:" "^X-Server-Date:" "^X-Cache:" + "^Originator:" "^X-Problems-To:" "^X-Auth-User:" "^X-Post-Time:" + "^X-Admin:" "^X-UID:" "^Resent-[-A-Za-z]+:" "^X-Mailing-List:" + "^Precedence:" "^Original-[-A-Za-z]+:" "^X-filename:" "^X-Orcpt:" + "^Old-Received:" "^X-Pgp-Fingerprint:" "^X-Pgp-Key-Id:" + "^X-Pgp-Public-Key-Url:" "^X-Auth:" "^X-From-Line:" + "^X-Gnus-Article-Number:" "^X-Majordomo:" "^X-Url:" "^X-Sender:" + "^X-Mailing-List:" "^MBOX-Line" "^Priority:" "^X-Pgp" "^X400-[-A-Za-z]+:" + "^Status:") + "*All headers that start with this regexp will be hidden. This variable can also be a list of regexps of headers to be ignored. If `gnus-visible-headers' is non-nil, this variable will be ignored." :type '(choice :custom-show nil @@ -104,8 +121,8 @@ :group 'gnus-article-hiding) (defcustom gnus-visible-headers - "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From" - "All headers that do not match this regexp will be hidden. + "From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:\\|X-Sent:" + "*All headers that do not match this regexp will be hidden. This variable can also be a list of regexp of headers to remain visible. If this variable is non-nil, `gnus-ignored-headers' will be ignored." :type '(repeat :value-to-internal (lambda (widget value) @@ -119,7 +136,7 @@ (defcustom gnus-sorted-header-list '("^From:" "^Subject:" "^Summary:" "^Keywords:" "^Newsgroups:" "^Followup-To:" "^To:" "^Cc:" "^Date:" "^Organization:") - "This variable is a list of regular expressions. + "*This variable is a list of regular expressions. If it is non-nil, headers that match the regular expressions will be placed first in the article buffer in the sequence specified by this list." @@ -129,12 +146,14 @@ (defcustom gnus-boring-article-headers '(empty followup-to reply-to) "Headers that are only to be displayed if they have interesting data. Possible values in this list are `empty', `newsgroups', `followup-to', -`reply-to', and `date'." +`reply-to', `date', `long-to', and `many-to'." :type '(set (const :tag "Headers with no content." empty) (const :tag "Newsgroups with only one group." newsgroups) (const :tag "Followup-to identical to newsgroups." followup-to) (const :tag "Reply-to identical to from." reply-to) - (const :tag "Date less than four days old." date)) + (const :tag "Date less than four days old." date) + (const :tag "Very long To header." long-to) + (const :tag "Multiple To headers." many-to)) :group 'gnus-article-hiding) (defcustom gnus-signature-separator '("^-- $" "^-- *$") @@ -153,7 +172,10 @@ will be called without any parameters, and if it returns nil, there is no signature in the buffer. If it is a string, it will be used as a regexp. If it matches, the text in question is not a signature." - :type '(choice integer number function regexp) + :type '(choice (integer :value 200) + (number :value 4.0) + (function :value fun) + (regexp :value ".*")) :group 'gnus-article-signature) (defcustom gnus-hidden-properties '(invisible t intangible t) @@ -163,7 +185,7 @@ (defcustom gnus-article-x-face-command "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -" - "String or function to be executed to display an X-Face header. + "*String or function to be executed to display an X-Face header. If it is a string, the command will be executed in a sub-shell asynchronously. The compressed face will be piped to this command." :type 'string ;Leave function case to Lisp. @@ -193,7 +215,7 @@ (format format (car spec) (cadr spec)) 2 3 (intern (format "gnus-emphasis-%s" (nth 2 spec))))) types))) - "Alist that says how to fontify certain phrases. + "*Alist that says how to fontify certain phrases. Each item looks like this: (\"_\\\\(\\\\w+\\\\)_\" 0 1 'underline) @@ -242,8 +264,12 @@ (defcustom gnus-article-time-format "%a, %b %d %Y %T %Z" "Format for display of Date headers in article bodies. -See `format-time-zone' for the possible values." - :type 'string +See `format-time-string' for the possible values. + +The variable can also be function, which should return a complete Date +header. The function is called with one argument, the time, which can +be fed to `format-time-string'." + :type '(choice string symbol) :link '(custom-manual "(gnus)Article Date") :group 'gnus-article-washing) @@ -268,7 +294,7 @@ :group 'gnus-article-saving :type '(choice (item always) (item :tag "never" nil) - (other :tag "once" t))) + (sexp :tag "once" :format "%t\n" :value t))) (defcustom gnus-saved-headers gnus-visible-headers "Headers to keep if `gnus-save-all-headers' is nil. @@ -327,7 +353,7 @@ (defcustom gnus-split-methods '((gnus-article-archive-name) (gnus-article-nndoc-name)) - "Variable used to suggest where articles are to be saved. + "*Variable used to suggest where articles are to be saved. For instance, if you would like to save articles related to Gnus in the file \"gnus-stuff\", and articles related to VM in \"vm-stuff\", you could set this variable to something like: @@ -347,9 +373,9 @@ a possible file name; and if it returns a non-nil list, that list will be used as possible file names." :group 'gnus-article-saving - :type '(repeat (choice (list function) - (cons regexp (repeat string)) - sexp))) + :type '(repeat (choice (list :value (fun) function) + (cons :value ("" "") regexp (repeat string)) + (sexp :value nil)))) (defcustom gnus-strict-mime t "*If nil, MIME-decode even if there is no Mime-Version header." @@ -377,8 +403,7 @@ "Function to decode ``localized RFC 822 messages''. The function is called from the article buffer." :group 'gnus-article-mime - :type 'function - :version "20.3") + :type 'function) (defcustom gnus-page-delimiter "^\^L" "*Regexp describing what to use as article page delimiters. @@ -412,8 +437,7 @@ (defcustom gnus-article-hide-pgp-hook nil "*A hook called after successfully hiding a PGP signature." :type 'hook - :group 'gnus-article-various - :version "20.3") + :group 'gnus-article-various) (defcustom gnus-article-button-face 'bold "Face used for highlighting buttons in the article buffer. @@ -448,12 +472,12 @@ (defface gnus-header-from-face '((((class color) (background dark)) - (:foreground "spring green" :bold t)) + (:foreground "spring green")) (((class color) (background light)) - (:foreground "red3" :bold t)) + (:foreground "red3")) (t - (:bold t :italic t))) + (:italic t))) "Face used for displaying from headers." :group 'gnus-article-headers :group 'gnus-article-highlight) @@ -461,10 +485,10 @@ (defface gnus-header-subject-face '((((class color) (background dark)) - (:foreground "SeaGreen3" :bold t)) + (:foreground "SeaGreen3")) (((class color) (background light)) - (:foreground "red4" :bold t)) + (:foreground "red4")) (t (:bold t :italic t))) "Face used for displaying subject headers." @@ -474,12 +498,12 @@ (defface gnus-header-newsgroups-face '((((class color) (background dark)) - (:foreground "yellow" :bold t :italic t)) + (:foreground "yellow" :italic t)) (((class color) (background light)) - (:foreground "MidnightBlue" :bold t :italic t)) + (:foreground "MidnightBlue" :italic t)) (t - (:bold t :italic t))) + (:italic t))) "Face used for displaying newsgroups headers." :group 'gnus-article-headers :group 'gnus-article-highlight) @@ -514,7 +538,7 @@ ("Subject" nil gnus-header-subject-face) ("Newsgroups:.*," nil gnus-header-newsgroups-face) ("" gnus-header-name-face gnus-header-content-face)) - "Controls highlighting of article header. + "*Controls highlighting of article header. An alist of the form (HEADER NAME CONTENT). @@ -537,6 +561,9 @@ ;;; Internal variables +(defvar article-lapsed-timer nil) +(defvar gnus-article-current-summary nil) + (defvar gnus-article-mode-syntax-table (let ((table (copy-syntax-table text-mode-syntax-table))) (modify-syntax-entry ?- "w" table) @@ -549,8 +576,8 @@ (defvar gnus-save-article-buffer nil) (defvar gnus-article-mode-line-format-alist - (nconc '((?w (gnus-article-wash-status) ?s)) - gnus-summary-mode-line-format-alist)) + (nconc '((?w (gnus-article-wash-status) ?s)) + gnus-summary-mode-line-format-alist)) (defvar gnus-number-of-articles-to-be-saved nil) @@ -577,7 +604,7 @@ b e (cons 'article-type (cons type gnus-hidden-properties)))) (defun gnus-article-unhide-text-type (b e type) - "Hide text of TYPE between B and E." + "Unhide text of TYPE between B and E." (remove-text-properties b e (cons 'article-type (cons type gnus-hidden-properties))) (when (memq 'intangible gnus-hidden-properties) @@ -630,6 +657,7 @@ If given a negative prefix, always show; if given a positive prefix, always hide." (interactive (gnus-article-hidden-arg)) + (current-buffer) (if (gnus-article-check-hidden-text 'headers arg) ;; Show boring headers as well. (gnus-article-show-hidden-text 'boring-headers) @@ -638,6 +666,7 @@ (save-excursion (save-restriction (let ((buffer-read-only nil) + (case-fold-search t) (props (nconc (list 'article-type 'headers) gnus-hidden-properties)) (max (1+ (length gnus-sorted-header-list))) @@ -654,7 +683,7 @@ (listp gnus-visible-headers)) (mapconcat 'identity gnus-visible-headers "\\|")))) (inhibit-point-motion-hooks t) - want-list beg) + beg) ;; First we narrow to just the headers. (widen) (goto-char (point-min)) @@ -755,7 +784,25 @@ (when (and date (< (gnus-days-between (current-time-string) date) 4)) - (gnus-article-hide-header "date"))))))))))) + (gnus-article-hide-header "date")))) + ((eq elem 'long-to) + (let ((to (message-fetch-field "to"))) + (when (> (length to) 1024) + (gnus-article-hide-header "to")))) + ((eq elem 'many-to) + (let ((to-count 0)) + (goto-char (point-min)) + (while (re-search-forward "^to:" nil t) + (setq to-count (1+ to-count))) + (when (> to-count 1) + (while (> to-count 0) + (goto-char (point-min)) + (save-restriction + (re-search-forward "^to:" nil nil to-count) + (forward-line -1) + (narrow-to-region (point) (point-max)) + (gnus-article-hide-header "to")) + (setq to-count (1- to-count))))))))))))) (defun gnus-article-hide-header (header) (save-excursion @@ -770,7 +817,29 @@ (point-max))) 'boring-headers)))) -;; Written by Per Abrahamsen <amanda@iesd.auc.dk>. +(defun article-treat-dumbquotes () + "Translate M******** sm*rtq**t*s into proper text." + (interactive) + (article-translate-characters "\221\222\223\223" "`'\"\"")) + +(defun article-translate-characters (from to) + "Translate all characters in the body of the article according to FROM and TO. +FROM is a string of characters to translate from; to is a string of +characters to translate to." + (save-excursion + (goto-char (point-min)) + (when (search-forward "\n\n" nil t) + (let ((buffer-read-only nil) + (x (make-string 225 ?x)) + (i -1)) + (while (< (incf i) (length x)) + (aset x i i)) + (setq i 0) + (while (< i (length from)) + (aset x (aref from i) (aref to i)) + (incf i)) + (translate-region (point) (point-max) x))))) + (defun article-treat-overstrike () "Translate overstrikes into bold text." (interactive) @@ -848,13 +917,14 @@ (when (process-status "article-x-face") (delete-process "article-x-face")) (let ((inhibit-point-motion-hooks t) - (case-fold-search nil) - from) + (case-fold-search t) + from last) (save-restriction (nnheader-narrow-to-headers) (setq from (message-fetch-field "from")) (goto-char (point-min)) (while (and gnus-article-x-face-command + (not last) (or force ;; Check whether this face is censored. (not gnus-article-x-face-too-ugly) @@ -863,6 +933,12 @@ from)))) ;; Has to be present. (re-search-forward "^X-Face: " nil t)) + ;; This used to try to do multiple faces (`while' instead of + ;; `when' above), but (a) sending multiple EOFs to xv doesn't + ;; work (b) it can crash some versions of Emacs (c) are + ;; multiple faces really something to encourage? + (when (stringp gnus-article-x-face-command) + (setq last t)) ;; We now have the area of the buffer where the X-Face is stored. (save-excursion (let ((beg (point)) @@ -975,29 +1051,27 @@ (goto-char (point-min)) ;; Hide the "header". (when (search-forward "\n-----BEGIN PGP SIGNED MESSAGE-----\n" nil t) - (gnus-article-hide-text-type (1+ (match-beginning 0)) - (match-end 0) 'pgp) + (delete-region (1+ (match-beginning 0)) (match-end 0)) (setq beg (point)) ;; Hide the actual signature. (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t) (setq end (1+ (match-beginning 0))) - (gnus-article-hide-text-type + (delete-region end (if (search-forward "\n-----END PGP SIGNATURE-----\n" nil t) (match-end 0) ;; Perhaps we shouldn't hide to the end of the buffer ;; if there is no end to the signature? - (point-max)) - 'pgp)) + (point-max)))) ;; Hide "- " PGP quotation markers. (when (and beg end) (narrow-to-region beg end) (goto-char (point-min)) (while (re-search-forward "^- " nil t) - (gnus-article-hide-text-type - (match-beginning 0) (match-end 0) 'pgp)) + (delete-region + (match-beginning 0) (match-end 0))) (widen)) - (run-hooks 'gnus-article-hide-pgp-hook)))))) + (gnus-run-hooks 'gnus-article-hide-pgp-hook)))))) (defun article-hide-pem (&optional arg) "Toggle hiding of any PEM headers and signatures in the current article. @@ -1087,42 +1161,54 @@ (article-remove-trailing-blank-lines) (article-strip-multiple-blank-lines)) +(defun article-strip-all-blank-lines () + "Strip all blank lines." + (interactive) + (save-excursion + (let ((inhibit-point-motion-hooks t) + buffer-read-only) + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (while (re-search-forward "^[ \t]*\n" nil t) + (replace-match "" t t))))) + (defvar mime::preview/content-list) (defvar mime::preview-content-info/point-min) (defun gnus-article-narrow-to-signature () "Narrow to the signature; return t if a signature is found, else nil." (widen) - (when (and (boundp 'mime::preview/content-list) - mime::preview/content-list) - ;; We have a MIMEish article, so we use the MIME data to narrow. - (let ((pcinfo (car (last mime::preview/content-list)))) - (ignore-errors - (narrow-to-region - (funcall (intern "mime::preview-content-info/point-min") pcinfo) - (point-max))))) + (let ((inhibit-point-motion-hooks t)) + (when (and (boundp 'mime::preview/content-list) + mime::preview/content-list) + ;; We have a MIMEish article, so we use the MIME data to narrow. + (let ((pcinfo (car (last mime::preview/content-list)))) + (ignore-errors + (narrow-to-region + (funcall (intern "mime::preview-content-info/point-min") pcinfo) + (point-max))))) - (when (gnus-article-search-signature) - (forward-line 1) - ;; Check whether we have some limits to what we consider - ;; to be a signature. - (let ((limits (if (listp gnus-signature-limit) gnus-signature-limit - (list gnus-signature-limit))) - limit limited) - (while (setq limit (pop limits)) - (if (or (and (integerp limit) - (< (- (point-max) (point)) limit)) - (and (floatp limit) - (< (count-lines (point) (point-max)) limit)) - (and (gnus-functionp limit) - (funcall limit)) - (and (stringp limit) - (not (re-search-forward limit nil t)))) - () ; This limit did not succeed. - (setq limited t - limits nil))) - (unless limited - (narrow-to-region (point) (point-max)) - t)))) + (when (gnus-article-search-signature) + (forward-line 1) + ;; Check whether we have some limits to what we consider + ;; to be a signature. + (let ((limits (if (listp gnus-signature-limit) gnus-signature-limit + (list gnus-signature-limit))) + limit limited) + (while (setq limit (pop limits)) + (if (or (and (integerp limit) + (< (- (point-max) (point)) limit)) + (and (floatp limit) + (< (count-lines (point) (point-max)) limit)) + (and (gnus-functionp limit) + (funcall limit)) + (and (stringp limit) + (not (re-search-forward limit nil t)))) + () ; This limit did not succeed. + (setq limited t + limits nil))) + (unless limited + (narrow-to-region (point) (point-max)) + t))))) (defun gnus-article-search-signature () "Search the current buffer for the signature separator. @@ -1142,7 +1228,8 @@ (eval-and-compile (autoload 'w3-display "w3-parse") - (autoload 'w3-do-setup "w3" "" t)) + (autoload 'w3-do-setup "w3" "" t) + (autoload 'w3-region "w3-display" "" t)) (defun gnus-article-treat-html () "Render HTML." @@ -1198,8 +1285,7 @@ (defun gnus-article-hidden-text-p (type) "Say whether the current buffer contains hidden text of type TYPE." - (let ((start (point-min)) - (pos (text-property-any (point-min) (point-max) 'article-type type))) + (let ((pos (text-property-any (point-min) (point-max) 'article-type type))) (while (and pos (not (get-text-property pos 'invisible))) (setq pos @@ -1249,7 +1335,7 @@ header)) (date-regexp "^Date:[ \t]\\|^X-Sent:[ \t]") (inhibit-point-motion-hooks t) - bface eface) + bface eface newline) (when (and date (not (string= date ""))) (save-excursion (save-restriction @@ -1261,17 +1347,22 @@ (setq bface (get-text-property (gnus-point-at-bol) 'face) eface (get-text-property (1- (gnus-point-at-eol)) 'face)) - (message-remove-header date-regexp t) + (delete-region (progn (beginning-of-line) (point)) + (progn (end-of-line) (point))) (beginning-of-line)) - (goto-char (point-max))) + (goto-char (point-max)) + (setq newline t)) (insert (article-make-date-line date type)) ;; Do highlighting. - (forward-line -1) + (beginning-of-line) (when (looking-at "\\([^:]+\\): *\\(.*\\)$") - (put-text-property (match-beginning 1) (match-end 1) + (put-text-property (match-beginning 1) (1+ (match-end 1)) 'face bface) (put-text-property (match-beginning 2) (match-end 2) - 'face eface)))))))) + 'face eface)) + (when newline + (end-of-line) + (insert "\n")))))))) (defun article-make-date-line (date type) "Return a DATE line of TYPE." @@ -1283,28 +1374,41 @@ ((eq type 'local) (concat "Date: " (condition-case () (timezone-make-date-arpa-standard date) - (error date)) - "\n")) + (error date)))) ;; Convert to Universal Time. ((eq type 'ut) (concat "Date: " (condition-case () (timezone-make-date-arpa-standard date nil "UT") - (error date)) - "\n")) + (error date)))) ;; Get the original date from the article. ((eq type 'original) - (concat "Date: " date "\n")) + (concat "Date: " date)) ;; Let the user define the format. ((eq type 'user) + (if (gnus-functionp gnus-article-time-format) + (funcall + gnus-article-time-format + (ignore-errors + (gnus-encode-date + (timezone-make-date-arpa-standard + date nil "UT")))) + (concat + "Date: " + (format-time-string gnus-article-time-format + (ignore-errors + (gnus-encode-date + (timezone-make-date-arpa-standard + date nil "UT"))))))) + ;; ISO 8601. + ((eq type 'iso8601) (concat "Date: " - (format-time-string gnus-article-time-format + (format-time-string "%Y%M%DT%h%m%s" (ignore-errors (gnus-encode-date (timezone-make-date-arpa-standard - date nil "UT")))) - "\n")) + date nil "UT")))))) ;; Do an X-Sent lapsed format. ((eq type 'lapsed) ;; If the date is seriously mangled, the timezone functions are @@ -1327,9 +1431,9 @@ num prev) (cond ((null real-time) - "X-Sent: Unknown\n") + "X-Sent: Unknown") ((zerop sec) - "X-Sent: Now\n") + "X-Sent: Now") (t (concat "X-Sent: " @@ -1355,8 +1459,8 @@ ;; If dates are odd, then it might appear like the ;; article was sent in the future. (if (> real-sec 0) - " ago\n" - " in the future\n")))))) + " ago" + " in the future")))))) (t (error "Unknown conversion type: %s" type)))) @@ -1377,12 +1481,46 @@ (interactive (list t)) (article-date-ut 'lapsed highlight)) +(defun article-update-date-lapsed () + "Function to be run from a timer to update the lapsed time line." + (let (deactivate-mark) + (save-excursion + (ignore-errors + (when (gnus-buffer-live-p gnus-article-buffer) + (set-buffer gnus-article-buffer) + (goto-char (point-min)) + (when (re-search-forward "^X-Sent:" nil t) + (article-date-lapsed t))))))) + +(defun gnus-start-date-timer (&optional n) + "Start a timer to update the X-Sent header in the article buffers. +The numerical prefix says how frequently (in seconds) the function +is to run." + (interactive "p") + (unless n + (setq n 1)) + (gnus-stop-date-timer) + (setq article-lapsed-timer + (nnheader-run-at-time 1 n 'article-update-date-lapsed))) + +(defun gnus-stop-date-timer () + "Stop the X-Sent timer." + (interactive) + (when article-lapsed-timer + (nnheader-cancel-timer article-lapsed-timer) + (setq article-lapsed-timer nil))) + (defun article-date-user (&optional highlight) "Convert the current article date to the user-defined format. This format is defined by the `gnus-article-time-format' variable." (interactive (list t)) (article-date-ut 'user highlight)) +(defun article-date-iso8601 (&optional highlight) + "Convert the current article date to ISO8601." + (interactive (list t)) + (article-date-ut 'iso8601 highlight)) + (defun article-show-all () "Show all hidden text in the article buffer." (interactive) @@ -1431,7 +1569,9 @@ (let ((gnus-visible-headers (or gnus-saved-headers gnus-visible-headers)) (gnus-article-buffer save-buffer)) - (gnus-article-hide-headers 1 t))) + (save-excursion + (set-buffer save-buffer) + (article-hide-headers 1 t)))) (save-window-excursion (if (not gnus-default-article-saver) (error "No default saver is defined") @@ -1448,7 +1588,7 @@ (gnus-number-of-articles-to-be-saved (when (eq gnus-prompt-before-saving t) num))) ; Magic - (set-buffer gnus-summary-buffer) + (set-buffer gnus-article-current-summary) (funcall gnus-default-article-saver filename))))) (defun gnus-read-save-file-name (prompt &optional filename @@ -1545,8 +1685,6 @@ "Append this article to Rmail file. Optional argument FILENAME specifies file name. Directory to save to is default to `gnus-article-save-directory'." - (interactive) - (gnus-set-global-variables) (setq filename (gnus-read-save-file-name "Save %s in rmail file:" filename gnus-rmail-save-name gnus-newsgroup-name @@ -1555,14 +1693,13 @@ (save-excursion (save-restriction (widen) - (gnus-output-to-rmail filename))))) + (gnus-output-to-rmail filename)))) + filename) (defun gnus-summary-save-in-mail (&optional filename) "Append this article to Unix mail file. Optional argument FILENAME specifies file name. Directory to save to is default to `gnus-article-save-directory'." - (interactive) - (gnus-set-global-variables) (setq filename (gnus-read-save-file-name "Save %s in Unix mail file:" filename gnus-mail-save-name gnus-newsgroup-name @@ -1574,14 +1711,13 @@ (if (and (file-readable-p filename) (mail-file-babyl-p filename)) (gnus-output-to-rmail filename t) - (gnus-output-to-mail filename)))))) + (gnus-output-to-mail filename))))) + filename) (defun gnus-summary-save-in-file (&optional filename overwrite) "Append this article to file. Optional argument FILENAME specifies file name. Directory to save to is default to `gnus-article-save-directory'." - (interactive) - (gnus-set-global-variables) (setq filename (gnus-read-save-file-name "Save %s in file:" filename gnus-file-save-name gnus-newsgroup-name @@ -1593,21 +1729,19 @@ (when (and overwrite (file-exists-p filename)) (delete-file filename)) - (gnus-output-to-file filename))))) + (gnus-output-to-file filename)))) + filename) (defun gnus-summary-write-to-file (&optional filename) "Write this article to a file. Optional argument FILENAME specifies file name. The directory to save in defaults to `gnus-article-save-directory'." - (interactive) (gnus-summary-save-in-file nil t)) (defun gnus-summary-save-body-in-file (&optional filename) "Append this article body to a file. Optional argument FILENAME specifies file name. The directory to save in defaults to `gnus-article-save-directory'." - (interactive) - (gnus-set-global-variables) (setq filename (gnus-read-save-file-name "Save %s body in file:" filename gnus-file-save-name gnus-newsgroup-name @@ -1619,12 +1753,11 @@ (goto-char (point-min)) (when (search-forward "\n\n" nil t) (narrow-to-region (point) (point-max))) - (gnus-output-to-file filename))))) + (gnus-output-to-file filename)))) + filename) (defun gnus-summary-save-in-pipe (&optional command) "Pipe this article to subprocess." - (interactive) - (gnus-set-global-variables) (setq command (cond ((eq command 'default) gnus-last-shell-command) @@ -1748,12 +1881,15 @@ article-strip-multiple-blank-lines article-strip-leading-space article-strip-blank-lines + article-strip-all-blank-lines article-date-local + article-date-iso8601 article-date-original article-date-ut article-date-user article-date-lapsed article-emphasize + article-treat-dumbquotes (article-show-all . gnus-article-show-all-headers)))) ;;; @@ -1800,7 +1936,8 @@ ["Scroll backwards" gnus-article-goto-prev-page t] ["Show summary" gnus-article-show-summary t] ["Fetch Message-ID at point" gnus-article-refer-article t] - ["Mail to address at point" gnus-article-mail t])) + ["Mail to address at point" gnus-article-mail t] + ["Send a bug report" gnus-bug t])) (easy-menu-define gnus-article-treatment-menu gnus-article-mode-map "" @@ -1812,16 +1949,13 @@ ["Remove carriage return" gnus-article-remove-cr t] ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t])) - (when nil - (when (boundp 'gnus-summary-article-menu) - (define-key gnus-article-mode-map [menu-bar commands] - (cons "Commands" gnus-summary-article-menu)))) + ;; Note "Commands" menu is defined in gnus-sum.el for consistency (when (boundp 'gnus-summary-post-menu) (define-key gnus-article-mode-map [menu-bar post] (cons "Post" gnus-summary-post-menu))) - (run-hooks 'gnus-article-menu-hook))) + (gnus-run-hooks 'gnus-article-menu-hook))) (defun gnus-article-mode () "Major mode for displaying an article. @@ -1841,7 +1975,6 @@ (interactive) (when (gnus-visual-p 'article-menu 'menu) (gnus-article-make-menu-bar)) - (kill-all-local-variables) (gnus-simplify-mode-line) (setq mode-name "Article") (setq major-mode 'gnus-article-mode) @@ -1851,13 +1984,14 @@ (use-local-map gnus-article-mode-map) (gnus-update-format-specifications nil 'article-mode) (set (make-local-variable 'page-delimiter) gnus-page-delimiter) - (set (make-local-variable 'gnus-page-broken) nil) - (set (make-local-variable 'gnus-button-marker-list) nil) + (make-local-variable 'gnus-page-broken) + (make-local-variable 'gnus-button-marker-list) + (make-local-variable 'gnus-article-current-summary) (gnus-set-default-directory) (buffer-disable-undo (current-buffer)) (setq buffer-read-only t) (set-syntax-table gnus-article-mode-syntax-table) - (run-hooks 'gnus-article-mode-hook)) + (gnus-run-hooks 'gnus-article-mode-hook)) (defun gnus-article-setup-buffer () "Initialize the article buffer." @@ -1878,23 +2012,20 @@ (gnus-set-global-variables))) ;; Init original article buffer. (save-excursion - (set-buffer (get-buffer-create gnus-original-article-buffer)) + (set-buffer (gnus-get-buffer-create gnus-original-article-buffer)) (buffer-disable-undo (current-buffer)) (setq major-mode 'gnus-original-article-mode) - (gnus-add-current-to-buffer-list) (make-local-variable 'gnus-original-article)) (if (get-buffer name) (save-excursion (set-buffer name) (buffer-disable-undo (current-buffer)) (setq buffer-read-only t) - (gnus-add-current-to-buffer-list) (unless (eq major-mode 'gnus-article-mode) (gnus-article-mode)) (current-buffer)) (save-excursion - (set-buffer (get-buffer-create name)) - (gnus-add-current-to-buffer-list) + (set-buffer (gnus-get-buffer-create name)) (gnus-article-mode) (make-local-variable 'gnus-summary-buffer) (current-buffer))))) @@ -1924,14 +2055,9 @@ (unless (eq major-mode 'gnus-summary-mode) (set-buffer gnus-summary-buffer)) (setq gnus-summary-buffer (current-buffer)) - ;; Make sure the connection to the server is alive. - (unless (gnus-server-opened - (gnus-find-method-for-group gnus-newsgroup-name)) - (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name)) - (gnus-request-group gnus-newsgroup-name t)) (let* ((gnus-article (if header (mail-header-number header) article)) (summary-buffer (current-buffer)) - (internal-hook gnus-article-internal-prepare-hook) + (gnus-tmp-internal-hook gnus-article-internal-prepare-hook) (group gnus-newsgroup-name) result) (save-excursion @@ -1952,17 +2078,21 @@ (cons gnus-newsgroup-name article)) (set-buffer gnus-summary-buffer) (setq gnus-current-article article) - (gnus-summary-mark-article article gnus-canceled-mark)) - (unless (memq article gnus-newsgroup-sparse) - (gnus-error - 1 "No such article (may have expired or been canceled)"))) - (if (or (eq result 'pseudo) (eq result 'nneething)) + (if (eq (gnus-article-mark article) gnus-undownloaded-mark) + (progn + (gnus-summary-set-agent-mark article) + (message "Message marked for downloading")) + (gnus-summary-mark-article article gnus-canceled-mark) + (unless (memq article gnus-newsgroup-sparse) + (gnus-error 1 + "No such article (may have expired or been canceled)"))))) + (if (or (eq result 'pseudo) + (eq result 'nneething)) (progn (save-excursion (set-buffer summary-buffer) + (push article gnus-newsgroup-history) (setq gnus-last-article gnus-current-article - gnus-newsgroup-history (cons gnus-current-article - gnus-newsgroup-history) gnus-current-article 0 gnus-current-headers nil gnus-article-current nil) @@ -1980,9 +2110,8 @@ ;; `gnus-current-article' must be an article number. (save-excursion (set-buffer summary-buffer) + (push article gnus-newsgroup-history) (setq gnus-last-article gnus-current-article - gnus-newsgroup-history (cons gnus-current-article - gnus-newsgroup-history) gnus-current-article article gnus-current-headers (gnus-summary-article-header gnus-current-article) @@ -1990,41 +2119,41 @@ (cons gnus-newsgroup-name gnus-current-article)) (unless (vectorp gnus-current-headers) (setq gnus-current-headers nil)) - (gnus-summary-show-thread) - (run-hooks 'gnus-mark-article-hook) + (gnus-summary-goto-subject gnus-current-article) + (when (gnus-summary-show-thread) + ;; If the summary buffer really was folded, the + ;; previous goto may not actually have gone to + ;; the right article, but the thread root instead. + ;; So we go again. + (gnus-summary-goto-subject gnus-current-article)) + (gnus-run-hooks 'gnus-mark-article-hook) (gnus-set-mode-line 'summary) (when (gnus-visual-p 'article-highlight 'highlight) - (run-hooks 'gnus-visual-mark-article-hook)) + (gnus-run-hooks 'gnus-visual-mark-article-hook)) ;; Set the global newsgroup variables here. ;; Suggested by Jim Sisolak ;; <sisolak@trans4.neep.wisc.edu>. (gnus-set-global-variables) (setq gnus-have-all-headers - (or all-headers gnus-show-all-headers)) - (and gnus-use-cache - (vectorp (gnus-summary-article-header article)) - (gnus-cache-possibly-enter-article - group article - (gnus-summary-article-header article) - (memq article gnus-newsgroup-marked) - (memq article gnus-newsgroup-dormant) - (memq article gnus-newsgroup-unreads))))) + (or all-headers gnus-show-all-headers)))) (when (or (numberp article) (stringp article)) ;; Hooks for getting information from the article. ;; This hook must be called before being narrowed. (let (buffer-read-only) - (run-hooks 'internal-hook) - (run-hooks 'gnus-article-prepare-hook) + (gnus-run-hooks 'gnus-tmp-internal-hook) + (gnus-run-hooks 'gnus-article-prepare-hook) ;; Decode MIME message. - (if gnus-show-mime - (if (or (not gnus-strict-mime) - (gnus-fetch-field "Mime-Version")) - (funcall gnus-show-mime-method) - (funcall gnus-decode-encoded-word-method)) - (funcall gnus-show-traditional-method)) + (if gnus-show-mime + (if (or (not gnus-strict-mime) + (gnus-fetch-field "Mime-Version")) + (let ((coding-system-for-write 'binary) + (coding-system-for-read 'binary)) + (funcall gnus-show-mime-method)) + (funcall gnus-decode-encoded-word-method)) + (funcall gnus-show-traditional-method)) ;; Perform the article display hooks. - (run-hooks 'gnus-article-display-hook)) + (gnus-run-hooks 'gnus-article-display-hook)) ;; Do page break. (goto-char (point-min)) (setq gnus-page-broken @@ -2034,6 +2163,8 @@ (gnus-set-mode-line 'article) (gnus-configure-windows 'article) (goto-char (point-min)) + (search-forward "\n\n" nil t) + (set-window-point (get-buffer-window (current-buffer)) (point)) t)))))) (defun gnus-article-wash-status () @@ -2058,7 +2189,9 @@ (if mime ?m ? ) (if emphasis ?e ? ))))) -(defun gnus-article-hide-headers-if-wanted () +(fset 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers) + +(defun gnus-article-maybe-hide-headers () "Hide unwanted headers if `gnus-have-all-headers' is nil. Provided for backwards compatibility." (or (save-excursion (set-buffer gnus-summary-buffer) gnus-have-all-headers) @@ -2198,7 +2331,8 @@ (error "There is no summary buffer for this article buffer") (gnus-article-set-globals) (gnus-configure-windows 'article) - (gnus-summary-goto-subject gnus-current-article))) + (gnus-summary-goto-subject gnus-current-article) + (gnus-summary-position-point))) (defun gnus-article-describe-briefly () "Describe article mode commands briefly." @@ -2212,7 +2346,7 @@ (let ((obuf (current-buffer)) (owin (current-window-configuration)) func) - (switch-to-buffer gnus-summary-buffer 'norecord) + (switch-to-buffer gnus-article-current-summary 'norecord) (setq func (lookup-key (current-local-map) (this-command-keys))) (call-interactively func) (set-buffer obuf) @@ -2223,7 +2357,7 @@ "Execute the last keystroke in the summary buffer." (interactive) (let (func) - (pop-to-buffer gnus-summary-buffer 'norecord) + (pop-to-buffer gnus-article-current-summary 'norecord) (setq func (lookup-key (current-local-map) (this-command-keys))) (call-interactively func))) @@ -2231,85 +2365,101 @@ "Read a summary buffer key sequence and execute it from the article buffer." (interactive "P") (let ((nosaves - '("q" "Q" "c" "r" "R" "\C-c\C-f" "m" "a" "f" "F" - "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP" - "=" "^" "\M-^" "|")) - (nosave-but-article - '("A\r")) - (nosave-in-article - '("\C-d")) - keys) + '("q" "Q" "c" "r" "R" "\C-c\C-f" "m" "a" "f" "F" + "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP" + "=" "^" "\M-^" "|")) + (nosave-but-article + '("A\r")) + (nosave-in-article + '("\C-d")) + (up-to-top + '("n" "Gn" "p" "Gp")) + keys new-sum-point) (save-excursion - (set-buffer gnus-summary-buffer) + (set-buffer gnus-article-current-summary) (let (gnus-pick-mode) - (push (or key last-command-event) unread-command-events) - (setq keys (read-key-sequence nil)))) + (push (or key last-command-event) unread-command-events) + (setq keys (read-key-sequence nil)))) (message "") (if (or (member keys nosaves) - (member keys nosave-but-article) - (member keys nosave-in-article)) - (let (func) - (save-window-excursion - (pop-to-buffer gnus-summary-buffer 'norecord) - ;; We disable the pick minor mode commands. - (let (gnus-pick-mode) - (setq func (lookup-key (current-local-map) keys)))) - (if (not func) - (ding) - (unless (member keys nosave-in-article) - (set-buffer gnus-summary-buffer)) - (call-interactively func)) - (when (member keys nosave-but-article) - (pop-to-buffer gnus-article-buffer 'norecord))) + (member keys nosave-but-article) + (member keys nosave-in-article)) + (let (func) + (save-window-excursion + (pop-to-buffer gnus-article-current-summary 'norecord) + ;; We disable the pick minor mode commands. + (let (gnus-pick-mode) + (setq func (lookup-key (current-local-map) keys)))) + (if (not func) + (ding) + (unless (member keys nosave-in-article) + (set-buffer gnus-article-current-summary)) + (call-interactively func) + (setq new-sum-point (point))) + (when (member keys nosave-but-article) + (pop-to-buffer gnus-article-buffer 'norecord))) ;; These commands should restore window configuration. (let ((obuf (current-buffer)) - (owin (current-window-configuration)) - (opoint (point)) - func in-buffer) - (if not-restore-window - (pop-to-buffer gnus-summary-buffer 'norecord) - (switch-to-buffer gnus-summary-buffer 'norecord)) - (setq in-buffer (current-buffer)) - ;; We disable the pick minor mode commands. - (if (setq func (let (gnus-pick-mode) - (lookup-key (current-local-map) keys))) - (call-interactively func) - (ding)) - (when (eq in-buffer (current-buffer)) - (set-buffer obuf) - (unless not-restore-window - (set-window-configuration owin)) - (set-window-point (get-buffer-window (current-buffer)) opoint)))))) + (owin (current-window-configuration)) + (opoint (point)) + (summary gnus-article-current-summary) + func in-buffer selected) + (if not-restore-window + (pop-to-buffer summary 'norecord) + (switch-to-buffer summary 'norecord)) + (setq in-buffer (current-buffer)) + ;; We disable the pick minor mode commands. + (if (setq func (let (gnus-pick-mode) + (lookup-key (current-local-map) keys))) + (progn + (call-interactively func) + (setq new-sum-point (point))) + (ding)) + (when (eq in-buffer (current-buffer)) + (setq selected (gnus-summary-select-article)) + (set-buffer obuf) + (unless not-restore-window + (set-window-configuration owin)) + (unless (or (not (eq selected 'old)) (member keys up-to-top)) + (set-window-point (get-buffer-window (current-buffer)) + opoint)) + (let ((win (get-buffer-window gnus-article-current-summary))) + (when win + (set-window-point win new-sum-point)))))))) (defun gnus-article-hide (&optional arg force) "Hide all the gruft in the current article. This means that PGP stuff, signatures, cited text and (some) headers will be hidden. If given a prefix, show the hidden text instead." - (interactive (list current-prefix-arg 'force)) + (interactive (append (gnus-article-hidden-arg) (list 'force))) (gnus-article-hide-headers arg) (gnus-article-hide-pgp arg) (gnus-article-hide-citation-maybe arg force) (gnus-article-hide-signature arg)) (defun gnus-article-maybe-highlight () - "Do some article highlighting if `article-visual' is non-nil." + "Do some article highlighting if article highlighting is requested." (when (gnus-visual-p 'article-highlight 'highlight) (gnus-article-highlight-some))) +(defun gnus-check-group-server () + ;; Make sure the connection to the server is alive. + (unless (gnus-server-opened + (gnus-find-method-for-group gnus-newsgroup-name)) + (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name)) + (gnus-request-group gnus-newsgroup-name t))) + (defun gnus-request-article-this-buffer (article group) "Get an article and insert it into this buffer." - (let (do-update-line) + (let (do-update-line sparse-header) (prog1 (save-excursion (erase-buffer) (gnus-kill-all-overlays) (setq group (or group gnus-newsgroup-name)) - ;; Open server if it has closed. - (gnus-check-server (gnus-find-method-for-group group)) - ;; Using `gnus-request-article' directly will insert the article into ;; `nntp-server-buffer' - so we'll save some time by not having to ;; copy it from the server buffer into the article buffer. @@ -2326,7 +2476,7 @@ (when (and (numberp article) gnus-summary-buffer (get-buffer gnus-summary-buffer) - (buffer-name (get-buffer gnus-summary-buffer))) + (gnus-buffer-exists-p gnus-summary-buffer)) (save-excursion (set-buffer gnus-summary-buffer) (let ((header (gnus-summary-article-header article))) @@ -2337,7 +2487,7 @@ (setq do-update-line article) (setq article (mail-header-id header)) (let ((gnus-override-method gnus-refer-article-method)) - (gnus-read-header article)) + (setq sparse-header (gnus-read-header article))) (setq gnus-newsgroup-sparse (delq article gnus-newsgroup-sparse))) ((vectorp header) @@ -2350,10 +2500,13 @@ (let ((method (gnus-find-method-for-group gnus-newsgroup-name))) - (if (not (eq (car method) 'nneething)) - () - (let ((dir (concat (file-name-as-directory (nth 1 method)) - (mail-header-subject header)))) + (when (and (eq (car method) 'nneething) + (vectorp header)) + (let ((dir (concat + (file-name-as-directory + (or (cadr (assq 'nneething-address method)) + (nth 1 method))) + (mail-header-subject header)))) (when (file-directory-p dir) (setq article 'nneething) (gnus-group-enter-directory dir)))))))) @@ -2363,7 +2516,7 @@ ((and (numberp article) gnus-summary-buffer (get-buffer gnus-summary-buffer) - (buffer-name (get-buffer gnus-summary-buffer)) + (gnus-buffer-exists-p gnus-summary-buffer) (eq (cdr (save-excursion (set-buffer gnus-summary-buffer) (assq article gnus-newsgroup-reads))) @@ -2385,6 +2538,8 @@ ;; Check asynchronous pre-fetch. ((gnus-async-request-fetched-article group article (current-buffer)) (gnus-async-prefetch-next group article gnus-summary-buffer) + (when (and (numberp article) gnus-keep-backlog) + (gnus-backlog-enter-article group article (current-buffer))) 'article) ;; Check the cache. ((and gnus-use-cache @@ -2398,6 +2553,7 @@ (buffer-read-only nil)) (erase-buffer) (gnus-kill-all-overlays) + (gnus-check-group-server) (when (gnus-request-article article group (current-buffer)) (when (numberp article) (gnus-async-prefetch-next group article gnus-summary-buffer) @@ -2408,20 +2564,21 @@ ;; It was a pseudo. (t article))) + ;; Associate this article with the current summary buffer. + (setq gnus-article-current-summary gnus-summary-buffer) + ;; Take the article from the original article buffer ;; and place it in the buffer it's supposed to be in. (when (and (get-buffer gnus-article-buffer) - ;;(numberp article) (equal (buffer-name (current-buffer)) (buffer-name (get-buffer gnus-article-buffer)))) (save-excursion (if (get-buffer gnus-original-article-buffer) - (set-buffer (get-buffer gnus-original-article-buffer)) - (set-buffer (get-buffer-create gnus-original-article-buffer)) + (set-buffer gnus-original-article-buffer) + (set-buffer (gnus-get-buffer-create gnus-original-article-buffer)) (buffer-disable-undo (current-buffer)) (setq major-mode 'gnus-original-article-mode) - (setq buffer-read-only t) - (gnus-add-current-to-buffer-list)) + (setq buffer-read-only t)) (let (buffer-read-only) (erase-buffer) (insert-buffer-substring gnus-article-buffer)) @@ -2433,7 +2590,7 @@ (stringp article))) (let ((buf (current-buffer))) (set-buffer gnus-summary-buffer) - (gnus-summary-update-article do-update-line) + (gnus-summary-update-article do-update-line sparse-header) (gnus-summary-goto-subject do-update-line nil t) (set-window-point (get-buffer-window (current-buffer) t) (point)) @@ -2469,7 +2626,6 @@ \\{gnus-article-edit-mode-map}" (interactive) - (kill-all-local-variables) (setq major-mode 'gnus-article-edit-mode) (setq mode-name "Article Edit") (use-local-map gnus-article-edit-mode-map) @@ -2478,7 +2634,7 @@ (setq buffer-read-only nil) (buffer-enable-undo) (widen) - (run-hooks 'text-mode 'gnus-article-edit-mode-hook)) + (gnus-run-hooks 'text-mode-hook 'gnus-article-edit-mode-hook)) (defun gnus-article-edit (&optional force) "Edit the current article. @@ -2489,26 +2645,50 @@ (when (and (not force) (gnus-group-read-only-p)) (error "The current newsgroup does not support article editing")) + (gnus-article-date-original) (gnus-article-edit-article - `(lambda () + `(lambda (no-highlight) (gnus-summary-edit-article-done ,(or (mail-header-references gnus-current-headers) "") - ,(gnus-group-read-only-p) ,gnus-summary-buffer)))) + ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight)))) (defun gnus-article-edit-article (exit-func) "Start editing the contents of the current article buffer." (let ((winconf (current-window-configuration))) (set-buffer gnus-article-buffer) (gnus-article-edit-mode) + (gnus-article-delete-text-of-type 'annotation) (gnus-set-text-properties (point-min) (point-max) nil) (gnus-configure-windows 'edit-article) (setq gnus-article-edit-done-function exit-func) (setq gnus-prev-winconf winconf) (gnus-message 6 "C-c C-c to end edits"))) -(defun gnus-article-edit-done () +(defun gnus-article-edit-done (&optional arg) "Update the article edits and exit." - (interactive) + (interactive "P") + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (when (search-forward "\n\n" nil 1) + (let ((lines (count-lines (point) (point-max))) + (length (- (point-max) (point))) + (case-fold-search t) + (body (copy-marker (point)))) + (goto-char (point-min)) + (when (re-search-forward "^content-length:[ \t]\\([0-9]+\\)" body t) + (delete-region (match-beginning 1) (match-end 1)) + (insert (number-to-string length))) + (goto-char (point-min)) + (when (re-search-forward + "^x-content-length:[ \t]\\([0-9]+\\)" body t) + (delete-region (match-beginning 1) (match-end 1)) + (insert (number-to-string length))) + (goto-char (point-min)) + (when (re-search-forward "^lines:[ \t]\\([0-9]+\\)" body t) + (delete-region (match-beginning 1) (match-end 1)) + (insert (number-to-string lines))))))) (let ((func gnus-article-edit-done-function) (buf (current-buffer)) (start (window-start))) @@ -2516,7 +2696,7 @@ (save-excursion (set-buffer buf) (let ((buffer-read-only nil)) - (funcall func))) + (funcall func arg))) (set-buffer buf) (set-window-start (get-buffer-window buf) start) (set-window-point (get-buffer-window buf) (point)))) @@ -2576,21 +2756,23 @@ :type 'regexp) (defcustom gnus-button-alist - `(("<\\(url: ?\\)?news:\\([^>\n\t ]*@[^>\n\t ]*\\)>" 0 t + `(("<\\(url:[>\n\t ]*?\\)?news:[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>" 0 t gnus-button-message-id 2) ("\\bnews:\\([^>\n\t ]*@[^>\n\t ]*\\)" 0 t gnus-button-message-id 1) - ("\\(\\b<\\(url: ?\\)?news:\\(//\\)?\\([^>\n\t ]*\\)>\\)" 1 t + ("\\(\\b<\\(url:[>\n\t ]*\\)?news:[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)" + 1 t gnus-button-fetch-group 4) - ("\\bnews:\\(//\\)?\\([^>\n\t ]+\\)" 0 t gnus-button-fetch-group 2) - ("\\bin\\( +article\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2 + ("\\bnews:\\(//\\)?\\([^'\">\n\t ]+\\)" 0 t gnus-button-fetch-group 2) + ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2 t gnus-button-message-id 3) ("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>" 0 t gnus-url-mailto 2) + ("mailto:\\([a-zA-Z.-@_+0-9%]+\\)" 0 t gnus-url-mailto 1) ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 1) ;; This is how URLs _should_ be embedded in text... ("<URL: *\\([^>]*\\)>" 0 t gnus-button-embedded-url 1) ;; Raw URLs. (,gnus-button-url-regexp 0 t gnus-button-url 0)) - "Alist of regexps matching buttons in article bodies. + "*Alist of regexps matching buttons in article bodies. Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where REGEXP: is the string matching text around the button, @@ -2622,7 +2804,7 @@ ("^[^:]+:" ,gnus-button-url-regexp 0 t gnus-button-url 0) ("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t gnus-button-message-id 3)) - "Alist of headers and regexps to match buttons in article heads. + "*Alist of headers and regexps to match buttons in article heads. This alist is very similar to `gnus-button-alist', except that each alist has an additional HEADER element first in each entry: @@ -2660,6 +2842,7 @@ (let* ((pos (posn-point (event-start event))) (data (get-text-property pos 'gnus-data)) (fun (get-text-property pos 'gnus-callback))) + (goto-char pos) (when fun (funcall fun data)))) @@ -2964,14 +3147,6 @@ (match-string 3 address) "nntp"))))))) -(defun gnus-split-string (string pattern) - "Return a list of substrings of STRING which are separated by PATTERN." - (let (parts (start 0)) - (while (string-match pattern string start) - (setq parts (cons (substring string start (match-beginning 0)) parts) - start (match-end 0))) - (nreverse (cons (substring string start) parts)))) - (defun gnus-url-parse-query-string (query &optional downcase) (let (retval pairs cur key val) (setq pairs (gnus-split-string query "&")) @@ -3026,7 +3201,7 @@ ;; Send mail to someone (when (string-match "mailto:/*\\(.*\\)" url) (setq url (substring url (match-beginning 1) nil))) - (let (to args source-url subject func) + (let (to args subject func) (if (string-match (regexp-quote "?") url) (setq to (gnus-url-unhex-string (substring url 0 (match-beginning 0))) args (gnus-url-parse-query-string @@ -3061,6 +3236,7 @@ (defun gnus-button-embedded-url (address) "Browse ADDRESS." + ;; In Emacs 20, `browse-url-browser-function' may be an alist. (browse-url (gnus-strip-whitespace address))) ;;; Next/prev buttons in the article buffer. @@ -3079,7 +3255,8 @@ (gnus-eval-format gnus-prev-page-line-format nil `(gnus-prev t local-map ,gnus-prev-page-map - gnus-callback gnus-article-button-prev-page)))) + gnus-callback gnus-article-button-prev-page + gnus-type annotation)))) (defvar gnus-next-page-map nil) (unless gnus-next-page-map @@ -3107,9 +3284,10 @@ (defun gnus-insert-next-page-button () (let ((buffer-read-only nil)) (gnus-eval-format gnus-next-page-line-format nil - `(gnus-next t local-map ,gnus-next-page-map - gnus-callback - gnus-article-button-next-page)))) + `(gnus-next + t local-map ,gnus-next-page-map + gnus-callback gnus-article-button-next-page + gnus-type annotation)))) (defun gnus-article-button-next-page (arg) "Go to the next page."
--- a/lisp/gnus/gnus-async.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/gnus-async.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ ;;; gnus-async.el --- asynchronous support for Gnus -;; Copyright (C) 1996,97 Free Software Foundation, Inc. +;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news ;; This file is part of GNU Emacs. @@ -27,6 +27,8 @@ (eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl)) + (require 'gnus) (require 'gnus-sum) (require 'nntp) @@ -77,6 +79,7 @@ (defvar gnus-async-article-alist nil) (defvar gnus-async-article-semaphore '(nil)) (defvar gnus-async-fetch-list nil) +(defvar gnus-asynch-obarray nil) (defvar gnus-async-prefetch-headers-buffer " *Async Prefetch Headers*") (defvar gnus-async-header-prefetched nil) @@ -120,7 +123,10 @@ gnus-async-header-prefetched nil)) (defun gnus-async-set-buffer () - (nnheader-set-temp-buffer gnus-async-prefetch-article-buffer t)) + (nnheader-set-temp-buffer gnus-async-prefetch-article-buffer t) + (unless gnus-asynch-obarray + (set (make-local-variable 'gnus-asynch-obarray) + (gnus-make-hashtable 1023)))) (defun gnus-async-halt-prefetch () "Stop prefetching." @@ -209,10 +215,13 @@ (when arg (gnus-async-set-buffer) (gnus-async-with-semaphore - (push (list ',(intern (format "%s-%d" group article)) - ,mark (set-marker (make-marker) (point-max)) - ,group ,article) - gnus-async-article-alist))) + (setq + gnus-async-article-alist + (cons (list ',(intern (format "%s-%d" group article) + gnus-asynch-obarray) + ,mark (set-marker (make-marker) (point-max)) + ,group ,article) + gnus-async-article-alist)))) (if (not (gnus-buffer-live-p ,summary)) (gnus-async-with-semaphore (setq gnus-async-fetch-list nil)) @@ -259,8 +268,11 @@ (defun gnus-async-prefetched-article-entry (group article) "Return the entry for ARTICLE in GROUP iff it has been prefetched." - (let ((entry (assq (intern (format "%s-%d" group article)) - gnus-async-article-alist))) + (let ((entry (save-excursion + (gnus-async-set-buffer) + (assq (intern (format "%s-%d" group article) + gnus-asynch-obarray) + gnus-async-article-alist)))) ;; Perhaps something has emptied the buffer? (if (and entry (= (cadr entry) (caddr entry)))
--- a/lisp/gnus/gnus-audio.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/gnus-audio.el Sat Feb 20 14:05:57 1999 +0000 @@ -2,7 +2,6 @@ ;; Copyright (C) 1996 Free Software Foundation ;; Author: Steven L. Baur <steve@miranova.com> -;; Keywords: news ;; This file is part of GNU Emacs. @@ -42,12 +41,12 @@ "The directory containing the Sound Files.") (defvar gnus-audio-au-player "/usr/bin/showaudio" - "Executable program for playing sun AU format sound files") + "Executable program for playing sun AU format sound files.") + (defvar gnus-audio-wav-player "/usr/local/bin/play" - "Executable program for playing WAV files") + "Executable program for playing WAV files.") - -;;; The following isn't implemented yet. Wait for Red Gnus. +;;; The following isn't implemented yet. Wait for Millennium Gnus. ;(defvar gnus-audio-effects-enabled t ; "When t, Gnus will use sound effects.") ;(defvar gnus-audio-enable-hooks nil @@ -71,14 +70,14 @@ ; "Enable Sound Effects for Gnus." ; (interactive) ; (setq gnus-audio-effects-enabled t) -; (run-hooks gnus-audio-enable-hooks)) +; (gnus-run-hooks gnus-audio-enable-hooks)) ;;;###autoload ;(defun gnus-audio-disable-sound () ; "Disable Sound Effects for Gnus." ; (interactive) ; (setq gnus-audio-effects-enabled nil) -; (run-hooks gnus-audio-disable-hooks)) +; (gnus-run-hooks gnus-audio-disable-hooks)) ;;;###autoload (defun gnus-audio-play (file)
--- a/lisp/gnus/gnus-bcklg.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/gnus-bcklg.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ ;;; gnus-bcklg.el --- backlog functions for Gnus -;; Copyright (C) 1996,97 Free Software Foundation, Inc. +;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news ;; This file is part of GNU Emacs. @@ -27,6 +27,8 @@ (eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl)) + (require 'gnus) ;;; @@ -41,10 +43,9 @@ "Return the backlog buffer." (or (get-buffer gnus-backlog-buffer) (save-excursion - (set-buffer (get-buffer-create gnus-backlog-buffer)) + (set-buffer (gnus-get-buffer-create gnus-backlog-buffer)) (buffer-disable-undo (current-buffer)) (setq buffer-read-only t) - (gnus-add-current-to-buffer-list) (get-buffer gnus-backlog-buffer)))) (defun gnus-backlog-setup () @@ -122,7 +123,8 @@ (1+ beg) 'gnus-backlog (current-buffer) (point-max))) (delete-region beg end) ;; Return success. - t))))))) + t)) + (setq gnus-backlog-articles (delq ident gnus-backlog-articles))))))) (defun gnus-backlog-request-article (group number buffer) (when (numberp number)
--- a/lisp/gnus/gnus-cache.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/gnus-cache.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ ;;; gnus-cache.el --- cache interface for Gnus -;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news ;; This file is part of GNU Emacs. @@ -27,6 +27,8 @@ (eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl)) + (require 'gnus) (require 'gnus-int) (require 'gnus-range) @@ -34,16 +36,6 @@ (eval-when-compile (require 'gnus-sum)) -(defgroup gnus-cache nil - "Cache interface." - :group 'gnus) - -(defcustom gnus-cache-directory - (nnheader-concat gnus-directory "cache/") - "*The directory where cached articles will be stored." - :group 'gnus-cache - :type 'directory) - (defcustom gnus-cache-active-file (concat (file-name-as-directory gnus-cache-directory) "active") "*The cache active file." @@ -60,15 +52,33 @@ :group 'gnus-cache :type '(set (const ticked) (const dormant) (const unread) (const read))) +(defcustom gnus-cacheable-groups nil + "*Groups that match this regexp will be cached. + +If you only want to cache your nntp groups, you could set this +variable to \"^nntp\". + +If a group matches both gnus-cacheable-groups and gnus-uncacheable-groups +it's not cached." + :group 'gnus-cache + :type '(choice (const :tag "off" nil) + regexp)) + (defcustom gnus-uncacheable-groups nil "*Groups that match this regexp will not be cached. If you want to avoid caching your nnml groups, you could set this -variable to \"^nnml\"." +variable to \"^nnml\". + +If a group matches both gnus-cacheable-groups and gnus-uncacheable-groups +it's not cached." :group 'gnus-cache :type '(choice (const :tag "off" nil) regexp)) +(defvar gnus-cache-overview-coding-system 'raw-text + "Coding system used on Gnus cache files.") + ;;; Internal variables. @@ -116,7 +126,9 @@ (set-buffer buffer) (if (> (buffer-size) 0) ;; Non-empty overview, write it to a file. - (gnus-write-buffer overview-file) + (let ((coding-system-for-write + gnus-cache-overview-coding-system)) + (gnus-write-buffer overview-file)) ;; Empty overview file, remove it (when (file-exists-p overview-file) (delete-file overview-file)) @@ -145,11 +157,13 @@ headers (copy-sequence headers)) (mail-header-set-number headers (cdr result)))) (let ((number (mail-header-number headers)) - file dir) + file) (when (and number (> number 0) ; Reffed article. (or force - (and (or (not gnus-uncacheable-groups) + (and (or (not gnus-cacheable-groups) + (string-match gnus-cacheable-groups group)) + (or (not gnus-uncacheable-groups) (not (string-match gnus-uncacheable-groups group))) (gnus-cache-member-of-class @@ -157,7 +171,7 @@ (not (file-exists-p (setq file (gnus-cache-file-name group number))))) ;; Possibly create the cache directory. - (gnus-make-directory (setq dir (file-name-directory file))) + (gnus-make-directory (file-name-directory file)) ;; Save the article in the cache. (if (file-exists-p file) t ; The article already is saved. @@ -316,10 +330,10 @@ If not given a prefix, use the process marked articles instead. Returns the list of articles entered." (interactive "P") - (gnus-set-global-variables) (let ((articles (gnus-summary-work-articles n)) article out) (while (setq article (pop articles)) + (gnus-summary-remove-process-mark article) (if (natnump article) (when (gnus-cache-possibly-enter-article gnus-newsgroup-name article @@ -327,7 +341,6 @@ nil nil nil t) (push article out)) (gnus-message 2 "Can't cache article %d" article)) - (gnus-summary-remove-process-mark article) (gnus-summary-update-secondary-mark article)) (gnus-summary-next-subject 1) (gnus-summary-position-point) @@ -338,15 +351,14 @@ If not given a prefix, use the process marked articles instead. Returns the list of articles removed." (interactive "P") - (gnus-set-global-variables) (gnus-cache-change-buffer gnus-newsgroup-name) (let ((articles (gnus-summary-work-articles n)) article out) (while articles (setq article (pop articles)) + (gnus-summary-remove-process-mark article) (when (gnus-cache-possibly-remove-article article nil nil nil t) (push article out)) - (gnus-summary-remove-process-mark article) (gnus-summary-update-secondary-mark article)) (gnus-summary-next-subject 1) (gnus-summary-position-point) @@ -359,13 +371,16 @@ (defun gnus-summary-insert-cached-articles () "Insert all the articles cached for this group into the current buffer." (interactive) - (let ((cached gnus-newsgroup-cached) + (let ((cached (sort (copy-sequence gnus-newsgroup-cached) '<)) (gnus-verbose (max 6 gnus-verbose))) (unless cached - (error "No cached articles for this group")) + (gnus-message 3 "No cached articles for this group")) (while cached (gnus-summary-goto-subject (pop cached) t)))) +(defalias 'gnus-summary-limit-include-cached + 'gnus-summary-insert-cached-articles) + ;;; Internal functions. (defun gnus-cache-change-buffer (group) @@ -380,7 +395,8 @@ (save-excursion (setq gnus-cache-buffer (cons group - (set-buffer (get-buffer-create " *gnus-cache-overview*")))) + (set-buffer (gnus-get-buffer-create + " *gnus-cache-overview*")))) (buffer-disable-undo (current-buffer)) ;; Insert the contents of this group's cache overview. (erase-buffer) @@ -408,12 +424,14 @@ ;; Translate the first colon into a slash. (when (string-match ":" group) (aset group (match-beginning 0) ?/)) - (nnheader-replace-chars-in-string group ?. ?/))))) + (nnheader-replace-chars-in-string group ?. ?/))) + t)) (if (stringp article) article (int-to-string article)))) (defun gnus-cache-update-article (group article) "If ARTICLE is in the cache, remove it and re-enter it." - (when (gnus-cache-possibly-remove-article article nil nil nil t) + (gnus-cache-change-buffer group) + (when (gnus-cache-possibly-remove-article article nil nil nil t) (let ((gnus-use-cache nil)) (gnus-cache-possibly-enter-article gnus-newsgroup-name article (gnus-summary-article-header article) @@ -466,7 +484,7 @@ articles))) (defun gnus-cache-braid-nov (group cached &optional file) - (let ((cache-buf (get-buffer-create " *gnus-cache*")) + (let ((cache-buf (gnus-get-buffer-create " *gnus-cache*")) beg end) (gnus-cache-save-buffers) (save-excursion @@ -498,7 +516,7 @@ (kill-buffer cache-buf))) (defun gnus-cache-braid-heads (group cached) - (let ((cache-buf (get-buffer-create " *gnus-cache*"))) + (let ((cache-buf (gnus-get-buffer-create " *gnus-cache*"))) (save-excursion (set-buffer cache-buf) (buffer-disable-undo (current-buffer)) @@ -560,6 +578,7 @@ "Read the cache active file." (gnus-make-directory gnus-cache-directory) (if (or (not (file-exists-p gnus-cache-active-file)) + (zerop (nth 7 (file-attributes gnus-cache-active-file))) force) ;; There is no active file, so we generate one. (gnus-cache-generate-active) @@ -614,8 +633,9 @@ (if top "" (string-match - (concat "^" (file-name-as-directory - (expand-file-name gnus-cache-directory))) + (concat "^" (regexp-quote + (file-name-as-directory + (expand-file-name gnus-cache-directory)))) (directory-file-name directory)) (nnheader-replace-chars-in-string (substring (directory-file-name directory) (match-end 0)) @@ -624,6 +644,8 @@ (when top (gnus-message 5 "Generating the cache active file...") (setq gnus-cache-active-hashtb (gnus-make-hashtable 123))) + (when (string-match "^\\(nn[^_]+\\)_" group) + (setq group (replace-match "\\1:" t t group))) ;; Separate articles from all other files and directories. (while files (if (string-match "^[0-9]+$" (file-name-nondirectory (car files))) @@ -636,7 +658,7 @@ ;; Go through all the other files. (while alphs (when (and (file-directory-p (car alphs)) - (not (string-match "^\\.\\.?$" + (not (string-match "^\\." (file-name-nondirectory (car alphs))))) ;; We descend directories. (gnus-cache-generate-active (car alphs)))
--- a/lisp/gnus/gnus-cite.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/gnus-cite.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,12 +1,7 @@ ;;; gnus-cite.el --- parse citations in articles for Gnus -;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. -;; Author: Per Abrahamsen <abraham@iesd.auc.dk> -;; Keywords: news, mail - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify +;; Author: Per Abhiddenware; 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. @@ -27,6 +22,8 @@ (eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl)) + (require 'gnus) (require 'gnus-art) (require 'gnus-range) @@ -41,7 +38,7 @@ (defcustom gnus-cite-reply-regexp "^\\(Subject: Re\\|In-Reply-To\\|References\\):" - "If headers match this regexp it is reasonable to believe that + "*If headers match this regexp it is reasonable to believe that article has citations." :group 'gnus-cite :type 'string) @@ -52,8 +49,13 @@ :type '(choice (const :tag "no" nil) (const :tag "yes" t))) -(defcustom gnus-cited-text-button-line-format "%(%{[...]%}%)\n" - "Format of cited text buttons." +(defcustom gnus-cited-opened-text-button-line-format "%(%{[-]%}%)\n" + "Format of opened cited text buttons." + :group 'gnus-cite + :type 'string) + +(defcustom gnus-cited-closed-text-button-line-format "%(%{[+]%}%)\n" + "Format of closed cited text buttons." :group 'gnus-cite :type 'string) @@ -71,8 +73,8 @@ integer)) (defcustom gnus-cite-prefix-regexp - "^[]>|:}+ ]*[]>|:}+]\\(.*>\\)?\\|^.*>" - "Regexp matching the longest possible citation prefix on a line." + "^[]>|:}+ ]*[]>|:}+]\\(.*>\\)?\\|^.*>" + "*Regexp matching the longest possible citation prefix on a line." :group 'gnus-cite :type 'regexp) @@ -84,7 +86,7 @@ (defcustom gnus-supercite-regexp (concat "^\\(" gnus-cite-prefix-regexp "\\)? *" ">>>>> +\"\\([^\"\n]+\\)\" +==") - "Regexp matching normal Supercite attribution lines. + "*Regexp matching normal Supercite attribution lines. The first grouping must match prefixes added by other packages." :group 'gnus-cite :type 'regexp) @@ -100,21 +102,21 @@ :group 'gnus-cite :type 'integer) -(defcustom gnus-cite-attribution-prefix - "in article\\|in <\\|On \\(Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\|Sun\\)," - "Regexp matching the beginning of an attribution line." +(defcustom gnus-cite-attribution-prefix + "In article\\|in <\\|On \\(Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\|Sun\\)," + "*Regexp matching the beginning of an attribution line." :group 'gnus-cite :type 'regexp) (defcustom gnus-cite-attribution-suffix - "\\(\\(wrote\\|writes\\|said\\|says\\|>\\)\\(:\\|\\.\\.\\.\\)\\)[ ]*$" - "Regexp matching the end of an attribution line. + "\\(\\(wrote\\|writes\\|said\\|says\\|>\\)\\(:\\|\\.\\.\\.\\)\\)[ \t]*$" + "*Regexp matching the end of an attribution line. The text matching the first grouping will be used as a button." :group 'gnus-cite :type 'regexp) (defface gnus-cite-attribution-face '((t - (:underline t))) + (:italic t))) "Face used for attribution lines.") (defcustom gnus-cite-attribution-face 'gnus-cite-attribution-face @@ -237,7 +239,7 @@ '(gnus-cite-face-1 gnus-cite-face-2 gnus-cite-face-3 gnus-cite-face-4 gnus-cite-face-5 gnus-cite-face-6 gnus-cite-face-7 gnus-cite-face-8 gnus-cite-face-9 gnus-cite-face-10 gnus-cite-face-11) - "List of faces used for highlighting citations. + "*List of faces used for highlighting citations. When there are citations from multiple articles in the same message, Gnus will try to give each citation from each article its own face. @@ -258,6 +260,7 @@ ;;; Internal Variables: (defvar gnus-cite-article nil) +(defvar gnus-cite-overlay-list nil) (defvar gnus-cite-prefix-alist nil) ;; Alist of citation prefixes. @@ -280,11 +283,16 @@ ;; PREFIX: Is the citation prefix of the attribution line(s), and ;; TAG: Is a Supercite tag, if any. -(defvar gnus-cited-text-button-line-format-alist +(defvar gnus-cited-opened-text-button-line-format-alist `((?b (marker-position beg) ?d) (?e (marker-position end) ?d) + (?n (count-lines beg end) ?d) (?l (- end beg) ?d))) -(defvar gnus-cited-text-button-line-format-spec nil) +(defvar gnus-cited-opened-text-button-line-format-spec nil) +(defvar gnus-cited-closed-text-button-line-format-alist + gnus-cited-opened-text-button-line-format-alist) +(defvar gnus-cited-closed-text-button-line-format-spec nil) + ;;; Commands: @@ -383,7 +391,7 @@ (gnus-article-search-signature) (push (cons (point-marker) "") marks) ;; Sort the marks. - (setq marks (sort marks (lambda (m1 m2) (< (car m1) (car m2))))) + (setq marks (sort marks 'car-less-than-car)) (let ((omarks marks)) (setq marks nil) (while (cdr omarks) @@ -449,9 +457,8 @@ If given a negative prefix, always show; if given a positive prefix, always hide." (interactive (append (gnus-article-hidden-arg) (list 'force))) - (setq gnus-cited-text-button-line-format-spec - (gnus-parse-format gnus-cited-text-button-line-format - gnus-cited-text-button-line-format-alist t)) + (gnus-set-format 'cited-opened-text-button t) + (gnus-set-format 'cited-closed-text-button t) (save-excursion (set-buffer gnus-article-buffer) (cond @@ -466,7 +473,7 @@ (inhibit-point-motion-hooks t) (props (nconc (list 'article-type 'cite) gnus-hidden-properties)) - beg end) + beg end start) (while marks (setq beg nil end nil) @@ -486,30 +493,58 @@ (setq beg nil) (setq beg (point-marker)))) (when (and beg end) + ;; We use markers for the end-points to facilitate later + ;; wrapping and mangling of text. + (setq beg (set-marker (make-marker) beg) + end (set-marker (make-marker) end)) (gnus-add-text-properties beg end props) (goto-char beg) (unless (save-excursion (search-backward "\n\n" nil t)) (insert "\n")) (put-text-property - (point) + (setq start (point-marker)) (progn (gnus-article-add-button (point) - (progn (eval gnus-cited-text-button-line-format-spec) (point)) - `gnus-article-toggle-cited-text (cons beg end)) + (progn (eval gnus-cited-closed-text-button-line-format-spec) + (point)) + `gnus-article-toggle-cited-text + (list (cons beg end) start)) (point)) 'article-type 'annotation) (set-marker beg (point))))))))) -(defun gnus-article-toggle-cited-text (region) +(defun gnus-article-toggle-cited-text (args) "Toggle hiding the text in REGION." - (let (buffer-read-only) + (let* ((region (car args)) + (start (cadr args)) + (hidden + (text-property-any + (car region) (1- (cdr region)) + (car gnus-hidden-properties) (cadr gnus-hidden-properties))) + (inhibit-point-motion-hooks t) + buffer-read-only) (funcall - (if (text-property-any - (car region) (1- (cdr region)) - (car gnus-hidden-properties) (cadr gnus-hidden-properties)) + (if hidden 'remove-text-properties 'gnus-add-text-properties) - (car region) (cdr region) gnus-hidden-properties))) + (car region) (cdr region) gnus-hidden-properties) + (save-excursion + (goto-char start) + (gnus-delete-line) + (put-text-property + (point) + (progn + (gnus-article-add-button + (point) + (progn (eval + (if hidden + gnus-cited-opened-text-button-line-format-spec + gnus-cited-closed-text-button-line-format-spec)) + (point)) + `gnus-article-toggle-cited-text + args) + (point)) + 'article-type 'annotation)))) (defun gnus-article-hide-citation-maybe (&optional arg force) "Toggle hiding of cited text that has an attribution line. @@ -520,7 +555,7 @@ cited text with attributions. When called interactively, these two variables are ignored. See also the documentation for `gnus-article-highlight-citation'." - (interactive (append (gnus-article-hidden-arg) (list 'force))) + (interactive (append (gnus-article-hidden-arg) '(force))) (unless (gnus-article-check-hidden-text 'cite arg) (save-excursion (set-buffer gnus-article-buffer) @@ -531,27 +566,27 @@ (atts gnus-cite-attribution-alist) (buffer-read-only nil) (inhibit-point-motion-hooks t) - (hiden 0) + (hidden 0) total) (goto-char (point-max)) (gnus-article-search-signature) (setq total (count-lines start (point))) (while atts - (setq hiden (+ hiden (length (cdr (assoc (cdar atts) - gnus-cite-prefix-alist)))) + (setq hidden (+ hidden (length (cdr (assoc (cdar atts) + gnus-cite-prefix-alist)))) atts (cdr atts))) (when (or force - (and (> (* 100 hiden) (* gnus-cite-hide-percentage total)) - (> hiden gnus-cite-hide-absolute))) + (and (> (* 100 hidden) (* gnus-cite-hide-percentage total)) + (> hidden gnus-cite-hide-absolute))) (setq atts gnus-cite-attribution-alist) (while atts (setq total (cdr (assoc (cdar atts) gnus-cite-prefix-alist)) atts (cdr atts)) (while total - (setq hiden (car total) + (setq hidden (car total) total (cdr total)) - (goto-line hiden) - (unless (assq hiden gnus-cite-attribution-alist) + (goto-line hidden) + (unless (assq hidden gnus-cite-attribution-alist) (gnus-add-text-properties (point) (progn (forward-line 1) (point)) (nconc (list 'article-type 'cite) @@ -572,13 +607,17 @@ (defun gnus-cite-parse-maybe (&optional force) ;; Parse if the buffer has changes since last time. - (if (equal gnus-cite-article gnus-article-current) + (if (and (not force) + (equal gnus-cite-article gnus-article-current)) () + (gnus-cite-localize) ;;Reset parser information. (setq gnus-cite-prefix-alist nil gnus-cite-attribution-alist nil gnus-cite-loose-prefix-alist nil gnus-cite-loose-attribution-alist nil) + (while gnus-cite-overlay-list + (gnus-delete-overlay (pop gnus-cite-overlay-list))) ;; Parse if not too large. (if (and (not force) gnus-cite-parse-max-size @@ -858,9 +897,9 @@ ;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line. (when face (let ((inhibit-point-motion-hooks t) - from to) + from to overlay) (goto-line number) - (unless (eobp);; Sometimes things become confused. + (unless (eobp) ; Sometimes things become confused. (forward-char (length prefix)) (skip-chars-forward " \t") (setq from (point)) @@ -868,11 +907,14 @@ (skip-chars-backward " \t") (setq to (point)) (when (< from to) - (gnus-overlay-put (gnus-make-overlay from to) 'face face)))))) + (push (setq overlay (gnus-make-overlay from to)) + gnus-cite-overlay-list) + (gnus-overlay-put overlay 'face face)))))) (defun gnus-cite-toggle (prefix) (save-excursion (set-buffer gnus-article-buffer) + (gnus-cite-parse-maybe) (let ((buffer-read-only nil) (numbers (cdr (assoc prefix gnus-cite-prefix-alist))) (inhibit-point-motion-hooks t) @@ -903,10 +945,14 @@ (setq prefix (car entry)))) prefix)) -(gnus-add-shutdown 'gnus-cache-close 'gnus) - -(defun gnus-cache-close () - (setq gnus-cite-prefix-alist nil)) +(defun gnus-cite-localize () + "Make the citation variables local to the article buffer." + (let ((vars '(gnus-cite-article + gnus-cite-overlay-list gnus-cite-prefix-alist + gnus-cite-attribution-alist gnus-cite-loose-prefix-alist + gnus-cite-loose-attribution-alist))) + (while vars + (make-local-variable (pop vars))))) (gnus-ems-redefine)
--- a/lisp/gnus/gnus-cus.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/gnus-cus.el Sat Feb 20 14:05:57 1999 +0000 @@ -51,7 +51,7 @@ (setq major-mode 'gnus-custom-mode mode-name "Gnus Customize") (use-local-map widget-keymap) - (run-hooks 'gnus-custom-mode-hook)) + (gnus-run-hooks 'gnus-custom-mode-hook)) ;;; Group Customization: @@ -155,7 +155,11 @@ unread and ticked articles.") (comment (string :tag "Comment") "\ -An arbitrary comment on the group.")) +An arbitrary comment on the group.") + + (visible (const :tag "Permanently visible" t) "\ +Always display this group, even when there are no unread articles +in it..")) "Alist of valid group parameters. Each entry has the form (NAME TYPE DOC), where NAME is the parameter @@ -166,11 +170,10 @@ (defvar gnus-custom-method) (defvar gnus-custom-group) -(defun gnus-group-customize (group &optional part) +(defun gnus-group-customize (group) "Edit the group on the current line." (interactive (list (gnus-group-group-name))) - (let ((part (or part 'info)) - info + (let (info (types (mapcar (lambda (entry) `(cons :format "%v%h\n" :doc ,(nth 2 entry) @@ -182,8 +185,8 @@ (unless (setq info (gnus-get-info group)) (error "Killed group; can't be edited")) ;; Ready. - (kill-buffer (get-buffer-create "*Gnus Customize*")) - (switch-to-buffer (get-buffer-create "*Gnus Customize*")) + (kill-buffer (gnus-get-buffer-create "*Gnus Customize*")) + (switch-to-buffer (gnus-get-buffer-create "*Gnus Customize*")) (gnus-custom-mode) (make-local-variable 'gnus-custom-group) (setq gnus-custom-group group) @@ -283,12 +286,12 @@ `gnus-thread-score-function' says how to compute the total score for a thread.") - (files (repeat :tag "Files" file) "\ + (files (repeat :inline t :tag "Files" file) "\ The value of this entry should be any number of file names. These files are assumed to be score files as well, and will be loaded the same way this one was.") - (exclude-files (repeat :tag "Exclude-files" file) "\ + (exclude-files (repeat :inline t :tag "Exclude-files" file) "\ The clue of this entry should be any number of files. These files will not be loaded, even though they would normally be so, for some reason or other.") @@ -540,8 +543,8 @@ ,(nth 1 entry))) gnus-score-parameters))) ;; Ready. - (kill-buffer (get-buffer-create "*Gnus Customize*")) - (switch-to-buffer (get-buffer-create "*Gnus Customize*")) + (kill-buffer (gnus-get-buffer-create "*Gnus Customize*")) + (switch-to-buffer (gnus-get-buffer-create "*Gnus Customize*")) (gnus-custom-mode) (make-local-variable 'gnus-custom-score-alist) (setq gnus-custom-score-alist scores) @@ -647,4 +650,3 @@ (provide 'gnus-cus) ;;; gnus-cus.el ends here -
--- a/lisp/gnus/gnus-demon.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/gnus-demon.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ ;;; gnus-demon.el --- daemonic Gnus behaviour -;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news ;; This file is part of GNU Emacs. @@ -27,9 +27,14 @@ (eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl)) + (require 'gnus) (require 'gnus-int) (require 'nnheader) +(require 'nntp) +(require 'nnmail) +(require 'gnus-util) (eval-and-compile (if (string-match "XEmacs" (emacs-version)) (require 'itimer) @@ -95,9 +100,7 @@ (defun gnus-demon-remove-handler (function &optional no-init) "Remove the handler FUNCTION from the list of handlers." - (setq gnus-demon-handlers - (delq (assq function gnus-demon-handlers) - gnus-demon-handlers)) + (gnus-pull function gnus-demon-handlers) (unless no-init (gnus-demon-init))) @@ -105,9 +108,8 @@ "Initialize the Gnus daemon." (interactive) (gnus-demon-cancel) - (if (null gnus-demon-handlers) - () ; Nothing to do. - ;; Set up timer. + (when gnus-demon-handlers + ;; Set up the timer. (setq gnus-demon-timer (nnheader-run-at-time gnus-demon-timestep gnus-demon-timestep 'gnus-demon)) @@ -130,7 +132,8 @@ (when gnus-demon-timer (nnheader-cancel-timer gnus-demon-timer)) (setq gnus-demon-timer nil - gnus-use-demon nil) + gnus-use-demon nil + gnus-demon-idle-has-been-called nil) (condition-case () (nnheader-cancel-function-timers 'gnus-demon) (error t))) @@ -259,6 +262,18 @@ (save-window-excursion (gnus-close-backends))) +(defun gnus-demon-add-nntp-close-connection () + "Add daemonic nntp server disconnection to Gnus. +If no commands have gone out via nntp during the last five +minutes, the connection is closed." + (gnus-demon-add-handler 'gnus-demon-close-connections 5 nil)) + +(defun gnus-demon-nntp-close-connection () + (save-window-excursion + (when (nnmail-time-less '(0 300) + (nnmail-time-since nntp-last-command-time)) + (nntp-close-server)))) + (defun gnus-demon-add-scanmail () "Add daemonic scanning of mail from the mail backends." (gnus-demon-add-handler 'gnus-demon-scan-mail 120 60)) @@ -267,6 +282,7 @@ (save-window-excursion (let ((servers gnus-opened-servers) server) + (gnus-clear-inboxes-moved) (while (setq server (car (pop servers))) (and (gnus-check-backend-function 'request-scan (car server)) (or (gnus-server-opened server) @@ -278,11 +294,15 @@ (gnus-demon-add-handler 'gnus-demon-scan-news 120 60)) (defun gnus-demon-scan-news () - (save-window-excursion - (when (gnus-alive-p) - (save-excursion - (set-buffer gnus-group-buffer) - (gnus-group-get-new-news))))) + (let ((win (current-window-configuration))) + (unwind-protect + (save-window-excursion + (save-excursion + (when (gnus-alive-p) + (save-excursion + (set-buffer gnus-group-buffer) + (gnus-group-get-new-news))))) + (set-window-configuration win)))) (defun gnus-demon-add-scan-timestamps () "Add daemonic updating of timestamps in empty newgroups."
--- a/lisp/gnus/gnus-dup.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/gnus-dup.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ ;;; gnus-dup.el --- suppression of duplicate articles in Gnus -;; Copyright (C) 1996,97 Free Software Foundation, Inc. +;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news ;; This file is part of GNU Emacs. @@ -32,6 +32,8 @@ (eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl)) + (require 'gnus) (require 'gnus-art) @@ -118,7 +120,7 @@ (while (setq datum (pop data)) (when (and (not (gnus-data-pseudo-p datum)) (> (gnus-data-number datum) 0) - (gnus-data-read-p datum) + (not (memq (gnus-data-number datum) gnus-newsgroup-unreads)) (not (= (gnus-data-mark datum) gnus-canceled-mark)) (setq msgid (mail-header-id (gnus-data-header datum))) (not (nnheader-fake-message-id-p msgid))
--- a/lisp/gnus/gnus-eform.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/gnus-eform.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ ;;; gnus-eform.el --- a mode for editing forms for Gnus -;; Copyright (C) 1996,97 Free Software Foundation, Inc. +;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news ;; This file is part of GNU Emacs. @@ -48,8 +48,8 @@ ;;; Internal variables +(defvar gnus-edit-form-buffer "*Gnus edit form*") (defvar gnus-edit-form-done-function nil) -(defvar gnus-edit-form-buffer "*Gnus edit form*") (defvar gnus-edit-form-mode-map nil) (unless gnus-edit-form-mode-map @@ -65,7 +65,7 @@ '("Edit Form" ["Exit and save changes" gnus-edit-form-done t] ["Exit" gnus-edit-form-exit t])) - (run-hooks 'gnus-edit-form-menu-hook))) + (gnus-run-hooks 'gnus-edit-form-menu-hook))) (defun gnus-edit-form-mode () "Major mode for editing forms. @@ -81,16 +81,15 @@ (use-local-map gnus-edit-form-mode-map) (make-local-variable 'gnus-edit-form-done-function) (make-local-variable 'gnus-prev-winconf) - (run-hooks 'gnus-edit-form-mode-hook)) + (gnus-run-hooks 'gnus-edit-form-mode-hook)) (defun gnus-edit-form (form documentation exit-func) "Edit FORM in a new buffer. Call EXIT-FUNC on exit. Display DOCUMENTATION in the beginning of the buffer." (let ((winconf (current-window-configuration))) - (set-buffer (get-buffer-create gnus-edit-form-buffer)) + (set-buffer (gnus-get-buffer-create gnus-edit-form-buffer)) (gnus-configure-windows 'edit-form) - (gnus-add-current-to-buffer-list) (gnus-edit-form-mode) (setq gnus-prev-winconf winconf) (setq gnus-edit-form-done-function exit-func)
--- a/lisp/gnus/gnus-ems.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/gnus-ems.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ ;;; gnus-ems.el --- functions for making Gnus work under different Emacsen -;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news ;; This file is part of GNU Emacs. @@ -56,16 +56,19 @@ (let ((inhibit-point-motion-hooks t) from to) (goto-line number) - (if (boundp 'MULE) - (forward-char (chars-in-string prefix)) - (forward-char (length prefix))) - (skip-chars-forward " \t") - (setq from (point)) - (end-of-line 1) - (skip-chars-backward " \t") - (setq to (point)) - (when (< from to) - (gnus-overlay-put (gnus-make-overlay from to) 'face face))))) + (unless (eobp) ; Sometimes things become confused (broken). + (if (boundp 'MULE) + (forward-char (chars-in-string prefix)) + (forward-char (length prefix))) + (skip-chars-forward " \t") + (setq from (point)) + (end-of-line 1) + (skip-chars-backward " \t") + (setq to (point)) + (when (< from to) + (push (setq overlay (gnus-make-overlay from to)) + gnus-cite-overlay-list) + (gnus-overlay-put (gnus-make-overlay from to) 'face face)))))) (defun gnus-mule-max-width-function (el max-width) (` (let* ((val (eval (, el))) @@ -78,6 +81,12 @@ (defun gnus-encode-coding-string (string system) string) +(defun gnus-decode-coding-string (string system) + string) + +(defun gnus-encode-coding-string (string system) + string) + (eval-and-compile (if (string-match "XEmacs\\|Lucid" emacs-version) nil @@ -90,7 +99,8 @@ (gnus-xmas-define)) ((or (not (boundp 'emacs-minor-version)) - (< emacs-minor-version 30)) + (and (< emacs-major-version 20) + (< emacs-minor-version 30))) ;; Remove the `intangible' prop. (let ((props (and (boundp 'gnus-hidden-properties) gnus-hidden-properties))) @@ -126,7 +136,8 @@ (eval-and-compile (let ((case-fold-search t)) (cond - ((string-match "windows-nt\\|os/2\\|emx" (format "%s" system-type)) + ((string-match "windows-nt\\|os/2\\|emx\\|cygwin" + (symbol-name system-type)) (setq nnheader-file-name-translation-alist (append nnheader-file-name-translation-alist '((?: . ?_) @@ -172,8 +183,9 @@ "Display table used in summary mode buffers.") (fset 'gnus-cite-add-face 'gnus-mule-cite-add-face) (fset 'gnus-max-width-function 'gnus-mule-max-width-function) - (fset 'gnus-summary-set-display-table 'ignore) + (fset 'gnus-summary-set-display-table (lambda ())) (fset 'gnus-encode-coding-string 'encode-coding-string) + (fset 'gnus-decode-coding-string 'decode-coding-string) (when (boundp 'gnus-check-before-posting) (setq gnus-check-before-posting @@ -214,12 +226,58 @@ (defun gnus-add-minor-mode (mode name map) (if (fboundp 'add-minor-mode) (add-minor-mode mode name map) + (set (make-local-variable mode) t) (unless (assq mode minor-mode-alist) (push `(,mode ,name) minor-mode-alist)) (unless (assq mode minor-mode-map-alist) (push (cons mode map) minor-mode-map-alist)))) +(defun gnus-x-splash () + "Show a splash screen using a pixmap in the current buffer." + (let ((dir (nnheader-find-etc-directory "gnus")) + pixmap file height beg i) + (save-excursion + (switch-to-buffer (gnus-get-buffer-create gnus-group-buffer)) + (let ((buffer-read-only nil)) + (erase-buffer) + (when (and dir + (file-exists-p (setq file (concat dir "x-splash")))) + (nnheader-temp-write nil + (insert-file-contents file) + (goto-char (point-min)) + (ignore-errors + (setq pixmap (read (current-buffer)))))) + (when pixmap + (erase-buffer) + (unless (facep 'gnus-splash) + (make-face 'gnus-splash)) + (setq height (/ (car pixmap) (frame-char-height)) + width (/ (cadr pixmap) (frame-char-width))) + (set-face-foreground 'gnus-splash "ForestGreen") + (set-face-stipple 'gnus-splash pixmap) + (insert-char ?\n (* (/ (window-height) 2 height) height)) + (setq i height) + (while (> i 0) + (insert-char ? (* (+ (/ (window-width) 2 width) 1) width)) + (setq beg (point)) + (insert-char ? width) + (set-text-properties beg (point) '(face gnus-splash)) + (insert "\n") + (decf i)) + (goto-char (point-min)) + (sit-for 0)))))) + +(if (fboundp 'split-string) + (fset 'gnus-split-string 'split-string) + (defun gnus-split-string (string pattern) + "Return a list of substrings of STRING which are separated by PATTERN." + (let (parts (start 0)) + (while (string-match pattern string start) + (setq parts (cons (substring string start (match-beginning 0)) parts) + start (match-end 0))) + (nreverse (cons (substring string start) parts))))) + (provide 'gnus-ems) ;; Local Variables:
--- a/lisp/gnus/gnus-gl.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/gnus-gl.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,5 +1,5 @@ ;;; gnus-gl.el --- an interface to GroupLens for Gnus -;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. ;; Author: Brad Miller <bmiller@cs.umn.edu> ;; Keywords: news, score @@ -234,7 +234,7 @@ (defun bbb-connect-to-bbbd (host port) (unless grouplens-bbb-buffer (setq grouplens-bbb-buffer - (get-buffer-create (format " *BBBD trace: %s*" host))) + (gnus-get-buffer-create (format " *BBBD trace: %s*" host))) (save-excursion (set-buffer grouplens-bbb-buffer) (make-local-variable 'bbb-read-point) @@ -299,7 +299,7 @@ ;;;; Login Functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun bbb-login () - "return the token number if login is successful, otherwise return nil" + "return the token number if login is successful, otherwise return nil." (interactive) (setq grouplens-bbb-token nil) (if (not (equal grouplens-pseudonym "")) @@ -324,7 +324,7 @@ (gnus-add-shutdown 'bbb-logout 'gnus) (defun bbb-logout () - "logout of bbb session" + "logout of bbb session." (when grouplens-bbb-token (let ((bbb-process (bbb-connect-to-bbbd grouplens-bbb-host grouplens-bbb-port))) @@ -339,9 +339,8 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun bbb-build-mid-scores-alist (groupname) - "this function can be called as part of the function to return the -list of score files to use. See the gnus variable -gnus-score-find-score-files-function. + "this function can be called as part of the function to return the list of score files to use. +See the gnus variable gnus-score-find-score-files-function. *Note:* If you want to use grouplens scores along with calculated scores, you should see the offset and scale variables. At this point, I don't @@ -669,9 +668,8 @@ (gnus-summary-best-unread-article)) (defun grouplens-summary-catchup-and-exit (rating) - "Mark all articles not marked as unread in this newsgroup as read, - then exit. If prefix argument ALL is non-nil, all articles are - marked as read." + "Mark all articles not marked as unread in this newsgroup as read, then exit. +If prefix argument ALL is non-nil, all articles are marked as read." (interactive "P") (when rating (bbb-summary-rate-article rating)) @@ -688,7 +686,6 @@ article) (while (setq article (pop articles)) (gnus-summary-goto-subject article) - (gnus-set-global-variables) (bbb-summary-rate-article score (mail-header-id (gnus-summary-article-header article))))) @@ -749,7 +746,7 @@ (defconst gnus-gl-version "gnus-gl.el 2.50") (defconst gnus-gl-maintainer-address "grouplens-bug@cs.umn.edu") (defun gnus-gl-submit-bug-report () - "Submit via mail a bug report on gnus-gl" + "Submit via mail a bug report on gnus-gl." (interactive) (require 'reporter) (reporter-submit-bug-report gnus-gl-maintainer-address @@ -766,7 +763,7 @@ 'gnus-gl-get-trace)) (defun gnus-gl-get-trace () - "Insert the contents of the BBBD trace buffer" + "Insert the contents of the BBBD trace buffer." (when grouplens-bbb-buffer (insert-buffer grouplens-bbb-buffer))) @@ -853,7 +850,7 @@ (gnus-grouplens-make-menu-bar)) (gnus-add-minor-mode 'gnus-grouplens-mode " GroupLens" gnus-grouplens-mode-map) - (run-hooks 'gnus-grouplens-mode-hook)))) + (gnus-run-hooks 'gnus-grouplens-mode-hook)))) (provide 'gnus-gl)
--- a/lisp/gnus/gnus-group.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/gnus-group.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ ;;; gnus-group.el --- group mode commands for Gnus -;; Copyright (C) 1996,97 Free Software Foundation, Inc. +;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news ;; This file is part of GNU Emacs. @@ -27,6 +27,8 @@ (eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl)) + (require 'gnus) (require 'gnus-start) (require 'nnmail) @@ -37,13 +39,13 @@ (require 'gnus-undo) (defcustom gnus-group-archive-directory - "/ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list/" + "*ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list/" "*The address of the (ding) archives." :group 'gnus-group-foreign :type 'directory) (defcustom gnus-group-recent-archive-directory - "/ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list-recent/" + "*ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list-recent/" "*The address of the most recent (ding) articles." :group 'gnus-group-foreign :type 'directory) @@ -89,7 +91,7 @@ If nil, no groups are permanently visible." :group 'gnus-group-listing - :type '(choice regexp (const nil))) + :type 'regexp) (defcustom gnus-list-groups-with-ticked-articles t "*If non-nil, list groups that have only ticked articles. @@ -261,10 +263,13 @@ :type 'hook) (defcustom gnus-useful-groups - `(("(ding) mailing list mirrored at sunsite.auc.dk" + '(("(ding) mailing list mirrored at sunsite.auc.dk" "emacs.ding" (nntp "sunsite.auc.dk" - (nntp-address "sunsite.auc.dk"))) + (nntp-address "sunsite.auc.dk"))) + ("gnus-bug archive" + "gnus-bug" + (nndir "/ftp@ftp.ifi.uio.no:/pub/emacs/gnus/gnus-bug/")) ("Gnus help group" "gnus-help" (nndoc "gnus-help" @@ -275,7 +280,7 @@ (unless file (error "Couldn't find doc group")) file)))))) - "Alist of useful group-server pairs." + "*Alist of useful group-server pairs." :group 'gnus-group-listing :type '(repeat (list (string :tag "Description") (string :tag "Name") @@ -316,7 +321,7 @@ gnus-group-mail-low-empty-face) (t . gnus-group-mail-low-face)) - "Controls the highlighting of group buffer lines. + "*Controls the highlighting of group buffer lines. Below is a list of `Form'/`Face' pairs. When deciding how a a particular group line should be displayed, each form is @@ -428,6 +433,7 @@ "p" gnus-group-prev-unread-group "\177" gnus-group-prev-unread-group [delete] gnus-group-prev-unread-group + [backspace] gnus-group-prev-unread-group "N" gnus-group-next-group "P" gnus-group-prev-group "\M-n" gnus-group-next-unread-group-same-level @@ -707,7 +713,7 @@ (fboundp 'gnus-soup-pack-packet)] ["Pack packet" gnus-soup-pack-packet (fboundp 'gnus-soup-pack-packet)] ["Save areas" gnus-soup-save-areas (fboundp 'gnus-soup-pack-packet)] - ["Brew SOUP" gnus-soup-brew-soup (fboundp 'gnus-soup-pack-packet)]) + ["Brew SOUP" gnus-group-brew-soup (fboundp 'gnus-soup-pack-packet)]) ["Send a bug report" gnus-bug t] ["Send a mail" gnus-group-mail t] ["Post an article..." gnus-group-post-news t] @@ -726,10 +732,11 @@ ["Read manual" gnus-info-find-node t] ["Flush score cache" gnus-score-flush-cache t] ["Toggle topics" gnus-topic-mode t] + ["Send a bug report" gnus-bug t] ["Exit from Gnus" gnus-group-exit t] ["Exit without saving" gnus-group-quit t])) - (run-hooks 'gnus-group-menu-hook))) + (gnus-run-hooks 'gnus-group-menu-hook))) (defun gnus-group-mode () "Major mode for reading news. @@ -768,13 +775,16 @@ (add-hook 'post-command-hook 'gnus-clear-inboxes-moved nil t) (when gnus-use-undo (gnus-undo-mode 1)) - (run-hooks 'gnus-group-mode-hook)) + (when gnus-slave + (gnus-slave-mode)) + (gnus-run-hooks 'gnus-group-mode-hook)) (defun gnus-update-group-mark-positions () (save-excursion - (let ((gnus-process-mark 128) + (let ((gnus-process-mark ?\200) (gnus-group-marked '("dummy.group")) - (gnus-active-hashtb (make-vector 10 0))) + (gnus-active-hashtb (make-vector 10 0)) + (topic "")) (gnus-set-active "dummy.group" '(0 . 0)) (gnus-set-work-buffer) (gnus-group-insert-group-line "dummy.group" 0 nil 0 nil) @@ -810,9 +820,8 @@ (or level gnus-group-default-list-level gnus-level-subscribed)))) (defun gnus-group-setup-buffer () - (switch-to-buffer gnus-group-buffer) + (set-buffer (gnus-get-buffer-create gnus-group-buffer)) (unless (eq major-mode 'gnus-group-mode) - (gnus-add-current-to-buffer-list) (gnus-group-mode) (when gnus-carpal (gnus-carpal-setup-buffer 'group)))) @@ -946,7 +955,7 @@ (gnus-group-set-mode-line) (setq gnus-group-list-mode (cons level all)) - (run-hooks 'gnus-group-prepare-hook) + (gnus-run-hooks 'gnus-group-prepare-hook) t)) (defun gnus-group-prepare-flat-list-dead (groups level mark regexp) @@ -1052,7 +1061,7 @@ (gnus-tmp-moderated-string (if (eq gnus-tmp-moderated ?m) "(m)" "")) (gnus-tmp-method - (gnus-server-get-method gnus-tmp-group gnus-tmp-method)) + (gnus-server-get-method gnus-tmp-group gnus-tmp-method)) ; (gnus-tmp-news-server (or (cadr gnus-tmp-method) "")) (gnus-tmp-news-method (or (car gnus-tmp-method) "")) (gnus-tmp-news-method-string @@ -1088,7 +1097,7 @@ gnus-level ,gnus-tmp-level)) (when (inline (gnus-visual-p 'group-highlight 'highlight)) (forward-line -1) - (run-hooks 'gnus-group-update-hook) + (gnus-run-hooks 'gnus-group-update-hook) (forward-line)) ;; Allow XEmacs to remove front-sticky text properties. (gnus-group-remove-excess-properties))) @@ -1111,7 +1120,7 @@ (mailp (memq 'mail (assoc (symbol-name (car (or method gnus-select-method))) gnus-valid-select-methods))) - (level (or (gnus-info-level info) 9)) + (level (or (gnus-info-level info) gnus-level-killed)) (score (or (gnus-info-score info) 0)) (ticked (gnus-range-length (cdr (assq 'tick marked)))) (group-age (gnus-group-timestamp-delta group)) @@ -1122,7 +1131,7 @@ (setq list (cdr list))) (let ((face (cdar list))) (unless (eq face (get-text-property beg 'face)) - (gnus-put-text-property + (gnus-put-text-property-excluding-characters-with-faces beg end 'face (setq face (if (boundp face) (symbol-value face) face))) (gnus-extent-start-open beg))) @@ -1145,7 +1154,8 @@ found buffer-read-only) ;; Enter the current status into the dribble buffer. (let ((entry (gnus-gethash group gnus-newsrc-hashtb))) - (when (and entry (not (gnus-ephemeral-group-p group))) + (when (and entry + (not (gnus-ephemeral-group-p group))) (gnus-dribble-enter (concat "(gnus-group-set-info '" (gnus-prin1-to-string (nth 2 entry)) @@ -1161,7 +1171,7 @@ (gnus-group-insert-group-line-info group) (save-excursion (forward-line -1) - (run-hooks 'gnus-group-update-group-hook))) + (gnus-run-hooks 'gnus-group-update-group-hook))) (setq loc (1+ loc))) (unless (or found visible-only) ;; No such line in the buffer, find out where it's supposed to @@ -1183,7 +1193,7 @@ (gnus-group-insert-group-line-info group) (save-excursion (forward-line -1) - (run-hooks 'gnus-group-update-group-hook)))) + (gnus-run-hooks 'gnus-group-update-group-hook)))) (when gnus-group-update-group-function (funcall gnus-group-update-group-function group)) (gnus-group-set-mode-line))) @@ -1198,10 +1208,7 @@ (save-excursion (set-buffer gnus-group-buffer) (let* ((gformat (or gnus-group-mode-line-format-spec - (setq gnus-group-mode-line-format-spec - (gnus-parse-format - gnus-group-mode-line-format - gnus-group-mode-line-format-alist)))) + (gnus-set-format 'group-mode))) (gnus-tmp-news-server (cadr gnus-select-method)) (gnus-tmp-news-method (car gnus-select-method)) (gnus-tmp-colon (if (equal gnus-tmp-news-server "") "" ":")) @@ -1232,7 +1239,8 @@ (defun gnus-group-group-name () "Get the name of the newsgroup on the current line." (let ((group (get-text-property (gnus-point-at-bol) 'gnus-group))) - (and group (symbol-name group)))) + (when group + (symbol-name group)))) (defun gnus-group-group-level () "Get the level of the newsgroup on the current line." @@ -1257,8 +1265,8 @@ (defun gnus-group-level (group) "Return the estimated level of GROUP." (or (gnus-info-level (gnus-get-info group)) - (and (member group gnus-zombie-list) 8) - 9)) + (and (member group gnus-zombie-list) gnus-level-zombie) + gnus-level-killed)) (defun gnus-group-search-forward (&optional backward all level first-too) "Find the next newsgroup with unread articles. @@ -1420,9 +1428,9 @@ (n (abs n)) group groups) (save-excursion - (while (and (> n 0) - (setq group (gnus-group-group-name))) - (push group groups) + (while (> n 0) + (if (setq group (gnus-group-group-name)) + (push group groups)) (setq n (1- n)) (gnus-group-next-group way))) (nreverse groups))) @@ -1447,25 +1455,33 @@ (let ((group (gnus-group-group-name))) (and group (list group)))))) -(defun gnus-group-iterate (arg function) - "Iterate FUNCTION over all process/prefixed groups. +;;; !!!Surely gnus-group-iterate should be a macro instead? I can't +;;; imagine why I went through these contortions... +(eval-and-compile + (let ((function (make-symbol "gnus-group-iterate-function")) + (window (make-symbol "gnus-group-iterate-window")) + (groups (make-symbol "gnus-group-iterate-groups")) + (group (make-symbol "gnus-group-iterate-group"))) + (eval + `(defun gnus-group-iterate (arg ,function) + "Iterate FUNCTION over all process/prefixed groups. FUNCTION will be called with the group name as the paremeter and with point over the group in question." - (let ((groups (gnus-group-process-prefix arg)) - (window (selected-window)) - group) - (while (setq group (pop groups)) - (select-window window) - (gnus-group-remove-mark group) - (save-selected-window - (save-excursion - (funcall function group)))))) + (let ((,groups (gnus-group-process-prefix arg)) + (,window (selected-window)) + ,group) + (while (setq ,group (pop ,groups)) + (select-window ,window) + (gnus-group-remove-mark ,group) + (save-selected-window + (save-excursion + (funcall ,function ,group))))))))) (put 'gnus-group-iterate 'lisp-indent-function 1) ;; Selecting groups. -(defun gnus-group-read-group (&optional all no-article group) +(defun gnus-group-read-group (&optional all no-article group select-articles) "Read news in this newsgroup. If the prefix argument ALL is non-nil, already read articles become readable. IF ALL is a number, fetch this number of articles. If the @@ -1496,7 +1512,7 @@ (cdr (assq 'tick marked))) (gnus-range-length (cdr (assq 'dormant marked))))))) - no-article nil no-display))) + no-article nil no-display nil select-articles))) (defun gnus-group-select-group (&optional all) "Select this newsgroup. @@ -1510,7 +1526,10 @@ "Select the current group \"quickly\". This means that no highlighting or scoring will be performed. If ALL (the prefix argument) is 0, don't even generate the summary -buffer." +buffer. + +This might be useful if you want to toggle threading +before entering the group." (interactive "P") (require 'gnus-score) (let (gnus-visual @@ -1539,10 +1558,6 @@ gnus-summary-mode-hook gnus-select-group-hook (group (gnus-group-group-name)) (method (gnus-find-method-for-group group))) - (setq method - `(,(car method) ,(concat (cadr method) "-ephemeral") - (,(intern (format "%s-address" (car method))) ,(cadr method)) - ,@(cddr method))) (gnus-group-read-ephemeral-group (gnus-group-prefixed-name group method) method))) @@ -1552,31 +1567,44 @@ Returns whether the fetching was successful or not." (interactive "sGroup name: ") (unless (get-buffer gnus-group-buffer) - (gnus)) + (gnus-no-server)) (gnus-group-read-group nil nil group)) +;;;###autoload +(defun gnus-fetch-group-other-frame (group) + "Pop up a frame and enter GROUP." + (interactive "P") + (let ((window (get-buffer-window gnus-group-buffer))) + (cond (window + (select-frame (window-frame window))) + ((= (length (frame-list)) 1) + (select-frame (make-frame))) + (t + (other-frame 1)))) + (gnus-fetch-group group)) + (defvar gnus-ephemeral-group-server 0) ;; Enter a group that is not in the group buffer. Non-nil is returned ;; if selection was successful. (defun gnus-group-read-ephemeral-group (group method &optional activate - quit-config request-only) + quit-config request-only + select-articles) "Read GROUP from METHOD as an ephemeral group. If ACTIVATE, request the group first. If QUIT-CONFIG, use that window configuration when exiting from the ephemeral group. If REQUEST-ONLY, don't actually read the group; just request it. +If SELECT-ARTICLES, only select those articles. Return the name of the group is selection was successful." ;; Transform the select method into a unique server. - (let ((saddr (intern (format "%s-address" (car method))))) - (setq method (gnus-copy-sequence method)) - (require (car method)) - (when (boundp saddr) - (unless (assq saddr method) - (nconc method `((,saddr ,(cadr method)))) - (setf (cadr method) (format "%s-%d" (cadr method) - (incf gnus-ephemeral-group-server)))))) + (when (stringp method) + (setq method (gnus-server-to-method method))) + (setq method + `(,(car method) ,(concat (cadr method) "-ephemeral") + (,(intern (format "%s-address" (car method))) ,(cadr method)) + ,@(cddr method))) (let ((group (if (gnus-group-foreign-p group) group (gnus-group-prefixed-name group method)))) (gnus-sethash @@ -1588,6 +1616,7 @@ (cons gnus-summary-buffer gnus-current-window-configuration)))))) gnus-newsrc-hashtb) + (push method gnus-ephemeral-servers) (set-buffer gnus-group-buffer) (unless (gnus-check-server method) (error "Unable to contact server: %s" (gnus-status-message method))) @@ -1599,7 +1628,7 @@ (if request-only group (condition-case () - (when (gnus-group-read-group t t group) + (when (gnus-group-read-group t t group select-articles) group) ;;(error nil) (quit nil))))) @@ -1774,6 +1803,8 @@ (gnus-read-group "Group name: ") (gnus-read-method "From method: "))) + (when (stringp method) + (setq method (gnus-server-to-method method))) (let* ((meth (when (and method (not (gnus-server-equal method gnus-select-method))) (if address (list (intern method) address) @@ -1886,6 +1917,9 @@ (gnus-set-active new-name (gnus-active group)) (gnus-message 6 "Renaming group %s to %s...done" group new-name) new-name) + (setq gnus-killed-list (delete group gnus-killed-list)) + (gnus-set-active group nil) + (gnus-dribble-touch) (gnus-group-position-point))) (defun gnus-group-edit-group (group &optional part) @@ -1964,6 +1998,7 @@ (gnus-group-position-point))) (defun gnus-group-make-useful-group (group method) + "Create one of the groups described in `gnus-useful-groups'." (interactive (let ((entry (assoc (completing-read "Create group: " gnus-useful-groups nil t) @@ -1979,8 +2014,7 @@ "Create the Gnus documentation group." (interactive) (let ((name (gnus-group-prefixed-name "gnus-help" '(nndoc "gnus-help"))) - (file (nnheader-find-etc-directory "gnus-tut.txt" t)) - dir) + (file (nnheader-find-etc-directory "gnus-tut.txt" t))) (when (gnus-gethash name gnus-newsrc-hashtb) (error "Documentation group already exists")) (if (not file) @@ -2373,7 +2407,7 @@ (when (gnus-group-native-p (gnus-info-group info)) (gnus-info-clear-data info))) (gnus-get-unread-articles) - (gnus-dribble-enter "") + (gnus-dribble-touch) (when (gnus-y-or-n-p "Move the cache away to avoid problems in the future? ") (call-interactively 'gnus-cache-move-cache))))) @@ -2395,16 +2429,15 @@ (defun gnus-group-catchup-current (&optional n all) "Mark all articles not marked as unread in current newsgroup as read. -If prefix argument N is numeric, the ARG next newsgroups will be +If prefix argument N is numeric, the next N newsgroups will be caught up. If ALL is non-nil, marked articles will also be marked as read. Cross references (Xref: header) of articles are ignored. -The difference between N and actual number of newsgroups that were -caught up is returned." +The number of newsgroups that this function was unable to catch +up is returned." (interactive "P") - (unless (gnus-group-group-name) - (error "No group on the current line")) (let ((groups (gnus-group-process-prefix n)) (ret 0)) + (unless groups (error "No groups selected")) (if (not (or (not gnus-interactive-catchup) ;Without confirmation? gnus-expert-user @@ -2468,7 +2501,7 @@ (gnus-add-marked-articles group 'tick nil nil 'force) (gnus-add-marked-articles group 'dormant nil nil 'force)) (let ((gnus-newsgroup-name group)) - (run-hooks 'gnus-group-catchup-group-hook)) + (gnus-run-hooks 'gnus-group-catchup-group-hook)) num)))) (defun gnus-group-expire-articles (&optional n) @@ -2592,7 +2625,7 @@ 'gnus-group-history))) (let ((newsrc (gnus-gethash group gnus-newsrc-hashtb))) (cond - ((string-match "^[ \t]$" group) + ((string-match "^[ \t]*$" group) (error "Empty group name")) (newsrc ;; Toggle subscription flag. @@ -2701,25 +2734,28 @@ (delq (assoc group gnus-newsrc-alist) gnus-newsrc-alist)) (when gnus-group-change-level-function - (funcall gnus-group-change-level-function group 9 3)) + (funcall gnus-group-change-level-function + group gnus-level-killed 3)) (cond ((setq entry (gnus-gethash group gnus-newsrc-hashtb)) (push (cons (car entry) (nth 2 entry)) gnus-list-of-killed-groups) (setcdr (cdr entry) (cdddr entry))) ((member group gnus-zombie-list) - (setq gnus-zombie-list (delete group gnus-zombie-list))))) + (setq gnus-zombie-list (delete group gnus-zombie-list)))) + ;; There may be more than one instance displayed. + (while (gnus-group-goto-group group) + (gnus-delete-line))) (gnus-make-hashtable-from-newsrc-alist))) (gnus-group-position-point) (if (< (length out) 2) (car out) (nreverse out)))) (defun gnus-group-yank-group (&optional arg) - "Yank the last newsgroups killed with \\[gnus-group-kill-group], -inserting it before the current newsgroup. The numeric ARG specifies -how many newsgroups are to be yanked. The name of the newsgroup yanked -is returned, or (if several groups are yanked) a list of yanked groups -is returned." + "Yank the last newsgroups killed with \\[gnus-group-kill-group], inserting it before the current newsgroup. +The numeric ARG specifies how many newsgroups are to be yanked. The +name of the newsgroup yanked is returned, or (if several groups are +yanked) a list of yanked groups is returned." (interactive "p") (setq arg (or arg 1)) (let (info group prev out) @@ -2843,7 +2879,7 @@ (defun gnus-activate-all-groups (level) "Activate absolutely all groups." - (interactive (list 7)) + (interactive (list gnus-level-unsubscribed)) (let ((gnus-activate-level level) (gnus-activate-foreign-newsgroups level)) (gnus-group-get-new-news))) @@ -2855,7 +2891,7 @@ \"hard\" re-reading of the active files from all servers." (interactive "P") (let ((gnus-inhibit-demon t)) - (run-hooks 'gnus-get-new-news-hook) + (gnus-run-hooks 'gnus-get-new-news-hook) ;; Read any slave files. (unless gnus-slave @@ -2882,7 +2918,7 @@ (gnus-get-unread-articles arg)) (let ((gnus-read-active-file (if arg nil gnus-read-active-file))) (gnus-get-unread-articles arg))) - (run-hooks 'gnus-after-getting-new-news-hook) + (gnus-run-hooks 'gnus-after-getting-new-news-hook) (gnus-group-list-groups (and (numberp arg) (max (car gnus-group-list-mode) arg))))) @@ -2895,17 +2931,19 @@ (ret (if (numberp n) (- n (length groups)) 0)) (beg (unless n (point))) - group) + group method) (while (setq group (pop groups)) (gnus-group-remove-mark group) ;; Bypass any previous denials from the server. - (gnus-remove-denial (gnus-find-method-for-group group)) + (gnus-remove-denial (setq method (gnus-find-method-for-group group))) (if (gnus-activate-group group (if dont-scan nil 'scan)) (progn (gnus-get-unread-articles-in-group (gnus-get-info group) (gnus-active group) t) (unless (gnus-virtual-group-p group) (gnus-close-group group)) + (gnus-agent-save-group-info + method (gnus-group-real-name group) (gnus-active group)) (gnus-group-update-group group)) (if (eq (gnus-server-status (gnus-find-method-for-group group)) 'denied) @@ -2938,8 +2976,8 @@ (setq dirs (list dirs))) (while (and (not found) (setq dir (pop dirs))) - (setq file (concat (file-name-as-directory dir) - (gnus-group-real-name group))) + (let ((name (gnus-group-real-name group))) + (setq file (concat (file-name-as-directory dir) name))) (if (not (file-exists-p file)) (gnus-message 1 "No such file: %s" file) (let ((enable-local-variables nil)) @@ -3004,6 +3042,7 @@ (lambda (group) (and (symbol-name group) (string-match regexp (symbol-name group)) + (symbol-value group) (push (symbol-name group) groups))) gnus-active-hashtb) ;; Also go through all descriptions that are known to Gnus. @@ -3011,7 +3050,6 @@ (mapatoms (lambda (group) (and (string-match regexp (symbol-value group)) - (gnus-active (symbol-name group)) (push (symbol-name group) groups))) gnus-description-hashtb)) (if (not groups) @@ -3104,12 +3142,14 @@ (defun gnus-group-find-new-groups (&optional arg) "Search for new groups and add them. Each new group will be treated with `gnus-subscribe-newsgroup-method.' -If ARG (the prefix), use the `ask-server' method to query -the server for new groups." - (interactive "P") - (gnus-find-new-newsgroups arg) +With 1 C-u, use the `ask-server' method to query the server for new +groups. +With 2 C-u's, use most complete method possible to query the server +for new groups, and subscribe the new groups as zombies." + (interactive "p") + (gnus-find-new-newsgroups (or arg 1)) (gnus-group-list-groups)) - + (defun gnus-group-edit-global-kill (&optional article group) "Edit the global kill file. If GROUP, edit that local kill file instead." @@ -3137,18 +3177,15 @@ In fact, cleanup buffers except for group mode buffer. The hook gnus-suspend-gnus-hook is called before actually suspending." (interactive) - (run-hooks 'gnus-suspend-gnus-hook) + (gnus-run-hooks 'gnus-suspend-gnus-hook) ;; Kill Gnus buffers except for group mode buffer. - (let* ((group-buf (get-buffer gnus-group-buffer)) - ;; Do this on a separate list in case the user does a ^G before we finish - (gnus-buffer-list - (delete group-buf (delete gnus-dribble-buffer - (append gnus-buffer-list nil))))) - (while gnus-buffer-list - (gnus-kill-buffer (pop gnus-buffer-list))) + (let ((group-buf (get-buffer gnus-group-buffer))) + (mapcar (lambda (buf) + (unless (member buf (list group-buf gnus-dribble-buffer)) + (kill-buffer buf))) + (gnus-buffers)) (gnus-kill-gnus-frames) (when group-buf - (setq gnus-buffer-list (list group-buf)) (bury-buffer group-buf) (delete-windows-on group-buf t)))) @@ -3167,7 +3204,7 @@ (not gnus-interactive-exit) ;Without confirmation gnus-expert-user (gnus-y-or-n-p "Are you sure you want to quit reading news? ")) - (run-hooks 'gnus-exit-gnus-hook) + (gnus-run-hooks 'gnus-exit-gnus-hook) ;; Offer to save data from non-quitted summary buffers. (gnus-offer-save-summaries) ;; Save the newsrc file(s). @@ -3177,7 +3214,7 @@ ;; Reset everything. (gnus-clear-system) ;; Allow the user to do things after cleaning up. - (run-hooks 'gnus-after-exiting-gnus-hook))) + (gnus-run-hooks 'gnus-after-exiting-gnus-hook))) (defun gnus-group-quit () "Quit reading news without updating .newsrc.eld or .newsrc. @@ -3191,14 +3228,14 @@ (gnus-yes-or-no-p (format "Quit reading news without saving %s? " (file-name-nondirectory gnus-current-startup-file)))) - (run-hooks 'gnus-exit-gnus-hook) + (gnus-run-hooks 'gnus-exit-gnus-hook) (gnus-configure-windows 'group t) (gnus-dribble-save) (gnus-close-backends) (gnus-clear-system) (gnus-kill-buffer gnus-group-buffer) ;; Allow the user to do things after cleaning up. - (run-hooks 'gnus-after-exiting-gnus-hook))) + (gnus-run-hooks 'gnus-after-exiting-gnus-hook))) (defun gnus-group-describe-briefly () "Give a one line description of the group mode commands." @@ -3295,7 +3332,6 @@ ;; If INFO is non-nil, use that info. If FORCE is non-nil, don't ;; add, but replace marked articles of TYPE with ARTICLES. (let ((info (or info (gnus-get-info group))) - (uncompressed '(score bookmark killed)) marked m) (or (not info) (and (not (setq marked (nthcdr 3 info))) @@ -3311,7 +3347,7 @@ (if force (if (null articles) (setcar (nthcdr 3 info) - (delq (assq type (car marked)) (car marked))) + (gnus-delete-alist type (car marked))) (setcdr m (gnus-compress-sequence articles t))) (setcdr m (gnus-compress-sequence (sort (nconc (gnus-uncompress-range (cdr m)) @@ -3332,7 +3368,7 @@ (defsubst gnus-group-timestamp (group) "Return the timestamp for GROUP." - (gnus-group-get-parameter group 'timestamp)) + (gnus-group-get-parameter group 'timestamp t)) (defun gnus-group-timestamp-delta (group) "Return the offset in seconds from the timestamp for GROUP to the current time, as a floating point number."
--- a/lisp/gnus/gnus-int.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/gnus-int.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ ;;; gnus-int.el --- backend interface functions for Gnus -;; Copyright (C) 1996,97 Free Software Foundation, Inc. +;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news ;; This file is part of GNU Emacs. @@ -27,6 +27,8 @@ (eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl)) + (require 'gnus) (defcustom gnus-open-server-hook nil @@ -86,7 +88,7 @@ (t (require 'nntp))) (setq gnus-current-select-method gnus-select-method) - (run-hooks 'gnus-open-server-hook) + (gnus-run-hooks 'gnus-open-server-hook) (or ;; gnus-open-server-hook might have opened it (gnus-server-opened gnus-select-method) @@ -121,7 +123,7 @@ (gnus-message 5 "Opening %s server%s..." (car method) (if (equal (nth 1 method) "") "" (format " on %s" (nth 1 method))))) - (run-hooks 'gnus-open-server-hook) + (gnus-run-hooks 'gnus-open-server-hook) (prog1 (gnus-open-server method) (unless silent @@ -134,15 +136,28 @@ (error "Attempted use of a nil select method")) (when (stringp method) (setq method (gnus-server-to-method method))) - (let ((func (intern (format "%s-%s" (car method) function)))) - ;; If the functions isn't bound, we require the backend in - ;; question. + ;; Check cache of constructed names. + (let* ((method-sym (if gnus-agent + (gnus-agent-get-function method) + (car method))) + (method-fns (get method-sym 'gnus-method-functions)) + (func (let ((method-fnlist-elt (assq function method-fns))) + (unless method-fnlist-elt + (setq method-fnlist-elt + (cons function + (intern (format "%s-%s" method-sym function)))) + (put method-sym 'gnus-method-functions + (cons method-fnlist-elt method-fns))) + (cdr method-fnlist-elt)))) + ;; Maybe complain if there is no function. (unless (fboundp func) + (unless (car method) + (error "Trying to require a method that doesn't exist")) (require (car method)) - (when (and (not (fboundp func)) - (not noerror)) - ;; This backend doesn't implement this function. - (error "No such function: %s" func))) + (when (not (fboundp func)) + (if noerror + (setq func nil) + (error "No such function: %s" func)))) func)) @@ -150,11 +165,11 @@ ;;; Interface functions to the backends. ;;; -(defun gnus-open-server (method) - "Open a connection to METHOD." - (when (stringp method) - (setq method (gnus-server-to-method method))) - (let ((elem (assoc method gnus-opened-servers))) +(defun gnus-open-server (gnus-command-method) + "Open a connection to GNUS-COMMAND-METHOD." + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (let ((elem (assoc gnus-command-method gnus-opened-servers))) ;; If this method was previously denied, we just return nil. (if (eq (nth 1 elem) 'denied) (progn @@ -162,137 +177,160 @@ nil) ;; Open the server. (let ((result - (funcall (gnus-get-function method 'open-server) - (nth 1 method) (nthcdr 2 method)))) + (funcall (gnus-get-function gnus-command-method 'open-server) + (nth 1 gnus-command-method) + (nthcdr 2 gnus-command-method)))) ;; If this hasn't been opened before, we add it to the list. (unless elem - (setq elem (list method nil) + (setq elem (list gnus-command-method nil) gnus-opened-servers (cons elem gnus-opened-servers))) ;; Set the status of this server. (setcar (cdr elem) (if result 'ok 'denied)) ;; Return the result from the "open" call. result)))) -(defun gnus-close-server (method) - "Close the connection to METHOD." - (when (stringp method) - (setq method (gnus-server-to-method method))) - (funcall (gnus-get-function method 'close-server) (nth 1 method))) +(defun gnus-close-server (gnus-command-method) + "Close the connection to GNUS-COMMAND-METHOD." + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (funcall (gnus-get-function gnus-command-method 'close-server) + (nth 1 gnus-command-method))) -(defun gnus-request-list (method) - "Request the active file from METHOD." - (when (stringp method) - (setq method (gnus-server-to-method method))) - (funcall (gnus-get-function method 'request-list) (nth 1 method))) +(defun gnus-request-list (gnus-command-method) + "Request the active file from GNUS-COMMAND-METHOD." + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (funcall (gnus-get-function gnus-command-method 'request-list) + (nth 1 gnus-command-method))) -(defun gnus-request-list-newsgroups (method) - "Request the newsgroups file from METHOD." - (when (stringp method) - (setq method (gnus-server-to-method method))) - (funcall (gnus-get-function method 'request-list-newsgroups) (nth 1 method))) +(defun gnus-request-list-newsgroups (gnus-command-method) + "Request the newsgroups file from GNUS-COMMAND-METHOD." + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (funcall (gnus-get-function gnus-command-method 'request-list-newsgroups) + (nth 1 gnus-command-method))) -(defun gnus-request-newgroups (date method) - "Request all new groups since DATE from METHOD." - (when (stringp method) - (setq method (gnus-server-to-method method))) - (let ((func (gnus-get-function method 'request-newgroups t))) +(defun gnus-request-newgroups (date gnus-command-method) + "Request all new groups since DATE from GNUS-COMMAND-METHOD." + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (let ((func (gnus-get-function gnus-command-method 'request-newgroups t))) (when func - (funcall func date (nth 1 method))))) + (funcall func date (nth 1 gnus-command-method))))) -(defun gnus-server-opened (method) - "Check whether a connection to METHOD has been opened." - (when (stringp method) - (setq method (gnus-server-to-method method))) - (funcall (inline (gnus-get-function method 'server-opened)) (nth 1 method))) +(defun gnus-server-opened (gnus-command-method) + "Check whether a connection to GNUS-COMMAND-METHOD has been opened." + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (funcall (inline (gnus-get-function gnus-command-method 'server-opened)) + (nth 1 gnus-command-method))) -(defun gnus-status-message (method) - "Return the status message from METHOD. -If METHOD is a string, it is interpreted as a group name. The method +(defun gnus-status-message (gnus-command-method) + "Return the status message from GNUS-COMMAND-METHOD. +If GNUS-COMMAND-METHOD is a string, it is interpreted as a group name. The method this group uses will be queried." - (let ((method (if (stringp method) (gnus-find-method-for-group method) - method))) - (funcall (gnus-get-function method 'status-message) (nth 1 method)))) + (let ((gnus-command-method + (if (stringp gnus-command-method) + (gnus-find-method-for-group gnus-command-method) + gnus-command-method))) + (funcall (gnus-get-function gnus-command-method 'status-message) + (nth 1 gnus-command-method)))) -(defun gnus-request-regenerate (method) - "Request a data generation from METHOD." - (when (stringp method) - (setq method (gnus-server-to-method method))) - (funcall (gnus-get-function method 'request-regenerate) (nth 1 method))) +(defun gnus-request-regenerate (gnus-command-method) + "Request a data generation from GNUS-COMMAND-METHOD." + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (funcall (gnus-get-function gnus-command-method 'request-regenerate) + (nth 1 gnus-command-method))) -(defun gnus-request-group (group &optional dont-check method) +(defun gnus-request-group (group &optional dont-check gnus-command-method) "Request GROUP. If DONT-CHECK, no information is required." - (let ((method (or method (inline (gnus-find-method-for-group group))))) - (when (stringp method) - (setq method (inline (gnus-server-to-method method)))) - (funcall (inline (gnus-get-function method 'request-group)) - (gnus-group-real-name group) (nth 1 method) dont-check))) + (let ((gnus-command-method + (or gnus-command-method (inline (gnus-find-method-for-group group))))) + (when (stringp gnus-command-method) + (setq gnus-command-method + (inline (gnus-server-to-method gnus-command-method)))) + (funcall (inline (gnus-get-function gnus-command-method 'request-group)) + (gnus-group-real-name group) (nth 1 gnus-command-method) + dont-check))) (defun gnus-list-active-group (group) "Request active information on GROUP." - (let ((method (gnus-find-method-for-group group)) + (let ((gnus-command-method (gnus-find-method-for-group group)) (func 'list-active-group)) (when (gnus-check-backend-function func group) - (funcall (gnus-get-function method func) - (gnus-group-real-name group) (nth 1 method))))) + (funcall (gnus-get-function gnus-command-method func) + (gnus-group-real-name group) (nth 1 gnus-command-method))))) (defun gnus-request-group-description (group) "Request a description of GROUP." - (let ((method (gnus-find-method-for-group group)) + (let ((gnus-command-method (gnus-find-method-for-group group)) (func 'request-group-description)) (when (gnus-check-backend-function func group) - (funcall (gnus-get-function method func) - (gnus-group-real-name group) (nth 1 method))))) + (funcall (gnus-get-function gnus-command-method func) + (gnus-group-real-name group) (nth 1 gnus-command-method))))) (defun gnus-close-group (group) "Request the GROUP be closed." - (let ((method (inline (gnus-find-method-for-group group)))) - (funcall (gnus-get-function method 'close-group) - (gnus-group-real-name group) (nth 1 method)))) + (let ((gnus-command-method (inline (gnus-find-method-for-group group)))) + (funcall (gnus-get-function gnus-command-method 'close-group) + (gnus-group-real-name group) (nth 1 gnus-command-method)))) (defun gnus-retrieve-headers (articles group &optional fetch-old) "Request headers for ARTICLES in GROUP. If FETCH-OLD, retrieve all headers (or some subset thereof) in the group." - (let ((method (gnus-find-method-for-group group))) + (let ((gnus-command-method (gnus-find-method-for-group group))) (if (and gnus-use-cache (numberp (car articles))) (gnus-cache-retrieve-headers articles group fetch-old) - (funcall (gnus-get-function method 'retrieve-headers) - articles (gnus-group-real-name group) (nth 1 method) - fetch-old)))) + (funcall (gnus-get-function gnus-command-method 'retrieve-headers) + articles (gnus-group-real-name group) + (nth 1 gnus-command-method) fetch-old)))) -(defun gnus-retrieve-groups (groups method) - "Request active information on GROUPS from METHOD." - (when (stringp method) - (setq method (gnus-server-to-method method))) - (funcall (gnus-get-function method 'retrieve-groups) groups (nth 1 method))) +(defun gnus-retrieve-articles (articles group) + "Request ARTICLES in GROUP." + (let ((gnus-command-method (gnus-find-method-for-group group))) + (funcall (gnus-get-function gnus-command-method 'retrieve-articles) + articles (gnus-group-real-name group) + (nth 1 gnus-command-method)))) + +(defun gnus-retrieve-groups (groups gnus-command-method) + "Request active information on GROUPS from GNUS-COMMAND-METHOD." + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (funcall (gnus-get-function gnus-command-method 'retrieve-groups) + groups (nth 1 gnus-command-method))) (defun gnus-request-type (group &optional article) "Return the type (`post' or `mail') of GROUP (and ARTICLE)." - (let ((method (gnus-find-method-for-group group))) - (if (not (gnus-check-backend-function 'request-type (car method))) + (let ((gnus-command-method (gnus-find-method-for-group group))) + (if (not (gnus-check-backend-function + 'request-type (car gnus-command-method))) 'unknown - (funcall (gnus-get-function method 'request-type) + (funcall (gnus-get-function gnus-command-method 'request-type) (gnus-group-real-name group) article)))) (defun gnus-request-update-mark (group article mark) - "Return the type (`post' or `mail') of GROUP (and ARTICLE)." - (let ((method (gnus-find-method-for-group group))) - (if (not (gnus-check-backend-function 'request-update-mark (car method))) + "Allow the backend to change the mark the user tries to put on an article." + (let ((gnus-command-method (gnus-find-method-for-group group))) + (if (not (gnus-check-backend-function + 'request-update-mark (car gnus-command-method))) mark - (funcall (gnus-get-function method 'request-update-mark) + (funcall (gnus-get-function gnus-command-method 'request-update-mark) (gnus-group-real-name group) article mark)))) (defun gnus-request-article (article group &optional buffer) "Request the ARTICLE in GROUP. ARTICLE can either be an article number or an article Message-ID. If BUFFER, insert the article in that group." - (let ((method (gnus-find-method-for-group group))) - (funcall (gnus-get-function method 'request-article) - article (gnus-group-real-name group) (nth 1 method) buffer))) + (let ((gnus-command-method (gnus-find-method-for-group group))) + (funcall (gnus-get-function gnus-command-method 'request-article) + article (gnus-group-real-name group) + (nth 1 gnus-command-method) buffer))) (defun gnus-request-head (article group) "Request the head of ARTICLE in GROUP." - (let* ((method (gnus-find-method-for-group group)) - (head (gnus-get-function method 'request-head t)) + (let* ((gnus-command-method (gnus-find-method-for-group group)) + (head (gnus-get-function gnus-command-method 'request-head t)) res clean-up) (cond ;; Check the cache. @@ -304,7 +342,7 @@ ;; Use `head' function. ((fboundp head) (setq res (funcall head article (gnus-group-real-name group) - (nth 1 method)))) + (nth 1 gnus-command-method)))) ;; Use `article' function. (t (setq res (gnus-request-article article group) @@ -320,60 +358,88 @@ (defun gnus-request-body (article group) "Request the body of ARTICLE in GROUP." - (let ((method (gnus-find-method-for-group group))) - (funcall (gnus-get-function method 'request-body) - article (gnus-group-real-name group) (nth 1 method)))) - -(defun gnus-request-post (method) - "Post the current buffer using METHOD." - (when (stringp method) - (setq method (gnus-server-to-method method))) - (funcall (gnus-get-function method 'request-post) (nth 1 method))) + (let* ((gnus-command-method (gnus-find-method-for-group group)) + (head (gnus-get-function gnus-command-method 'request-body t)) + res clean-up) + (cond + ;; Check the cache. + ((and gnus-use-cache + (numberp article) + (gnus-cache-request-article article group)) + (setq res (cons group article) + clean-up t)) + ;; Use `head' function. + ((fboundp head) + (setq res (funcall head article (gnus-group-real-name group) + (nth 1 gnus-command-method)))) + ;; Use `article' function. + (t + (setq res (gnus-request-article article group) + clean-up t))) + (when clean-up + (save-excursion + (set-buffer nntp-server-buffer) + (goto-char (point-min)) + (when (search-forward "\n\n" nil t) + (delete-region (point-min) (1- (point)))))) + res)) -(defun gnus-request-scan (group method) - "Request a SCAN being performed in GROUP from METHOD. -If GROUP is nil, all groups on METHOD are scanned." - (let ((method (if group (gnus-find-method-for-group group) method)) - (gnus-inhibit-demon t)) - (funcall (gnus-get-function method 'request-scan) - (and group (gnus-group-real-name group)) (nth 1 method)))) +(defun gnus-request-post (gnus-command-method) + "Post the current buffer using GNUS-COMMAND-METHOD." + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (funcall (gnus-get-function gnus-command-method 'request-post) + (nth 1 gnus-command-method))) -(defsubst gnus-request-update-info (info method) - "Request that METHOD update INFO." - (when (stringp method) - (setq method (gnus-server-to-method method))) - (when (gnus-check-backend-function 'request-update-info (car method)) - (funcall (gnus-get-function method 'request-update-info) +(defun gnus-request-scan (group gnus-command-method) + "Request a SCAN being performed in GROUP from GNUS-COMMAND-METHOD. +If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned." + (when gnus-plugged + (let ((gnus-command-method + (if group (gnus-find-method-for-group group) gnus-command-method)) + (gnus-inhibit-demon t)) + (funcall (gnus-get-function gnus-command-method 'request-scan) + (and group (gnus-group-real-name group)) + (nth 1 gnus-command-method))))) + +(defsubst gnus-request-update-info (info gnus-command-method) + "Request that GNUS-COMMAND-METHOD update INFO." + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (when (gnus-check-backend-function + 'request-update-info (car gnus-command-method)) + (funcall (gnus-get-function gnus-command-method 'request-update-info) (gnus-group-real-name (gnus-info-group info)) - info (nth 1 method)))) + info (nth 1 gnus-command-method)))) (defun gnus-request-expire-articles (articles group &optional force) - (let ((method (gnus-find-method-for-group group))) - (funcall (gnus-get-function method 'request-expire-articles) - articles (gnus-group-real-name group) (nth 1 method) + (let ((gnus-command-method (gnus-find-method-for-group group))) + (funcall (gnus-get-function gnus-command-method 'request-expire-articles) + articles (gnus-group-real-name group) (nth 1 gnus-command-method) force))) (defun gnus-request-move-article (article group server accept-function &optional last) - (let ((method (gnus-find-method-for-group group))) - (funcall (gnus-get-function method 'request-move-article) + (let ((gnus-command-method (gnus-find-method-for-group group))) + (funcall (gnus-get-function gnus-command-method 'request-move-article) article (gnus-group-real-name group) - (nth 1 method) accept-function last))) + (nth 1 gnus-command-method) accept-function last))) -(defun gnus-request-accept-article (group method &optional last) +(defun gnus-request-accept-article (group &optional gnus-command-method last) ;; Make sure there's a newline at the end of the article. - (when (stringp method) - (setq method (gnus-server-to-method method))) - (when (and (not method) + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (when (and (not gnus-command-method) (stringp group)) - (setq method (gnus-group-name-to-method group))) + (setq gnus-command-method (gnus-group-name-to-method group))) (goto-char (point-max)) (unless (bolp) (insert "\n")) - (let ((func (car (or method (gnus-find-method-for-group group))))) + (let ((func (car (or gnus-command-method + (gnus-find-method-for-group group))))) (funcall (intern (format "%s-request-accept-article" func)) (if (stringp group) (gnus-group-real-name group) group) - (cadr method) + (cadr gnus-command-method) last))) (defun gnus-request-replace-article (article group buffer) @@ -382,53 +448,56 @@ article (gnus-group-real-name group) buffer))) (defun gnus-request-associate-buffer (group) - (let ((method (gnus-find-method-for-group group))) - (funcall (gnus-get-function method 'request-associate-buffer) + (let ((gnus-command-method (gnus-find-method-for-group group))) + (funcall (gnus-get-function gnus-command-method 'request-associate-buffer) (gnus-group-real-name group)))) (defun gnus-request-restore-buffer (article group) "Request a new buffer restored to the state of ARTICLE." - (let ((method (gnus-find-method-for-group group))) - (funcall (gnus-get-function method 'request-restore-buffer) - article (gnus-group-real-name group) (nth 1 method)))) + (let ((gnus-command-method (gnus-find-method-for-group group))) + (funcall (gnus-get-function gnus-command-method 'request-restore-buffer) + article (gnus-group-real-name group) + (nth 1 gnus-command-method)))) -(defun gnus-request-create-group (group &optional method args) - (when (stringp method) - (setq method (gnus-server-to-method method))) - (let ((method (or method (gnus-find-method-for-group group)))) - (funcall (gnus-get-function method 'request-create-group) - (gnus-group-real-name group) (nth 1 method) args))) +(defun gnus-request-create-group (group &optional gnus-command-method args) + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (let ((gnus-command-method + (or gnus-command-method (gnus-find-method-for-group group)))) + (funcall (gnus-get-function gnus-command-method 'request-create-group) + (gnus-group-real-name group) (nth 1 gnus-command-method) args))) (defun gnus-request-delete-group (group &optional force) - (let ((method (gnus-find-method-for-group group))) - (funcall (gnus-get-function method 'request-delete-group) - (gnus-group-real-name group) force (nth 1 method)))) + (let ((gnus-command-method (gnus-find-method-for-group group))) + (funcall (gnus-get-function gnus-command-method 'request-delete-group) + (gnus-group-real-name group) force (nth 1 gnus-command-method)))) (defun gnus-request-rename-group (group new-name) - (let ((method (gnus-find-method-for-group group))) - (funcall (gnus-get-function method 'request-rename-group) + (let ((gnus-command-method (gnus-find-method-for-group group))) + (funcall (gnus-get-function gnus-command-method 'request-rename-group) (gnus-group-real-name group) - (gnus-group-real-name new-name) (nth 1 method)))) + (gnus-group-real-name new-name) (nth 1 gnus-command-method)))) (defun gnus-close-backends () ;; Send a close request to all backends that support such a request. (let ((methods gnus-valid-select-methods) (gnus-inhibit-demon t) - func method) - (while (setq method (pop methods)) + func gnus-command-method) + (while (setq gnus-command-method (pop methods)) (when (fboundp (setq func (intern - (concat (car method) "-request-close")))) + (concat (car gnus-command-method) + "-request-close")))) (funcall func))))) -(defun gnus-asynchronous-p (method) - (let ((func (gnus-get-function method 'asynchronous-p t))) +(defun gnus-asynchronous-p (gnus-command-method) + (let ((func (gnus-get-function gnus-command-method 'asynchronous-p t))) (when (fboundp func) (funcall func)))) -(defun gnus-remove-denial (method) - (when (stringp method) - (setq method (gnus-server-to-method method))) - (let* ((elem (assoc method gnus-opened-servers)) +(defun gnus-remove-denial (gnus-command-method) + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (let* ((elem (assoc gnus-command-method gnus-opened-servers)) (status (cadr elem))) ;; If this hasn't been opened before, we add it to the list. (when (eq status 'denied)
--- a/lisp/gnus/gnus-kill.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/gnus-kill.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,8 +1,8 @@ ;;; gnus-kill.el --- kill commands for Gnus -;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> -;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news ;; This file is part of GNU Emacs. @@ -28,6 +28,8 @@ (eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl)) + (require 'gnus) (require 'gnus-art) (require 'gnus-range) @@ -159,7 +161,7 @@ (setq major-mode 'gnus-kill-file-mode) (setq mode-name "Kill") (lisp-mode-variables nil) - (run-hooks 'emacs-lisp-mode-hook 'gnus-kill-file-mode-hook)) + (gnus-run-hooks 'emacs-lisp-mode-hook 'gnus-kill-file-mode-hook)) (defun gnus-kill-file-edit-file (newsgroup) "Begin editing a kill file for NEWSGROUP. @@ -406,7 +408,6 @@ () (gnus-message 6 "Processing kill file %s..." (car kill-files)) (find-file (car kill-files)) - (gnus-add-current-to-buffer-list) (goto-char (point-min)) (if (consp (ignore-errors (read (current-buffer)))) @@ -469,9 +470,9 @@ (?h . "") (?f . "from") (?: . "subject"))) - (com-to-com - '((?m . " ") - (?j . "X"))) + ;;(com-to-com + ;; '((?m . " ") + ;; (?j . "X"))) pattern modifier commands) (while (not (eobp)) (if (not (looking-at "[ \t]*/\\([^/]*\\)/\\([ahfcH]\\)?:\\([a-z=:]*\\)")) @@ -566,7 +567,7 @@ (not (consp (cdadr (nth 2 object)))))) (concat "\n" (gnus-prin1-to-string object)) (save-excursion - (set-buffer (get-buffer-create "*Gnus PP*")) + (set-buffer (gnus-get-buffer-create "*Gnus PP*")) (buffer-disable-undo (current-buffer)) (erase-buffer) (insert (format "\n(%S %S\n '(" (nth 0 object) (nth 1 object))) @@ -676,10 +677,7 @@ ;;;###autoload (defun gnus-batch-score () "Run batched scoring. -Usage: emacs -batch -l gnus -f gnus-batch-score <newsgroups> ... -Newsgroups is a list of strings in Bnews format. If you want to score -the comp hierarchy, you'd say \"comp.all\". If you would not like to -score the alt hierarchy, you'd say \"!alt.all\"." +Usage: emacs -batch -l ~/.emacs -l gnus -f gnus-batch-score" (interactive) (let* ((gnus-newsrc-options-n (gnus-newsrc-parse-options @@ -689,7 +687,7 @@ (nnmail-spool-file nil) (gnus-use-dribble-file nil) (gnus-batch-mode t) - group newsrc entry + info group newsrc entry ;; Disable verbose message. gnus-novice-user gnus-large-newsgroup gnus-options-subscribe gnus-auto-subscribed-groups @@ -699,14 +697,13 @@ (gnus-slave) ;; Apply kills to specified newsgroups in command line arguments. (setq newsrc (cdr gnus-newsrc-alist)) - (while (setq group (car (pop newsrc))) - (setq entry (gnus-gethash group gnus-newsrc-hashtb)) - (when (and (<= (gnus-info-level (car newsrc)) gnus-level-subscribed) + (while (setq info (pop newsrc)) + (setq group (gnus-info-group info) + entry (gnus-gethash group gnus-newsrc-hashtb)) + (when (and (<= (gnus-info-level info) gnus-level-subscribed) (and (car entry) (or (eq (car entry) t) - (not (zerop (car entry))))) - ;;(eq (gnus-matches-options-n group) 'subscribe) - ) + (not (zerop (car entry)))))) (gnus-summary-read-group group nil t nil t) (when (eq (current-buffer) (get-buffer gnus-summary-buffer)) (gnus-summary-exit))))
--- a/lisp/gnus/gnus-logic.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/gnus-logic.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ ;;; gnus-logic.el --- advanced scoring code for Gnus -;; Copyright (C) 1996,97 Free Software Foundation, Inc. +;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news ;; This file is part of GNU Emacs. @@ -27,6 +27,8 @@ (eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl)) + (require 'gnus) (require 'gnus-score) (require 'gnus-util) @@ -164,9 +166,9 @@ (funcall type match (or (aref gnus-advanced-headers index) 0)))) (defun gnus-advanced-date (index match type) - (let ((date (encode-time (parse-time-string - (aref gnus-advanced-headers index)))) - (match (encode-time (parse-time-string match)))) + (let ((date (apply 'encode-time (parse-time-string + (aref gnus-advanced-headers index)))) + (match (apply 'encode-time (parse-time-string match)))) (cond ((eq type 'at) (equal date match))
--- a/lisp/gnus/gnus-mh.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/gnus-mh.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,8 +1,8 @@ ;;; gnus-mh.el --- mh-e interface for Gnus -;; Copyright (C) 1994,95,96,97 Free Software Foundation, Inc. +;; Copyright (C) 1994,95,96,97,98 Free Software Foundation, Inc. ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> -;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news ;; This file is part of GNU Emacs. @@ -64,7 +64,7 @@ (funcall gnus-folder-save-name gnus-newsgroup-name gnus-current-headers gnus-newsgroup-last-folder) t)))) - (errbuf (get-buffer-create " *Gnus rcvstore*")) + (errbuf (gnus-get-buffer-create " *Gnus rcvstore*")) ;; Find the rcvstore program. (exec-path (if mh-lib (cons mh-lib exec-path) exec-path))) (gnus-eval-in-buffer-window gnus-original-article-buffer
--- a/lisp/gnus/gnus-move.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/gnus-move.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ ;;; gnus-move.el --- commands for moving Gnus from one server to another -;; Copyright (C) 1996,97 Free Software Foundation, Inc. +;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news ;; This file is part of GNU Emacs. @@ -27,6 +27,8 @@ (eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl)) + (require 'gnus) (require 'gnus-start) (require 'gnus-int) @@ -113,24 +115,27 @@ (goto-char (point-min)) (while (looking-at "^[0-9]+\t[^\t]*\t[^\t]*\t[^\t]*\t\\([^\t]*\\)\t") - (setq to-article - (gnus-gethash - (buffer-substring (match-beginning 1) (match-end 1)) - hashtb)) - ;; Add this article to the list of read articles. - (push to-article to-reads) - ;; See if there are any marks and then add them. - (when (setq mark (assq (read (current-buffer)) marks)) - (setq marks (delq mark marks)) - (setcar mark to-article) - (push mark to-marks)) - (forward-line 1)) + (when (setq to-article + (gnus-gethash + (buffer-substring (match-beginning 1) (match-end 1)) + hashtb)) + ;; Add this article to the list of read articles. + (push to-article to-reads) + ;; See if there are any marks and then add them. + (when (setq mark (assq (read (current-buffer)) marks)) + (setq marks (delq mark marks)) + (setcar mark to-article) + (push mark to-marks)) + (forward-line 1))) ;; Now we know what the read articles are and what the ;; article marks are. We transform the information ;; into the Gnus info format. (setq to-reads (gnus-range-add - (gnus-compress-sequence (and to-reads (sort to-reads '<)) t) + (gnus-compress-sequence + (and (setq to-reads (delq nil to-reads)) + (sort to-reads '<)) + t) (cons 1 (1- (car to-active))))) (gnus-info-set-read info to-reads) ;; Do the marks. I'm sure y'all understand what's
--- a/lisp/gnus/gnus-msg.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/gnus-msg.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,8 +1,8 @@ ;;; gnus-msg.el --- mail and post interface for Gnus -;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> -;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news ;; This file is part of GNU Emacs. @@ -28,23 +28,32 @@ (eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl)) + (require 'gnus) (require 'gnus-ems) (require 'message) (require 'gnus-art) -;; Added by Sudish Joseph <joseph@cis.ohio-state.edu>. -(defvar gnus-post-method nil +(defcustom gnus-post-method nil "*Preferred method for posting USENET news. -If this variable is nil, Gnus will use the current method to decide -which method to use when posting. If it is non-nil, it will override -the current method. This method will not be used in mail groups and -the like, only in \"real\" newsgroups. + +If this variable is `current', Gnus will use the \"current\" select +method when posting. If it is nil (which is the default), Gnus will +use the native posting method of the server. + +This method will not be used in mail groups and the like, only in +\"real\" newsgroups. -The value must be a valid method as discussed in the documentation of -`gnus-select-method'. It can also be a list of methods. If that is -the case, the user will be queried for what select method to use when -posting.") +If not nil nor `native', the value must be a valid method as discussed +in the documentation of `gnus-select-method'. It can also be a list of +methods. If that is the case, the user will be queried for what select +method to use when posting." + :group 'gnus-group-foreign + :type `(choice (const nil) + (const current) + (const native) + (sexp :tag "Methods" ,gnus-select-method))) (defvar gnus-outgoing-message-group nil "*All outgoing messages will be put in this group. @@ -66,13 +75,6 @@ (defvar gnus-add-to-list nil "*If non-nil, add a `to-list' parameter automatically.") -(defvar gnus-sent-message-ids-file - (nnheader-concat gnus-directory "Sent-Message-IDs") - "File where Gnus saves a cache of sent message ids.") - -(defvar gnus-sent-message-ids-length 1000 - "The number of sent Message-IDs to save.") - (defvar gnus-crosspost-complaint "Hi, @@ -94,11 +96,29 @@ (defvar gnus-message-setup-hook nil "Hook run after setting up a message buffer.") +(defvar gnus-bug-create-help-buffer t + "*Should we create the *Gnus Help Bug* buffer?") + +(defvar gnus-posting-styles nil + "*Alist of styles to use when posting.") + +(defvar gnus-posting-style-alist + '((organization . message-user-organization) + (signature . message-signature) + (signature-file . message-signature-file) + (address . user-mail-address) + (name . user-full-name)) + "*Mapping from style parameters to variables.") + ;;; Internal variables. +(defvar gnus-inhibit-posting-styles nil + "Inhibit the use of posting styles.") + (defvar gnus-message-buffer "*Mail Gnus*") (defvar gnus-article-copy nil) (defvar gnus-last-posting-server nil) +(defvar gnus-message-group-art nil) (defconst gnus-bug-message "Sending a bug report to the Gnus Towers. @@ -161,22 +181,30 @@ (defvar gnus-article-reply nil) (defmacro gnus-setup-message (config &rest forms) - (let ((winconf (make-symbol "winconf")) - (buffer (make-symbol "buffer")) - (article (make-symbol "article"))) + (let ((winconf (make-symbol "gnus-setup-message-winconf")) + (buffer (make-symbol "gnus-setup-message-buffer")) + (article (make-symbol "gnus-setup-message-article")) + (group (make-symbol "gnus-setup-message-group"))) `(let ((,winconf (current-window-configuration)) (,buffer (buffer-name (current-buffer))) (,article (and gnus-article-reply (gnus-summary-article-number))) + (,group gnus-newsgroup-name) (message-header-setup-hook - (copy-sequence message-header-setup-hook))) + (copy-sequence message-header-setup-hook)) + (message-mode-hook (copy-sequence message-mode-hook))) (add-hook 'message-header-setup-hook 'gnus-inews-insert-gcc) (add-hook 'message-header-setup-hook 'gnus-inews-insert-archive-gcc) + (add-hook 'message-mode-hook 'gnus-configure-posting-styles) (unwind-protect - ,@forms + (progn + ,@forms) (gnus-inews-add-send-actions ,winconf ,buffer ,article) (setq gnus-message-buffer (current-buffer)) + (set (make-local-variable 'gnus-message-group-art) + (cons ,group ,article)) (make-local-variable 'gnus-newsgroup-name) - (run-hooks 'gnus-message-setup-hook)) + (gnus-run-hooks 'gnus-message-setup-hook)) + (gnus-add-buffer) (gnus-configure-windows ,config t) (set-buffer-modified-p nil)))) @@ -190,9 +218,9 @@ (message-add-action `(set-window-configuration ,winconf) 'exit 'postpone 'kill) (message-add-action - `(when (buffer-name (get-buffer ,buffer)) + `(when (gnus-buffer-exists-p ,buffer) (save-excursion - (set-buffer (get-buffer ,buffer)) + (set-buffer ,buffer) ,(when article `(gnus-summary-mark-article-as-replied ,article)))) 'send)) @@ -213,8 +241,7 @@ If ARG, post to the group under point. If ARG is 1, prompt for a group name." (interactive "P") - ;; Bind this variable here to make message mode hooks - ;; work ok. + ;; Bind this variable here to make message mode hooks work ok. (let ((gnus-newsgroup-name (if arg (if (= 1 (prefix-numeric-value arg)) @@ -227,7 +254,6 @@ (defun gnus-summary-post-news () "Start composing a news message." (interactive) - (gnus-set-global-variables) (gnus-post-news 'post gnus-newsgroup-name)) (defun gnus-summary-followup (yank &optional force-news) @@ -236,7 +262,6 @@ (interactive (list (and current-prefix-arg (gnus-summary-work-articles 1)))) - (gnus-set-global-variables) (when yank (gnus-summary-goto-subject (car yank))) (save-window-excursion @@ -283,14 +308,16 @@ (push-mark) (goto-char beg))) -(defun gnus-summary-cancel-article (n) - "Cancel an article you posted." - (interactive "P") - (gnus-set-global-variables) +(defun gnus-summary-cancel-article (&optional n symp) + "Cancel an article you posted. +Uses the process-prefix convention. If given the symbolic +prefix `a', cancel using the standard posting method; if not +post using the current select method." + (interactive (gnus-interactive "P\ny")) (let ((articles (gnus-summary-work-articles n)) (message-post-method `(lambda (arg) - (gnus-post-method nil ,gnus-newsgroup-name))) + (gnus-post-method (not (eq symp 'a)) ,gnus-newsgroup-name))) article) (while (setq article (pop articles)) (when (gnus-summary-select-article t nil nil article) @@ -306,7 +333,6 @@ This is done simply by taking the old article and adding a Supersedes header line with the old Message-ID." (interactive) - (gnus-set-global-variables) (let ((article (gnus-summary-article-number))) (gnus-setup-message 'reply-yank (gnus-summary-select-article t) @@ -314,9 +340,9 @@ (message-supersede) (push `((lambda () - (when (buffer-name (get-buffer ,gnus-summary-buffer)) + (when (gnus-buffer-exists-p ,gnus-summary-buffer) (save-excursion - (set-buffer (get-buffer ,gnus-summary-buffer)) + (set-buffer ,gnus-summary-buffer) (gnus-cache-possibly-remove-article ,article nil nil nil t) (gnus-summary-mark-as-read ,article gnus-canceled-mark))))) message-send-actions)))) @@ -328,14 +354,12 @@ ;; this copy is in the buffer gnus-article-copy. ;; if ARTICLE-BUFFER is nil, gnus-article-buffer is used ;; this buffer should be passed to all mail/news reply/post routines. - (setq gnus-article-copy (get-buffer-create " *gnus article copy*")) + (setq gnus-article-copy (gnus-get-buffer-create " *gnus article copy*")) (buffer-disable-undo gnus-article-copy) - (or (memq gnus-article-copy gnus-buffer-list) - (push gnus-article-copy gnus-buffer-list)) (let ((article-buffer (or article-buffer gnus-article-buffer)) - end beg contents) + end beg) (if (not (and (get-buffer article-buffer) - (buffer-name (get-buffer article-buffer)))) + (gnus-buffer-exists-p article-buffer))) (error "Can't find any article buffer") (save-excursion (set-buffer article-buffer) @@ -404,6 +428,7 @@ (if post (message-news (or to-group group)) (set-buffer gnus-article-copy) + (gnus-msg-treat-broken-reply-to) (message-followup (if (or newsgroup-p force-news) nil to-group))) ;; The is mail. (if post @@ -417,12 +442,19 @@ (push (list 'gnus-inews-add-to-address pgroup) message-send-actions))) (set-buffer gnus-article-copy) - (message-wide-reply to-address - (gnus-group-find-parameter - gnus-newsgroup-name 'broken-reply-to)))) + (gnus-msg-treat-broken-reply-to) + (message-wide-reply to-address))) (when yank (gnus-inews-yank-articles yank)))))) +(defun gnus-msg-treat-broken-reply-to () + "Remove the Reply-to header iff broken-reply-to." + (when (gnus-group-find-parameter + gnus-newsgroup-name 'broken-reply-to) + (save-restriction + (message-narrow-to-head) + (message-remove-header "reply-to")))) + (defun gnus-post-method (arg group &optional silent) "Return the posting method based on GROUP and ARG. If SILENT, don't prompt the user." @@ -431,22 +463,28 @@ ;; If the group-method is nil (which shouldn't happen) we use ;; the default method. ((null group-method) - (or gnus-post-method gnus-select-method message-post-method)) - ;; We want this group's method. + (or (and (null (eq gnus-post-method 'active)) gnus-post-method) + gnus-select-method message-post-method)) + ;; We want the inverse of the default ((and arg (not (eq arg 0))) - group-method) + (if (eq gnus-post-method 'active) + gnus-select-method + group-method)) ;; We query the user for a post method. ((or arg (and gnus-post-method + (not (eq gnus-post-method 'current)) (listp (car gnus-post-method)))) (let* ((methods ;; Collect all methods we know about. (append - (when gnus-post-method + (when (and gnus-post-method + (not (eq gnus-post-method 'current))) (if (listp (car gnus-post-method)) gnus-post-method (list gnus-post-method))) gnus-secondary-select-methods + (mapcar 'cdr gnus-server-alist) (list gnus-select-method) (list group-method))) method-alist post-methods method) @@ -475,41 +513,16 @@ (cons (or gnus-last-posting-server "") 0)))) method-alist)))) ;; Override normal method. - (gnus-post-method + ((and (eq gnus-post-method 'current) + (not (eq (car group-method) 'nndraft)) + (not arg)) + group-method) + ((and gnus-post-method + (not (eq gnus-post-method 'current))) gnus-post-method) ;; Use the normal select method. (t gnus-select-method)))) -;;; -;;; Check whether the message has been sent already. -;;; - -(defvar gnus-inews-sent-ids nil) - -(defun gnus-inews-reject-message () - "Check whether this message has already been sent." - (when gnus-sent-message-ids-file - (let ((message-id (save-restriction (message-narrow-to-headers) - (mail-fetch-field "message-id"))) - end) - (when message-id - (unless gnus-inews-sent-ids - (ignore-errors - (load t t t))) - (if (member message-id gnus-inews-sent-ids) - ;; Reject this message. - (not (gnus-yes-or-no-p - (format "Message %s already sent. Send anyway? " - message-id))) - (push message-id gnus-inews-sent-ids) - ;; Chop off the last Message-IDs. - (when (setq end (nthcdr gnus-sent-message-ids-length - gnus-inews-sent-ids)) - (setcdr end nil)) - (nnheader-temp-write gnus-sent-message-ids-file - (gnus-prin1 `(setq gnus-inews-sent-ids ',gnus-inews-sent-ids))) - nil))))) - ;; Dummy to avoid byte-compile warning. @@ -520,7 +533,7 @@ ;;; as well include the Emacs version as well. ;;; The following function works with later GNU Emacs, and XEmacs. (defun gnus-extended-version () - "Stringified Gnus version and Emacs version" + "Stringified Gnus version and Emacs version." (interactive) (concat gnus-version @@ -547,6 +560,8 @@ ;; Written by "Mr. Per Persson" <pp@gnu.ai.mit.edu>. (defun gnus-inews-insert-mime-headers () + "Insert MIME headers. +Assumes ISO-Latin-1 is used iff 8-bit characters are present." (goto-char (point-min)) (let ((mail-header-separator (progn @@ -561,7 +576,7 @@ (cond ((save-restriction (widen) (goto-char (point-min)) - (re-search-forward "[\200-\377]" nil t)) + (re-search-forward "[^\000-\177]" nil t)) (or (mail-position-on-field "Content-Type") (insert "text/plain; charset=ISO-8859-1")) (or (mail-position-on-field "Content-Transfer-Encoding") @@ -571,6 +586,8 @@ (or (mail-position-on-field "Content-Transfer-Encoding") (insert "7bit"))))))) +(custom-add-option 'message-header-hook 'gnus-inews-insert-mime-headers) + ;;; ;;; Gnus Mail Functions @@ -586,15 +603,14 @@ (list (and current-prefix-arg (gnus-summary-work-articles 1)))) ;; Stripping headers should be specified with mail-yank-ignored-headers. - (gnus-set-global-variables) (when yank (gnus-summary-goto-subject (car yank))) (let ((gnus-article-reply t)) (gnus-setup-message (if yank 'reply-yank 'reply) (gnus-summary-select-article) (set-buffer (gnus-copy-article-buffer)) - (message-reply nil wide (gnus-group-find-parameter - gnus-newsgroup-name 'broken-reply-to)) + (gnus-msg-treat-broken-reply-to) + (message-reply nil wide) (when yank (gnus-inews-yank-articles yank))))) @@ -623,7 +639,6 @@ "Forward the current message to another user. If FULL-HEADERS (the prefix), include full headers when forwarding." (interactive "P") - (gnus-set-global-variables) (gnus-setup-message 'forward (gnus-summary-select-article) (set-buffer gnus-original-article-buffer) @@ -696,8 +711,7 @@ (message-goto-subject) (re-search-forward " *$") (replace-match " (crosspost notification)" t t) - (when (fboundp 'deactivate-mark) - (deactivate-mark)) + (gnus-deactivate-mark) (when (gnus-y-or-n-p "Send this complaint? ") (message-send-and-exit))))))) @@ -801,18 +815,20 @@ (error "Gnus has been shut down")) (gnus-setup-message 'bug (delete-other-windows) - (switch-to-buffer "*Gnus Help Bug*") - (erase-buffer) - (insert gnus-bug-message) - (goto-char (point-min)) + (when gnus-bug-create-help-buffer + (switch-to-buffer "*Gnus Help Bug*") + (erase-buffer) + (insert gnus-bug-message) + (goto-char (point-min))) (message-pop-to-buffer "*Gnus Bug*") (message-setup `((To . ,gnus-maintainer) (Subject . ""))) - (push `(gnus-bug-kill-buffer) message-send-actions) + (when gnus-bug-create-help-buffer + (push `(gnus-bug-kill-buffer) message-send-actions)) (goto-char (point-min)) (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$")) (forward-line 1) - (insert (gnus-version) "\n") - (insert (emacs-version) "\n") + (insert (gnus-version) "\n" + (emacs-version) "\n") (when (and (boundp 'nntp-server-type) (stringp nntp-server-type)) (insert nntp-server-type)) @@ -834,12 +850,13 @@ "gnus-art.el" "gnus-start.el" "gnus-async.el" "gnus-msg.el" "gnus-score.el" "gnus-win.el" "gnus-topic.el" "nnmail.el" "message.el")) + (point (point)) file expr olist sym) (gnus-message 4 "Please wait while we snoop your variables...") (sit-for 0) ;; Go through all the files looking for non-default values for variables. (save-excursion - (set-buffer (get-buffer-create " *gnus bug info*")) + (set-buffer (gnus-get-buffer-create " *gnus bug info*")) (buffer-disable-undo (current-buffer)) (while files (erase-buffer) @@ -879,11 +896,12 @@ (insert ";; (makeunbound '" (symbol-name (car olist)) ")\n")) (setq olist (cdr olist))) (insert "\n\n") - ;; Remove any null chars - they seem to cause trouble for some + ;; Remove any control chars - they seem to cause trouble for some ;; mailers. (Byte-compiled output from the stuff above.) - (goto-char (point-min)) - (while (re-search-forward "[\000\200]" nil t) - (replace-match "" t t)))) + (goto-char point) + (while (re-search-forward "[\000-\010\013-\037\200-\237]" nil t) + (replace-match (format "\\%03o" (string-to-char (match-string 0))) + t t)))) ;;; Treatment of rejected articles. ;;; Bounced mail. @@ -978,8 +996,11 @@ "Insert the Gcc to say where the article is to be archived." (let* ((var gnus-message-archive-group) (group (or group gnus-newsgroup-name "")) - result - gcc-self-val + (gcc-self-val + (and gnus-newsgroup-name + (gnus-group-find-parameter + gnus-newsgroup-name 'gcc-self))) + result (groups (cond ((null gnus-message-archive-method) @@ -1015,7 +1036,7 @@ (setq var (cdr var))) result))) name) - (when groups + (when (or groups gcc-self-val) (when (stringp groups) (setq groups (list groups))) (save-excursion @@ -1023,10 +1044,8 @@ (message-narrow-to-headers) (goto-char (point-max)) (insert "Gcc: ") - (if (and gnus-newsgroup-name - (setq gcc-self-val - (gnus-group-find-parameter - gnus-newsgroup-name 'gcc-self))) + (if gcc-self-val + ;; Use the `gcc-self' param value instead. (progn (insert (if (stringp gcc-self-val) @@ -1037,6 +1056,7 @@ (progn (beginning-of-line) (kill-line)))) + ;; Use the list of groups. (while (setq name (pop groups)) (insert (if (string-match ":" name) name @@ -1046,31 +1066,88 @@ (insert " "))) (insert "\n"))))))) -(defun gnus-summary-send-draft () - "Enter a mail/post buffer to edit and send the draft." - (interactive) - (gnus-set-global-variables) - (let (buf) - (if (not (setq buf (gnus-request-restore-buffer - (gnus-summary-article-number) gnus-newsgroup-name))) - (error "Couldn't restore the article") - (switch-to-buffer buf) - (when (eq major-mode 'news-reply-mode) - (local-set-key "\C-c\C-c" 'gnus-inews-news)) - ;; Insert the separator. - (goto-char (point-min)) - (search-forward "\n\n") - (forward-char -1) - (insert mail-header-separator) - ;; Configure windows. - (let ((gnus-draft-buffer (current-buffer))) - (gnus-configure-windows 'draft t) - (goto-char (point)))))) +;;; Posting styles. + +(defvar gnus-message-style-insertions nil) -(gnus-add-shutdown 'gnus-inews-close 'gnus) +(defun gnus-configure-posting-styles () + "Configure posting styles according to `gnus-posting-styles'." + (unless gnus-inhibit-posting-styles + (let ((styles gnus-posting-styles) + (gnus-newsgroup-name (or gnus-newsgroup-name "")) + style match variable attribute value value-value) + (make-local-variable 'gnus-message-style-insertions) + ;; Go through all styles and look for matches. + (while styles + (setq style (pop styles) + match (pop style)) + (when (cond ((stringp match) + ;; Regexp string match on the group name. + (string-match match gnus-newsgroup-name)) + ((or (symbolp match) + (gnus-functionp match)) + (cond ((gnus-functionp match) + ;; Function to be called. + (funcall match)) + ((boundp match) + ;; Variable to be checked. + (symbol-value match)))) + ((listp match) + ;; This is a form to be evaled. + (eval match))) + ;; We have a match, so we set the variables. + (while style + (setq attribute (pop style) + value (cadr attribute) + variable nil) + ;; We find the variable that is to be modified. + (if (and (not (stringp (car attribute))) + (not (eq 'body (car attribute))) + (not (setq variable + (cdr (assq (car attribute) + gnus-posting-style-alist))))) + (message "Couldn't find attribute %s" (car attribute)) + ;; We get the value. + (setq value-value + (cond ((stringp value) + value) + ((or (symbolp value) + (gnus-functionp value)) + (cond ((gnus-functionp value) + (funcall value)) + ((boundp value) + (symbol-value value)))) + ((listp value) + (eval value)))) + (if variable + ;; This is an ordinary variable. + (set (make-local-variable variable) value-value) + ;; This is either a body or a header to be inserted in the + ;; message. + (when value-value + (let ((attr (car attribute))) + (make-local-variable 'message-setup-hook) + (if (eq 'body attr) + (add-hook 'message-setup-hook + `(lambda () + (save-excursion + (message-goto-body) + (insert ,value-value)))) + (add-hook 'message-setup-hook + 'gnus-message-insert-stylings) + (push (cons (if (stringp attr) attr + (symbol-name attr)) + value-value) + gnus-message-style-insertions)))))))))))) -(defun gnus-inews-close () - (setq gnus-inews-sent-ids nil)) +(defun gnus-message-insert-stylings () + (let (val) + (save-excursion + (message-goto-eoh) + (while (setq val (pop gnus-message-style-insertions)) + (when (cdr val) + (insert (car val) ": " (cdr val) "\n")) + (gnus-pull (car val) gnus-message-style-insertions))))) ;;; Allow redefinition of functions.
--- a/lisp/gnus/gnus-mule.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/gnus-mule.el Sat Feb 20 14:05:57 1999 +0000 @@ -125,12 +125,15 @@ ;; current news group is encoded. This function is set in ;; `gnus-parse-headers-hook'. (defun gnus-mule-select-coding-system () - (save-excursion - (set-buffer gnus-summary-buffer) - (let ((coding-system (gnus-mule-get-coding-system gnus-newsgroup-name))) - (setq gnus-mule-coding-system - (if (and coding-system (coding-system-p (car coding-system))) - (car coding-system)))))) + (if (gnus-buffer-live-p gnus-summary-buffer) + (save-excursion + (set-buffer gnus-summary-buffer) + (let ((coding-system + (gnus-mule-get-coding-system gnus-newsgroup-name))) + (setq gnus-mule-coding-system + (if (and coding-system (coding-system-p (car coding-system))) + (car coding-system))))) + 'binary)) ;; Decode the current article. This function is set in ;; `gnus-show-traditional-method'. @@ -193,7 +196,7 @@ nnmail-file-coding-system 'binary) ) -(gnus-mule-add-group "" '(undecided . iso-latin-1)) +(gnus-mule-add-group "" 'iso-latin-1) (gnus-mule-add-group "fj" 'iso-2022-7bit) (gnus-mule-add-group "tnn" 'iso-2022-7bit) (gnus-mule-add-group "japan" 'iso-2022-7bit)
--- a/lisp/gnus/gnus-nocem.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/gnus-nocem.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ ;;; gnus-nocem.el --- NoCeM pseudo-cancellation treatment -;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news ;; This file is part of GNU Emacs. @@ -27,6 +27,8 @@ (eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl)) + (require 'gnus) (require 'nnmail) (require 'gnus-art) @@ -40,7 +42,7 @@ (defcustom gnus-nocem-groups '("news.lists.filters" "news.admin.net-abuse.bulletins" "alt.nocem.misc" "news.admin.net-abuse.announce") - "List of groups that will be searched for NoCeM messages." + "*List of groups that will be searched for NoCeM messages." :group 'gnus-nocem :type '(repeat (string :tag "Group"))) @@ -52,9 +54,11 @@ "snowhare@xmission.com" ; Benjamin "Snowhare" Franz "red@redpoll.mrfs.oh.us (Richard E. Depew)" ; ARMM! ARMM! ) - "List of NoCeM issuers to pay attention to." + "*List of NoCeM issuers to pay attention to. + +This can also be a list of `(ISSUER CONDITIONS)' elements." :group 'gnus-nocem - :type '(repeat string)) + :type '(repeat (choice string sexp))) (defcustom gnus-nocem-directory (nnheader-concat gnus-article-save-directory "NoCeM/") @@ -106,8 +110,7 @@ "Real-name mappings of subscribed groups.") (defun gnus-fill-real-hashtb () - "Fill up a hash table with the real-name mappings from the user's -active file." + "Fill up a hash table with the real-name mappings from the user's active file." (setq gnus-nocem-real-group-hashtb (gnus-make-hashtable (length gnus-newsrc-alist))) (mapcar (lambda (group) @@ -187,7 +190,7 @@ (gnus-message 7 "Checking article %d in %s for NoCeM..." (mail-header-number header) group) (let ((date (mail-header-date header)) - issuer b e) + issuer b e type) (when (or (not date) (nnmail-time-less (nnmail-time-since (nnmail-date-to-time date)) @@ -204,15 +207,36 @@ (setq e (search-forward "\n@@BEGIN NCM BODY\n" nil t))) ;; We get the name of the issuer. (narrow-to-region b e) - (setq issuer (mail-fetch-field "issuer")) + (setq issuer (mail-fetch-field "issuer") + type (mail-fetch-field "issuer")) (widen) - (or (member issuer gnus-nocem-issuers) - (message "invalid NoCeM issuer: %s" issuer)) - (and (member issuer gnus-nocem-issuers) ; We like her.... - (gnus-nocem-verify-issuer issuer) ; She is who she says she is... - (gnus-nocem-enter-article) ; We gobble the message.. - (push (mail-header-message-id header) ; But don't come back for - gnus-nocem-seen-message-ids)))))) ; second helpings. + (if (not (gnus-nocem-message-wanted-p issuer type)) + (message "invalid NoCeM issuer: %s" issuer) + (and (gnus-nocem-verify-issuer issuer) ; She is who she says she is. + (gnus-nocem-enter-article) ; We gobble the message. + (push (mail-header-message-id header) ; But don't come back for + gnus-nocem-seen-message-ids))))))) ; second helpings. + +(defun gnus-nocem-message-wanted-p (issuer type) + (let ((issuers gnus-nocem-issuers) + wanted conditions condition) + (cond + ;; Do the quick check first. + ((member issuer issuers) + t) + ((setq conditions (cdr (assoc issuer issuers))) + ;; Check whether we want this type. + (while (setq condition (pop conditions)) + (cond + ((stringp condition) + (setq wanted (string-match condition type))) + ((and (consp condition) + (eq (car condition) 'not) + (stringp (cadr condition))) + (setq wanted (not (string-match (cadr condition) type)))) + (t + (error "Invalid NoCeM condition: %S" condition)))) + wanted)))) (defun gnus-nocem-verify-issuer (person) "Verify using PGP that the canceler is who she says she is." @@ -322,7 +346,8 @@ (defun gnus-nocem-unwanted-article-p (id) "Say whether article ID in the current group is wanted." - (gnus-gethash id gnus-nocem-hashtb)) + (and gnus-nocem-hashtb + (gnus-gethash id gnus-nocem-hashtb))) (provide 'gnus-nocem)
--- a/lisp/gnus/gnus-range.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/gnus-range.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ ;;; gnus-range.el --- range and sequence functions for Gnus -;; Copyright (C) 1996,97 Free Software Foundation, Inc. +;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news ;; This file is part of GNU Emacs. @@ -27,6 +27,8 @@ (eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl)) + ;;; List and range functions (defun gnus-last-element (list) @@ -55,7 +57,7 @@ list1)) (defun gnus-sorted-complement (list1 list2) - "Return a list of elements of LIST1 that do not appear in LIST2. + "Return a list of elements that are in LIST1 or LIST2 but not both. Both lists have to be sorted over <." (let (out) (if (or (null list1) (null list2))
--- a/lisp/gnus/gnus-salt.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/gnus-salt.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,8 @@ ;;; gnus-salt.el --- alternate summary mode interfaces for Gnus -;; Copyright (C) 1996,97 Free Software Foundation, Inc. +;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> +;; Keywords: news ;; This file is part of GNU Emacs. @@ -26,6 +27,8 @@ (eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl)) + (require 'gnus) (require 'gnus-sum) @@ -70,25 +73,13 @@ (unless gnus-pick-mode-map (setq gnus-pick-mode-map (make-sparse-keymap)) - (gnus-define-keys - gnus-pick-mode-map - "t" gnus-uu-mark-thread - "T" gnus-uu-unmark-thread - " " gnus-pick-next-page - "u" gnus-summary-unmark-as-processable - "U" gnus-summary-unmark-all-processable - "v" gnus-uu-mark-over - "r" gnus-uu-mark-region - "R" gnus-uu-unmark-region - "e" gnus-uu-mark-by-regexp - "E" gnus-uu-mark-by-regexp - "b" gnus-uu-mark-buffer - "B" gnus-uu-unmark-buffer - "." gnus-pick-article - gnus-down-mouse-2 gnus-pick-mouse-pick-region - ;;gnus-mouse-2 gnus-pick-mouse-pick - "X" gnus-pick-start-reading - "\r" gnus-pick-start-reading)) + (gnus-define-keys gnus-pick-mode-map + " " gnus-pick-next-page + "u" gnus-pick-unmark-article-or-thread + "." gnus-pick-article-or-thread + gnus-down-mouse-2 gnus-pick-mouse-pick-region + "\r" gnus-pick-start-reading + )) (defun gnus-pick-make-menu-bar () (unless (boundp 'gnus-pick-menu) @@ -99,14 +90,14 @@ ["Article" gnus-summary-mark-as-processable t] ["Thread" gnus-uu-mark-thread t] ["Region" gnus-uu-mark-region t] - ["Regexp" gnus-uu-mark-regexp t] + ["Regexp" gnus-uu-mark-by-regexp t] ["Buffer" gnus-uu-mark-buffer t]) ("Unpick" ["Article" gnus-summary-unmark-as-processable t] ["Thread" gnus-uu-unmark-thread t] ["Region" gnus-uu-unmark-region t] - ["Regexp" gnus-uu-unmark-regexp t] - ["Buffer" gnus-uu-unmark-buffer t]) + ["Regexp" gnus-uu-unmark-by-regexp t] + ["Buffer" gnus-summary-unmark-all-processable t]) ["Start reading" gnus-pick-start-reading t] ["Switch pick mode off" gnus-pick-mode gnus-pick-mode])))) @@ -133,7 +124,7 @@ (when (gnus-visual-p 'pick-menu 'menu) (gnus-pick-make-menu-bar)) (gnus-add-minor-mode 'gnus-pick-mode " Pick" gnus-pick-mode-map) - (run-hooks 'gnus-pick-mode-hook)))) + (gnus-run-hooks 'gnus-pick-mode-hook)))) (defun gnus-pick-setup-message () "Make Message do the right thing on exit." @@ -172,21 +163,48 @@ (gnus-summary-next-group))) (error "No articles have been picked")))) +(defun gnus-pick-goto-article (arg) + "Go to the article number indicated by ARG. If ARG is an invalid +article number, then stay on current line." + (let (pos) + (save-excursion + (goto-char (point-min)) + (when (zerop (forward-line (1- (prefix-numeric-value arg)))) + (setq pos (point)))) + (if (not pos) + (gnus-error 2 "No such line: %s" arg) + (goto-char pos)))) + (defun gnus-pick-article (&optional arg) - "Pick the article on the current line. + "Pick the article on the current line. If ARG, pick the article on that line instead." (interactive "P") (when arg - (let (pos) - (save-excursion - (goto-char (point-min)) - (when (zerop (forward-line (1- (prefix-numeric-value arg)))) - (setq pos (point)))) - (if (not pos) - (gnus-error 2 "No such line: %s" arg) - (goto-char pos)))) + (gnus-pick-goto-article arg)) (gnus-summary-mark-as-processable 1)) +(defun gnus-pick-article-or-thread (&optional arg) + "If gnus-thread-hide-subtree is t, then pick the thread on the current line. +Otherwise pick the article on the current line. +If ARG, pick the article/thread on that line instead." + (interactive "P") + (when arg + (gnus-pick-goto-article arg)) + (if gnus-thread-hide-subtree + (gnus-uu-mark-thread) + (gnus-summary-mark-as-processable 1))) + +(defun gnus-pick-unmark-article-or-thread (&optional arg) + "If gnus-thread-hide-subtree is t, then unmark the thread on current line. +Otherwise unmark the article on current line. +If ARG, unmark thread/article on that line instead." + (interactive "P") + (when arg + (gnus-pick-goto-article arg)) + (if gnus-thread-hide-subtree + (gnus-uu-unmark-thread) + (gnus-summary-unmark-as-processable 1))) + (defun gnus-pick-mouse-pick (e) (interactive "e") (mouse-set-point e) @@ -203,8 +221,7 @@ (start-point (posn-point start-posn)) (start-line (1+ (count-lines 1 start-point))) (start-window (posn-window start-posn)) - (start-frame (window-frame start-window)) - (bounds (window-edges start-window)) + (bounds (gnus-window-edges start-window)) (top (nth 1 bounds)) (bottom (if (window-minibuffer-p start-window) (nth 3 bounds) @@ -223,50 +240,48 @@ ;; end-of-range is used only in the single-click case. ;; It is the place where the drag has reached so far ;; (but not outside the window where the drag started). - (let (event end end-point last-end-point (end-of-range (point))) + (let (event end end-point (end-of-range (point))) (track-mouse - (while (progn - (setq event (read-event)) - (or (mouse-movement-p event) - (eq (car-safe event) 'switch-frame))) - (if (eq (car-safe event) 'switch-frame) - nil - (setq end (event-end event) - end-point (posn-point end)) - (when end-point - (setq last-end-point end-point)) + (while (progn + (setq event (cdr (gnus-read-event-char))) + (or (mouse-movement-p event) + (eq (car-safe event) 'switch-frame))) + (if (eq (car-safe event) 'switch-frame) + nil + (setq end (event-end event) + end-point (posn-point end)) - (cond - ;; Are we moving within the original window? - ((and (eq (posn-window end) start-window) - (integer-or-marker-p end-point)) - ;; Go to START-POINT first, so that when we move to END-POINT, - ;; if it's in the middle of intangible text, - ;; point jumps in the direction away from START-POINT. - (goto-char start-point) - (goto-char end-point) - (gnus-pick-article) - ;; In case the user moved his mouse really fast, pick - ;; articles on the line between this one and the last one. - (let* ((this-line (1+ (count-lines 1 end-point))) - (min-line (min this-line start-line)) - (max-line (max this-line start-line))) - (while (< min-line max-line) - (goto-line min-line) - (gnus-pick-article) - (setq min-line (1+ min-line))) - (setq start-line this-line)) - (when (zerop (% click-count 3)) - (setq end-of-range (point)))) - (t - (let ((mouse-row (cdr (cdr (mouse-position))))) - (cond - ((null mouse-row)) - ((< mouse-row top) - (mouse-scroll-subr start-window (- mouse-row top))) - ((>= mouse-row bottom) - (mouse-scroll-subr start-window - (1+ (- mouse-row bottom))))))))))) + (cond + ;; Are we moving within the original window? + ((and (eq (posn-window end) start-window) + (integer-or-marker-p end-point)) + ;; Go to START-POINT first, so that when we move to END-POINT, + ;; if it's in the middle of intangible text, + ;; point jumps in the direction away from START-POINT. + (goto-char start-point) + (goto-char end-point) + (gnus-pick-article) + ;; In case the user moved his mouse really fast, pick + ;; articles on the line between this one and the last one. + (let* ((this-line (1+ (count-lines 1 end-point))) + (min-line (min this-line start-line)) + (max-line (max this-line start-line))) + (while (< min-line max-line) + (goto-line min-line) + (gnus-pick-article) + (setq min-line (1+ min-line))) + (setq start-line this-line)) + (when (zerop (% click-count 3)) + (setq end-of-range (point)))) + (t + (let ((mouse-row (cdr (cdr (mouse-position))))) + (cond + ((null mouse-row)) + ((< mouse-row top) + (mouse-scroll-subr start-window (- mouse-row top))) + ((>= mouse-row bottom) + (mouse-scroll-subr start-window + (1+ (- mouse-row bottom))))))))))) (when (consp event) (let ((fun (key-binding (vector (car event))))) ;; Run the binding of the terminating up-event, if possible. @@ -336,7 +351,7 @@ (when (gnus-visual-p 'binary-menu 'menu) (gnus-binary-make-menu-bar)) (gnus-add-minor-mode 'gnus-binary-mode " Binary" gnus-binary-mode-map) - (run-hooks 'gnus-binary-mode-hook)))) + (gnus-run-hooks 'gnus-binary-mode-hook)))) (defun gnus-binary-display-article (article &optional all-header) "Run ARTICLE through the binary decode functions." @@ -363,7 +378,8 @@ "If non-nil, minimize the tree buffer window. If a number, never let the tree buffer grow taller than that number of lines." - :type 'boolean + :type '(choice boolean + integer) :group 'gnus-summary-tree) (defcustom gnus-selected-tree-face 'modeline @@ -445,12 +461,8 @@ (defun gnus-tree-mode () "Major mode for displaying thread trees." (interactive) - (setq gnus-tree-mode-line-format-spec - (gnus-parse-format gnus-tree-mode-line-format - gnus-summary-mode-line-format-alist)) - (setq gnus-tree-line-format-spec - (gnus-parse-format gnus-tree-line-format - gnus-tree-line-format-alist t)) + (gnus-set-format 'tree-mode) + (gnus-set-format 'tree t) (when (gnus-visual-p 'tree-menu 'menu) (gnus-tree-make-menu-bar)) (kill-all-local-variables) @@ -465,13 +477,14 @@ (gnus-set-work-buffer) (gnus-tree-node-insert (make-mail-header "") nil) (setq gnus-tree-node-length (1- (point)))) - (run-hooks 'gnus-tree-mode-hook)) + (gnus-run-hooks 'gnus-tree-mode-hook)) (defun gnus-tree-read-summary-keys (&optional arg) "Read a summary buffer key sequence and execute it." (interactive "P") (let ((buf (current-buffer)) win) + (set-buffer gnus-article-buffer) (gnus-article-read-summary-keys arg nil t) (when (setq win (get-buffer-window buf)) (select-window win) @@ -543,9 +556,8 @@ (defun gnus-get-tree-buffer () "Return the tree buffer properly initialized." (save-excursion - (set-buffer (get-buffer-create gnus-tree-buffer)) + (set-buffer (gnus-get-buffer-create gnus-tree-buffer)) (unless (eq major-mode 'gnus-tree-mode) - (gnus-add-current-to-buffer-list) (gnus-tree-mode)) (current-buffer))) @@ -640,7 +652,7 @@ (not (eval (caar list)))) (setq list (cdr list))))) (unless (eq (setq face (cdar list)) (get-text-property beg 'face)) - (gnus-put-text-property + (gnus-put-text-property-excluding-characters-with-faces beg end 'face (if (boundp face) (symbol-value face) face))))) @@ -749,7 +761,8 @@ (setq beg (point)) (forward-char -1) ;; Draw "-" lines leftwards. - (while (= (char-after (1- (point))) ? ) + (while (and (> (point) 1) + (= (char-after (1- (point))) ? )) (delete-char -1) (insert (car gnus-tree-parent-child-edges)) (forward-char -1)) @@ -800,8 +813,7 @@ (gnus-get-tree-buffer)) (defun gnus-tree-close (group) - ;(gnus-kill-buffer gnus-tree-buffer) - ) + (gnus-kill-buffer gnus-tree-buffer)) (defun gnus-highlight-selected-tree (article) "Highlight the selected article in the tree." @@ -960,18 +972,17 @@ (buffer-disable-undo (current-buffer)) (setq buffer-read-only t) (make-local-variable 'gnus-carpal-attached-buffer) - (run-hooks 'gnus-carpal-mode-hook)) + (gnus-run-hooks 'gnus-carpal-mode-hook)) (defun gnus-carpal-setup-buffer (type) (let ((buffer (symbol-value (intern (format "gnus-carpal-%s-buffer" type))))) (if (get-buffer buffer) () (save-excursion - (set-buffer (get-buffer-create buffer)) + (set-buffer (gnus-get-buffer-create buffer)) (gnus-carpal-mode) (setq gnus-carpal-attached-buffer (intern (format "gnus-%s-buffer" type))) - (gnus-add-current-to-buffer-list) (let ((buttons (symbol-value (intern (format "gnus-carpal-%s-buffer-buttons" type))))
--- a/lisp/gnus/gnus-score.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/gnus-score.el Sat Feb 20 14:05:57 1999 +0000 @@ -2,7 +2,7 @@ ;; Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc. ;; Author: Per Abrahamsen <amanda@iesd.auc.dk> -;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news ;; This file is part of GNU Emacs. @@ -28,10 +28,13 @@ (eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl)) + (require 'gnus) (require 'gnus-sum) (require 'gnus-range) (require 'message) +(require 'score-mode) (defcustom gnus-global-score-files nil "List of global score files and directories. @@ -107,7 +110,11 @@ This variable can also be a list of functions to be called. Each function should either return a list of score files, or a list of -score alists." +score alists. + +If functions other than these pre-defined functions are used, +the `a' symbolic prefix to the score commands will always use +\"all.SCORE\"." :group 'gnus-score-files :type '(radio (function-item gnus-score-find-single) (function-item gnus-score-find-hierarchical) @@ -117,7 +124,8 @@ (defcustom gnus-score-interactive-default-score 1000 "*Scoring commands will raise/lower the score with this number as the default." :group 'gnus-score-default - :type 'integer) + :type '(choice (const nil) + integer)) (defcustom gnus-score-expiry-days 7 "*Number of days before unused score file entries are expired. @@ -195,8 +203,8 @@ :type '(choice string (repeat (choice string (cons regexp (repeat file)) - function)) - function)) + (function :value fun))) + (function :value fun))) (defcustom gnus-home-adapt-file nil "Variable to control where new adaptive score entries are to go. @@ -206,8 +214,8 @@ :type '(choice string (repeat (choice string (cons regexp (repeat file)) - function)) - function)) + (function :value fun))) + (function :value fun))) (defcustom gnus-default-adaptive-score-alist '((gnus-kill-file-mark) @@ -216,7 +224,7 @@ (gnus-catchup-mark (subject -10)) (gnus-killed-mark (from -1) (subject -20)) (gnus-del-mark (from -2) (subject -15))) -"Alist of marks and scores." +"*Alist of marks and scores." :group 'gnus-score-adapt :type '(repeat (cons (symbol :tag "Mark") (repeat (list (choice :tag "Header" @@ -245,7 +253,7 @@ "being" "current" "back" "still" "go" "point" "value" "each" "did" "both" "true" "off" "say" "another" "state" "might" "under" "start" "try" "re") - "Default list of words to be ignored when doing adaptive word scoring." + "*Default list of words to be ignored when doing adaptive word scoring." :group 'gnus-score-adapt :type '(repeat string)) @@ -254,11 +262,21 @@ (,gnus-catchup-mark . -10) (,gnus-killed-mark . -20) (,gnus-del-mark . -15)) -"Alist of marks and scores." +"*Alist of marks and scores." :group 'gnus-score-adapt :type '(repeat (cons (character :tag "Mark") (integer :tag "Score")))) +(defcustom gnus-adaptive-word-minimum nil + "If a number, this is the minimum score value that can be assigned to a word." + :group 'gnus-score-adapt + :type '(choice (const nil) integer)) + +(defcustom gnus-adaptive-word-no-group-words nil + "If t, don't adaptively score words included in the group name." + :group 'gnus-score-adapt + :type 'boolean) + (defcustom gnus-score-mimic-keymap nil "*Have the score entry functions pretend that they are a keymap." :group 'gnus-score-default @@ -321,7 +339,7 @@ f: fuzzy string r: regexp string b: before date - a: at date + a: after date n: this date <: less than number >: greater than number @@ -334,7 +352,7 @@ (const :tag "fuzzy string" f) (const :tag "regexp string" r) (const :tag "before date" b) - (const :tag "at date" a) + (const :tag "after date" a) (const :tag "this date" n) (const :tag "less than number" <) (const :tag "greater than number" >) @@ -367,6 +385,11 @@ :group 'gnus-score-files :type 'function) +(defcustom gnus-score-thread-simplify nil + "If non-nil, subjects will simplified as in threading." + :group 'gnus-score-various + :type 'boolean) + ;; Internal variables. @@ -434,7 +457,6 @@ (gnus-define-keys (gnus-summary-score-map "V" gnus-summary-mode-map) "s" gnus-summary-set-score - "a" gnus-summary-score-entry "S" gnus-summary-current-score "c" gnus-score-change-score-file "C" gnus-score-customize @@ -452,13 +474,13 @@ ;; Much modification of the kill (ahem, score) code and lots of the ;; functions are written by Per Abrahamsen <amanda@iesd.auc.dk>. -(defun gnus-summary-lower-score (&optional score) +(defun gnus-summary-lower-score (&optional score symp) "Make a score entry based on the current article. The user will be prompted for header to score on, match type, permanence, and the string to be used. The numerical prefix will be used as score." - (interactive "P") - (gnus-summary-increase-score (- (gnus-score-default score)))) + (interactive (gnus-interactive "P\ny")) + (gnus-summary-increase-score (- (gnus-score-default score)) symp)) (defun gnus-score-kill-help-buffer () (when (get-buffer "*Score Help*") @@ -466,13 +488,12 @@ (when gnus-score-help-winconf (set-window-configuration gnus-score-help-winconf)))) -(defun gnus-summary-increase-score (&optional score) +(defun gnus-summary-increase-score (&optional score symp) "Make a score entry based on the current article. The user will be prompted for header to score on, match type, permanence, and the string to be used. The numerical prefix will be used as score." - (interactive "P") - (gnus-set-global-variables) + (interactive (gnus-interactive "P\ny")) (let* ((nscore (gnus-score-default score)) (prefix (if (< nscore 0) ?L ?I)) (increase (> nscore 0)) @@ -482,12 +503,12 @@ (?b "body" "" nil body-string) (?h "head" "" nil body-string) (?i "message-id" nil t string) - (?t "references" "message-id" nil string) + (?r "references" "message-id" nil string) (?x "xref" nil nil string) (?l "lines" nil nil number) (?d "date" nil nil date) (?f "followup" nil nil string) - (?T "thread" nil nil string))) + (?t "thread" "message-id" nil string))) (char-to-type '((?s s "substring" string) (?e e "exact string" string) @@ -496,11 +517,12 @@ (?z s "substring" body-string) (?p r "regexp string" body-string) (?b before "before date" date) - (?a at "at date" date) - (?n now "this date" date) + (?a after "after date" date) + (?n at "this date" date) (?< < "less than number" number) (?> > "greater than number" number) (?= = "equal to number" number))) + (current-score-file gnus-current-score-file) (char-to-perm (list (list ?t (current-time-string) "temporary") '(?p perm "permanent") '(?i now "immediate"))) @@ -572,7 +594,7 @@ ;; It was a majuscule, so we end reading and use the default. (if mimic (message "%c %c %c" prefix hchar tchar) (message "")) - (setq pchar (or pchar ?p))) + (setq pchar (or pchar ?t))) ;; We continue reading. (while (not pchar) @@ -618,6 +640,21 @@ (when (memq type '(r R regexp Regexp)) (setq match (regexp-quote match))) + ;; Change score file to the "all.SCORE" file. + (when (eq symp 'a) + (save-excursion + (set-buffer gnus-summary-buffer) + (gnus-score-load-file + ;; This is a kludge; yes... + (cond + ((eq gnus-score-find-score-files-function + 'gnus-score-find-hierarchical) + (gnus-score-file-name "")) + ((eq gnus-score-find-score-files-function 'gnus-score-find-single) + current-score-file) + (t + (gnus-score-file-name "all")))))) + (gnus-summary-score-entry (nth 1 entry) ; Header match ; Match @@ -627,12 +664,17 @@ nil temporary) (not (nth 3 entry))) ; Prompt - )) + + (when (eq symp 'a) + ;; We change the score file back to the previous one. + (save-excursion + (set-buffer gnus-summary-buffer) + (gnus-score-load-file current-score-file))))) (defun gnus-score-insert-help (string alist idx) (setq gnus-score-help-winconf (current-window-configuration)) (save-excursion - (set-buffer (get-buffer-create "*Score Help*")) + (set-buffer (gnus-get-buffer-create "*Score Help*")) (buffer-disable-undo (current-buffer)) (delete-windows-on (current-buffer)) (erase-buffer) @@ -712,20 +754,6 @@ DATE is the expire date, or nil for no expire, or 'now for immediate expire. If optional argument `PROMPT' is non-nil, allow user to edit match. If optional argument `SILENT' is nil, show effect of score entry." - (interactive - (list (completing-read "Header: " - gnus-header-index - (lambda (x) (fboundp (nth 2 x))) - t) - (read-string "Match: ") - (if (y-or-n-p "Use regexp match? ") 'r 's) - (and current-prefix-arg - (prefix-numeric-value current-prefix-arg)) - (cond ((not (y-or-n-p "Add to score file? ")) - 'now) - ((y-or-n-p "Expire kill? ") - (current-time-string)) - (t nil)))) ;; Regexp is the default type. (when (eq type t) (setq type 'r)) @@ -788,7 +816,7 @@ (or (nth 1 new) gnus-score-interactive-default-score))) ;; Nope, we have to add a new elem. - (gnus-score-set header (if old (cons new old) (list new)))) + (gnus-score-set header (if old (cons new old) (list new)) nil t)) (gnus-score-set 'touched '(t)))) ;; Score the current buffer. @@ -938,7 +966,7 @@ "references" id 's score (current-time-string)))))))) -(defun gnus-score-set (symbol value &optional alist) +(defun gnus-score-set (symbol value &optional alist warn) ;; Set SYMBOL to VALUE in ALIST. (let* ((alist (or alist @@ -947,7 +975,8 @@ (entry (assoc symbol alist))) (cond ((gnus-score-get 'read-only alist) ;; This is a read-only score file, so we do nothing. - ) + (when warn + (gnus-message 4 "Note: read-only score file; entry discarded"))) (entry (setcdr entry value)) ((null alist) @@ -959,14 +988,12 @@ (defun gnus-summary-raise-score (n) "Raise the score of the current article by N." (interactive "p") - (gnus-set-global-variables) (gnus-summary-set-score (+ (gnus-summary-article-score) (or n gnus-score-interactive-default-score )))) (defun gnus-summary-set-score (n) "Set the score of the current article to N." (interactive "p") - (gnus-set-global-variables) (save-excursion (gnus-summary-show-thread) (let ((buffer-read-only nil)) @@ -985,7 +1012,6 @@ (defun gnus-summary-current-score () "Return the score of the current article." (interactive) - (gnus-set-global-variables) (gnus-message 1 "%s" (gnus-summary-article-score))) (defun gnus-score-change-score-file (file) @@ -999,21 +1025,21 @@ (defun gnus-score-edit-current-scores (file) "Edit the current score alist." (interactive (list gnus-current-score-file)) - (gnus-set-global-variables) - (let ((winconf (current-window-configuration))) - (when (buffer-name gnus-summary-buffer) - (gnus-score-save)) - (gnus-make-directory (file-name-directory file)) - (setq gnus-score-edit-buffer (find-file-noselect file)) - (gnus-configure-windows 'edit-score) - (select-window (get-buffer-window gnus-score-edit-buffer)) - (gnus-score-mode) - (setq gnus-score-edit-exit-function 'gnus-score-edit-done) - (make-local-variable 'gnus-prev-winconf) - (setq gnus-prev-winconf winconf)) - (gnus-message - 4 (substitute-command-keys - "\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits"))) + (if (not gnus-current-score-file) + (error "No current score file") + (let ((winconf (current-window-configuration))) + (when (buffer-name gnus-summary-buffer) + (gnus-score-save)) + (gnus-make-directory (file-name-directory file)) + (setq gnus-score-edit-buffer (find-file-noselect file)) + (gnus-configure-windows 'edit-score) + (gnus-score-mode) + (setq gnus-score-edit-exit-function 'gnus-score-edit-done) + (make-local-variable 'gnus-prev-winconf) + (setq gnus-prev-winconf winconf)) + (gnus-message + 4 (substitute-command-keys + "\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits")))) (defun gnus-score-edit-file (file) "Edit a score file." @@ -1037,8 +1063,9 @@ ;; Load score file FILE. Returns a list a retrieved score-alists. (let* ((file (expand-file-name (or (and (string-match - (concat "^" (expand-file-name - gnus-kill-files-directory)) + (concat "^" (regexp-quote + (expand-file-name + gnus-kill-files-directory))) (expand-file-name file)) file) (concat (file-name-as-directory gnus-kill-files-directory) @@ -1065,9 +1092,13 @@ found) (while a ;; Downcase all header names. - (when (stringp (caar a)) + (cond + ((stringp (caar a)) (setcar (car a) (downcase (caar a))) (setq found t)) + ;; Advanced scoring. + ((consp (caar a)) + (setq found t))) (pop a)) ;; If there are actual scores in the alist, we add it to the ;; return value of this function. @@ -1088,30 +1119,35 @@ (decay (car (gnus-score-get 'decay alist))) (eval (car (gnus-score-get 'eval alist)))) ;; Perform possible decays. - (when gnus-decay-scores - (when (or (not decay) - (gnus-decay-scores alist decay)) - (gnus-score-set 'touched '(t) alist) - (gnus-score-set 'decay (list (gnus-time-to-day (current-time)))))) + (when (and gnus-decay-scores + (or cached (file-exists-p file)) + (or (not decay) + (gnus-decay-scores alist decay))) + (gnus-score-set 'touched '(t) alist) + (gnus-score-set 'decay (list (gnus-time-to-day (current-time))) alist)) ;; We do not respect eval and files atoms from global score ;; files. - (and files (not global) - (setq lists (apply 'append lists - (mapcar (lambda (file) - (gnus-score-load-file file)) - (if adapt-file (cons adapt-file files) - files))))) - (and eval (not global) (eval eval)) + (when (and files (not global)) + (setq lists (apply 'append lists + (mapcar (lambda (file) + (gnus-score-load-file file)) + (if adapt-file (cons adapt-file files) + files))))) + (when (and eval (not global)) + (eval eval)) ;; We then expand any exclude-file directives. (setq gnus-scores-exclude-files (nconc - (mapcar - (lambda (sfile) - (expand-file-name sfile (file-name-directory file))) - exclude-files) + (apply + 'nconc + (mapcar + (lambda (sfile) + (list + (expand-file-name sfile (file-name-directory file)) + (expand-file-name sfile gnus-kill-files-directory))) + exclude-files)) gnus-scores-exclude-files)) - (if (not local) - () + (when local (save-excursion (set-buffer gnus-summary-buffer) (while local @@ -1180,10 +1216,16 @@ (read (current-buffer)) (error (gnus-error 3.2 "Problem with score file %s" file)))))) - (if (eq (car alist) 'setq) - ;; This is an old-style score file. - (setq gnus-score-alist (gnus-score-transform-old-to-new alist)) - (setq gnus-score-alist alist)) + (cond + ((and alist + (atom alist)) + ;; Bogus score file. + (error "Invalid syntax with score file %s" file)) + ((eq (car alist) 'setq) + ;; This is an old-style score file. + (setq gnus-score-alist (gnus-score-transform-old-to-new alist))) + (t + (setq gnus-score-alist alist))) ;; Check the syntax of the score file. (setq gnus-score-alist (gnus-score-check-syntax gnus-score-alist file))))) @@ -1278,7 +1320,7 @@ (and (file-exists-p file) (not (file-writable-p file)))) () - (setq score (setcdr entry (delq (assq 'touched score) score))) + (setq score (setcdr entry (gnus-delete-alist 'touched score))) (erase-buffer) (let (emacs-lisp-mode-hook) (if (string-match @@ -1290,7 +1332,8 @@ (gnus-prin1 score) ;; This is a normal score file, so we print it very ;; prettily. - (pp score (current-buffer)))) + (let ((lisp-mode-syntax-table score-mode-syntax-table)) + (pp score (current-buffer))))) (gnus-make-directory (file-name-directory file)) ;; If the score file is empty, we delete it. (if (zerop (buffer-size)) @@ -1363,9 +1406,10 @@ gnus-scores-articles)))) (save-excursion - (set-buffer (get-buffer-create "*Headers*")) + (set-buffer (gnus-get-buffer-create "*Headers*")) (buffer-disable-undo (current-buffer)) - (message-clone-locals gnus-summary-buffer) + (when (gnus-buffer-live-p gnus-summary-buffer) + (message-clone-locals gnus-summary-buffer)) ;; Set the global variant of this variable. (setq gnus-current-score-file current-score-file) @@ -1616,7 +1660,7 @@ (setq request-func 'gnus-request-article)) (while articles (setq article (mail-header-number (caar articles))) - (gnus-message 7 "Scoring on article %s of %s..." article last) + (gnus-message 7 "Scoring article %s of %s..." article last) (when (funcall request-func article gnus-newsgroup-name) (widen) (goto-char (point-min)) @@ -1812,6 +1856,8 @@ ;; Insert the unique article headers in the buffer. (let ((gnus-score-index (nth 1 (assoc header gnus-header-index))) ;; gnus-score-index is used as a free variable. + (simplify (and gnus-score-thread-simplify + (string= "subject" header))) alike last this art entries alist articles fuzzies arts words kill) @@ -1827,6 +1873,8 @@ (erase-buffer) (while (setq art (pop articles)) (setq this (aref (car art) gnus-score-index)) + (if simplify + (setq this (gnus-map-function gnus-simplify-subject-functions this))) (if (equal last this) ;; O(N*H) cons-cells used here, where H is the number of ;; headers. @@ -1852,7 +1900,6 @@ entries (assoc header alist)) (while (cdr entries) ;First entry is the header index. (let* ((kill (cadr entries)) - (match (nth 0 kill)) (type (or (nth 3 kill) 's)) (score (or (nth 1 kill) gnus-score-interactive-default-score)) (date (nth 2 kill)) @@ -1860,6 +1907,12 @@ (mt (aref (symbol-name type) 0)) (case-fold-search (not (memq mt '(?R ?S ?E ?F)))) (dmt (downcase mt)) + ; Assume user already simplified regexp and fuzzies + (match (if (and simplify (not (memq dmt '(?f ?r)))) + (gnus-map-function + gnus-simplify-subject-functions + (nth 0 kill)) + (nth 0 kill))) (search-func (cond ((= dmt ?r) 're-search-forward) ((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward) @@ -1868,10 +1921,12 @@ (cond ;; Fuzzy matches. We save these for later. ((= dmt ?f) - (push (cons entries alist) fuzzies)) + (push (cons entries alist) fuzzies) + (setq entries (cdr entries))) ;; Word matches. Save these for even later. ((= dmt ?w) - (push (cons entries alist) words)) + (push (cons entries alist) words) + (setq entries (cdr entries))) ;; Exact matches. ((= dmt ?e) ;; Do exact matching. @@ -1896,7 +1951,26 @@ gnus-score-trace)) (while (setq art (pop arts)) (setcdr art (+ score (cdr art))))))) - (forward-line 1))) + (forward-line 1)) + ;; Update expiry date + (if trace + (setq entries (cdr entries)) + (cond + ;; Permanent entry. + ((null date) + (setq entries (cdr entries))) + ;; We have a match, so we update the date. + ((and found gnus-update-score-entry-dates) + (gnus-score-set 'touched '(t) alist) + (setcar (nthcdr 2 kill) now) + (setq entries (cdr entries))) + ;; This entry has expired, so we remove it. + ((and expire (< date expire)) + (gnus-score-set 'touched '(t) alist) + (setcdr entries (cddr entries))) + ;; No match; go to next entry. + (t + (setq entries (cdr entries)))))) ;; Regexp and substring matching. (t (goto-char (point-min)) @@ -1915,26 +1989,26 @@ gnus-score-trace)) (while (setq art (pop arts)) (setcdr art (+ score (cdr art))))) - (forward-line 1)))) - ;; Update expiry date - (if trace - (setq entries (cdr entries)) - (cond - ;; Permanent entry. - ((null date) - (setq entries (cdr entries))) - ;; We have a match, so we update the date. - ((and found gnus-update-score-entry-dates) - (gnus-score-set 'touched '(t) alist) - (setcar (nthcdr 2 kill) now) - (setq entries (cdr entries))) - ;; This entry has expired, so we remove it. - ((and expire (< date expire)) - (gnus-score-set 'touched '(t) alist) - (setcdr entries (cddr entries))) - ;; No match; go to next entry. - (t - (setq entries (cdr entries)))))))) + (forward-line 1)) + ;; Update expiry date + (if trace + (setq entries (cdr entries)) + (cond + ;; Permanent entry. + ((null date) + (setq entries (cdr entries))) + ;; We have a match, so we update the date. + ((and found gnus-update-score-entry-dates) + (gnus-score-set 'touched '(t) alist) + (setcar (nthcdr 2 kill) now) + (setq entries (cdr entries))) + ;; This entry has expired, so we remove it. + ((and expire (< date expire)) + (gnus-score-set 'touched '(t) alist) + (setcdr entries (cddr entries))) + ;; No match; go to next entry. + (t + (setq entries (cdr entries)))))))))) ;; Find fuzzy matches. (when fuzzies @@ -1966,18 +2040,19 @@ (setcdr art (+ score (cdr art)))))) (forward-line 1)) ;; Update expiry date - (cond - ;; Permanent. - ((null date) - ) - ;; Match, update date. - ((and found gnus-update-score-entry-dates) - (gnus-score-set 'touched '(t) (cdar fuzzies)) - (setcar (nthcdr 2 kill) now)) - ;; Old entry, remove. - ((and expire (< date expire)) - (gnus-score-set 'touched '(t) (cdar fuzzies)) - (setcdr (caar fuzzies) (cddaar fuzzies)))) + (if (not trace) + (cond + ;; Permanent. + ((null date) + ) + ;; Match, update date. + ((and found gnus-update-score-entry-dates) + (gnus-score-set 'touched '(t) (cdar fuzzies)) + (setcar (nthcdr 2 kill) now)) + ;; Old entry, remove. + ((and expire (< date expire)) + (gnus-score-set 'touched '(t) (cdar fuzzies)) + (setcdr (caar fuzzies) (cddaar fuzzies))))) (setq fuzzies (cdr fuzzies))))) (when words @@ -2003,18 +2078,19 @@ (while (setq art (pop arts)) (setcdr art (+ score (cdr art)))))) ;; Update expiry date - (cond - ;; Permanent. - ((null date) - ) - ;; Match, update date. - ((and found gnus-update-score-entry-dates) - (gnus-score-set 'touched '(t) (cdar words)) - (setcar (nthcdr 2 kill) now)) - ;; Old entry, remove. - ((and expire (< date expire)) - (gnus-score-set 'touched '(t) (cdar words)) - (setcdr (caar words) (cddaar words)))) + (if (not trace) + (cond + ;; Permanent. + ((null date) + ) + ;; Match, update date. + ((and found gnus-update-score-entry-dates) + (gnus-score-set 'touched '(t) (cdar words)) + (setcar (nthcdr 2 kill) now)) + ;; Old entry, remove. + ((and expire (< date expire)) + (gnus-score-set 'touched '(t) (cdar words)) + (setcdr (caar words) (cddaar words))))) (setq words (cdr words)))))) nil)) @@ -2040,6 +2116,10 @@ (set-syntax-table syntab)) ;; Make all the ignorable words ignored. (let ((ignored (append gnus-ignored-adaptive-words + (if gnus-adaptive-word-no-group-words + (message-tokenize-header + (gnus-group-real-name gnus-newsgroup-name) + ".")) gnus-default-ignored-adaptive-words))) (while ignored (gnus-sethash (pop ignored) nil hashtb))))) @@ -2064,6 +2144,7 @@ (set-buffer gnus-summary-buffer) (gnus-score-load-file (or gnus-newsgroup-adaptive-score-file + (gnus-home-score-file gnus-newsgroup-name t) (gnus-score-file-name gnus-newsgroup-name gnus-adaptive-file-suffix)))) ;; Perform ordinary line scoring. @@ -2074,7 +2155,7 @@ (alist malist) (date (current-time-string)) (data gnus-newsgroup-data) - elem headers match) + elem headers match func) ;; First we transform the adaptive rule alist into something ;; that's faster to process. (while malist @@ -2083,19 +2164,21 @@ (setcar elem (symbol-value (car elem)))) (setq elem (cdr elem)) (while elem - (setcdr (car elem) - (cons (if (eq (caar elem) 'followup) - "references" - (symbol-name (caar elem))) - (cdar elem))) - (setcar (car elem) - `(lambda (h) - (,(intern + (when (fboundp + (setq func + (intern (concat "mail-header-" (if (eq (caar elem) 'followup) "message-id" - (downcase (symbol-name (caar elem)))))) - h))) + (downcase (symbol-name (caar elem)))))))) + (setcdr (car elem) + (cons (if (eq (caar elem) 'followup) + "references" + (symbol-name (caar elem))) + (cdar elem))) + (setcar (car elem) + `(lambda (h) + (,func h)))) (setq elem (cdr elem))) (setq malist (cdr malist))) ;; Then we score away. @@ -2156,11 +2239,20 @@ ;; Put the word and score into the hashtb. (setq val (gnus-gethash (setq word (match-string 0)) hashtb)) - (gnus-sethash word (+ (or val 0) score) hashtb)) + (setq val (+ score (or val 0))) + (if (and gnus-adaptive-word-minimum + (< val gnus-adaptive-word-minimum)) + (setq val gnus-adaptive-word-minimum)) + (gnus-sethash word val hashtb)) (erase-buffer)))) (set-syntax-table syntab)) ;; Make all the ignorable words ignored. (let ((ignored (append gnus-ignored-adaptive-words + (if gnus-adaptive-word-no-group-words + (message-tokenize-header + (gnus-group-real-name + gnus-newsgroup-name) + ".")) gnus-default-ignored-adaptive-words))) (while ignored (gnus-sethash (pop ignored) nil hashtb))) @@ -2200,7 +2292,6 @@ 1 "No score rules apply to the current article (default score %d)." gnus-summary-default-score) (set-buffer "*Score Trace*") - (gnus-add-current-to-buffer-list) (while trace (insert (format "%S -> %s\n" (cdar trace) (if (caar trace) @@ -2246,7 +2337,6 @@ (while rules (insert (format "%-5d: %s\n" (caar rules) (cdar rules))) (pop rules)) - (gnus-add-current-to-buffer-list) (goto-char (point-min)) (gnus-configure-windows 'score-words)))) @@ -2417,7 +2507,7 @@ (trans (cdr (assq ?: nnheader-file-name-translation-alist))) ofiles not-match regexp) (save-excursion - (set-buffer (get-buffer-create "*gnus score files*")) + (set-buffer (gnus-get-buffer-create "*gnus score files*")) (buffer-disable-undo (current-buffer)) ;; Go through all score file names and create regexp with them ;; as the source. @@ -2546,7 +2636,7 @@ files))) (mapcar (lambda (f) (cdr f)) - (sort alist (lambda (f1 f2) (< (car f1) (car f2)))))))) + (sort alist 'car-less-than-car))))) (defun gnus-score-find-alist (group) "Return list of score files for GROUP. @@ -2583,57 +2673,58 @@ (let ((funcs gnus-score-find-score-files-function) (group (or group gnus-newsgroup-name)) score-files) - ;; Make sure funcs is a list. - (and funcs - (not (listp funcs)) - (setq funcs (list funcs))) - ;; Get the initial score files for this group. - (when funcs - (setq score-files (nreverse (gnus-score-find-alist group)))) - ;; Add any home adapt files. - (let ((home (gnus-home-score-file group t))) - (when home - (push home score-files) - (setq gnus-newsgroup-adaptive-score-file home))) - ;; Check whether there is a `adapt-file' group parameter. - (let ((param-file (gnus-group-find-parameter group 'adapt-file))) - (when param-file - (push param-file score-files) - (setq gnus-newsgroup-adaptive-score-file param-file))) - ;; Go through all the functions for finding score files (or actual - ;; scores) and add them to a list. - (while funcs - (when (gnus-functionp (car funcs)) - (setq score-files - (nconc score-files (nreverse (funcall (car funcs) group))))) - (setq funcs (cdr funcs))) - ;; Add any home score files. - (let ((home (gnus-home-score-file group))) - (when home - (push home score-files))) - ;; Check whether there is a `score-file' group parameter. - (let ((param-file (gnus-group-find-parameter group 'score-file))) - (when param-file - (push param-file score-files))) - ;; Expand all files names. - (let ((files score-files)) - (while files - (when (stringp (car files)) - (setcar files (expand-file-name - (car files) gnus-kill-files-directory))) - (pop files))) - (setq score-files (nreverse score-files)) - ;; Remove any duplicate score files. - (while (and score-files - (member (car score-files) (cdr score-files))) - (pop score-files)) - (let ((files score-files)) - (while (cdr files) - (if (member (cadr files) (cddr files)) - (setcdr files (cddr files)) - (pop files)))) - ;; Do the scoring if there are any score files for this group. - score-files)) + (when group + ;; Make sure funcs is a list. + (and funcs + (not (listp funcs)) + (setq funcs (list funcs))) + ;; Get the initial score files for this group. + (when funcs + (setq score-files (nreverse (gnus-score-find-alist group)))) + ;; Add any home adapt files. + (let ((home (gnus-home-score-file group t))) + (when home + (push home score-files) + (setq gnus-newsgroup-adaptive-score-file home))) + ;; Check whether there is a `adapt-file' group parameter. + (let ((param-file (gnus-group-find-parameter group 'adapt-file))) + (when param-file + (push param-file score-files) + (setq gnus-newsgroup-adaptive-score-file param-file))) + ;; Go through all the functions for finding score files (or actual + ;; scores) and add them to a list. + (while funcs + (when (gnus-functionp (car funcs)) + (setq score-files + (nconc score-files (nreverse (funcall (car funcs) group))))) + (setq funcs (cdr funcs))) + ;; Add any home score files. + (let ((home (gnus-home-score-file group))) + (when home + (push home score-files))) + ;; Check whether there is a `score-file' group parameter. + (let ((param-file (gnus-group-find-parameter group 'score-file))) + (when param-file + (push param-file score-files))) + ;; Expand all files names. + (let ((files score-files)) + (while files + (when (stringp (car files)) + (setcar files (expand-file-name + (car files) gnus-kill-files-directory))) + (pop files))) + (setq score-files (nreverse score-files)) + ;; Remove any duplicate score files. + (while (and score-files + (member (car score-files) (cdr score-files))) + (pop score-files)) + (let ((files score-files)) + (while (cdr files) + (if (member (cadr files) (cddr files)) + (setcdr files (cddr files)) + (pop files)))) + ;; Do the scoring if there are any score files for this group. + score-files))) (defun gnus-possibly-score-headers (&optional trace) "Do scoring if scoring is required." @@ -2649,8 +2740,7 @@ ((or (null newsgroup) (string-equal newsgroup "")) ;; The global score file is placed at top of the directory. - (expand-file-name - suffix gnus-kill-files-directory)) + (expand-file-name suffix gnus-kill-files-directory)) ((gnus-use-long-file-name 'not-score) ;; Append ".SCORE" to newsgroup name. (expand-file-name (concat (gnus-newsgroup-savable-name newsgroup) @@ -2669,6 +2759,7 @@ (interactive (list gnus-global-score-files)) (let (out) (while files + ;; #### /$ Unix-specific? (if (string-match "/$" (car files)) (setq out (nconc (directory-files (car files) t @@ -2708,8 +2799,8 @@ (funcall elem group)) ;; Regexp-file cons ((consp elem) - (when (string-match (car elem) group) - (cadr elem)))))) + (when (string-match (gnus-globalify-regexp (car elem)) group) + (replace-match (cadr elem) t nil group )))))) (when found (nnheader-concat gnus-kill-files-directory found)))) @@ -2729,6 +2820,10 @@ (concat group (if (gnus-use-long-file-name 'not-score) "." "/") gnus-adaptive-file-suffix))) +(defun gnus-current-home-score-file (group) + "Return the \"current\" regular score file." + (car (nreverse (gnus-score-find-alist group)))) + ;;; ;;; Score decays ;;; @@ -2764,6 +2859,63 @@ ;; Return whether this score file needs to be saved. By Je-haysuss! updated)) +(defun gnus-score-regexp-bad-p (regexp) + "Test whether REGEXP is safe for Gnus scoring. +A regexp is unsafe if it matches newline or a buffer boundary. + +If the regexp is good, return nil. If the regexp is bad, return a +cons cell (SYM . STRING), where the symbol SYM is `new' or `bad'. +In the `new' case, the string is a safe replacement for REGEXP. +In the `bad' case, the string is a unsafe subexpression of REGEXP, +and we do not have a simple replacement to suggest. + +See `(Gnus)Scoring Tips' for examples of good regular expressions." + (let (case-fold-search) + (and + ;; First, try a relatively fast necessary condition. + ;; Notice ranges (like [^:] or [\t-\r]), \s>, \Sw, \W, \', \`: + (string-match "\n\\|\\\\[SsW`']\\|\\[\\^\\|[\0-\n]-" regexp) + ;; Now break the regexp into tokens, and check each: + (let ((tail regexp) ; remaining regexp to check + tok ; current token + bad ; nil, or bad subexpression + new ; nil, or replacement regexp so far + end) ; length of current token + (while (and (not bad) + (string-match + "\\`\\(\\\\[sS]?.\\|\\[\\^?]?[^]]*]\\|[^\\]\\)" + tail)) + (setq end (match-end 0) + tok (substring tail 0 end) + tail (substring tail end)) + (if;; Is token `bad' (matching newline or buffer ends)? + (or (member tok '("\n" "\\W" "\\`" "\\'")) + ;; This next handles "[...]", "\\s.", and "\\S.": + (and (> end 2) (string-match tok "\n"))) + (let ((newtok + ;; Try to suggest a replacement for tok ... + (cond ((string-equal tok "\\`") "^") ; or "\\(^\\)" + ((string-equal tok "\\'") "$") ; or "\\($\\)" + ((string-match "\\[\\^" tok) ; very common + (concat (substring tok 0 -1) "\n]"))))) + (if newtok + (setq new + (concat + (or new + ;; good prefix so far: + (substring regexp 0 (- (+ (length tail) end)))) + newtok)) + ;; No replacement idea, so give up: + (setq bad tok))) + ;; tok is good, may need to extend new + (and new (setq new (concat new tok))))) + ;; Now return a value: + (cond + (bad (cons 'bad bad)) + (new (cons 'new new)) + ;; or nil + ))))) + (provide 'gnus-score) ;;; gnus-score.el ends here
--- a/lisp/gnus/gnus-soup.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/gnus-soup.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,8 +1,8 @@ ;;; gnus-soup.el --- SOUP packet writing support for Gnus -;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. ;; Author: Per Abrahamsen <abraham@iesd.auc.dk> -;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news, mail ;; This file is part of GNU Emacs. @@ -28,6 +28,8 @@ (eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl)) + (require 'gnus) (require 'gnus-art) (require 'message) @@ -132,9 +134,8 @@ If N is nil and any articles have been marked with the process mark, move those articles instead." (interactive "P") - (gnus-set-global-variables) (let* ((articles (gnus-summary-work-articles n)) - (tmp-buf (get-buffer-create "*soup work*")) + (tmp-buf (gnus-get-buffer-create "*soup work*")) (area (gnus-soup-area gnus-newsgroup-name)) (prefix (gnus-soup-area-prefix area)) headers) @@ -162,7 +163,8 @@ (gnus-summary-mark-as-read (car articles) gnus-souped-mark) (setq articles (cdr articles))) (kill-buffer tmp-buf)) - (gnus-soup-save-areas))) + (gnus-soup-save-areas) + (gnus-set-mode-line 'summary))) (defun gnus-soup-pack-packet () "Make a SOUP packet from the SOUP areas." @@ -205,7 +207,9 @@ For instance, if you want to brew on all the nnml groups, as well as groups with \"emacs\" in the name, you could say something like: -$ emacs -batch -f gnus-batch-brew-soup ^nnml \".*emacs.*\"" +$ emacs -batch -f gnus-batch-brew-soup ^nnml \".*emacs.*\" + +Note -- this function hasn't been implemented yet." (interactive) nil) @@ -311,6 +315,8 @@ (or (mail-header-lines header) "0")))) (defun gnus-soup-save-areas () + "Write all SOUP buffers." + (interactive) (gnus-soup-write-areas) (save-excursion (let (buf) @@ -367,22 +373,23 @@ [prefix name encoding description number] though the two last may be nil if they are missing." (let (areas) - (save-excursion - (set-buffer (nnheader-find-file-noselect file 'force)) - (buffer-disable-undo (current-buffer)) - (goto-char (point-min)) - (while (not (eobp)) - (push (vector (gnus-soup-field) - (gnus-soup-field) - (gnus-soup-field) - (and (eq (preceding-char) ?\t) - (gnus-soup-field)) - (and (eq (preceding-char) ?\t) - (string-to-int (gnus-soup-field)))) - areas) - (when (eq (preceding-char) ?\t) - (beginning-of-line 2))) - (kill-buffer (current-buffer))) + (when (file-exists-p file) + (save-excursion + (set-buffer (nnheader-find-file-noselect file 'force)) + (buffer-disable-undo (current-buffer)) + (goto-char (point-min)) + (while (not (eobp)) + (push (vector (gnus-soup-field) + (gnus-soup-field) + (gnus-soup-field) + (and (eq (preceding-char) ?\t) + (gnus-soup-field)) + (and (eq (preceding-char) ?\t) + (string-to-int (gnus-soup-field)))) + areas) + (when (eq (preceding-char) ?\t) + (beginning-of-line 2))) + (kill-buffer (current-buffer)))) areas)) (defun gnus-soup-parse-replies (file) @@ -507,7 +514,7 @@ ".MSG")) (msg-buf (and (file-exists-p msg-file) (nnheader-find-file-noselect msg-file))) - (tmp-buf (get-buffer-create " *soup send*")) + (tmp-buf (gnus-get-buffer-create " *soup send*")) beg end) (cond ((/= (gnus-soup-encoding-format @@ -518,7 +525,6 @@ t) (t (buffer-disable-undo msg-buf) - (buffer-disable-undo tmp-buf) (set-buffer msg-buf) (goto-char (point-min)) (while (not (eobp))
--- a/lisp/gnus/gnus-spec.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/gnus-spec.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ ;;; gnus-spec.el --- format spec functions for Gnus -;; Copyright (C) 1996,97 Free Software Foundation, Inc. +;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news ;; This file is part of GNU Emacs. @@ -27,6 +27,8 @@ (eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl)) + (require 'gnus) ;;; Internal variables. @@ -182,9 +184,8 @@ val) (when (and (boundp buffer) (setq val (symbol-value buffer)) - (get-buffer val) - (buffer-name (get-buffer val))) - (set-buffer (get-buffer val))) + (gnus-buffer-exists-p val)) + (set-buffer val)) (setq new-format (symbol-value (intern (format "gnus-%s-line-format" type))))) (setq entry (cdr (assq type gnus-format-specs))) @@ -238,9 +239,9 @@ (defvar gnus-face-4 'bold) (defun gnus-face-face-function (form type) - `(gnus-put-text-property + `(gnus-add-text-properties (point) (progn ,@form (point)) - 'face ',(symbol-value (intern (format "gnus-face-%d" type))))) + '(gnus-face t face ,(symbol-value (intern (format "gnus-face-%d" type)))))) (defun gnus-tilde-max-form (el max-width) "Return a form that limits EL to MAX-WIDTH." @@ -308,7 +309,8 @@ (let ((number (if (match-beginning 1) (match-string 1) "0")) (delim (aref (match-string 2) 0))) - (if (or (= delim ?\() (= delim ?\{)) + (if (or (= delim ?\() + (= delim ?\{)) (replace-match (concat "\"(" (if (= delim ?\() "mouse" "face") " " number " \"")) (replace-match "\")\"")))) @@ -502,8 +504,7 @@ (defun gnus-compile () "Byte-compile the user-defined format specs." (interactive) - (when gnus-xemacs - (error "Can't compile specs under XEmacs")) + (require 'bytecomp) (let ((entries gnus-format-specs) (byte-compile-warnings '(unresolved callargs redefine)) entry gnus-tmp-func) @@ -514,17 +515,30 @@ (setq entry (pop entries)) (if (eq (car entry) 'version) (setq gnus-format-specs (delq entry gnus-format-specs)) - (when (and (listp (caddr entry)) - (not (eq 'byte-code (caaddr entry)))) - (fset 'gnus-tmp-func `(lambda () ,(caddr entry))) - (byte-compile 'gnus-tmp-func) - (setcar (cddr entry) (gnus-byte-code 'gnus-tmp-func))))) + (let ((form (caddr entry))) + (when (and (listp form) + ;; Under GNU Emacs, it's (byte-code ...) + (not (eq 'byte-code (car form))) + ;; Under XEmacs, it's (funcall #<compiled-function ...>) + (not (and (eq 'funcall (car form)) + (compiled-function-p (cadr form))))) + (fset 'gnus-tmp-func `(lambda () ,form)) + (byte-compile 'gnus-tmp-func) + (setcar (cddr entry) (gnus-byte-code 'gnus-tmp-func)))))) (push (cons 'version emacs-version) gnus-format-specs) ;; Mark the .newsrc.eld file as "dirty". - (gnus-dribble-enter " ") + (gnus-dribble-touch) (gnus-message 7 "Compiling user specs...done")))) +(defun gnus-set-format (type &optional insertable) + (set (intern (format "gnus-%s-line-format-spec" type)) + (gnus-parse-format + (symbol-value (intern (format "gnus-%s-line-format" type))) + (symbol-value (intern (format "gnus-%s-line-format-alist" type))) + insertable))) + + (provide 'gnus-spec) ;;; gnus-spec.el ends here
--- a/lisp/gnus/gnus-srvr.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/gnus-srvr.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ ;;; gnus-srvr.el --- virtual server support for Gnus -;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news ;; This file is part of GNU Emacs. @@ -27,6 +27,8 @@ (eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl)) + (require 'gnus) (require 'gnus-spec) (require 'gnus-group) @@ -39,9 +41,16 @@ (defconst gnus-server-line-format " {%(%h:%w%)} %s\n" "Format of server lines. It works along the same lines as a normal formatting string, -with some simple extensions.") +with some simple extensions. + +The following specs are understood: -(defvar gnus-server-mode-line-format "Gnus List of servers" +%h backend +%n name +%w address +%s status") + +(defvar gnus-server-mode-line-format "Gnus: %%b" "The format specification for the server mode line.") (defvar gnus-server-exit-hook nil @@ -52,15 +61,15 @@ (defvar gnus-inserted-opened-servers nil) (defvar gnus-server-line-format-alist - `((?h how ?s) - (?n name ?s) - (?w where ?s) - (?s status ?s))) + `((?h gnus-tmp-how ?s) + (?n gnus-tmp-name ?s) + (?w gnus-tmp-where ?s) + (?s gnus-tmp-status ?s))) (defvar gnus-server-mode-line-format-alist - `((?S news-server ?s) - (?M news-method ?s) - (?u user-defined ?s))) + `((?S gnus-tmp-news-server ?s) + (?M gnus-tmp-news-method ?s) + (?u gnus-tmp-user-defined ?s))) (defvar gnus-server-line-format-spec nil) (defvar gnus-server-mode-line-format-spec nil) @@ -99,7 +108,7 @@ ["Close All" gnus-server-close-all-servers t] ["Reset All" gnus-server-remove-denials t])) - (run-hooks 'gnus-server-menu-hook))) + (gnus-run-hooks 'gnus-server-menu-hook))) (defvar gnus-server-mode-map nil) (put 'gnus-server-mode 'mode-class 'special) @@ -108,28 +117,27 @@ (setq gnus-server-mode-map (make-sparse-keymap)) (suppress-keymap gnus-server-mode-map) - (gnus-define-keys - gnus-server-mode-map - " " gnus-server-read-server - "\r" gnus-server-read-server - gnus-mouse-2 gnus-server-pick-server - "q" gnus-server-exit - "l" gnus-server-list-servers - "k" gnus-server-kill-server - "y" gnus-server-yank-server - "c" gnus-server-copy-server - "a" gnus-server-add-server - "e" gnus-server-edit-server - "s" gnus-server-scan-server + (gnus-define-keys gnus-server-mode-map + " " gnus-server-read-server + "\r" gnus-server-read-server + gnus-mouse-2 gnus-server-pick-server + "q" gnus-server-exit + "l" gnus-server-list-servers + "k" gnus-server-kill-server + "y" gnus-server-yank-server + "c" gnus-server-copy-server + "a" gnus-server-add-server + "e" gnus-server-edit-server + "s" gnus-server-scan-server - "O" gnus-server-open-server - "\M-o" gnus-server-open-all-servers - "C" gnus-server-close-server - "\M-c" gnus-server-close-all-servers - "D" gnus-server-deny-server - "R" gnus-server-remove-denials + "O" gnus-server-open-server + "\M-o" gnus-server-open-all-servers + "C" gnus-server-close-server + "\M-c" gnus-server-close-all-servers + "D" gnus-server-deny-server + "R" gnus-server-remove-denials - "g" gnus-server-regenerate-server + "g" gnus-server-regenerate-server "\C-c\C-i" gnus-info-find-node "\C-c\C-b" gnus-bug)) @@ -158,13 +166,13 @@ (buffer-disable-undo (current-buffer)) (setq truncate-lines t) (setq buffer-read-only t) - (run-hooks 'gnus-server-mode-hook)) + (gnus-run-hooks 'gnus-server-mode-hook)) -(defun gnus-server-insert-server-line (name method) - (let* ((how (car method)) - (where (nth 1 method)) +(defun gnus-server-insert-server-line (gnus-tmp-name method) + (let* ((gnus-tmp-how (car method)) + (gnus-tmp-where (nth 1 method)) (elem (assoc method gnus-opened-servers)) - (status (cond ((eq (nth 1 elem) 'denied) + (gnus-tmp-status (cond ((eq (nth 1 elem) 'denied) "(denied)") ((or (gnus-server-opened method) (eq (nth 1 elem) 'ok)) @@ -177,7 +185,7 @@ (prog1 (1+ (point)) ;; Insert the text. (eval gnus-server-line-format-spec)) - (list 'gnus-server (intern name))))) + (list 'gnus-server (intern gnus-tmp-name))))) (defun gnus-enter-server-buffer () "Set up the server buffer." @@ -189,18 +197,14 @@ "Initialize the server buffer." (unless (get-buffer gnus-server-buffer) (save-excursion - (set-buffer (get-buffer-create gnus-server-buffer)) + (set-buffer (gnus-get-buffer-create gnus-server-buffer)) (gnus-server-mode) (when gnus-carpal (gnus-carpal-setup-buffer 'server))))) (defun gnus-server-prepare () - (setq gnus-server-mode-line-format-spec - (gnus-parse-format gnus-server-mode-line-format - gnus-server-mode-line-format-alist)) - (setq gnus-server-line-format-spec - (gnus-parse-format gnus-server-line-format - gnus-server-line-format-alist t)) + (gnus-set-format 'server-mode) + (gnus-set-format 'server t) (let ((alist gnus-server-alist) (buffer-read-only nil) (opened gnus-opened-servers) @@ -219,7 +223,9 @@ ;; Then we insert the list of servers that have been opened in ;; this session. (while opened - (unless (member (caar opened) done) + (when (and (not (member (caar opened) done)) + ;; Just ignore ephemeral servers. + (not (member (caar opened) gnus-ephemeral-servers))) (push (caar opened) done) (gnus-server-insert-server-line (setq op-ser (format "%s:%s" (caaar opened) (nth 1 (caar opened)))) @@ -283,7 +289,7 @@ (error "No server on the current line"))) (unless (assoc server gnus-server-alist) (error "Read-only server %s" server)) - (gnus-dribble-enter "") + (gnus-dribble-touch) (let ((buffer-read-only nil)) (gnus-delete-line)) (push (assoc server gnus-server-alist) gnus-server-killed-servers) @@ -316,7 +322,7 @@ (defun gnus-server-exit () "Return to the group buffer." (interactive) - (run-hooks 'gnus-server-exit-hook) + (gnus-run-hooks 'gnus-server-exit-hook) (kill-buffer (current-buffer)) (gnus-configure-windows 'group t)) @@ -462,16 +468,19 @@ (defun gnus-server-scan-server (server) "Request a scan from the current server." (interactive (list (gnus-server-server-name))) - (gnus-message 3 "Scanning %s...done" server) - (gnus-request-scan nil (gnus-server-to-method server)) - (gnus-message 3 "Scanning %s...done" server)) + (let ((method (gnus-server-to-method server))) + (if (not (gnus-get-function method 'request-scan)) + (error "Server %s can't scan" (car method)) + (gnus-message 3 "Scanning %s..." server) + (gnus-request-scan nil method) + (gnus-message 3 "Scanning %s...done" server)))) (defun gnus-server-read-server (server) "Browse a server." (interactive (list (gnus-server-server-name))) (let ((buf (current-buffer))) (prog1 - (gnus-browse-foreign-server (gnus-server-to-method server) buf) + (gnus-browse-foreign-server server buf) (save-excursion (set-buffer buf) (gnus-server-update-server (gnus-server-server-name)) @@ -530,25 +539,24 @@ '("Browse" ["Subscribe" gnus-browse-unsubscribe-current-group t] ["Read" gnus-browse-read-group t] - ["Select" gnus-browse-read-group t] + ["Select" gnus-browse-select-group t] ["Next" gnus-browse-next-group t] ["Prev" gnus-browse-next-group t] ["Exit" gnus-browse-exit t])) - (run-hooks 'gnus-browse-menu-hook))) + (gnus-run-hooks 'gnus-browse-menu-hook))) (defvar gnus-browse-current-method nil) (defvar gnus-browse-return-buffer nil) (defvar gnus-browse-buffer "*Gnus Browse Server*") -(defun gnus-browse-foreign-server (method &optional return-buffer) - "Browse the server METHOD." - (setq gnus-browse-current-method method) +(defun gnus-browse-foreign-server (server &optional return-buffer) + "Browse the server SERVER." + (setq gnus-browse-current-method server) (setq gnus-browse-return-buffer return-buffer) - (when (stringp method) - (setq method (gnus-server-to-method method))) - (let ((gnus-select-method method) - groups group) + (let* ((method (gnus-server-to-method server)) + (gnus-select-method method) + groups group) (gnus-message 5 "Connecting to %s..." (nth 1 method)) (cond ((not (gnus-check-server method)) @@ -565,8 +573,7 @@ 1 "Couldn't request list: %s" (gnus-status-message method)) nil) (t - (get-buffer-create gnus-browse-buffer) - (gnus-add-current-to-buffer-list) + (gnus-get-buffer-create gnus-browse-buffer) (when gnus-carpal (gnus-carpal-setup-buffer 'browse)) (gnus-configure-windows 'browse) @@ -587,9 +594,11 @@ (while (re-search-forward "\\(^[^ \t]+\\)[ \t]+[0-9]+[ \t]+[0-9]+" nil t) (goto-char (match-end 1)) - (push (cons (match-string 1) - (max 0 (- (1+ (read cur)) (read cur)))) - groups)))) + (condition-case () + (push (cons (match-string 1) + (max 0 (- (1+ (read cur)) (read cur)))) + groups) + (error nil))))) (setq groups (sort groups (lambda (l1 l2) (string< (car l1) (car l2))))) @@ -633,17 +642,21 @@ (setq truncate-lines t) (gnus-set-default-directory) (setq buffer-read-only t) - (run-hooks 'gnus-browse-mode-hook)) + (gnus-run-hooks 'gnus-browse-mode-hook)) (defun gnus-browse-read-group (&optional no-article) "Enter the group at the current line." (interactive) - (let ((group (gnus-group-real-name (gnus-browse-group-name)))) - (unless (gnus-group-read-ephemeral-group - group gnus-browse-current-method nil - (cons (current-buffer) 'browse)) - (error "Couldn't enter %s" group)))) - + (let ((group (gnus-browse-group-name))) + (if (or (not (gnus-get-info group)) + (gnus-ephemeral-group-p group)) + (unless (gnus-group-read-ephemeral-group + group gnus-browse-current-method nil + (cons (current-buffer) 'browse)) + (error "Couldn't enter %s" group)) + (unless (gnus-group-read-group nil no-article group) + (error "Couldn't enter %s" group))))) + (defun gnus-browse-select-group () "Select the current group." (interactive) @@ -697,18 +710,22 @@ ;; If this group it killed, then we want to subscribe it. (when (= (following-char) ?K) (setq sub t)) - (when (gnus-gethash (setq group (gnus-browse-group-name)) - gnus-newsrc-hashtb) + (setq group (gnus-browse-group-name)) + (when (and sub + (cadr (gnus-gethash group gnus-newsrc-hashtb))) (error "Group already subscribed")) - ;; Make sure the group has been properly removed before we - ;; subscribe to it. - (gnus-kill-ephemeral-group group) (delete-char 1) (if sub (progn + ;; Make sure the group has been properly removed before we + ;; subscribe to it. + (gnus-kill-ephemeral-group group) (gnus-group-change-level (list t group gnus-level-default-subscribed - nil nil gnus-browse-current-method) + nil nil (if (gnus-server-equal + gnus-browse-current-method "native") + nil + gnus-browse-current-method)) gnus-level-default-subscribed gnus-level-killed (and (car (nth 1 gnus-newsrc-alist)) (gnus-gethash (car (nth 1 gnus-newsrc-alist))
--- a/lisp/gnus/gnus-start.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/gnus-start.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ ;;; gnus-start.el --- startup functions for Gnus -;; Copyright (C) 1996,97 Free Software Foundation, Inc. +;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news ;; This file is part of GNU Emacs. @@ -52,7 +52,7 @@ (directory-file-name installation-directory)) "site-lisp/gnus-init") (error nil)) - "The site-wide Gnus Emacs-Lisp startup file name, or nil if none. + "*The site-wide Gnus Emacs-Lisp startup file name, or nil if none. If a file with the `.el' or `.elc' suffixes exists, it will be read instead." :group 'gnus-start :type '(choice file (const nil))) @@ -80,18 +80,18 @@ :type '(choice directory (const nil))) (defcustom gnus-check-new-newsgroups 'ask-server - "*Non-nil means that Gnus will run gnus-find-new-newsgroups at startup. + "*Non-nil means that Gnus will run `gnus-find-new-newsgroups' at startup. This normally finds new newsgroups by comparing the active groups the servers have already reported with those Gnus already knows, either alive or killed. -When any of the following are true, gnus-find-new-newsgroups will instead +When any of the following are true, `gnus-find-new-newsgroups' will instead ask the servers (primary, secondary, and archive servers) to list new groups since the last time it checked: 1. This variable is `ask-server'. 2. This variable is a list of select methods (see below). 3. `gnus-read-active-file' is nil or `some'. - 4. A prefix argument is given to gnus-find-new-newsgroups interactively. + 4. A prefix argument is given to `gnus-find-new-newsgroups' interactively. Thus, if this variable is `ask-server' or a list of select methods or `gnus-read-active-file' is nil or `some', then the killed list is no @@ -194,7 +194,8 @@ but you won't be told how many unread articles there are in the groups." :group 'gnus-group-levels - :type 'integer) + :type '(choice integer + (const :tag "none" nil))) (defcustom gnus-save-newsrc-file t "*Non-nil means that Gnus will save the `.newsrc' file. @@ -228,7 +229,7 @@ "[][\"#'()]" ; bogus characters ) "\\|")) - "A regexp to match uninteresting newsgroups in the active file. + "*A regexp to match uninteresting newsgroups in the active file. Any lines in the active file matching this regular expression are removed from the newsgroup list before anything else is done to it, thus making them effectively non-existent." @@ -253,8 +254,6 @@ (function-item gnus-subscribe-zombies) function)) -;; Suggested by a bug report by Hallvard B Furuseth. -;; <h.b.furuseth@usit.uio.no>. (defcustom gnus-subscribe-options-newsgroup-method 'gnus-subscribe-alphabetically "*This function is called to subscribe newsgroups mentioned on \"options -n\" lines. @@ -288,7 +287,7 @@ :type 'boolean) (defcustom gnus-auto-subscribed-groups - "^nnml\\|^nnfolder\\|^nnmbox\\|^nnmh\\|^nnbabyl" + "nnml\\|^nnfolder\\|^nnmbox\\|^nnmh\\|^nnbabyl" "*All new groups that match this regexp will be subscribed automatically. Note that this variable only deals with new groups. It has no effect whatsoever on old groups. @@ -337,11 +336,22 @@ :group 'gnus-start :type 'hook) +(defcustom gnus-before-startup-hook nil + "A hook called at before startup. +This hook is called as the first thing when Gnus is started." + :group 'gnus-start + :type 'hook) + (defcustom gnus-started-hook nil "A hook called as the last thing after startup." :group 'gnus-start :type 'hook) +(defcustom gnus-setup-news-hook nil + "A hook after reading the .newsrc file, but before generating the buffer." + :group 'gnus-start + :type 'hook) + (defcustom gnus-get-new-news-hook nil "A hook run just before Gnus checks for new news." :group 'gnus-group-new @@ -350,7 +360,7 @@ (defcustom gnus-after-getting-new-news-hook (when (gnus-boundp 'display-time-timer) '(display-time-event-handler)) - "A hook run after Gnus checks for new news." + "*A hook run after Gnus checks for new news." :group 'gnus-group-new :type 'hook) @@ -371,6 +381,14 @@ :group 'gnus-newsrc :type 'hook) +(defcustom gnus-always-read-dribble-file nil + "Uncoditionally read the dribble file." + :group 'gnus-newsrc + :type 'boolean) + +(defvar gnus-startup-file-coding-system 'binary + "*Coding system for startup file.") + (defvar gnus-startup-file-coding-system 'binary "*Coding system for startup file.") @@ -439,7 +457,8 @@ (push prefix prefixes) (message "Descend hierarchy %s? ([y]nsq): " (substring prefix 1 (1- (length prefix)))) - (while (not (memq (setq ans (read-char)) '(?y ?\n ?\r ?n ?s ?q))) + (while (not (memq (setq ans (read-char-exclusive)) + '(?y ?\n ?\r ?n ?s ?q))) (ding) (message "Descend hierarchy %s? ([y]nsq): " (substring prefix 1 (1- (length prefix))))) @@ -467,7 +486,8 @@ (setq groups (cdr groups)))) (t nil))) (message "Subscribe %s? ([n]yq)" (car groups)) - (while (not (memq (setq ans (read-char)) '(?y ?\n ?\r ?q ?n))) + (while (not (memq (setq ans (read-char-exclusive)) + '(?y ?\n ?\r ?q ?n))) (ding) (message "Subscribe %s? ([n]yq)" (car groups))) (setq group (car groups)) @@ -567,6 +587,7 @@ (defvar gnus-newsgroup-unreads) (defvar nnoo-state-alist) (defvar gnus-current-select-method) + (defun gnus-clear-system () "Clear all variables and buffers." ;; Clear Gnus variables. @@ -596,7 +617,8 @@ gnus-newsgroup-data nil gnus-newsgroup-unreads nil nnoo-state-alist nil - gnus-current-select-method nil) + gnus-current-select-method nil + gnus-ephemeral-servers nil) (gnus-shutdown 'gnus) ;; Kill the startup file. (and gnus-current-startup-file @@ -609,8 +631,9 @@ (kill-buffer (get-file-buffer (gnus-newsgroup-kill-file nil)))) (gnus-kill-buffer nntp-server-buffer) ;; Kill Gnus buffers. - (while gnus-buffer-list - (gnus-kill-buffer (pop gnus-buffer-list))) + (let ((buffers (gnus-buffers))) + (when buffers + (mapcar 'kill-buffer buffers))) ;; Remove Gnus frames. (gnus-kill-gnus-frames)) @@ -634,10 +657,7 @@ prompt the user for the name of an NNTP server to use." (interactive "P") - (if (and (get-buffer gnus-group-buffer) - (save-excursion - (set-buffer gnus-group-buffer) - (eq major-mode 'gnus-group-mode))) + (if (gnus-alive-p) (progn (switch-to-buffer gnus-group-buffer) (gnus-group-get-new-news @@ -645,16 +665,21 @@ (> arg 0) (max (car gnus-group-list-mode) arg)))) + (gnus-clear-system) (gnus-splash) - (gnus-clear-system) + (gnus-run-hooks 'gnus-before-startup-hook) (nnheader-init-server-buffer) (setq gnus-slave slave) (gnus-read-init-file) - (when (and (string-match "XEmacs" (emacs-version)) - gnus-simple-splash) + (when gnus-simple-splash (setq gnus-simple-splash nil) - (gnus-xmas-splash)) + (cond + (gnus-xemacs + (gnus-xmas-splash)) + ((and (eq window-system 'x) + (= (frame-height) (1+ (window-height)))) + (gnus-x-splash)))) (let ((level (and (numberp arg) (> arg 0) arg)) did-connect) @@ -666,7 +691,7 @@ (if (and (not dont-connect) (not did-connect)) (gnus-group-quit) - (run-hooks 'gnus-startup-hook) + (gnus-run-hooks 'gnus-startup-hook) ;; NNTP server is successfully open. ;; Find the current startup file name. @@ -684,12 +709,23 @@ ;; Do the actual startup. (gnus-setup-news nil level dont-connect) + (gnus-run-hooks 'gnus-setup-news-hook) + (gnus-start-draft-setup) ;; Generate the group buffer. (gnus-group-list-groups level) (gnus-group-first-unread-group) (gnus-configure-windows 'group) (gnus-group-set-mode-line) - (run-hooks 'gnus-started-hook)))))) + (gnus-run-hooks 'gnus-started-hook)))))) + +(defun gnus-start-draft-setup () + "Make sure the draft group exists." + (gnus-request-create-group "drafts" '(nndraft "")) + (unless (gnus-gethash "nndraft:drafts" gnus-newsrc-hashtb) + (let ((gnus-level-default-subscribed 1)) + (gnus-subscribe-group "nndraft:drafts" nil '(nndraft ""))) + (gnus-group-set-parameter + "nndraft:drafts" 'gnus-dummy '((gnus-draft-mode))))) ;;;###autoload (defun gnus-unload () @@ -733,6 +769,9 @@ (insert string "\n") (set-window-point (get-buffer-window (current-buffer)) (point-max)) (bury-buffer gnus-dribble-buffer) + (save-excursion + (set-buffer gnus-group-buffer) + (gnus-group-set-mode-line)) (set-buffer obuf)))) (defun gnus-dribble-touch () @@ -744,9 +783,8 @@ (let ((dribble-file (gnus-dribble-file-name))) (save-excursion (set-buffer (setq gnus-dribble-buffer - (get-buffer-create + (gnus-get-buffer-create (file-name-nondirectory dribble-file)))) - (gnus-add-current-to-buffer-list) (erase-buffer) (setq buffer-file-name dribble-file) (auto-save-mode t) @@ -771,8 +809,9 @@ (setq modes (file-modes gnus-current-startup-file))) (set-file-modes dribble-file modes)) ;; Possibly eval the file later. - (when (gnus-y-or-n-p - "Gnus auto-save file exists. Do you want to read it? ") + (when (or gnus-always-read-dribble-file + (gnus-y-or-n-p + "Gnus auto-save file exists. Do you want to read it? ")) (setq gnus-dribble-eval-file t))))))) (defun gnus-dribble-eval-file () @@ -828,8 +867,10 @@ ;; Read the newsrc file and create `gnus-newsrc-hashtb'. (gnus-read-newsrc-file rawfile)) - (when (and (not (assoc "archive" gnus-server-alist)) - (gnus-archive-server-wanted-p)) + ;; Make sure the archive server is available to all and sundry. + (when gnus-message-archive-method + (setq gnus-server-alist (delq (assoc "archive" gnus-server-alist) + gnus-server-alist)) (push (cons "archive" gnus-message-archive-method) gnus-server-alist)) @@ -877,7 +918,8 @@ ;; Find new newsgroups and treat them. (when (and init gnus-check-new-newsgroups (not level) (gnus-check-server gnus-select-method) - (not gnus-slave)) + (not gnus-slave) + gnus-plugged) (gnus-find-new-newsgroups)) ;; We might read in new NoCeM messages here. @@ -902,13 +944,25 @@ "Search for new newsgroups and add them. Each new newsgroup will be treated with `gnus-subscribe-newsgroup-method.' The `-n' option line from .newsrc is respected. -If ARG (the prefix), use the `ask-server' method to query the server -for new groups." - (interactive "P") - (let ((check (if (or (and arg (not (listp gnus-check-new-newsgroups))) - (null gnus-read-active-file) - (eq gnus-read-active-file 'some)) - 'ask-server gnus-check-new-newsgroups))) + +With 1 C-u, use the `ask-server' method to query the server for new +groups. +With 2 C-u's, use most complete method possible to query the server +for new groups, and subscribe the new groups as zombies." + (interactive "p") + (let* ((gnus-subscribe-newsgroup-method + gnus-subscribe-newsgroup-method) + (check (cond + ((or (and (= (or arg 1) 4) + (not (listp gnus-check-new-newsgroups))) + (null gnus-read-active-file) + (eq gnus-read-active-file 'some)) + 'ask-server) + ((= (or arg 1) 16) + (setq gnus-subscribe-newsgroup-method + 'gnus-subscribe-zombies) + t) + (t gnus-check-new-newsgroups)))) (unless (gnus-check-first-time-used) (if (or (consp check) (eq check 'ask-server)) @@ -996,16 +1050,18 @@ (new-date (current-time-string)) group new-newsgroups got-new method hashtb gnus-override-subscribe-method) + (unless gnus-killed-hashtb + (gnus-make-hashtable-from-killed)) ;; Go through both primary and secondary select methods and ;; request new newsgroups. (while (setq method (gnus-server-get-method nil (pop methods))) - (setq new-newsgroups nil) - (setq gnus-override-subscribe-method method) + (setq new-newsgroups nil + gnus-override-subscribe-method method) (when (and (gnus-check-server method) (gnus-request-newgroups date method)) (save-excursion - (setq got-new t) - (setq hashtb (gnus-make-hashtable 100)) + (setq got-new t + hashtb (gnus-make-hashtable 100)) (set-buffer nntp-server-buffer) ;; Enter all the new groups into a hashtable. (gnus-active-to-gnus-format method hashtb 'ignore)) @@ -1041,10 +1097,10 @@ hashtb)) (when new-newsgroups (gnus-subscribe-hierarchical-interactive new-newsgroups))) - ;; Suggested by Per Abrahamsen <amanda@iesd.auc.dk>. - (when (> groups 0) - (gnus-message 6 "%d new newsgroup%s arrived." - groups (if (> groups 1) "s have" " has"))) + (if (> groups 0) + (gnus-message 5 "%d new newsgroup%s arrived" + groups (if (> groups 1) "s have" " has")) + (gnus-message 5 "No new newsgroups")) (when got-new (setq gnus-newsrc-last-checked-date new-date)) got-new)) @@ -1128,7 +1184,7 @@ (if (and (not oldlevel) (consp entry)) (setq oldlevel (gnus-info-level (nth 2 entry))) - (setq oldlevel (or oldlevel 9))) + (setq oldlevel (or oldlevel gnus-level-killed))) (when (stringp previous) (setq previous (gnus-gethash previous gnus-newsrc-hashtb))) @@ -1274,7 +1330,7 @@ (set (car dead-lists) (delete group (symbol-value (car dead-lists)))))) (setq dead-lists (cdr dead-lists)))) - (run-hooks 'gnus-check-bogus-groups-hook) + (gnus-run-hooks 'gnus-check-bogus-groups-hook) (gnus-message 5 "Checking bogus newsgroups...done")))) (defun gnus-check-duplicate-killed-groups () @@ -1338,6 +1394,7 @@ info (inline (gnus-find-method-for-group (gnus-info-group info))))) (gnus-activate-group (gnus-info-group info) nil t)) + (let* ((range (gnus-info-read info)) (num 0)) ;; If a cache is present, we may have to alter the active info. @@ -1449,6 +1506,10 @@ ;; These groups are foreign. Check the level. (when (<= (gnus-info-level info) foreign-level) (setq active (gnus-activate-group group 'scan)) + ;; Let the Gnus agent save the active file. + (when (and gnus-agent gnus-plugged active) + (gnus-agent-save-group-info + method (gnus-group-real-name group) active)) (unless (inline (gnus-virtual-group-p group)) (inline (gnus-close-group group))) (when (fboundp (intern (concat (symbol-name (car method)) @@ -1628,9 +1689,11 @@ 1.2 "Cannot read partial active file from %s server." (car method))) ((eq list-type 'active) - (gnus-active-to-gnus-format method gnus-active-hashtb)) + (gnus-active-to-gnus-format + method gnus-active-hashtb nil t)) (t - (gnus-groups-to-gnus-format method gnus-active-hashtb)))))) + (gnus-groups-to-gnus-format + method gnus-active-hashtb t)))))) ((null method) t) (t @@ -1639,7 +1702,7 @@ (gnus-error 1 "Cannot read active file from %s server" (car method))) (gnus-message 5 mesg) - (gnus-active-to-gnus-format method gnus-active-hashtb) + (gnus-active-to-gnus-format method gnus-active-hashtb nil t) ;; We mark this active file as read. (push method gnus-have-read-active-file) (gnus-message 5 "%sdone" mesg)))))) @@ -1647,14 +1710,14 @@ (defun gnus-ignored-newsgroups-has-to-p () - "T only when gnus-ignored-newsgroups includes \"^to\\\\.\" as an element." + "Non-nil iff gnus-ignored-newsgroups includes \"^to\\\\.\" as an element." ;; note this regexp is the same as: ;; (concat (regexp-quote "^to\\.") "\\($\\|" (regexp-quote "\\|") "\\)") - (string-match "\\^to\\\\\\.\\($\\|\\\\|\\)" - gnus-ignored-newsgroups)) + (string-match "\\^to\\\\\\.\\($\\|\\\\|\\)" gnus-ignored-newsgroups)) ;; Read an active file and place the results in `gnus-active-hashtb'. -(defun gnus-active-to-gnus-format (&optional method hashtb ignore-errors) +(defun gnus-active-to-gnus-format (&optional method hashtb ignore-errors + real-active) (unless method (setq method gnus-select-method)) (let ((cur (current-buffer)) @@ -1683,6 +1746,10 @@ (while (re-search-backward "[][';?()#]" nil t) (insert ?\\)) + ;; Let the Gnus agent save the active file. + (when (and gnus-agent real-active) + (gnus-agent-save-active method)) + ;; If these are groups from a foreign select method, we insert the ;; group prefix in front of the group names. (when (not (gnus-server-equal @@ -1731,7 +1798,7 @@ (widen) (forward-line 1))))) -(defun gnus-groups-to-gnus-format (method &optional hashtb) +(defun gnus-groups-to-gnus-format (method &optional hashtb real-active) ;; Parse a "groups" active file. (let ((cur (current-buffer)) (hashtb (or hashtb @@ -1746,6 +1813,10 @@ (gnus-server-get-method nil gnus-select-method))) (gnus-group-prefixed-name "" method)))) + ;; Let the Gnus agent save the active file. + (when (and gnus-agent real-active) + (gnus-agent-save-groups method)) + (goto-char (point-min)) ;; We split this into to separate loops, one with the prefix ;; and one without to speed the reading up somewhat. @@ -1928,7 +1999,8 @@ (if (or (file-exists-p real-file) (file-exists-p (concat real-file ".el")) (file-exists-p (concat real-file ".eld"))) - real-file file))) + real-file + file))) (defun gnus-newsrc-to-gnus-format () (setq gnus-newsrc-options "") @@ -2164,11 +2236,12 @@ (push (cons (concat "^" (buffer-substring (1+ (match-beginning 0)) - (match-end 0))) + (match-end 0)) + "\\($\\|\\.\\)") 'ignore) out) ;; There was no bang, so this is a "yes" spec. - (push (cons (concat "^" (match-string 0)) + (push (cons (concat "^" (match-string 0) "\\($\\|\\.\\)") 'subscribe) out)))) @@ -2189,7 +2262,7 @@ (set-buffer gnus-dribble-buffer) (buffer-size))))) (gnus-message 4 "(No changes need to be saved)") - (run-hooks 'gnus-save-newsrc-hook) + (gnus-run-hooks 'gnus-save-newsrc-hook) (if gnus-slave (gnus-slave-save-newsrc) ;; Save .newsrc. @@ -2198,18 +2271,17 @@ (gnus-gnus-to-newsrc-format) (gnus-message 8 "Saving %s...done" gnus-current-startup-file)) ;; Save .newsrc.eld. - (set-buffer (get-buffer-create " *Gnus-newsrc*")) + (set-buffer (gnus-get-buffer-create " *Gnus-newsrc*")) (make-local-variable 'version-control) (setq version-control 'never) (setq buffer-file-name (concat gnus-current-startup-file ".eld")) (setq default-directory (file-name-directory buffer-file-name)) - (gnus-add-current-to-buffer-list) (buffer-disable-undo (current-buffer)) (erase-buffer) (gnus-message 5 "Saving %s.eld..." gnus-current-startup-file) (gnus-gnus-to-quick-newsrc-format) - (run-hooks 'gnus-save-quick-newsrc-hook) + (gnus-run-hooks 'gnus-save-quick-newsrc-hook) (let ((coding-system-for-write gnus-startup-file-coding-system)) (save-buffer)) (kill-buffer (current-buffer)) @@ -2224,9 +2296,9 @@ (print-escape-newlines t)) (insert ";; -*- emacs-lisp -*-\n") (insert ";; Gnus startup file.\n") - (insert - ";; Never delete this file - touch .newsrc instead to force Gnus\n") - (insert ";; to read .newsrc.\n") + (insert "\ +;; Never delete this file -- if you want to force Gnus to read the +;; .newsrc file (if you have one), touch .newsrc instead.\n") (insert "(setq gnus-newsrc-file-version " (prin1-to-string gnus-version) ")\n") (let* ((gnus-killed-list @@ -2255,7 +2327,7 @@ (let ((list gnus-killed-list) olist) (while list - (when (string-match gnus-save-killed-list) + (when (string-match gnus-save-killed-list (car list)) (push (car list) olist)) (pop list)) (nreverse olist))) @@ -2312,7 +2384,7 @@ (if gnus-modtime-botch (delete-file gnus-startup-file) (clear-visited-file-modtime)) - (run-hooks 'gnus-save-standard-newsrc-hook) + (gnus-run-hooks 'gnus-save-standard-newsrc-hook) (save-buffer) (kill-buffer (current-buffer))))) @@ -2321,6 +2393,13 @@ ;;; Slave functions. ;;; +(defvar gnus-slave-mode nil) + +(defun gnus-slave-mode () + "Minor mode for slave Gnusae." + (gnus-add-minor-mode 'gnus-slave-mode " Slave" (make-sparse-keymap)) + (gnus-run-hooks 'gnus-slave-mode-hook)) + (defun gnus-slave-save-newsrc () (save-excursion (set-buffer gnus-dribble-buffer) @@ -2347,7 +2426,7 @@ () ; There are no slave files to read. (gnus-message 7 "Reading slave newsrcs...") (save-excursion - (set-buffer (get-buffer-create " *gnus slave*")) + (set-buffer (gnus-get-buffer-create " *gnus slave*")) (buffer-disable-undo (current-buffer)) (setq slave-files (sort (mapcar (lambda (file) @@ -2450,10 +2529,12 @@ (let ((str (buffer-substring (point) (progn (end-of-line) (point)))) (coding - (and enable-multibyte-characters + (and (boundp 'enable-multibyte-characters) + enable-multibyte-characters + (fboundp 'gnus-mule-get-coding-system) (gnus-mule-get-coding-system (symbol-name group))))) (if coding - (setq str (decode-coding-string str (car coding)))) + (setq str (gnus-decode-coding-string str (car coding)))) (set group str))) (forward-line 1)))) (gnus-message 5 "Reading descriptions file...done")
--- a/lisp/gnus/gnus-sum.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/gnus-sum.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ ;;; gnus-sum.el --- summary mode commands for Gnus -;; Copyright (C) 1996,97 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news ;; This file is part of GNU Emacs. @@ -27,12 +27,16 @@ (eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl)) + (require 'gnus) (require 'gnus-group) (require 'gnus-spec) (require 'gnus-range) (require 'gnus-int) (require 'gnus-undo) +(require 'gnus-util) +(autoload 'gnus-summary-limit-include-cached "gnus-cache" nil t) (defcustom gnus-kill-summary-on-exit t "*If non-nil, kill the summary buffer when you exit from it. @@ -47,10 +51,11 @@ just marked as read) article, the old article will not normally be displayed in the Summary buffer. If this variable is non-nil, Gnus will attempt to grab the headers to the old articles, and thereby -build complete threads. If it has the value `some', only enough -headers to connect otherwise loose threads will be displayed. -This variable can also be a number. In that case, no more than that -number of old headers will be fetched. +build complete threads. If it has the value `some', only enough +headers to connect otherwise loose threads will be displayed. This +variable can also be a number. In that case, no more than that number +of old headers will be fetched. If it has the value `invisible', all +old headers will be fetched, but none will be displayed. The server has to support NOV for any of this to work." :group 'gnus-thread @@ -59,6 +64,13 @@ number (sexp :menu-tag "other" t))) +(defcustom gnus-refer-thread-limit 200 + "*The number of old headers to fetch when doing \\<gnus-summary-mode-map>\\[gnus-summary-refer-thread]. +If t, fetch all the available old headers." + :group 'gnus-thread + :type '(choice number + (sexp :menu-tag "other" t))) + (defcustom gnus-summary-make-false-root 'adopt "*nil means that Gnus won't gather loose threads. If the root of a thread has expired or been read in a previous @@ -111,6 +123,15 @@ (const fuzzy) (sexp :menu-tag "on" t))) +(defcustom gnus-simplify-subject-functions nil + "List of functions taking a string argument that simplify subjects. +The functions are applied recursively. + +Useful functions to put in this list include: `gnus-simplify-subject-re', +`gnus-simplify-subject-fuzzy' and `gnus-simplify-whitespace'." + :group 'gnus-thread + :type '(repeat function)) + (defcustom gnus-simplify-ignored-prefixes nil "*Regexp, matches for which are removed from subject lines when simplifying fuzzily." :group 'gnus-thread @@ -130,7 +151,7 @@ (defcustom gnus-summary-thread-gathering-function 'gnus-gather-threads-by-subject - "Function used for gathering loose threads. + "*Function used for gathering loose threads. There are two pre-defined functions: `gnus-gather-threads-by-subject', which only takes Subjects into consideration; and `gnus-gather-threads-by-references', which compared the References @@ -140,7 +161,6 @@ (function-item gnus-gather-threads-by-references) (function :tag "other"))) -;; Added by Per Abrahamsen <amanda@iesd.auc.dk>. (defcustom gnus-summary-same-subject "" "*String indicating that the current article has the same subject as the previous. This variable will only be used if the value of @@ -200,10 +220,10 @@ :group 'gnus-thread :type 'boolean) -(defcustom gnus-thread-ignore-subject nil - "*If non-nil, ignore subjects and do all threading based on the Reference header. -If nil, which is the default, articles that have different subjects -from their parents will start separate threads." +(defcustom gnus-thread-ignore-subject t + "*If non-nil, which is the default, ignore subjects and do all threading based on the Reference header. +If nil, articles that have different subjects from their parents will +start separate threads." :group 'gnus-thread :type 'boolean) @@ -264,7 +284,9 @@ (sexp :menu-tag "on" t))) (defcustom gnus-auto-select-same nil - "*If non-nil, select the next article with the same subject." + "*If non-nil, select the next article with the same subject. +If there are no more articles with the same subject, go to +the first unread article." :group 'gnus-summary-maneuvering :type 'boolean) @@ -294,7 +316,7 @@ "*If non-nil, ignore articles with identical Message-ID headers." :group 'gnus-summary :type 'boolean) - + (defcustom gnus-single-article-buffer t "*If non-nil, display all articles in the same buffer. If nil, each group will get its own article buffer." @@ -319,11 +341,11 @@ "*Variable used to suggest where articles are to be moved to. It uses the same syntax as the `gnus-split-methods' variable." :group 'gnus-summary-mail - :type '(repeat (choice (list function) - (cons regexp (repeat string)) - sexp))) - -(defcustom gnus-unread-mark ? + :type '(repeat (choice (list :value (fun) function) + (cons :value ("" "") regexp (repeat string)) + (sexp :value nil)))) + +(defcustom gnus-unread-mark ? ;space "*Mark used for unread articles." :group 'gnus-summary-marks :type 'character) @@ -413,6 +435,21 @@ :group 'gnus-summary-marks :type 'character) +(defcustom gnus-undownloaded-mark ?@ + "*Mark used for articles that weren't downloaded." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-downloadable-mark ?% + "*Mark used for articles that are to be downloaded." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-unsendable-mark ?= + "*Mark used for articles that won't be sent." + :group 'gnus-summary-marks + :type 'character) + (defcustom gnus-score-over-mark ?+ "*Score mark used for articles with high scores." :group 'gnus-summary-marks @@ -423,7 +460,7 @@ :group 'gnus-summary-marks :type 'character) -(defcustom gnus-empty-thread-mark ? +(defcustom gnus-empty-thread-mark ? ;space "*There is no thread under the article." :group 'gnus-summary-marks :type 'character) @@ -460,7 +497,7 @@ :type 'boolean) (defcustom gnus-summary-dummy-line-format - "* %(: :%) %S\n" + " %(: :%) %S\n" "*The format specification for the dummy roots in the summary buffer. It works along the same lines as a normal formatting string, with some simple extensions. @@ -477,6 +514,7 @@ %G Group name %p Unprefixed group name %A Current article number +%z Current article score %V Gnus version %U Number of unread articles in the group %e Number of unselected articles in the group @@ -543,7 +581,8 @@ :type 'function) (defcustom gnus-summary-expunge-below nil - "All articles that have a score less than this variable will be expunged." + "All articles that have a score less than this variable will be expunged. +This variable is local to the summary buffers." :group 'gnus-score-default :type '(choice (const :tag "off" nil) integer)) @@ -551,7 +590,9 @@ (defcustom gnus-thread-expunge-below nil "All threads that have a total score less than this variable will be expunged. See `gnus-thread-score-function' for en explanation of what a -\"thread score\" is." +\"thread score\" is. + +This variable is local to the summary buffers." :group 'gnus-treading :group 'gnus-score-default :type '(choice (const :tag "off" nil) @@ -580,6 +621,11 @@ :group 'gnus-summary-various :type 'hook) +(defcustom gnus-summary-prepared-hook nil + "*A hook called as the last thing after the summary buffer has been generated." + :group 'gnus-summary-various + :type 'hook) + (defcustom gnus-summary-generate-hook nil "*A hook run just before generating the summary buffer. This hook is commonly used to customize threading variables and the @@ -619,7 +665,6 @@ :group 'gnus-summary-visual :type 'hook) -;; 1997/5/4 by MORIOKA Tomohiko <morioka@jaist.ac.jp> (defcustom gnus-structured-field-decoder (if (and (featurep 'mule) (boundp 'enable-multibyte-characters)) @@ -712,7 +757,15 @@ . gnus-summary-high-unread-face) ((and (< score default) (= mark gnus-unread-mark)) . gnus-summary-low-unread-face) - ((and (= mark gnus-unread-mark)) + ((= mark gnus-unread-mark) + . gnus-summary-normal-unread-face) + ((and (> score default) (memq mark (list gnus-downloadable-mark + gnus-undownloaded-mark))) + . gnus-summary-high-unread-face) + ((and (< score default) (memq mark (list gnus-downloadable-mark + gnus-undownloaded-mark))) + . gnus-summary-low-unread-face) + ((memq mark (list gnus-downloadable-mark gnus-undownloaded-mark)) . gnus-summary-normal-unread-face) ((> score default) . gnus-summary-high-read-face) @@ -720,7 +773,7 @@ . gnus-summary-low-read-face) (t . gnus-summary-normal-read-face)) - "Controls the highlighting of summary buffer lines. + "*Controls the highlighting of summary buffer lines. A list of (FORM . FACE) pairs. When deciding how a a particular summary line should be displayed, each form is evaluated. The content @@ -737,6 +790,10 @@ :type '(repeat (cons (sexp :tag "Form" nil) face))) +(defcustom gnus-alter-header-function nil + "Function called to allow alteration of article header structures. +The function is called with one parameter, the article header vector, +which it may alter in any way.") ;;; Internal variables @@ -779,7 +836,7 @@ (?x ,(macroexpand '(mail-header-xref gnus-tmp-header)) ?s) (?D ,(macroexpand '(mail-header-date gnus-tmp-header)) ?s) (?d (gnus-dd-mmm (mail-header-date gnus-tmp-header)) ?s) - (?o (gnus-date-iso8601 gnus-tmp-header) ?s) + (?o (gnus-date-iso8601 (mail-header-date gnus-tmp-header)) ?s) (?M ,(macroexpand '(mail-header-id gnus-tmp-header)) ?s) (?r ,(macroexpand '(mail-header-references gnus-tmp-header)) ?s) (?c (or (mail-header-chars gnus-tmp-header) 0) ?d) @@ -827,6 +884,7 @@ (?d (length gnus-newsgroup-dormant) ?d) (?t (length gnus-newsgroup-marked) ?d) (?r (length gnus-newsgroup-reads) ?d) + (?z (gnus-summary-article-score gnus-tmp-article-number) ?d) (?E gnus-newsgroup-expunged-tally ?d) (?s (gnus-current-score-file-nondirectory) ?s))) @@ -884,6 +942,15 @@ (defvar gnus-newsgroup-processable nil "List of articles in the current newsgroup that can be processed.") +(defvar gnus-newsgroup-downloadable nil + "List of articles in the current newsgroup that can be processed.") + +(defvar gnus-newsgroup-undownloaded nil + "List of articles in the current newsgroup that haven't been downloaded..") + +(defvar gnus-newsgroup-unsendable nil + "List of articles in the current newsgroup that won't be sent.") + (defvar gnus-newsgroup-bookmarks nil "List of articles in the current newsgroup that have bookmarks.") @@ -923,6 +990,8 @@ gnus-newsgroup-reads gnus-newsgroup-saved gnus-newsgroup-replied gnus-newsgroup-expirable gnus-newsgroup-processable gnus-newsgroup-killed + gnus-newsgroup-downloadable gnus-newsgroup-undownloaded + gnus-newsgroup-unsendable gnus-newsgroup-bookmarks gnus-newsgroup-dormant gnus-newsgroup-headers gnus-newsgroup-threads gnus-newsgroup-prepared gnus-summary-highlight-line-function @@ -949,6 +1018,22 @@ ;; Subject simplification. +(defun gnus-simplify-whitespace (str) + "Remove excessive whitespace." + (let ((mystr str)) + ;; Multiple spaces. + (while (string-match "[ \t][ \t]+" mystr) + (setq mystr (concat (substring mystr 0 (match-beginning 0)) + " " + (substring mystr (match-end 0))))) + ;; Leading spaces. + (when (string-match "^[ \t]+" mystr) + (setq mystr (substring mystr (match-end 0)))) + ;; Trailing spaces. + (when (string-match "[ \t]+$" mystr) + (setq mystr (substring mystr 0 (match-beginning 0)))) + mystr)) + (defsubst gnus-simplify-subject-re (subject) "Remove \"Re:\" from subject lines." (if (string-match "^[Rr][Ee]: *" subject) @@ -1012,10 +1097,14 @@ (defun gnus-simplify-subject-fuzzy (subject) "Simplify a subject string fuzzily. -See gnus-simplify-buffer-fuzzy for details." +See `gnus-simplify-buffer-fuzzy' for details." (save-excursion (gnus-set-work-buffer) (let ((case-fold-search t)) + ;; Remove uninteresting prefixes. + (when (and gnus-simplify-ignored-prefixes + (string-match gnus-simplify-ignored-prefixes subject)) + (setq subject (substring subject (match-end 0)))) (insert subject) (inline (gnus-simplify-buffer-fuzzy)) (buffer-string)))) @@ -1023,6 +1112,8 @@ (defsubst gnus-simplify-subject-fully (subject) "Simplify a subject string according to gnus-summary-gather-subject-limit." (cond + (gnus-simplify-subject-functions + (gnus-map-function gnus-simplify-subject-functions subject)) ((null gnus-summary-gather-subject-limit) (gnus-simplify-subject-re subject)) ((eq gnus-summary-gather-subject-limit 'fuzzy) @@ -1034,8 +1125,9 @@ subject))) (defsubst gnus-subject-equal (s1 s2 &optional simple-first) - "Check whether two subjects are equal. If optional argument -simple-first is t, first argument is already simplified." + "Check whether two subjects are equal. +If optional argument simple-first is t, first argument is already +simplified." (cond ((null simple-first) (equal (gnus-simplify-subject-fully s1) @@ -1064,7 +1156,9 @@ " " gnus-summary-next-page "\177" gnus-summary-prev-page [delete] gnus-summary-prev-page + [backspace] gnus-summary-prev-page "\r" gnus-summary-scroll-up + "\M-\r" gnus-summary-scroll-down "n" gnus-summary-next-unread-article "p" gnus-summary-prev-unread-article "N" gnus-summary-next-article @@ -1149,6 +1243,7 @@ "\C-c\C-v\C-v" gnus-uu-decode-uu-view "\C-d" gnus-summary-enter-digest-group "\M-\C-d" gnus-summary-read-document + "\M-\C-e" gnus-summary-edit-parameters "\C-c\C-b" gnus-bug "*" gnus-cache-enter-article "\M-*" gnus-cache-remove-article @@ -1156,6 +1251,8 @@ "\C-l" gnus-recenter "I" gnus-summary-increase-score "L" gnus-summary-lower-score + "\M-i" gnus-symbolic-argument + "h" gnus-summary-select-article-buffer "V" gnus-summary-score-map "X" gnus-uu-extract-map @@ -1199,7 +1296,9 @@ "u" gnus-summary-limit-to-unread "m" gnus-summary-limit-to-marks "v" gnus-summary-limit-to-score + "*" gnus-summary-limit-include-cached "D" gnus-summary-limit-include-dormant + "T" gnus-summary-limit-include-thread "d" gnus-summary-limit-exclude-dormant "t" gnus-summary-limit-to-age "E" gnus-summary-limit-include-expunged @@ -1265,6 +1364,7 @@ [delete] gnus-summary-prev-page "p" gnus-summary-prev-page "\r" gnus-summary-scroll-up + "\M-\r" gnus-summary-scroll-down "<" gnus-summary-beginning-of-article ">" gnus-summary-end-of-article "b" gnus-summary-beginning-of-article @@ -1272,6 +1372,7 @@ "^" gnus-summary-refer-parent-article "r" gnus-summary-refer-parent-article "R" gnus-summary-refer-references + "T" gnus-summary-refer-thread "g" gnus-summary-show-article "s" gnus-summary-isearch-article "P" gnus-summary-print-article) @@ -1290,7 +1391,8 @@ "t" gnus-article-hide-headers "v" gnus-summary-verbose-headers "m" gnus-summary-toggle-mime - "h" gnus-article-treat-html) + "h" gnus-article-treat-html + "d" gnus-article-treat-dumbquotes) (gnus-define-keys (gnus-summary-wash-hide-map "W" gnus-summary-wash-map) "a" gnus-article-hide @@ -1298,6 +1400,7 @@ "b" gnus-article-hide-boring-headers "s" gnus-article-hide-signature "c" gnus-article-hide-citation + "C" gnus-article-hide-citation-in-followups "p" gnus-article-hide-pgp "P" gnus-article-hide-pem "\C-c" gnus-article-hide-citation-maybe) @@ -1314,6 +1417,7 @@ "l" gnus-article-date-local "e" gnus-article-date-lapsed "o" gnus-article-date-original + "i" gnus-article-date-iso8601 "s" gnus-article-date-user) (gnus-define-keys (gnus-summary-wash-empty-map "E" gnus-summary-wash-map) @@ -1321,6 +1425,7 @@ "l" gnus-article-strip-leading-blank-lines "m" gnus-article-strip-multiple-blank-lines "a" gnus-article-strip-blank-lines + "A" gnus-article-strip-all-blank-lines "s" gnus-article-strip-leading-space) (gnus-define-keys (gnus-summary-help-map "H" gnus-summary-mode-map) @@ -1341,6 +1446,7 @@ "c" gnus-summary-copy-article "B" gnus-summary-crosspost-article "q" gnus-summary-respool-query + "t" gnus-summary-respool-trace "i" gnus-summary-import-article "p" gnus-summary-article-posted-p) @@ -1389,208 +1495,112 @@ ["Increase score..." gnus-summary-increase-score t] ["Lower score..." gnus-summary-lower-score t])))) - '(("Default header" - ["Ask" (gnus-score-set-default 'gnus-score-default-header nil) - :style radio - :selected (null gnus-score-default-header)] - ["From" (gnus-score-set-default 'gnus-score-default-header 'a) - :style radio - :selected (eq gnus-score-default-header 'a)] - ["Subject" (gnus-score-set-default 'gnus-score-default-header 's) - :style radio - :selected (eq gnus-score-default-header 's)] - ["Article body" - (gnus-score-set-default 'gnus-score-default-header 'b) - :style radio - :selected (eq gnus-score-default-header 'b )] - ["All headers" - (gnus-score-set-default 'gnus-score-default-header 'h) - :style radio - :selected (eq gnus-score-default-header 'h )] - ["Message-ID" (gnus-score-set-default 'gnus-score-default-header 'i) - :style radio - :selected (eq gnus-score-default-header 'i )] - ["Thread" (gnus-score-set-default 'gnus-score-default-header 't) - :style radio - :selected (eq gnus-score-default-header 't )] - ["Crossposting" - (gnus-score-set-default 'gnus-score-default-header 'x) - :style radio - :selected (eq gnus-score-default-header 'x )] - ["Lines" (gnus-score-set-default 'gnus-score-default-header 'l) - :style radio - :selected (eq gnus-score-default-header 'l )] - ["Date" (gnus-score-set-default 'gnus-score-default-header 'd) - :style radio - :selected (eq gnus-score-default-header 'd )] - ["Followups to author" - (gnus-score-set-default 'gnus-score-default-header 'f) - :style radio - :selected (eq gnus-score-default-header 'f )]) - ("Default type" - ["Ask" (gnus-score-set-default 'gnus-score-default-type nil) - :style radio - :selected (null gnus-score-default-type)] - ;; The `:active' key is commented out in the following, - ;; because the GNU Emacs hack to support radio buttons use - ;; active to indicate which button is selected. - ["Substring" (gnus-score-set-default 'gnus-score-default-type 's) - :style radio - ;; :active (not (memq gnus-score-default-header '(l d))) - :selected (eq gnus-score-default-type 's)] - ["Regexp" (gnus-score-set-default 'gnus-score-default-type 'r) - :style radio - ;; :active (not (memq gnus-score-default-header '(l d))) - :selected (eq gnus-score-default-type 'r)] - ["Exact" (gnus-score-set-default 'gnus-score-default-type 'e) - :style radio - ;; :active (not (memq gnus-score-default-header '(l d))) - :selected (eq gnus-score-default-type 'e)] - ["Fuzzy" (gnus-score-set-default 'gnus-score-default-type 'f) - :style radio - ;; :active (not (memq gnus-score-default-header '(l d))) - :selected (eq gnus-score-default-type 'f)] - ["Before date" (gnus-score-set-default 'gnus-score-default-type 'b) - :style radio - ;; :active (eq (gnus-score-default-header 'd)) - :selected (eq gnus-score-default-type 'b)] - ["At date" (gnus-score-set-default 'gnus-score-default-type 'n) - :style radio - ;; :active (eq (gnus-score-default-header 'd)) - :selected (eq gnus-score-default-type 'n)] - ["After date" (gnus-score-set-default 'gnus-score-default-type 'a) - :style radio - ;; :active (eq (gnus-score-default-header 'd)) - :selected (eq gnus-score-default-type 'a)] - ["Less than number" - (gnus-score-set-default 'gnus-score-default-type '<) - :style radio - ;; :active (eq (gnus-score-default-header 'l)) - :selected (eq gnus-score-default-type '<)] - ["Equal to number" - (gnus-score-set-default 'gnus-score-default-type '=) - :style radio - ;; :active (eq (gnus-score-default-header 'l)) - :selected (eq gnus-score-default-type '=)] - ["Greater than number" - (gnus-score-set-default 'gnus-score-default-type '>) - :style radio - ;; :active (eq (gnus-score-default-header 'l)) - :selected (eq gnus-score-default-type '>)]) - ["Default fold" gnus-score-default-fold-toggle - :style toggle - :selected gnus-score-default-fold] - ("Default duration" - ["Ask" (gnus-score-set-default 'gnus-score-default-duration nil) - :style radio - :selected (null gnus-score-default-duration)] - ["Permanent" - (gnus-score-set-default 'gnus-score-default-duration 'p) - :style radio - :selected (eq gnus-score-default-duration 'p)] - ["Temporary" - (gnus-score-set-default 'gnus-score-default-duration 't) - :style radio - :selected (eq gnus-score-default-duration 't)] - ["Immediate" - (gnus-score-set-default 'gnus-score-default-duration 'i) - :style radio - :selected (eq gnus-score-default-duration 'i)])) - - (easy-menu-define - gnus-summary-article-menu gnus-summary-mode-map "" - '("Article" - ("Hide" - ["All" gnus-article-hide t] - ["Headers" gnus-article-hide-headers t] - ["Signature" gnus-article-hide-signature t] - ["Citation" gnus-article-hide-citation t] - ["PGP" gnus-article-hide-pgp t] - ["Boring headers" gnus-article-hide-boring-headers t]) - ("Highlight" - ["All" gnus-article-highlight t] - ["Headers" gnus-article-highlight-headers t] - ["Signature" gnus-article-highlight-signature t] - ["Citation" gnus-article-highlight-citation t]) - ("Date" - ["Local" gnus-article-date-local t] - ["UT" gnus-article-date-ut t] - ["Original" gnus-article-date-original t] - ["Lapsed" gnus-article-date-lapsed t] - ["User-defined" gnus-article-date-user t]) - ("Washing" - ("Remove Blanks" - ["Leading" gnus-article-strip-leading-blank-lines t] - ["Multiple" gnus-article-strip-multiple-blank-lines t] - ["Trailing" gnus-article-remove-trailing-blank-lines t] - ["All of the above" gnus-article-strip-blank-lines t] - ["Leading space" gnus-article-strip-leading-space t]) - ["Overstrike" gnus-article-treat-overstrike t] - ["Emphasis" gnus-article-emphasize t] - ["Word wrap" gnus-article-fill-cited-article t] - ["CR" gnus-article-remove-cr t] - ["Show X-Face" gnus-article-display-x-face t] - ["Quoted-Printable" gnus-article-de-quoted-unreadable t] - ["UnHTMLize" gnus-article-treat-html t] - ["Rot 13" gnus-summary-caesar-message t] - ["Unix pipe" gnus-summary-pipe-message t] - ["Add buttons" gnus-article-add-buttons t] - ["Add buttons to head" gnus-article-add-buttons-to-head t] - ["Stop page breaking" gnus-summary-stop-page-breaking t] - ["Toggle MIME" gnus-summary-toggle-mime t] - ["Verbose header" gnus-summary-verbose-headers t] - ["Toggle header" gnus-summary-toggle-header t]) - ("Output" - ["Save in default format" gnus-summary-save-article t] - ["Save in file" gnus-summary-save-article-file t] - ["Save in Unix mail format" gnus-summary-save-article-mail t] - ["Write to file" gnus-summary-write-article-mail t] - ["Save in MH folder" gnus-summary-save-article-folder t] - ["Save in VM folder" gnus-summary-save-article-vm t] - ["Save in RMAIL mbox" gnus-summary-save-article-rmail t] - ["Save body in file" gnus-summary-save-article-body-file t] - ["Pipe through a filter" gnus-summary-pipe-output t] - ["Add to SOUP packet" gnus-soup-add-article t] - ["Print" gnus-summary-print-article t]) - ("Backend" - ["Respool article..." gnus-summary-respool-article t] - ["Move article..." gnus-summary-move-article - (gnus-check-backend-function - 'request-move-article gnus-newsgroup-name)] - ["Copy article..." gnus-summary-copy-article t] - ["Crosspost article..." gnus-summary-crosspost-article - (gnus-check-backend-function - 'request-replace-article gnus-newsgroup-name)] - ["Import file..." gnus-summary-import-article t] - ["Check if posted" gnus-summary-article-posted-p t] - ["Edit article" gnus-summary-edit-article - (not (gnus-group-read-only-p))] - ["Delete article" gnus-summary-delete-article - (gnus-check-backend-function - 'request-expire-articles gnus-newsgroup-name)] - ["Query respool" gnus-summary-respool-query t] - ["Delete expirable articles" gnus-summary-expire-articles-now - (gnus-check-backend-function - 'request-expire-articles gnus-newsgroup-name)]) - ("Extract" - ["Uudecode" gnus-uu-decode-uu t] - ["Uudecode and save" gnus-uu-decode-uu-and-save t] - ["Unshar" gnus-uu-decode-unshar t] - ["Unshar and save" gnus-uu-decode-unshar-and-save t] - ["Save" gnus-uu-decode-save t] - ["Binhex" gnus-uu-decode-binhex t] - ["Postscript" gnus-uu-decode-postscript t]) - ("Cache" - ["Enter article" gnus-cache-enter-article t] - ["Remove article" gnus-cache-remove-article t]) - ["Enter digest buffer" gnus-summary-enter-digest-group t] - ["Isearch article..." gnus-summary-isearch-article t] - ["Beginning of the article" gnus-summary-beginning-of-article t] - ["End of the article" gnus-summary-end-of-article t] - ["Fetch parent of article" gnus-summary-refer-parent-article t] - ["Fetch referenced articles" gnus-summary-refer-references t] - ["Fetch article with id..." gnus-summary-refer-article t] - ["Redisplay" gnus-summary-show-article t])) + ;; Define both the Article menu in the summary buffer and the equivalent + ;; Commands menu in the article buffer here for consistency. + (let ((innards + '(("Hide" + ["All" gnus-article-hide t] + ["Headers" gnus-article-hide-headers t] + ["Signature" gnus-article-hide-signature t] + ["Citation" gnus-article-hide-citation t] + ["PGP" gnus-article-hide-pgp t] + ["Boring headers" gnus-article-hide-boring-headers t]) + ("Highlight" + ["All" gnus-article-highlight t] + ["Headers" gnus-article-highlight-headers t] + ["Signature" gnus-article-highlight-signature t] + ["Citation" gnus-article-highlight-citation t]) + ("Date" + ["Local" gnus-article-date-local t] + ["ISO8601" gnus-article-date-iso8601 t] + ["UT" gnus-article-date-ut t] + ["Original" gnus-article-date-original t] + ["Lapsed" gnus-article-date-lapsed t] + ["User-defined" gnus-article-date-user t]) + ("Washing" + ("Remove Blanks" + ["Leading" gnus-article-strip-leading-blank-lines t] + ["Multiple" gnus-article-strip-multiple-blank-lines t] + ["Trailing" gnus-article-remove-trailing-blank-lines t] + ["All of the above" gnus-article-strip-blank-lines t] + ["All" gnus-article-strip-all-blank-lines t] + ["Leading space" gnus-article-strip-leading-space t]) + ["Overstrike" gnus-article-treat-overstrike t] + ["Dumb quotes" gnus-article-treat-dumbquotes t] + ["Emphasis" gnus-article-emphasize t] + ["Word wrap" gnus-article-fill-cited-article t] + ["CR" gnus-article-remove-cr t] + ["Show X-Face" gnus-article-display-x-face t] + ["Quoted-Printable" gnus-article-de-quoted-unreadable t] + ["UnHTMLize" gnus-article-treat-html t] + ["Rot 13" gnus-summary-caesar-message t] + ["Unix pipe" gnus-summary-pipe-message t] + ["Add buttons" gnus-article-add-buttons t] + ["Add buttons to head" gnus-article-add-buttons-to-head t] + ["Stop page breaking" gnus-summary-stop-page-breaking t] + ["Toggle MIME" gnus-summary-toggle-mime t] + ["Verbose header" gnus-summary-verbose-headers t] + ["Toggle header" gnus-summary-toggle-header t]) + ("Output" + ["Save in default format" gnus-summary-save-article t] + ["Save in file" gnus-summary-save-article-file t] + ["Save in Unix mail format" gnus-summary-save-article-mail t] + ["Save in MH folder" gnus-summary-save-article-folder t] + ["Save in VM folder" gnus-summary-save-article-vm t] + ["Save in RMAIL mbox" gnus-summary-save-article-rmail t] + ["Save body in file" gnus-summary-save-article-body-file t] + ["Pipe through a filter" gnus-summary-pipe-output t] + ["Add to SOUP packet" gnus-soup-add-article t] + ["Print" gnus-summary-print-article t]) + ("Backend" + ["Respool article..." gnus-summary-respool-article t] + ["Move article..." gnus-summary-move-article + (gnus-check-backend-function + 'request-move-article gnus-newsgroup-name)] + ["Copy article..." gnus-summary-copy-article t] + ["Crosspost article..." gnus-summary-crosspost-article + (gnus-check-backend-function + 'request-replace-article gnus-newsgroup-name)] + ["Import file..." gnus-summary-import-article t] + ["Check if posted" gnus-summary-article-posted-p t] + ["Edit article" gnus-summary-edit-article + (not (gnus-group-read-only-p))] + ["Delete article" gnus-summary-delete-article + (gnus-check-backend-function + 'request-expire-articles gnus-newsgroup-name)] + ["Query respool" gnus-summary-respool-query t] + ["Trace respool" gnus-summary-respool-trace t] + ["Delete expirable articles" gnus-summary-expire-articles-now + (gnus-check-backend-function + 'request-expire-articles gnus-newsgroup-name)]) + ("Extract" + ["Uudecode" gnus-uu-decode-uu t] + ["Uudecode and save" gnus-uu-decode-uu-and-save t] + ["Unshar" gnus-uu-decode-unshar t] + ["Unshar and save" gnus-uu-decode-unshar-and-save t] + ["Save" gnus-uu-decode-save t] + ["Binhex" gnus-uu-decode-binhex t] + ["Postscript" gnus-uu-decode-postscript t]) + ("Cache" + ["Enter article" gnus-cache-enter-article t] + ["Remove article" gnus-cache-remove-article t]) + ["Select article buffer" gnus-summary-select-article-buffer t] + ["Enter digest buffer" gnus-summary-enter-digest-group t] + ["Isearch article..." gnus-summary-isearch-article t] + ["Beginning of the article" gnus-summary-beginning-of-article t] + ["End of the article" gnus-summary-end-of-article t] + ["Fetch parent of article" gnus-summary-refer-parent-article t] + ["Fetch referenced articles" gnus-summary-refer-references t] + ["Fetch current thread" gnus-summary-refer-thread t] + ["Fetch article with id..." gnus-summary-refer-article t] + ["Redisplay" gnus-summary-show-article t]))) + (easy-menu-define + gnus-summary-article-menu gnus-summary-mode-map "" + (cons "Article" innards)) + + (easy-menu-define + gnus-article-commands-menu gnus-article-mode-map "" + (cons "Commands" innards))) (easy-menu-define gnus-summary-thread-menu gnus-summary-mode-map "" @@ -1681,7 +1691,9 @@ ["Mark above" gnus-uu-mark-over t] ["Mark series" gnus-uu-mark-series t] ["Mark region" gnus-uu-mark-region t] + ["Unmark region" gnus-uu-unmark-region t] ["Mark by regexp..." gnus-uu-mark-by-regexp t] + ["Unmark by regexp..." gnus-uu-unmark-by-regexp t] ["Mark all" gnus-uu-mark-all t] ["Mark buffer" gnus-uu-mark-buffer t] ["Mark sparse" gnus-uu-mark-sparse t] @@ -1740,9 +1752,11 @@ 'request-expire-articles gnus-newsgroup-name)] ["Edit local kill file" gnus-summary-edit-local-kill t] ["Edit main kill file" gnus-summary-edit-global-kill t] + ["Edit group parameters" gnus-summary-edit-parameters t] + ["Send a bug report" gnus-bug t] ("Exit" ["Catchup and exit" gnus-summary-catchup-and-exit t] - ["Catchup all and exit" gnus-summary-catchup-and-exit t] + ["Catchup all and exit" gnus-summary-catchup-all-and-exit t] ["Catchup and goto next" gnus-summary-catchup-and-goto-next-group t] ["Exit group" gnus-summary-exit t] ["Exit group without updating" gnus-summary-exit-no-update t] @@ -1752,7 +1766,7 @@ ["Rescan group" gnus-summary-rescan-group t] ["Update dribble" gnus-summary-save-newsrc t]))) - (run-hooks 'gnus-summary-menu-hook))) + (gnus-run-hooks 'gnus-summary-menu-hook))) (defun gnus-score-set-default (var value) "A version of set that updates the GNU Emacs menu-bar." @@ -1880,10 +1894,14 @@ (setq gnus-newsgroup-name group) (make-local-variable 'gnus-summary-line-format) (make-local-variable 'gnus-summary-line-format-spec) + (make-local-variable 'gnus-summary-dummy-line-format) + (make-local-variable 'gnus-summary-dummy-line-format-spec) (make-local-variable 'gnus-summary-mark-positions) (make-local-hook 'post-command-hook) (add-hook 'post-command-hook 'gnus-clear-inboxes-moved nil t) - (run-hooks 'gnus-summary-mode-hook) + (make-local-hook 'pre-command-hook) + (add-hook 'pre-command-hook 'gnus-set-global-variables nil t) + (gnus-run-hooks 'gnus-summary-mode-hook) (gnus-update-format-specifications nil 'summary 'summary-mode 'summary-dummy) (gnus-update-summary-mark-positions)) @@ -1977,21 +1995,26 @@ (when list (let ((data (and after-article (gnus-data-find-list after-article))) (ilist list)) - (or data (not after-article) (error "No such article: %d" after-article)) - ;; Find the last element in the list to be spliced into the main - ;; list. - (while (cdr list) - (setq list (cdr list))) - (if (not data) - (progn - (setcdr list gnus-newsgroup-data) - (setq gnus-newsgroup-data ilist) + (if (not (or data + after-article)) + (let ((odata gnus-newsgroup-data)) + (setq gnus-newsgroup-data (nconc list gnus-newsgroup-data)) (when offset - (gnus-data-update-list (cdr list) offset))) - (setcdr list (cdr data)) - (setcdr data ilist) - (when offset - (gnus-data-update-list (cdr list) offset))) + (gnus-data-update-list odata offset))) + ;; Find the last element in the list to be spliced into the main + ;; list. + (while (cdr list) + (setq list (cdr list))) + (if (not data) + (progn + (setcdr list gnus-newsgroup-data) + (setq gnus-newsgroup-data ilist) + (when offset + (gnus-data-update-list (cdr list) offset))) + (setcdr list (cdr data)) + (setcdr data ilist) + (when offset + (gnus-data-update-list (cdr list) offset)))) (setq gnus-newsgroup-data-reverse nil)))) (defun gnus-data-remove (article &optional offset) @@ -2020,20 +2043,25 @@ (defun gnus-data-update-list (data offset) "Add OFFSET to the POS of all data entries in DATA." + (setq gnus-newsgroup-data-reverse nil) (while data (setcar (nthcdr 2 (car data)) (+ offset (nth 2 (car data)))) (setq data (cdr data)))) (defun gnus-data-compute-positions () "Compute the positions of all articles." - (let ((data gnus-newsgroup-data) - pos) - (while data - (when (setq pos (text-property-any - (point-min) (point-max) - 'gnus-number (gnus-data-number (car data)))) - (gnus-data-set-pos (car data) (+ pos 3))) - (setq data (cdr data))))) + (setq gnus-newsgroup-data-reverse nil) + (let ((data gnus-newsgroup-data)) + (save-excursion + (gnus-save-hidden-threads + (gnus-summary-show-all-threads) + (goto-char (point-min)) + (while data + (while (get-text-property (point) 'gnus-intangible) + (forward-line 1)) + (gnus-data-set-pos (car data) (+ (point) 3)) + (setq data (cdr data)) + (forward-line 1)))))) (defun gnus-summary-article-pseudo-p (article) "Say whether this article is a pseudo article or not." @@ -2094,10 +2122,12 @@ (gnus-summary-last-subject)))) (defmacro gnus-summary-article-header (&optional number) + "Return the header of article NUMBER." `(gnus-data-header (gnus-data-find ,(or number '(gnus-summary-article-number))))) (defmacro gnus-summary-thread-level (&optional number) + "Return the level of thread that starts with article NUMBER." `(if (and (eq gnus-summary-make-false-root 'dummy) (get-text-property (point) 'gnus-intangible)) 0 @@ -2105,10 +2135,12 @@ ,(or number '(gnus-summary-article-number)))))) (defmacro gnus-summary-article-mark (&optional number) + "Return the mark of article NUMBER." `(gnus-data-mark (gnus-data-find ,(or number '(gnus-summary-article-number))))) (defmacro gnus-summary-article-pos (&optional number) + "Return the position of the line of article NUMBER." `(gnus-data-pos (gnus-data-find ,(or number '(gnus-summary-article-number))))) @@ -2131,6 +2163,7 @@ gnus-summary-default-score 0)) (defun gnus-summary-article-children (&optional number) + "Return a list of article numbers that are children of article NUMBER." (let* ((data (gnus-data-find-list (or number (gnus-summary-article-number)))) (level (gnus-data-level (car data))) l children) @@ -2142,6 +2175,7 @@ (nreverse children))) (defun gnus-summary-article-parent (&optional number) + "Return the article number of the parent of article NUMBER." (let* ((data (gnus-data-find-list (or number (gnus-summary-article-number)) (gnus-data-list t))) (level (gnus-data-level (car data)))) @@ -2166,7 +2200,15 @@ (= mark gnus-expirable-mark)))) (defmacro gnus-article-mark (number) + "Return the MARK of article NUMBER. +This macro should only be used when computing the mark the \"first\" +time; i.e., when generating the summary lines. After that, +`gnus-summary-article-mark' should be used to examine the +marks of articles." `(cond + ((memq ,number gnus-newsgroup-unsendable) gnus-unsendable-mark) + ((memq ,number gnus-newsgroup-undownloaded) gnus-undownloaded-mark) + ((memq ,number gnus-newsgroup-downloadable) gnus-downloadable-mark) ((memq ,number gnus-newsgroup-unreads) gnus-unread-mark) ((memq ,number gnus-newsgroup-marked) gnus-ticked-mark) ((memq ,number gnus-newsgroup-dormant) gnus-dormant-mark) @@ -2229,6 +2271,8 @@ ;; selective display). (aset table ?\n nil) (aset table ?\r nil) + ;; We keep TAB as well. + (aset table ?\t nil) ;; We nix out any glyphs over 126 that are not set already. (let ((i 256)) (while (>= (setq i (1- i)) 127) @@ -2246,8 +2290,7 @@ (setq gnus-summary-buffer (current-buffer)) (not gnus-newsgroup-prepared)) ;; Fix by Sudish Joseph <joseph@cis.ohio-state.edu> - (setq gnus-summary-buffer (set-buffer (get-buffer-create buffer))) - (gnus-add-current-to-buffer-list) + (setq gnus-summary-buffer (set-buffer (gnus-get-buffer-create buffer))) (gnus-summary-mode group) (when gnus-carpal (gnus-carpal-setup-buffer 'summary)) @@ -2277,17 +2320,17 @@ (score-file gnus-current-score-file)) (save-excursion (set-buffer gnus-group-buffer) - (setq gnus-newsgroup-name name) - (setq gnus-newsgroup-marked marked) - (setq gnus-newsgroup-unreads unread) - (setq gnus-current-headers headers) - (setq gnus-newsgroup-data data) - (setq gnus-article-current gac) - (setq gnus-summary-buffer summary) - (setq gnus-article-buffer article-buffer) - (setq gnus-original-article-buffer original) - (setq gnus-reffed-article-number reffed) - (setq gnus-current-score-file score-file) + (setq gnus-newsgroup-name name + gnus-newsgroup-marked marked + gnus-newsgroup-unreads unread + gnus-current-headers headers + gnus-newsgroup-data data + gnus-article-current gac + gnus-summary-buffer summary + gnus-article-buffer article-buffer + gnus-original-article-buffer original + gnus-reffed-article-number reffed + gnus-current-score-file score-file) ;; The article buffer also has local variables. (when (gnus-buffer-live-p gnus-article-buffer) (set-buffer gnus-article-buffer) @@ -2323,18 +2366,18 @@ (defun gnus-update-summary-mark-positions () "Compute where the summary marks are to go." (save-excursion - (when (and gnus-summary-buffer - (get-buffer gnus-summary-buffer) - (buffer-name (get-buffer gnus-summary-buffer))) + (when (gnus-buffer-exists-p gnus-summary-buffer) (set-buffer gnus-summary-buffer)) (let ((gnus-replied-mark 129) (gnus-score-below-mark 130) (gnus-score-over-mark 130) + (gnus-download-mark 131) (spec gnus-summary-line-format-spec) - thread gnus-visual pos) + gnus-visual pos) (save-excursion (gnus-set-work-buffer) - (let ((gnus-summary-line-format-spec spec)) + (let ((gnus-summary-line-format-spec spec) + (gnus-newsgroup-downloadable '((0 . t)))) (gnus-summary-insert-line [0 "" "" "" "" "" 0 0 ""] 0 nil 128 t nil "" nil 1) (goto-char (point-min)) @@ -2346,6 +2389,10 @@ pos) (goto-char (point-min)) (push (cons 'score (and (search-forward "\202" nil t) (- (point) 2))) + pos) + (goto-char (point-min)) + (push (cons 'download + (and (search-forward "\203" nil t) (- (point) 2))) pos))) (setq gnus-summary-mark-positions pos)))) @@ -2369,7 +2416,7 @@ (if (or (null gnus-summary-default-score) (<= (abs (- gnus-tmp-score gnus-summary-default-score)) gnus-summary-zcore-fuzz)) - ? + ? ;space (if (< gnus-tmp-score gnus-summary-default-score) gnus-score-below-mark gnus-score-over-mark))) (gnus-tmp-replied @@ -2402,13 +2449,13 @@ (setq gnus-tmp-name gnus-tmp-from)) (unless (numberp gnus-tmp-lines) (setq gnus-tmp-lines 0)) - (gnus-put-text-property + (gnus-put-text-property-excluding-characters-with-faces (point) (progn (eval gnus-summary-line-format-spec) (point)) 'gnus-number gnus-tmp-number) (when (gnus-visual-p 'summary-highlight 'highlight) (forward-line -1) - (run-hooks 'gnus-summary-update-hook) + (gnus-run-hooks 'gnus-summary-update-hook) (forward-line 1)))) (defun gnus-summary-update-line (&optional dont-update) @@ -2434,13 +2481,13 @@ (if (or (null gnus-summary-default-score) (<= (abs (- score gnus-summary-default-score)) gnus-summary-zcore-fuzz)) - ? + ? ;space (if (< score gnus-summary-default-score) gnus-score-below-mark gnus-score-over-mark)) 'score)) ;; Do visual highlighting. (when (gnus-visual-p 'summary-highlight 'highlight) - (run-hooks 'gnus-summary-update-hook))))) + (gnus-run-hooks 'gnus-summary-update-hook))))) (defvar gnus-tmp-new-adopts nil) @@ -2482,14 +2529,14 @@ (and (consp elem) ; Has to be a cons. (consp (cdr elem)) ; The cdr has to be a list. (symbolp (car elem)) ; Has to be a symbol in there. - (not (memq (car elem) - '(quit-config to-address to-list to-group))) + (not (memq (car elem) '(quit-config))) ; Ignore quit-config. (ignore-errors ; So we set it. (make-local-variable (car elem)) (set (car elem) (eval (nth 1 elem)))))))) (defun gnus-summary-read-group (group &optional show-all no-article - kill-buffer no-display) + kill-buffer no-display backward + select-articles) "Start reading news in newsgroup GROUP. If SHOW-ALL is non-nil, already read articles are also listed. If NO-ARTICLE is non-nil, no article is selected initially. @@ -2498,18 +2545,27 @@ (while (and group (null (setq result (let ((gnus-auto-select-next nil)) - (gnus-summary-read-group-1 - group show-all no-article - kill-buffer no-display)))) + (or (gnus-summary-read-group-1 + group show-all no-article + kill-buffer no-display + select-articles) + (setq show-all nil + select-articles nil))))) (eq gnus-auto-select-next 'quietly)) (set-buffer gnus-group-buffer) + ;; The entry function called above goes to the next + ;; group automatically, so we go two groups back + ;; if we are searching for the previous group. + (when backward + (gnus-group-prev-unread-group 2)) (if (not (equal group (gnus-group-group-name))) (setq group (gnus-group-group-name)) (setq group nil))) result)) (defun gnus-summary-read-group-1 (group show-all no-article - kill-buffer no-display) + kill-buffer no-display + &optional select-articles) ;; Killed foreign groups can't be entered. (when (and (not (gnus-group-native-p group)) (not (gnus-gethash group gnus-newsrc-hashtb))) @@ -2517,7 +2573,8 @@ (gnus-message 5 "Retrieving newsgroup: %s..." group) (let* ((new-group (gnus-summary-setup-buffer group)) (quit-config (gnus-group-quit-config group)) - (did-select (and new-group (gnus-select-newsgroup group show-all)))) + (did-select (and new-group (gnus-select-newsgroup + group show-all select-articles)))) (cond ;; This summary buffer exists already, so we just select it. ((not new-group) @@ -2536,6 +2593,9 @@ (kill-buffer (current-buffer)) (if (not quit-config) (progn + ;; Update the info -- marks might need to be removed, + ;; for instance. + (gnus-summary-update-info) (set-buffer gnus-group-buffer) (gnus-group-jump-to-group group) (gnus-group-next-unread-group 1)) @@ -2567,7 +2627,7 @@ (gnus-copy-sequence (gnus-active gnus-newsgroup-name))) ;; You can change the summary buffer in some way with this hook. - (run-hooks 'gnus-select-group-hook) + (gnus-run-hooks 'gnus-select-group-hook) ;; Set any local variables in the group parameters. (gnus-summary-set-local-parameters gnus-newsgroup-name) (gnus-update-format-specifications @@ -2605,7 +2665,7 @@ ((and gnus-newsgroup-scored show-all) (gnus-summary-limit-include-expunged t)))) ;; Function `gnus-apply-kill-file' must be called in this hook. - (run-hooks 'gnus-apply-kill-hook) + (gnus-run-hooks 'gnus-apply-kill-hook) (if (and (zerop (buffer-size)) (not no-display)) (progn @@ -2622,6 +2682,8 @@ (and gnus-show-threads gnus-thread-hide-subtree (gnus-summary-hide-all-threads)) + (when kill-buffer + (gnus-kill-or-deaden-summary kill-buffer)) ;; Show first unread article if requested. (if (and (not no-article) (not no-display) @@ -2635,10 +2697,8 @@ ;; article in the group. (goto-char (point-min)) (gnus-summary-position-point) - (gnus-set-mode-line 'summary) - (gnus-configure-windows 'summary 'force)) - (when kill-buffer - (gnus-kill-or-deaden-summary kill-buffer)) + (gnus-configure-windows 'summary 'force) + (gnus-set-mode-line 'summary)) (when (get-buffer-window gnus-group-buffer t) ;; Gotta use windows, because recenter does weird stuff if ;; the current buffer ain't the displayed window. @@ -2649,6 +2709,7 @@ (select-window owin))) ;; Mark this buffer as "prepared". (setq gnus-newsgroup-prepared t) + (gnus-run-hooks 'gnus-summary-prepared-hook) t))))) (defun gnus-summary-prepare () @@ -2658,7 +2719,7 @@ (erase-buffer) (setq gnus-newsgroup-data nil gnus-newsgroup-data-reverse nil) - (run-hooks 'gnus-summary-generate-hook) + (gnus-run-hooks 'gnus-summary-generate-hook) ;; Generate the buffer, either with threads or without. (when gnus-newsgroup-headers (gnus-summary-prepare-threads @@ -2672,13 +2733,15 @@ (setq gnus-newsgroup-data (nreverse gnus-newsgroup-data)) ;; Call hooks for modifying summary buffer. (goto-char (point-min)) - (run-hooks 'gnus-summary-prepare-hook))) + (gnus-run-hooks 'gnus-summary-prepare-hook))) (defsubst gnus-general-simplify-subject (subject) "Simply subject by the same rules as gnus-gather-threads-by-subject." (setq subject (cond ;; Truncate the subject. + (gnus-simplify-subject-functions + (gnus-map-function gnus-simplify-subject-functions subject)) ((numberp gnus-summary-gather-subject-limit) (setq subject (gnus-simplify-subject-re subject)) (if (> (length subject) gnus-summary-gather-subject-limit) @@ -2699,7 +2762,6 @@ (defun gnus-summary-simplify-subject-query () "Query where the respool algorithm would put this article." (interactive) - (gnus-set-global-variables) (gnus-summary-select-article) (message (gnus-general-simplify-subject (gnus-summary-article-subject)))) @@ -2835,11 +2897,89 @@ gnus-newsgroup-dependencies))) threads)) +;; Build the thread tree. +(defun gnus-dependencies-add-header (header dependencies force-new) + "Enter HEADER into the DEPENDENCIES table if it is not already there. + +If FORCE-NEW is not nil, enter HEADER into the DEPENDENCIES table even +if it was already present. + +If `gnus-summary-ignore-duplicates' is nil then duplicate Message-IDs +will not be entered in the DEPENDENCIES table. Otherwise duplicate +Message-IDs will be renamed be renamed to a unique Message-ID before +being entered. + +Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise." + (let* ((id (mail-header-id header)) + (id-dep (and id (intern id dependencies))) + ref ref-dep ref-header) + ;; Enter this `header' in the `dependencies' table. + (cond + ((not id-dep) + (setq header nil)) + ;; The first two cases do the normal part: enter a new `header' + ;; in the `dependencies' table. + ((not (boundp id-dep)) + (set id-dep (list header))) + ((null (car (symbol-value id-dep))) + (setcar (symbol-value id-dep) header)) + + ;; From here the `header' was already present in the + ;; `dependencies' table. + (force-new + ;; Overrides an existing entry; + ;; just set the header part of the entry. + (setcar (symbol-value id-dep) header)) + + ;; Renames the existing `header' to a unique Message-ID. + ((not gnus-summary-ignore-duplicates) + ;; An article with this Message-ID has already been seen. + ;; We rename the Message-ID. + (set (setq id-dep (intern (setq id (nnmail-message-id)) dependencies)) + (list header)) + (mail-header-set-id header id)) + + ;; The last case ignores an existing entry, except it adds any + ;; additional Xrefs (in case the two articles came from different + ;; servers. + ;; Also sets `header' to `nil' meaning that the `dependencies' + ;; table was *not* modified. + (t + (mail-header-set-xref + (car (symbol-value id-dep)) + (concat (or (mail-header-xref (car (symbol-value id-dep))) + "") + (or (mail-header-xref header) ""))) + (setq header nil))) + + (when header + ;; First check if that we are not creating a References loop. + (setq ref (gnus-parent-id (mail-header-references header))) + (while (and ref + (setq ref-dep (intern-soft ref dependencies)) + (boundp ref-dep) + (setq ref-header (car (symbol-value ref-dep)))) + (if (string= id ref) + ;; Yuk! This is a reference loop. Make the article be a + ;; root article. + (progn + (mail-header-set-references (car (symbol-value id-dep)) "none") + (setq ref nil)) + (setq ref (gnus-parent-id (mail-header-references ref-header))))) + (setq ref (gnus-parent-id (mail-header-references header))) + (setq ref-dep (intern (or ref "none") dependencies)) + (if (boundp ref-dep) + (setcdr (symbol-value ref-dep) + (nconc (cdr (symbol-value ref-dep)) + (list (symbol-value id-dep)))) + (set ref-dep (list nil (symbol-value id-dep))))) + header)) + (defun gnus-build-sparse-threads () (let ((headers gnus-newsgroup-headers) - (deps gnus-newsgroup-dependencies) + (gnus-summary-ignore-duplicates t) header references generation relations - cthread subject child end pthread relation) + subject child end new-child date) ;; First we create an alist of generations/relations, where ;; generations is how much we trust the relation, and the relation ;; is parent/child. @@ -2851,45 +2991,37 @@ (not (string= references ""))) (insert references) (setq child (mail-header-id header) - subject (mail-header-subject header)) - (setq generation 0) + subject (mail-header-subject header) + date (mail-header-date header) + generation 0) (while (search-backward ">" nil t) (setq end (1+ (point))) (when (search-backward "<" nil t) + (setq new-child (buffer-substring (point) end)) (push (list (incf generation) - child (setq child (buffer-substring (point) end)) - subject) + child (setq child new-child) + subject date) relations))) - (push (list (1+ generation) child nil subject) relations) + (when child + (push (list (1+ generation) child nil subject) relations)) (erase-buffer))) (kill-buffer (current-buffer))) ;; Sort over trustworthiness. - (setq relations (sort relations (lambda (r1 r2) (< (car r1) (car r2))))) - (while (setq relation (pop relations)) - (when (if (boundp (setq cthread (intern (cadr relation) deps))) - (unless (car (symbol-value cthread)) - ;; Make this article the parent of these threads. - (setcar (symbol-value cthread) - (vector gnus-reffed-article-number - (cadddr relation) - "" "" - (cadr relation) - (or (caddr relation) "") 0 0 ""))) - (set cthread (list (vector gnus-reffed-article-number - (cadddr relation) - "" "" (cadr relation) - (or (caddr relation) "") 0 0 "")))) - (push gnus-reffed-article-number gnus-newsgroup-limit) - (push gnus-reffed-article-number gnus-newsgroup-sparse) - (push (cons gnus-reffed-article-number gnus-sparse-mark) - gnus-newsgroup-reads) - (decf gnus-reffed-article-number) - ;; Make this new thread the child of its parent. - (if (boundp (setq pthread (intern (or (caddr relation) "none") deps))) - (setcdr (symbol-value pthread) - (nconc (cdr (symbol-value pthread)) - (list (symbol-value cthread)))) - (set pthread (list nil (symbol-value cthread)))))) + (mapcar + (lambda (relation) + (when (gnus-dependencies-add-header + (make-full-mail-header + gnus-reffed-article-number + (nth 3 relation) "" (or (nth 4 relation) "") + (nth 1 relation) + (or (nth 2 relation) "") 0 0 "") + gnus-newsgroup-dependencies nil) + (push gnus-reffed-article-number gnus-newsgroup-limit) + (push gnus-reffed-article-number gnus-newsgroup-sparse) + (push (cons gnus-reffed-article-number gnus-sparse-mark) + gnus-newsgroup-reads) + (decf gnus-reffed-article-number))) + (sort relations 'car-less-than-car)) (gnus-message 7 "Making sparse threads...done"))) (defun gnus-build-old-threads () @@ -2908,11 +3040,64 @@ (setq heads (cdr heads)) (setq id (symbol-name refs)) (while (and (setq id (gnus-build-get-header id)) - (not (car (gnus-gethash - id gnus-newsgroup-dependencies))))) + (not (car (gnus-id-to-thread id))))) (setq heads nil))))) gnus-newsgroup-dependencies))) +;; The following macros and functions were written by Felix Lee +;; <flee@cse.psu.edu>. + +(defmacro gnus-nov-read-integer () + '(prog1 + (if (= (following-char) ?\t) + 0 + (let ((num (ignore-errors (read buffer)))) + (if (numberp num) num 0))) + (unless (eobp) + (search-forward "\t" eol 'move)))) + +(defmacro gnus-nov-skip-field () + '(search-forward "\t" eol 'move)) + +(defmacro gnus-nov-field () + '(buffer-substring (point) (if (gnus-nov-skip-field) (1- (point)) eol))) + +;; This function has to be called with point after the article number +;; on the beginning of the line. +(defsubst gnus-nov-parse-line (number dependencies &optional force-new) + (let ((eol (gnus-point-at-eol)) + (buffer (current-buffer)) + header) + + ;; overview: [num subject from date id refs chars lines misc] + (unwind-protect + (progn + (narrow-to-region (point) eol) + (unless (eobp) + (forward-char)) + + (setq header + (make-full-mail-header + number ; number + (funcall + gnus-unstructured-field-decoder (gnus-nov-field)) ; subject + (funcall + gnus-structured-field-decoder (gnus-nov-field)) ; from + (gnus-nov-field) ; date + (or (gnus-nov-field) + (nnheader-generate-fake-message-id)) ; id + (gnus-nov-field) ; refs + (gnus-nov-read-integer) ; chars + (gnus-nov-read-integer) ; lines + (unless (= (following-char) ?\n) + (gnus-nov-field))))) ; misc + + (widen)) + + (when gnus-alter-header-function + (funcall gnus-alter-header-function header)) + (gnus-dependencies-add-header header dependencies force-new))) + (defun gnus-build-get-header (id) ;; Look through the buffer of NOV lines and find the header to ;; ID. Enter this line into the dependencies hash table, and return @@ -2948,6 +3133,33 @@ (delq number gnus-newsgroup-unselected))) (push number gnus-newsgroup-ancient))))))) +(defun gnus-build-all-threads () + "Read all the headers." + (let ((gnus-summary-ignore-duplicates t) + (dependencies gnus-newsgroup-dependencies) + header article) + (save-excursion + (set-buffer nntp-server-buffer) + (let ((case-fold-search nil)) + (goto-char (point-min)) + (while (not (eobp)) + (ignore-errors + (setq article (read (current-buffer)) + header (gnus-nov-parse-line + article dependencies))) + (when header + (save-excursion + (set-buffer gnus-summary-buffer) + (push header gnus-newsgroup-headers) + (if (memq (setq article (mail-header-number header)) + gnus-newsgroup-unselected) + (progn + (push article gnus-newsgroup-unreads) + (setq gnus-newsgroup-unselected + (delq article gnus-newsgroup-unselected))) + (push article gnus-newsgroup-ancient))) + (forward-line 1))))))) + (defun gnus-summary-update-article-line (article header) "Update the line for ARTICLE using HEADERS." (let* ((id (mail-header-id header)) @@ -2993,7 +3205,7 @@ (defun gnus-summary-update-article (article &optional iheader) "Update ARTICLE in the summary buffer." (set-buffer gnus-summary-buffer) - (let* ((header (or iheader (gnus-summary-article-header article))) + (let* ((header (gnus-summary-article-header article)) (id (mail-header-id header)) (data (gnus-data-find article)) (thread (gnus-id-to-thread id)) @@ -3006,23 +3218,21 @@ references)) "none"))) (buffer-read-only nil) - (old (car thread)) - (number (mail-header-number header)) - pos) + (old (car thread))) (when thread - ;; !!! Should this be in or not? (unless iheader - (setcar thread nil)) - (when parent - (delq thread parent)) - (if (gnus-summary-insert-subject id header iheader) + (setcar thread nil) + (when parent + (delq thread parent))) + (if (gnus-summary-insert-subject id header) ;; Set the (possibly) new article number in the data structure. (gnus-data-set-number data (gnus-id-to-article id)) (setcar thread old) nil)))) -(defun gnus-rebuild-thread (id) - "Rebuild the thread containing ID." +(defun gnus-rebuild-thread (id &optional line) + "Rebuild the thread containing ID. +If LINE, insert the rebuilt thread starting on line LINE." (let ((buffer-read-only nil) old-pos current thread data) (if (not gnus-show-threads) @@ -3052,6 +3262,9 @@ (setq thread (cons subject (gnus-sort-threads roots)))))) (let (threads) ;; We then insert this thread into the summary buffer. + (when line + (goto-char (point-min)) + (forward-line (1- line))) (let (gnus-newsgroup-data gnus-newsgroup-threads) (if gnus-show-threads (gnus-summary-prepare-threads (gnus-cut-threads (list thread))) @@ -3059,8 +3272,15 @@ (setq data (nreverse gnus-newsgroup-data)) (setq threads gnus-newsgroup-threads)) ;; We splice the new data into the data structure. - (gnus-data-enter-list current data (- (point) old-pos)) - (setq gnus-newsgroup-threads (nconc threads gnus-newsgroup-threads))))) + ;;!!! This is kinda bogus. We assume that in LINE is non-nil, + ;;!!! then we want to insert at the beginning of the buffer. + ;;!!! That happens to be true with Gnus now, but that may + ;;!!! change in the future. Perhaps. + (gnus-data-enter-list + (if line nil current) data (- (point) old-pos)) + (setq gnus-newsgroup-threads + (nconc threads gnus-newsgroup-threads)) + (gnus-data-compute-positions)))) (defun gnus-number-to-header (number) "Return the header for article NUMBER." @@ -3071,19 +3291,23 @@ (when headers (car headers)))) -(defun gnus-parent-headers (headers &optional generation) +(defun gnus-parent-headers (in-headers &optional generation) "Return the headers of the GENERATIONeth parent of HEADERS." (unless generation (setq generation 1)) (let ((parent t) + (headers in-headers) references) - (while (and parent headers (not (zerop generation))) - (setq references (mail-header-references headers)) - (when (and references - (setq parent (gnus-parent-id references)) - (setq headers (car (gnus-id-to-thread parent)))) - (decf generation))) - headers)) + (while (and parent + (not (zerop generation)) + (setq references (mail-header-references headers))) + (setq headers (if (and references + (setq parent (gnus-parent-id references))) + (car (gnus-id-to-thread parent)) + nil)) + (decf generation)) + (and (not (eq headers in-headers)) + headers))) (defun gnus-id-to-thread (id) "Return the (sub-)thread where ID appears." @@ -3118,20 +3342,22 @@ (defun gnus-root-id (id) "Return the id of the root of the thread where ID appears." (let (last-id prev) - (while (and id (setq prev (car (gnus-gethash - id gnus-newsgroup-dependencies)))) + (while (and id (setq prev (car (gnus-id-to-thread id)))) (setq last-id id id (gnus-parent-id (mail-header-references prev)))) last-id)) +(defun gnus-articles-in-thread (thread) + "Return the list of articles in THREAD." + (cons (mail-header-number (car thread)) + (apply 'nconc (mapcar 'gnus-articles-in-thread (cdr thread))))) + (defun gnus-remove-thread (id &optional dont-remove) "Remove the thread that has ID in it." - (let ((dep gnus-newsgroup-dependencies) - headers thread last-id) + (let (headers thread last-id) ;; First go up in this thread until we find the root. - (setq last-id (gnus-root-id id)) - (setq headers (list (car (gnus-id-to-thread last-id)) - (caadr (gnus-id-to-thread last-id)))) + (setq last-id (gnus-root-id id) + headers (message-flatten-list (gnus-id-to-thread last-id))) ;; We have now found the real root of this thread. It might have ;; been gathered into some loose thread, so we have to search ;; through the threads to find the thread we wanted. @@ -3160,7 +3386,7 @@ (if thread (unless dont-remove (setq gnus-newsgroup-threads (delq thread gnus-newsgroup-threads))) - (setq thread (gnus-gethash last-id dep))) + (setq thread (gnus-id-to-thread last-id))) (when thread (prog1 thread ; We return this thread. @@ -3170,12 +3396,18 @@ ;; If we use dummy roots, then we have to remove the ;; dummy root as well. (when (eq gnus-summary-make-false-root 'dummy) + ;; We go to the dummy root by going to + ;; the first sub-"thread", and then one line up. + (gnus-summary-goto-article + (mail-header-number (caadr thread))) + (forward-line -1) (gnus-delete-line) (gnus-data-compute-positions)) (setq thread (cdr thread)) (while thread (gnus-remove-thread-1 (car thread)) (setq thread (cdr thread)))) + (gnus-summary-show-all-threads) (gnus-remove-thread-1 thread)))))))) (defun gnus-remove-thread-1 (thread) @@ -3198,10 +3430,10 @@ "Sort THREADS." (if (not gnus-thread-sort-functions) threads - (gnus-message 7 "Sorting threads...") + (gnus-message 8 "Sorting threads...") (prog1 (sort threads (gnus-make-sort-function gnus-thread-sort-functions)) - (gnus-message 7 "Sorting threads...done")))) + (gnus-message 8 "Sorting threads...done")))) (defun gnus-sort-articles (articles) "Sort ARTICLES." @@ -3320,8 +3552,7 @@ (apply gnus-thread-score-function (or (append (mapcar 'gnus-thread-total-score - (cdr (gnus-gethash (mail-header-id root) - gnus-newsgroup-dependencies))) + (cdr (gnus-id-to-thread (mail-header-id root)))) (when (> (mail-header-number root) 0) (list (or (cdr (assq (mail-header-number root) gnus-newsgroup-scored)) @@ -3368,7 +3599,6 @@ (while (or threads stack gnus-tmp-new-adopts new-roots) (if (and (= gnus-tmp-level 0) - (not (setq gnus-tmp-dummy-line nil)) (or (not stack) (= (caar stack) 0)) (not gnus-tmp-false-parent) @@ -3483,7 +3713,10 @@ (when gnus-tmp-header ;; We may have an old dummy line to output before this ;; article. - (when gnus-tmp-dummy-line + (when (and gnus-tmp-dummy-line + (gnus-subject-equal + gnus-tmp-dummy-line + (mail-header-subject gnus-tmp-header))) (gnus-summary-insert-dummy-line gnus-tmp-dummy-line (mail-header-number gnus-tmp-header)) (setq gnus-tmp-dummy-line nil)) @@ -3530,7 +3763,7 @@ (if (or (null gnus-summary-default-score) (<= (abs (- gnus-tmp-score gnus-summary-default-score)) gnus-summary-zcore-fuzz)) - ? + ? ;space (if (< gnus-tmp-score gnus-summary-default-score) gnus-score-below-mark gnus-score-over-mark)) gnus-tmp-replied @@ -3560,13 +3793,13 @@ (setq gnus-tmp-name gnus-tmp-from)) (unless (numberp gnus-tmp-lines) (setq gnus-tmp-lines 0)) - (gnus-put-text-property + (gnus-put-text-property-excluding-characters-with-faces (point) (progn (eval gnus-summary-line-format-spec) (point)) 'gnus-number number) (when gnus-visual-p (forward-line -1) - (run-hooks 'gnus-summary-update-hook) + (gnus-run-hooks 'gnus-summary-update-hook) (forward-line 1)) (setq gnus-tmp-prev-subject subject))) @@ -3614,13 +3847,14 @@ (cdr (assq number gnus-newsgroup-scored)) (memq number gnus-newsgroup-processable)))))) -(defun gnus-select-newsgroup (group &optional read-all) +(defun gnus-select-newsgroup (group &optional read-all select-articles) "Select newsgroup GROUP. -If READ-ALL is non-nil, all articles in the group are selected." +If READ-ALL is non-nil, all articles in the group are selected. +If SELECT-ARTICLES, only select those articles from GROUP." (let* ((entry (gnus-gethash group gnus-newsrc-hashtb)) ;;!!! Dirty hack; should be removed. (gnus-summary-ignore-duplicates - (if (eq (car (gnus-find-method-for-group group)) 'nnvirtual) + (if (eq (car (gnus-find-method-for-group group)) 'nnvirtual) t gnus-summary-ignore-duplicates)) (info (nth 2 entry)) @@ -3665,10 +3899,13 @@ (setq gnus-newsgroup-processable nil) (gnus-update-read-articles group gnus-newsgroup-unreads) - (unless (gnus-ephemeral-group-p gnus-newsgroup-name) - (gnus-group-update-group group)) - - (setq articles (gnus-articles-to-read group read-all)) + + (if (setq articles select-articles) + (setq gnus-newsgroup-unselected + (gnus-sorted-intersection + gnus-newsgroup-unreads + (gnus-sorted-complement gnus-newsgroup-unreads articles))) + (setq articles (gnus-articles-to-read group read-all))) (cond ((null articles) @@ -3688,11 +3925,11 @@ articles gnus-newsgroup-name ;; We might want to fetch old headers, but ;; not if there is only 1 article. - (and gnus-fetch-old-headers - (or (and + (and (or (and (not (eq gnus-fetch-old-headers 'some)) (not (numberp gnus-fetch-old-headers))) - (> (length articles) 1)))))) + (> (length articles) 1)) + gnus-fetch-old-headers)))) (gnus-get-newsgroup-headers-xover articles nil nil gnus-newsgroup-name t) (gnus-get-newsgroup-headers))) @@ -3719,9 +3956,14 @@ (gnus-update-missing-marks (gnus-sorted-complement fetched-articles articles)) ;; We might want to build some more threads first. - (and gnus-fetch-old-headers - (eq gnus-headers-retrieved-by 'nov) - (gnus-build-old-threads)) + (when (and gnus-fetch-old-headers + (eq gnus-headers-retrieved-by 'nov)) + (if (eq gnus-fetch-old-headers 'invisible) + (gnus-build-all-threads) + (gnus-build-old-threads))) + ;; Let the Gnus agent mark articles as read. + (when gnus-agent + (gnus-agent-get-undownloaded-list)) ;; Check whether auto-expire is to be done in this group. (setq gnus-newsgroup-auto-expire (gnus-group-auto-expirable-p group)) @@ -3865,7 +4107,7 @@ (set var (delq article (symbol-value var)))))))))) (defun gnus-update-missing-marks (missing) - "Go through the list of MISSING articles and remove them mark lists." + "Go through the list of MISSING articles and remove them from the mark lists." (when missing (let ((types gnus-article-mark-lists) var m) @@ -4055,6 +4297,41 @@ (gnus-group-make-articles-read name idlist)))) xref-hashtb))))) +(defun gnus-compute-read-articles (group articles) + (let* ((entry (gnus-gethash group gnus-newsrc-hashtb)) + (info (nth 2 entry)) + (active (gnus-active group)) + ninfo) + (when entry + ;; First peel off all illegal article numbers. + (when active + (let ((ids articles) + id first) + (while (setq id (pop ids)) + (when (and first (> id (cdr active))) + ;; We'll end up in this situation in one particular + ;; obscure situation. If you re-scan a group and get + ;; a new article that is cross-posted to a different + ;; group that has not been re-scanned, you might get + ;; crossposted article that has a higher number than + ;; Gnus believes possible. So we re-activate this + ;; group as well. This might mean doing the + ;; crossposting thingy will *increase* the number + ;; of articles in some groups. Tsk, tsk. + (setq active (or (gnus-activate-group group) active))) + (when (or (> id (cdr active)) + (< id (car active))) + (setq articles (delq id articles)))))) + ;; If the read list is nil, we init it. + (if (and active + (null (gnus-info-read info)) + (> (car active) 1)) + (setq ninfo (cons 1 (1- (car active)))) + (setq ninfo (gnus-info-read info))) + ;; Then we add the read articles to the range. + (gnus-add-to-range + ninfo (setq articles (sort articles '<)))))) + (defun gnus-group-make-articles-read (group articles) "Update the info of GROUP to say that ARTICLES are read." (let* ((num 0) @@ -4062,64 +4339,38 @@ (info (nth 2 entry)) (active (gnus-active group)) range) - ;; First peel off all illegal article numbers. - (when active - (let ((ids articles) - id first) - (while (setq id (pop ids)) - (when (and first (> id (cdr active))) - ;; We'll end up in this situation in one particular - ;; obscure situation. If you re-scan a group and get - ;; a new article that is cross-posted to a different - ;; group that has not been re-scanned, you might get - ;; crossposted article that has a higher number than - ;; Gnus believes possible. So we re-activate this - ;; group as well. This might mean doing the - ;; crossposting thingy will *increase* the number - ;; of articles in some groups. Tsk, tsk. - (setq active (or (gnus-activate-group group) active))) - (when (or (> id (cdr active)) - (< id (car active))) - (setq articles (delq id articles)))))) - (save-excursion - (set-buffer gnus-group-buffer) - (gnus-undo-register - `(progn - (gnus-info-set-marks ',info ',(gnus-info-marks info) t) - (gnus-info-set-read ',info ',(gnus-info-read info)) - (gnus-get-unread-articles-in-group ',info (gnus-active ,group)) - (gnus-group-update-group ,group t)))) - ;; If the read list is nil, we init it. - (and active - (null (gnus-info-read info)) - (> (car active) 1) - (gnus-info-set-read info (cons 1 (1- (car active))))) - ;; Then we add the read articles to the range. - (gnus-info-set-read - info - (setq range - (gnus-add-to-range - (gnus-info-read info) (setq articles (sort articles '<))))) - ;; Then we have to re-compute how many unread - ;; articles there are in this group. - (when active - (cond - ((not range) - (setq num (- (1+ (cdr active)) (car active)))) - ((not (listp (cdr range))) - (setq num (- (cdr active) (- (1+ (cdr range)) - (car range))))) - (t - (while range - (if (numberp (car range)) - (setq num (1+ num)) - (setq num (+ num (- (1+ (cdar range)) (caar range))))) - (setq range (cdr range))) - (setq num (- (cdr active) num)))) - ;; Update the number of unread articles. - (setcar entry num) - ;; Update the group buffer. - (gnus-group-update-group group t)))) + (when entry + (setq range (gnus-compute-read-articles group articles)) + (save-excursion + (set-buffer gnus-group-buffer) + (gnus-undo-register + `(progn + (gnus-info-set-marks ',info ',(gnus-info-marks info) t) + (gnus-info-set-read ',info ',(gnus-info-read info)) + (gnus-get-unread-articles-in-group ',info (gnus-active ,group)) + (gnus-group-update-group ,group t)))) + ;; Add the read articles to the range. + (gnus-info-set-read info range) + ;; Then we have to re-compute how many unread + ;; articles there are in this group. + (when active + (cond + ((not range) + (setq num (- (1+ (cdr active)) (car active)))) + ((not (listp (cdr range))) + (setq num (- (cdr active) (- (1+ (cdr range)) + (car range))))) + (t + (while range + (if (numberp (car range)) + (setq num (1+ num)) + (setq num (+ num (- (1+ (cdar range)) (caar range))))) + (setq range (cdr range))) + (setq num (- (cdr active) num)))) + ;; Update the number of unread articles. + (setcar entry num) + ;; Update the group buffer. + (gnus-group-update-group group t))))) (defun gnus-methods-equal-p (m1 m2) (let ((m1 (or m1 gnus-select-method)) @@ -4138,14 +4389,14 @@ (or dependencies (save-excursion (set-buffer gnus-summary-buffer) gnus-newsgroup-dependencies))) - headers id id-dep ref-dep end ref) + headers id end ref) (save-excursion (set-buffer nntp-server-buffer) ;; Translate all TAB characters into SPACE characters. (subst-char-in-region (point-min) (point-max) ?\t ? t) - (run-hooks 'gnus-parse-headers-hook) + (gnus-run-hooks 'gnus-parse-headers-hook) (let ((case-fold-search t) - in-reply-to header p lines) + in-reply-to header p lines chars) (goto-char (point-min)) ;; Search to the beginning of the next header. Error messages ;; do not begin with 2 or 3. @@ -4174,7 +4425,6 @@ (progn (goto-char p) (if (search-forward "\nsubject: " nil t) - ;; 1997/5/4 by MORIOKA Tomohiko <morioka@jaist.ac.jp> (funcall gnus-unstructured-field-decoder (nnheader-header-value)) "(none)")) @@ -4182,7 +4432,6 @@ (progn (goto-char p) (if (search-forward "\nfrom: " nil t) - ;; 1997/5/4 by MORIOKA Tomohiko <morioka@jaist.ac.jp> (funcall gnus-structured-field-decoder (nnheader-header-value)) "(nobody)")) @@ -4194,10 +4443,12 @@ ;; Message-ID. (progn (goto-char p) - (setq id (if (search-forward "\nmessage-id:" nil t) - (buffer-substring - (1- (or (search-forward "<" nil t) (point))) - (or (search-forward ">" nil t) (point))) + (setq id (if (re-search-forward + "^message-id: *\\(<[^\n\t> ]+>\\)" nil t) + ;; We do it this way to make sure the Message-ID + ;; is (somewhat) syntactically valid. + (buffer-substring (match-beginning 1) + (match-end 1)) ;; If there was no message-id, we just fake one ;; to make subsequent routines simpler. (nnheader-generate-fake-message-id)))) @@ -4224,11 +4475,23 @@ (if (and (search-forward "\nin-reply-to: " nil t) (setq in-reply-to (nnheader-header-value)) (string-match "<[^>]+>" in-reply-to)) - (setq ref (substring in-reply-to (match-beginning 0) - (match-end 0))) + (let (ref2) + (setq ref (substring in-reply-to (match-beginning 0) + (match-end 0))) + (while (string-match "<[^>]+>" in-reply-to (match-end 0)) + (setq ref2 (substring in-reply-to (match-beginning 0) + (match-end 0))) + (when (> (length ref2) (length ref)) + (setq ref ref2))) + ref) (setq ref nil)))) ;; Chars. - 0 + (progn + (goto-char p) + (if (search-forward "\nchars: " nil t) + (if (numberp (setq chars (ignore-errors (read cur)))) + chars 0) + 0)) ;; Lines. (progn (goto-char p) @@ -4243,146 +4506,20 @@ (nnheader-header-value))))) (when (equal id ref) (setq ref nil)) - ;; We do the threading while we read the headers. The - ;; message-id and the last reference are both entered into - ;; the same hash table. Some tippy-toeing around has to be - ;; done in case an article has arrived before the article - ;; which it refers to. - (if (boundp (setq id-dep (intern id dependencies))) - (if (and (car (symbol-value id-dep)) - (not force-new)) - ;; An article with this Message-ID has already been seen. - (if gnus-summary-ignore-duplicates - ;; We ignore this one, except we add - ;; any additional Xrefs (in case the two articles - ;; came from different servers). - (progn - (mail-header-set-xref - (car (symbol-value id-dep)) - (concat (or (mail-header-xref - (car (symbol-value id-dep))) - "") - (or (mail-header-xref header) ""))) - (setq header nil)) - ;; We rename the Message-ID. - (set - (setq id-dep (intern (setq id (nnmail-message-id)) - dependencies)) - (list header)) - (mail-header-set-id header id)) - (setcar (symbol-value id-dep) header)) - (set id-dep (list header))) - (when header - (if (boundp (setq ref-dep (intern (or ref "none") dependencies))) - (setcdr (symbol-value ref-dep) - (nconc (cdr (symbol-value ref-dep)) - (list (symbol-value id-dep)))) - (set ref-dep (list nil (symbol-value id-dep)))) + + (when gnus-alter-header-function + (funcall gnus-alter-header-function header) + (setq id (mail-header-id header) + ref (gnus-parent-id (mail-header-references header)))) + + (when (setq header + (gnus-dependencies-add-header + header dependencies force-new)) (push header headers)) (goto-char (point-max)) (widen)) (nreverse headers))))) -;; The following macros and functions were written by Felix Lee -;; <flee@cse.psu.edu>. - -(defmacro gnus-nov-read-integer () - '(prog1 - (if (= (following-char) ?\t) - 0 - (let ((num (ignore-errors (read buffer)))) - (if (numberp num) num 0))) - (unless (eobp) - (forward-char 1)))) - -(defmacro gnus-nov-skip-field () - '(search-forward "\t" eol 'move)) - -(defmacro gnus-nov-field () - '(buffer-substring (point) (if (gnus-nov-skip-field) (1- (point)) eol))) - -;; (defvar gnus-nov-none-counter 0) - -;; This function has to be called with point after the article number -;; on the beginning of the line. -(defun gnus-nov-parse-line (number dependencies &optional force-new) - (let ((eol (gnus-point-at-eol)) - (buffer (current-buffer)) - header ref id id-dep ref-dep) - - ;; overview: [num subject from date id refs chars lines misc] - (unwind-protect - (progn - (narrow-to-region (point) eol) - (unless (eobp) - (forward-char)) - - (setq header - (vector - number ; number - ;; 1997/5/4 by MORIOKA Tomohiko <morioka@jaist.ac.jp> - (funcall - gnus-unstructured-field-decoder (gnus-nov-field)) ; subject - (funcall - gnus-structured-field-decoder (gnus-nov-field)) ; from - (gnus-nov-field) ; date - (setq id (or (gnus-nov-field) - (nnheader-generate-fake-message-id))) ; id - (progn - (let ((beg (point))) - (search-forward "\t" eol) - (if (search-backward ">" beg t) - (setq ref - (buffer-substring - (1+ (point)) - (search-backward "<" beg t))) - (setq ref nil)) - (goto-char beg)) - (gnus-nov-field)) ; refs - (gnus-nov-read-integer) ; chars - (gnus-nov-read-integer) ; lines - (if (= (following-char) ?\n) - nil - (gnus-nov-field))))) ; misc - - (widen)) - - ;; We build the thread tree. - (when (equal id ref) - ;; This article refers back to itself. Naughty, naughty. - (setq ref nil)) - (if (boundp (setq id-dep (intern id dependencies))) - (if (and (car (symbol-value id-dep)) - (not force-new)) - ;; An article with this Message-ID has already been seen. - (if gnus-summary-ignore-duplicates - ;; We ignore this one, except we add any additional - ;; Xrefs (in case the two articles came from different - ;; servers. - (progn - (mail-header-set-xref - (car (symbol-value id-dep)) - (concat (or (mail-header-xref - (car (symbol-value id-dep))) - "") - (or (mail-header-xref header) ""))) - (setq header nil)) - ;; We rename the Message-ID. - (set - (setq id-dep (intern (setq id (nnmail-message-id)) - dependencies)) - (list header)) - (mail-header-set-id header id)) - (setcar (symbol-value id-dep) header)) - (set id-dep (list header))) - (when header - (if (boundp (setq ref-dep (intern (or ref "none") dependencies))) - (setcdr (symbol-value ref-dep) - (nconc (cdr (symbol-value ref-dep)) - (list (symbol-value id-dep)))) - (set ref-dep (list nil (symbol-value id-dep))))) - header)) - ;; Goes through the xover lines and returns a list of vectors (defun gnus-get-newsgroup-headers-xover (sequence &optional force-new dependencies @@ -4398,7 +4535,7 @@ (save-excursion (set-buffer nntp-server-buffer) ;; Allow the user to mangle the headers before parsing them. - (run-hooks 'gnus-parse-headers-hook) + (gnus-run-hooks 'gnus-parse-headers-hook) (goto-char (point-min)) (while (not (eobp)) (condition-case () @@ -4459,17 +4596,27 @@ (mail-header-set-xref headers xref))))))) (defun gnus-summary-insert-subject (id &optional old-header use-old-header) - "Find article ID and insert the summary line for that article." - (let ((header (if (and old-header use-old-header) - old-header (gnus-read-header id))) + "Find article ID and insert the summary line for that article. +OLD-HEADER can either be a header or a line number to insert +the subject line on." + (let* ((line (and (numberp old-header) old-header)) + (old-header (and (vectorp old-header) old-header)) + (header (cond ((and old-header use-old-header) + old-header) + ((and (numberp id) + (gnus-number-to-header id)) + (gnus-number-to-header id)) + (t + (gnus-read-header id)))) (number (and (numberp id) id)) - pos d) + d) (when header ;; Rebuild the thread that this article is part of and go to the ;; article we have fetched. (when (and (not gnus-show-threads) old-header) - (when (setq d (gnus-data-find (mail-header-number old-header))) + (when (and number + (setq d (gnus-data-find (mail-header-number old-header)))) (goto-char (gnus-data-pos d)) (gnus-data-remove number @@ -4483,7 +4630,8 @@ (delq (setq number (mail-header-number header)) gnus-newsgroup-sparse)) (setq gnus-newsgroup-ancient (delq number gnus-newsgroup-ancient)) - (gnus-rebuild-thread (mail-header-id header)) + (push number gnus-newsgroup-limit) + (gnus-rebuild-thread (mail-header-id header) line) (gnus-summary-goto-subject number nil t)) (when (and (numberp number) (> number 0)) @@ -4503,47 +4651,63 @@ ;;; Process/prefix in the summary buffer (defun gnus-summary-work-articles (n) - "Return a list of articles to be worked upon. The prefix argument, -the list of process marked articles, and the current article will be -taken into consideration." - (cond - (n - ;; A numerical prefix has been given. - (setq n (prefix-numeric-value n)) - (let ((backward (< n 0)) - (n (abs (prefix-numeric-value n))) - articles article) - (save-excursion - (while - (and (> n 0) - (push (setq article (gnus-summary-article-number)) - articles) - (if backward - (gnus-summary-find-prev nil article) - (gnus-summary-find-next nil article))) - (decf n))) - (nreverse articles))) - ((gnus-region-active-p) - ;; Work on the region between point and mark. - (let ((max (max (point) (mark))) - articles article) - (save-excursion - (goto-char (min (point) (mark))) - (while - (and - (push (setq article (gnus-summary-article-number)) articles) - (gnus-summary-find-next nil article) - (< (point) max))) - (nreverse articles)))) - (gnus-newsgroup-processable - ;; There are process-marked articles present. - ;; Save current state. - (gnus-summary-save-process-mark) - ;; Return the list. - (reverse gnus-newsgroup-processable)) - (t - ;; Just return the current article. - (list (gnus-summary-article-number))))) + "Return a list of articles to be worked upon. +The prefix argument, the list of process marked articles, and the +current article will be taken into consideration." + (save-excursion + (set-buffer gnus-summary-buffer) + (cond + (n + ;; A numerical prefix has been given. + (setq n (prefix-numeric-value n)) + (let ((backward (< n 0)) + (n (abs (prefix-numeric-value n))) + articles article) + (save-excursion + (while + (and (> n 0) + (push (setq article (gnus-summary-article-number)) + articles) + (if backward + (gnus-summary-find-prev nil article) + (gnus-summary-find-next nil article))) + (decf n))) + (nreverse articles))) + ((and (gnus-region-active-p) (mark)) + (message "region active") + ;; Work on the region between point and mark. + (let ((max (max (point) (mark))) + articles article) + (save-excursion + (goto-char (min (min (point) (mark)))) + (while + (and + (push (setq article (gnus-summary-article-number)) articles) + (gnus-summary-find-next nil article) + (< (point) max))) + (nreverse articles)))) + (gnus-newsgroup-processable + ;; There are process-marked articles present. + ;; Save current state. + (gnus-summary-save-process-mark) + ;; Return the list. + (reverse gnus-newsgroup-processable)) + (t + ;; Just return the current article. + (list (gnus-summary-article-number)))))) + +(defmacro gnus-summary-iterate (arg &rest forms) + "Iterate over the process/prefixed articles and do FORMS. +ARG is the interactive prefix given to the command. FORMS will be +executed with point over the summary line of the articles." + (let ((articles (make-symbol "gnus-summary-iterate-articles"))) + `(let ((,articles (gnus-summary-work-articles ,arg))) + (while ,articles + (gnus-summary-goto-subject (car ,articles)) + ,@forms)))) + +(put 'gnus-summary-iterate 'lisp-indent-function 1) +(put 'gnus-summary-iterate 'edebug-form-spec '(form body)) (defun gnus-summary-save-process-mark () "Push the current set of process marked articles on the stack." @@ -4589,7 +4753,7 @@ (save-excursion (gnus-group-best-unread-group exclude-group)))) -(defun gnus-summary-find-next (&optional unread article backward) +(defun gnus-summary-find-next (&optional unread article backward undownloaded) (if backward (gnus-summary-find-prev) (let* ((dummy (gnus-summary-article-intangible-p)) (article (or article (gnus-summary-article-number))) @@ -4604,7 +4768,10 @@ (if unread (progn (while arts - (when (gnus-data-unread-p (car arts)) + (when (or (and undownloaded + (eq gnus-undownloaded-mark + (gnus-data-mark (car arts)))) + (gnus-data-unread-p (car arts))) (setq result (car arts) arts nil)) (setq arts (cdr arts))) @@ -4740,12 +4907,12 @@ ;; first unread article is the article after the last read ;; article. Sounds logical, doesn't it? (if (not (listp (cdr read))) - (setq first (1+ (cdr read))) + (setq first (max (car active) (1+ (cdr read)))) ;; `read' is a list of ranges. (when (/= (setq nlast (or (and (numberp (car read)) (car read)) (caar read))) 1) - (setq first 1)) + (setq first (car active))) (while read (when first (while (< first nlast) @@ -4759,7 +4926,7 @@ (push first unread) (setq first (1+ first))) ;; Return the list of unread articles. - (nreverse unread))) + (delq 0 (nreverse unread)))) (defun gnus-list-of-read-articles (group) "Return a list of unread, unticked and non-dormant articles." @@ -4777,10 +4944,17 @@ ;; Various summary commands +(defun gnus-summary-select-article-buffer () + "Reconfigure windows to show article buffer." + (interactive) + (if (not (gnus-buffer-live-p gnus-article-buffer)) + (error "There is no article buffer for this summary buffer") + (gnus-configure-windows 'article) + (select-window (get-buffer-window gnus-article-buffer)))) + (defun gnus-summary-universal-argument (arg) "Perform any operation on all articles that are process/prefixed." (interactive "P") - (gnus-set-global-variables) (let ((articles (gnus-summary-work-articles arg)) func article) (if (eq @@ -4814,7 +4988,6 @@ "Exit and then reselect the current newsgroup. The prefix argument ALL means to select all articles." (interactive "P") - (gnus-set-global-variables) (when (gnus-ephemeral-group-p gnus-newsgroup-name) (error "Ephemeral groups can't be reselected")) (let ((current-subject (gnus-summary-article-number)) @@ -4838,43 +5011,42 @@ (defun gnus-summary-update-info (&optional non-destructive) (save-excursion (let ((group gnus-newsgroup-name)) - (when gnus-newsgroup-kill-headers - (setq gnus-newsgroup-killed - (gnus-compress-sequence - (nconc - (gnus-set-sorted-intersection - (gnus-uncompress-range gnus-newsgroup-killed) - (setq gnus-newsgroup-unselected - (sort gnus-newsgroup-unselected '<))) - (setq gnus-newsgroup-unreads - (sort gnus-newsgroup-unreads '<))) - t))) - (unless (listp (cdr gnus-newsgroup-killed)) - (setq gnus-newsgroup-killed (list gnus-newsgroup-killed))) - (let ((headers gnus-newsgroup-headers)) - (when (and (not gnus-save-score) - (not non-destructive)) - (setq gnus-newsgroup-scored nil)) - ;; Set the new ranges of read articles. - (save-excursion + (when group + (when gnus-newsgroup-kill-headers + (setq gnus-newsgroup-killed + (gnus-compress-sequence + (nconc + (gnus-set-sorted-intersection + (gnus-uncompress-range gnus-newsgroup-killed) + (setq gnus-newsgroup-unselected + (sort gnus-newsgroup-unselected '<))) + (setq gnus-newsgroup-unreads + (sort gnus-newsgroup-unreads '<))) + t))) + (unless (listp (cdr gnus-newsgroup-killed)) + (setq gnus-newsgroup-killed (list gnus-newsgroup-killed))) + (let ((headers gnus-newsgroup-headers)) + ;; Set the new ranges of read articles. + (save-excursion + (set-buffer gnus-group-buffer) + (gnus-undo-force-boundary)) + (gnus-update-read-articles + group (append gnus-newsgroup-unreads gnus-newsgroup-unselected)) + ;; Set the current article marks. + (let ((gnus-newsgroup-scored + (if (and (not gnus-save-score) + (not non-destructive)) + nil + gnus-newsgroup-scored))) + (save-excursion + (gnus-update-marks))) + ;; Do the cross-ref thing. + (when gnus-use-cross-reference + (gnus-mark-xrefs-as-read group headers gnus-newsgroup-unreads)) + ;; Do not switch windows but change the buffer to work. (set-buffer gnus-group-buffer) - (gnus-undo-force-boundary)) - (gnus-update-read-articles - group (append gnus-newsgroup-unreads gnus-newsgroup-unselected)) - ;; Set the current article marks. - (gnus-update-marks) - ;; Do the cross-ref thing. - (when gnus-use-cross-reference - (gnus-mark-xrefs-as-read group headers gnus-newsgroup-unreads)) - ;; Do adaptive scoring, and possibly save score files. - (when gnus-newsgroup-adaptive - (gnus-score-adaptive)) - (when gnus-use-scoring - (gnus-score-save)) - ;; Do not switch windows but change the buffer to work. - (set-buffer gnus-group-buffer) - (unless (gnus-ephemeral-group-p gnus-newsgroup-name) - (gnus-group-update-group group)))))) + (unless (gnus-ephemeral-group-p group) + (gnus-group-update-group group))))))) (defun gnus-summary-save-newsrc (&optional force) "Save the current number of read/marked articles in the dribble buffer. @@ -4892,12 +5064,13 @@ (interactive) (gnus-set-global-variables) (gnus-kill-save-kill-buffer) + (gnus-async-halt-prefetch) (let* ((group gnus-newsgroup-name) (quit-config (gnus-group-quit-config gnus-newsgroup-name)) (mode major-mode) (group-point nil) (buf (current-buffer))) - (run-hooks 'gnus-summary-prepare-exit-hook) + (gnus-run-hooks 'gnus-summary-prepare-exit-hook) ;; If we have several article buffers, we kill them at exit. (unless gnus-single-article-buffer (gnus-kill-buffer gnus-original-article-buffer) @@ -4910,17 +5083,27 @@ (gnus-dup-enter-articles)) (when gnus-use-trees (gnus-tree-close group)) + ;; Remove entries for this group. + (nnmail-purge-split-history (gnus-group-real-name group)) ;; Make all changes in this group permanent. (unless quit-config - (run-hooks 'gnus-exit-group-hook) - (gnus-summary-update-info)) + (gnus-run-hooks 'gnus-exit-group-hook) + (gnus-summary-update-info) + ;; Do adaptive scoring, and possibly save score files. + (when gnus-newsgroup-adaptive + (gnus-score-adaptive)) + (when gnus-use-scoring + (gnus-score-save))) (gnus-close-group group) ;; Make sure where we were, and go to next newsgroup. (set-buffer gnus-group-buffer) (unless quit-config (gnus-group-jump-to-group group)) - (run-hooks 'gnus-summary-exit-hook) - (unless quit-config + (gnus-run-hooks 'gnus-summary-exit-hook) + (unless (or quit-config + ;; If this group has disappeared from the summary + ;; buffer, don't skip forwards. + (not (string= group (gnus-group-group-name)))) (gnus-group-next-unread-group 1)) (setq group-point (point)) (if temporary @@ -4949,12 +5132,12 @@ (gnus-kill-buffer buf))) (setq gnus-current-select-method gnus-select-method) (pop-to-buffer gnus-group-buffer) - ;; Clear the current group name. (if (not quit-config) (progn (goto-char group-point) (gnus-configure-windows 'group 'force)) (gnus-handle-ephemeral-exit quit-config)) + ;; Clear the current group name. (unless quit-config (setq gnus-newsgroup-name nil))))) @@ -4962,12 +5145,13 @@ (defun gnus-summary-exit-no-update (&optional no-questions) "Quit reading current newsgroup without updating read article info." (interactive) - (gnus-set-global-variables) (let* ((group gnus-newsgroup-name) (quit-config (gnus-group-quit-config group))) (when (or no-questions gnus-expert-user (gnus-y-or-n-p "Discard changes to this group and exit? ")) + (gnus-async-halt-prefetch) + (gnus-run-hooks 'gnus-summary-prepare-exit-hook) ;; If we have several article buffers, we kill them at exit. (unless gnus-single-article-buffer (gnus-kill-buffer gnus-article-buffer) @@ -4998,8 +5182,8 @@ (gnus-handle-ephemeral-exit quit-config))))) (defun gnus-handle-ephemeral-exit (quit-config) - "Handle movement when leaving an ephemeral group. The state -which existed when entering the ephemeral is reset." + "Handle movement when leaving an ephemeral group. +The state which existed when entering the ephemeral is reset." (if (not (buffer-name (car quit-config))) (gnus-configure-windows 'group 'force) (set-buffer (car quit-config)) @@ -5079,25 +5263,24 @@ (defun gnus-kill-or-deaden-summary (buffer) "Kill or deaden the summary BUFFER." - (when (and (buffer-name buffer) - (not gnus-single-article-buffer)) - (save-excursion - (set-buffer buffer) - (gnus-kill-buffer gnus-article-buffer) - (gnus-kill-buffer gnus-original-article-buffer))) - (cond (gnus-kill-summary-on-exit - (when (and gnus-use-trees - (and (get-buffer buffer) - (buffer-name (get-buffer buffer)))) + (save-excursion + (when (and (buffer-name buffer) + (not gnus-single-article-buffer)) + (save-excursion + (set-buffer buffer) + (gnus-kill-buffer gnus-article-buffer) + (gnus-kill-buffer gnus-original-article-buffer))) + (cond (gnus-kill-summary-on-exit + (when (and gnus-use-trees + (gnus-buffer-exists-p buffer)) + (save-excursion + (set-buffer buffer) + (gnus-tree-close gnus-newsgroup-name))) + (gnus-kill-buffer buffer)) + ((gnus-buffer-exists-p buffer) (save-excursion - (set-buffer (get-buffer buffer)) - (gnus-tree-close gnus-newsgroup-name))) - (gnus-kill-buffer buffer)) - ((and (get-buffer buffer) - (buffer-name (get-buffer buffer))) - (save-excursion - (set-buffer buffer) - (gnus-deaden-summary))))) + (set-buffer buffer) + (gnus-deaden-summary)))))) (defun gnus-summary-wake-up-the-dead (&rest args) "Wake up the dead summary buffer." @@ -5148,7 +5331,6 @@ initially. If NEXT-GROUP, go to this group. If BACKWARD, go to previous group instead." (interactive "P") - (gnus-set-global-variables) ;; Stop pre-fetching. (gnus-async-halt-prefetch) (let ((current-group gnus-newsgroup-name) @@ -5177,7 +5359,7 @@ (when (gnus-buffer-live-p current-buffer) (set-buffer current-buffer) (gnus-summary-exit)) - (run-hooks 'gnus-group-no-more-groups-hook)) + (gnus-run-hooks 'gnus-group-no-more-groups-hook)) ;; We try to enter the target group. (gnus-group-jump-to-group target-group) (let ((unreads (gnus-group-group-unread))) @@ -5185,7 +5367,8 @@ (and unreads (not (zerop unreads)))) (gnus-summary-read-group target-group nil no-article - (and (buffer-name current-buffer) current-buffer))) + (and (buffer-name current-buffer) current-buffer) + nil backward)) (setq entered t) (setq current-group target-group target-group nil))))))) @@ -5198,7 +5381,7 @@ ;; Walking around summary lines. -(defun gnus-summary-first-subject (&optional unread) +(defun gnus-summary-first-subject (&optional unread undownloaded) "Go to the first unread subject. If UNREAD is non-nil, go to the first unread article. Returns the article selected or nil if there are no unread articles." @@ -5221,7 +5404,10 @@ (t (let ((data gnus-newsgroup-data)) (while (and data - (not (gnus-data-unread-p (car data)))) + (and (not (and undownloaded + (eq gnus-undownloaded-mark + (gnus-data-mark (car data))))) + (not (gnus-data-unread-p (car data))))) (setq data (cdr data))) (when data (goto-char (gnus-data-pos (car data))) @@ -5241,6 +5427,7 @@ (if backward (gnus-summary-find-prev unread) (gnus-summary-find-next unread))) + (gnus-summary-show-thread) (setq n (1- n))) (when (/= 0 n) (gnus-message 7 "No more%s articles" @@ -5275,7 +5462,10 @@ ;; We read in the article if we have to. (and (not data) force - (gnus-summary-insert-subject article (and (vectorp force) force) t) + (gnus-summary-insert-subject + article + (if (or (numberp force) (vectorp force)) force) + t) (setq data (gnus-data-find article))) (goto-char b) (if (not data) @@ -5284,6 +5474,7 @@ (gnus-message 3 "Can't find article %d" article)) nil) (goto-char (gnus-data-pos data)) + (gnus-summary-position-point) article))) ;; Walking around summary lines with displaying articles. @@ -5292,7 +5483,6 @@ "Make the summary buffer take up the entire Emacs frame. Given a prefix, will force an `article' buffer configuration." (interactive "P") - (gnus-set-global-variables) (if arg (gnus-configure-windows 'article 'force) (gnus-configure-windows 'summary 'force))) @@ -5306,7 +5496,7 @@ (if gnus-summary-display-article-function (funcall gnus-summary-display-article-function article all-header) (gnus-article-prepare article all-header)) - (run-hooks 'gnus-select-article-hook) + (gnus-run-hooks 'gnus-select-article-hook) (when (and gnus-current-article (not (zerop gnus-current-article))) (gnus-summary-goto-subject gnus-current-article)) @@ -5369,7 +5559,6 @@ If SUBJECT, only articles with SUBJECT are selected. If BACKWARD, the previous article is selected instead of the next." (interactive "P") - (gnus-set-global-variables) (cond ;; Is there such an article? ((and (gnus-summary-search-forward unread subject backward) @@ -5387,7 +5576,7 @@ (not unread) (not subject)) (gnus-summary-goto-article (if backward (1- gnus-newsgroup-begin) (1+ gnus-newsgroup-end)) - nil t)) + nil (count-lines (point-min) (point)))) ;; Go to next/previous group. (t (unless (gnus-ephemeral-group-p gnus-newsgroup-name) @@ -5509,6 +5698,9 @@ (let ((article (gnus-summary-article-number)) (article-window (get-buffer-window gnus-article-buffer t)) endp) + ;; If the buffer is empty, we have no article. + (unless article + (error "No article to select")) (gnus-configure-windows 'article) (if (eq (cdr (assq article gnus-newsgroup-reads)) gnus-canceled-mark) (if (and (eq gnus-summary-goto-unread 'never) @@ -5543,7 +5735,6 @@ If MOVE, move to the previous unread article if point is at the beginning of the buffer." (interactive "P") - (gnus-set-global-variables) (let ((article (gnus-summary-article-number)) (article-window (get-buffer-window gnus-article-buffer t)) endp) @@ -5579,7 +5770,6 @@ "Scroll up (or down) one line current article. Argument LINES specifies lines to be scrolled up (or down if negative)." (interactive "p") - (gnus-set-global-variables) (gnus-configure-windows 'article) (gnus-summary-show-thread) (when (eq (gnus-summary-select-article nil nil 'pseudo) 'old) @@ -5592,35 +5782,36 @@ (gnus-summary-recenter) (gnus-summary-position-point)) +(defun gnus-summary-scroll-down (lines) + "Scroll down (or up) one line current article. +Argument LINES specifies lines to be scrolled down (or up if negative)." + (interactive "p") + (gnus-summary-scroll-up (- lines))) + (defun gnus-summary-next-same-subject () "Select next article which has the same subject as current one." (interactive) - (gnus-set-global-variables) (gnus-summary-next-article nil (gnus-summary-article-subject))) (defun gnus-summary-prev-same-subject () "Select previous article which has the same subject as current one." (interactive) - (gnus-set-global-variables) (gnus-summary-prev-article nil (gnus-summary-article-subject))) (defun gnus-summary-next-unread-same-subject () "Select next unread article which has the same subject as current one." (interactive) - (gnus-set-global-variables) (gnus-summary-next-article t (gnus-summary-article-subject))) (defun gnus-summary-prev-unread-same-subject () "Select previous unread article which has the same subject as current one." (interactive) - (gnus-set-global-variables) (gnus-summary-prev-article t (gnus-summary-article-subject))) (defun gnus-summary-first-unread-article () "Select the first unread article. Return nil if there are no unread articles." (interactive) - (gnus-set-global-variables) (prog1 (when (gnus-summary-first-subject t) (gnus-summary-show-thread) @@ -5632,7 +5823,6 @@ "Select the first article. Return nil if there are no articles." (interactive) - (gnus-set-global-variables) (prog1 (when (gnus-summary-first-subject) (gnus-summary-show-thread) @@ -5643,7 +5833,6 @@ (defun gnus-summary-best-unread-article () "Select the unread article with the highest score." (interactive) - (gnus-set-global-variables) (let ((best -1000000) (data gnus-newsgroup-data) article score) @@ -5668,21 +5857,27 @@ (gnus-summary-goto-subject article)))) (defun gnus-summary-goto-article (article &optional all-headers force) - "Fetch ARTICLE and display it if it exists. -If ALL-HEADERS is non-nil, no header lines are hidden." + "Fetch ARTICLE (article number or Message-ID) and display it if it exists. +If ALL-HEADERS is non-nil, no header lines are hidden. +If FORCE, go to the article even if it isn't displayed. If FORCE +is a number, it is the line the article is to be displayed on." (interactive (list - (string-to-int - (completing-read - "Article number: " - (mapcar (lambda (number) (list (int-to-string number))) - gnus-newsgroup-limit))) + (completing-read + "Article number or Message-ID: " + (mapcar (lambda (number) (list (int-to-string number))) + gnus-newsgroup-limit)) current-prefix-arg t)) (prog1 - (if (gnus-summary-goto-subject article force) - (gnus-summary-display-article article all-headers) - (gnus-message 4 "Couldn't go to article %s" article) nil) + (if (and (stringp article) + (string-match "@" article)) + (gnus-summary-refer-article article) + (when (stringp article) + (setq article (string-to-number article))) + (if (gnus-summary-goto-subject article force) + (gnus-summary-display-article article all-headers) + (gnus-message 4 "Couldn't go to article %s" article) nil)) (gnus-summary-position-point))) (defun gnus-summary-goto-last-article () @@ -5690,7 +5885,7 @@ (interactive) (prog1 (when gnus-last-article - (gnus-summary-goto-article gnus-last-article)) + (gnus-summary-goto-article gnus-last-article nil t)) (gnus-summary-position-point))) (defun gnus-summary-pop-article (number) @@ -5701,7 +5896,7 @@ (setq gnus-newsgroup-history (cdr (setq to (nthcdr number gnus-newsgroup-history)))) (if to - (gnus-summary-goto-article (car to)) + (gnus-summary-goto-article (car to) nil t) (error "Article history empty"))) (gnus-summary-position-point)) @@ -5711,7 +5906,6 @@ "Limit the summary buffer to the next N articles. If not given a prefix, use the process marked articles instead." (interactive "P") - (gnus-set-global-variables) (prog1 (let ((articles (gnus-summary-work-articles n))) (setq gnus-newsgroup-processable nil) @@ -5722,7 +5916,6 @@ "Restore the previous limit. If given a prefix, remove all limits." (interactive "P") - (gnus-set-global-variables) (when total (setq gnus-newsgroup-limits (list (mapcar (lambda (h) (mail-header-number h)) @@ -5767,7 +5960,9 @@ (setq is-younger (nnmail-time-less (nnmail-time-since (nnmail-date-to-time date)) cutoff)) - (when (if younger-p is-younger (not is-younger)) + (when (if younger-p + is-younger + (not is-younger)) (push (gnus-data-number d) articles)))) (gnus-summary-limit (nreverse articles))) (gnus-summary-position-point))) @@ -5810,8 +6005,7 @@ not marked with MARKS. MARKS can either be a string of marks or a list of marks. Returns how many articles were removed." - (interactive (list (read-string "Marks: ") current-prefix-arg)) - (gnus-set-global-variables) + (interactive "sMarks: \nP") (prog1 (let ((data gnus-newsgroup-data) (marks (if (listp marks) marks @@ -5828,7 +6022,6 @@ (defun gnus-summary-limit-to-score (&optional score) "Limit to articles with score at or above SCORE." (interactive "P") - (gnus-set-global-variables) (setq score (if score (prefix-numeric-value score) (or gnus-summary-default-score 0))) @@ -5843,10 +6036,20 @@ (gnus-summary-limit articles) (gnus-summary-position-point)))) +(defun gnus-summary-limit-include-thread (id) + "Display all the hidden articles that in the current thread." + (interactive (list (mail-header-id (gnus-summary-article-header)))) + (let ((articles (gnus-articles-in-thread + (gnus-id-to-thread (gnus-root-id id))))) + (prog1 + (gnus-summary-limit (nconc articles gnus-newsgroup-limit)) + (gnus-summary-position-point)))) + (defun gnus-summary-limit-include-dormant () - "Display all the hidden articles that are marked as dormant." + "Display all the hidden articles that are marked as dormant. +Note that this command only works on a subset of the articles currently +fetched for this group." (interactive) - (gnus-set-global-variables) (unless gnus-newsgroup-dormant (error "There are no dormant articles in this group")) (prog1 @@ -5856,7 +6059,6 @@ (defun gnus-summary-limit-exclude-dormant () "Hide all dormant articles." (interactive) - (gnus-set-global-variables) (prog1 (gnus-summary-limit-to-marks (list gnus-dormant-mark) 'reverse) (gnus-summary-position-point))) @@ -5864,7 +6066,6 @@ (defun gnus-summary-limit-exclude-childless-dormant () "Hide all dormant articles that have no children." (interactive) - (gnus-set-global-variables) (let ((data (gnus-data-list t)) articles d children) ;; Find all articles that are either not dormant or have @@ -5897,7 +6098,8 @@ '<) (sort gnus-newsgroup-limit '<))) article) - (setq gnus-newsgroup-unreads gnus-newsgroup-limit) + (setq gnus-newsgroup-unreads + (gnus-intersection gnus-newsgroup-unreads gnus-newsgroup-limit)) (if all (setq gnus-newsgroup-dormant nil gnus-newsgroup-marked nil @@ -5945,6 +6147,7 @@ ;; after the current one. (goto-char (point-max)) (gnus-summary-find-prev)) + (gnus-set-mode-line 'summary) ;; We return how many articles were removed from the summary ;; buffer as a result of the new limit. (- total (length gnus-newsgroup-data)))) @@ -5960,6 +6163,7 @@ (defsubst gnus-cut-thread (thread) "Go forwards in the thread until we find an article that we want to display." (when (or (eq gnus-fetch-old-headers 'some) + (eq gnus-fetch-old-headers 'invisible) (eq gnus-build-sparse-threads 'some) (eq gnus-build-sparse-threads 'more)) ;; Deal with old-fetched headers and sparse threads. @@ -5969,25 +6173,26 @@ (gnus-summary-article-sparse-p (mail-header-number (car thread))) (gnus-summary-article-ancient-p (mail-header-number (car thread)))) - (progn - (if (<= (length (cdr thread)) 1) - (setq gnus-newsgroup-limit - (delq (mail-header-number (car thread)) + (if (or (<= (length (cdr thread)) 1) + (eq gnus-fetch-old-headers 'invisible)) + (setq gnus-newsgroup-limit + (delq (mail-header-number (car thread)) + gnus-newsgroup-limit) + thread (cadr thread)) + (when (gnus-invisible-cut-children (cdr thread)) + (let ((th (cdr thread))) + (while th + (if (memq (mail-header-number (caar th)) gnus-newsgroup-limit) - thread (cadr thread)) - (when (gnus-invisible-cut-children (cdr thread)) - (let ((th (cdr thread))) - (while th - (if (memq (mail-header-number (caar th)) - gnus-newsgroup-limit) - (setq thread (car th) - th nil) - (setq th (cdr th))))))))))) + (setq thread (car th) + th nil) + (setq th (cdr th)))))))))) thread) (defun gnus-cut-threads (threads) "Cut off all uninteresting articles from the beginning of threads." (when (or (eq gnus-fetch-old-headers 'some) + (eq gnus-fetch-old-headers 'invisible) (eq gnus-build-sparse-threads 'some) (eq gnus-build-sparse-threads 'more)) (let ((th threads)) @@ -6005,6 +6210,7 @@ (if (or gnus-inhibit-limiting (and (null gnus-newsgroup-dormant) (not (eq gnus-fetch-old-headers 'some)) + (not (eq gnus-fetch-old-headers 'invisible)) (null gnus-summary-expunge-below) (not (eq gnus-build-sparse-threads 'some)) (not (eq gnus-build-sparse-threads 'more)) @@ -6060,6 +6266,10 @@ (and (eq gnus-fetch-old-headers 'some) (gnus-summary-article-ancient-p number) (zerop children)) + ;; If this is "fetch-old-headered" and `invisible', then + ;; we don't want this article. + (and (eq gnus-fetch-old-headers 'invisible) + (gnus-summary-article-ancient-p number)) ;; If this is a sparsely inserted article with no children, ;; we don't want it. (and (eq gnus-build-sparse-threads 'some) @@ -6121,7 +6331,6 @@ If N is negative, go to ancestor -N instead. The difference between N and the number of articles fetched is returned." (interactive "p") - (gnus-set-global-variables) (let ((skip 1) error header ref) (when (not (natnump n)) @@ -6162,9 +6371,8 @@ (defun gnus-summary-refer-references () "Fetch all articles mentioned in the References header. -Return how many articles were fetched." +Return the number of articles fetched." (interactive) - (gnus-set-global-variables) (let ((ref (mail-header-references (gnus-summary-article-header))) (current (gnus-summary-article-number)) (n 0)) @@ -6182,6 +6390,30 @@ (gnus-summary-position-point) n))) +(defun gnus-summary-refer-thread (&optional limit) + "Fetch all articles in the current thread. +If LIMIT (the numerical prefix), fetch that many old headers instead +of what's specified by the `gnus-refer-thread-limit' variable." + (interactive "P") + (let ((id (mail-header-id (gnus-summary-article-header))) + (limit (if limit (prefix-numeric-value limit) + gnus-refer-thread-limit))) + ;; We want to fetch LIMIT *old* headers, but we also have to + ;; re-fetch all the headers in the current buffer, because many of + ;; them may be undisplayed. So we adjust LIMIT. + (when (numberp limit) + (incf limit (- gnus-newsgroup-end gnus-newsgroup-begin))) + (unless (eq gnus-fetch-old-headers 'invisible) + (gnus-message 5 "Fetching headers for %s..." gnus-newsgroup-name) + ;; Retrieve the headers and read them in. + (if (eq (gnus-retrieve-headers + (list gnus-newsgroup-end) gnus-newsgroup-name limit) + 'nov) + (gnus-build-all-threads) + (error "Can't fetch thread from backends that don't support NOV")) + (gnus-message 5 "Fetching headers for %s...done" gnus-newsgroup-name)) + (gnus-summary-limit-include-thread id))) + (defun gnus-summary-refer-article (message-id &optional arg) "Fetch an article specified by MESSAGE-ID. If ARG (the prefix), fetch the article using `gnus-refer-article-method' @@ -6201,16 +6433,18 @@ (mail-header-number header)) (memq (mail-header-number header) gnus-newsgroup-limit)))) - (if (and header - (or (not (gnus-summary-article-sparse-p - (mail-header-number header))) - sparse)) - (prog1 - ;; The article is present in the buffer, so we just go to it. - (gnus-summary-goto-article - (mail-header-number header) nil t) - (when sparse - (gnus-summary-update-article (mail-header-number header)))) + (cond + ;; If the article is present in the buffer we just go to it. + ((and header + (or (not (gnus-summary-article-sparse-p + (mail-header-number header))) + sparse)) + (prog1 + (gnus-summary-goto-article + (mail-header-number header) nil t) + (when sparse + (gnus-summary-update-article (mail-header-number header))))) + (t ;; We fetch the article (let ((gnus-override-method (cond ((gnus-news-group-p gnus-newsgroup-name) @@ -6226,14 +6460,18 @@ ;; Fetch the header, and display the article. (if (setq number (gnus-summary-insert-subject message-id)) (gnus-summary-select-article nil nil nil number) - (gnus-message 3 "Couldn't fetch article %s" message-id))))))) + (gnus-message 3 "Couldn't fetch article %s" message-id)))))))) + +(defun gnus-summary-edit-parameters () + "Edit the group parameters of the current group." + (interactive) + (gnus-group-edit-group gnus-newsgroup-name 'params)) (defun gnus-summary-enter-digest-group (&optional force) "Enter an nndoc group based on the current article. If FORCE, force a digest interpretation. If not, try to guess what the document format is." (interactive "P") - (gnus-set-global-variables) (let ((conf gnus-current-window-configuration)) (save-excursion (gnus-summary-select-article)) @@ -6331,12 +6569,12 @@ "Do incremental search forward on the current article. If REGEXP-P (the prefix) is non-nil, do regexp isearch." (interactive "P") - (gnus-set-global-variables) (gnus-summary-select-article) (gnus-configure-windows 'article) (gnus-eval-in-buffer-window gnus-article-buffer - ;;(goto-char (point-min)) - (isearch-forward regexp-p))) + (save-restriction + (widen) + (isearch-forward regexp-p)))) (defun gnus-summary-search-article-forward (regexp &optional backward) "Search for an article containing REGEXP forward. @@ -6349,7 +6587,6 @@ (concat ", default " gnus-last-search-regexp) ""))) current-prefix-arg)) - (gnus-set-global-variables) (if (string-equal regexp "") (setq regexp (or gnus-last-search-regexp "")) (setq gnus-last-search-regexp regexp)) @@ -6471,7 +6708,6 @@ current-prefix-arg)) (when (equal header "Body") (setq header "")) - (gnus-set-global-variables) ;; Hidden thread subtrees must be searched as well. (gnus-summary-show-all-threads) ;; We don't want to change current point nor window configuration. @@ -6487,7 +6723,6 @@ (defun gnus-summary-beginning-of-article () "Scroll the article back to the beginning." (interactive) - (gnus-set-global-variables) (gnus-summary-select-article) (gnus-configure-windows 'article) (gnus-eval-in-buffer-window gnus-article-buffer @@ -6499,7 +6734,6 @@ (defun gnus-summary-end-of-article () "Scroll to the end of the article." (interactive) - (gnus-set-global-variables) (gnus-summary-select-article) (gnus-configure-windows 'article) (gnus-eval-in-buffer-window gnus-article-buffer @@ -6509,32 +6743,48 @@ (when gnus-page-broken (gnus-narrow-to-page)))) -(defun gnus-summary-print-article (&optional filename) - "Generate and print a PostScript image of the article buffer. - -If the optional argument FILENAME is nil, send the image to the printer. -If FILENAME is a string, save the PostScript image in a file with that -name. If FILENAME is a number, prompt the user for the name of the file +(defun gnus-summary-print-article (&optional filename n) + "Generate and print a PostScript image of the N next (mail) articles. + +If N is negative, print the N previous articles. If N is nil and articles +have been marked with the process mark, print these instead. + +If the optional second argument FILENAME is nil, send the image to the +printer. If FILENAME is a string, save the PostScript image in a file with +that name. If FILENAME is a number, prompt the user for the name of the file to save in." - (interactive (list (ps-print-preprint current-prefix-arg))) - (gnus-summary-select-article) - (gnus-eval-in-buffer-window gnus-article-buffer - (let ((buffer (generate-new-buffer " *print*"))) - (unwind-protect - (progn - (copy-to-buffer buffer (point-min) (point-max)) - (set-buffer buffer) - (gnus-article-delete-invisible-text) - (run-hooks 'gnus-ps-print-hook) - (ps-print-buffer-with-faces filename)) - (kill-buffer buffer))))) + (interactive (list (ps-print-preprint current-prefix-arg) + current-prefix-arg)) + (dolist (article (gnus-summary-work-articles n)) + (gnus-summary-select-article nil nil 'pseudo article) + (gnus-eval-in-buffer-window gnus-article-buffer + (let ((buffer (generate-new-buffer " *print*"))) + (unwind-protect + (progn + (copy-to-buffer buffer (point-min) (point-max)) + (set-buffer buffer) + (gnus-article-delete-invisible-text) + (let ((ps-left-header + (list + (concat "(" + (mail-header-subject gnus-current-headers) ")") + (concat "(" + (mail-header-from gnus-current-headers) ")"))) + (ps-right-header + (list + "/pagenumberstring load" + (concat "(" + (mail-header-date gnus-current-headers) ")")))) + (gnus-run-hooks 'gnus-ps-print-hook) + (save-excursion + (ps-print-buffer-with-faces filename)))) + (kill-buffer buffer)))))) (defun gnus-summary-show-article (&optional arg) "Force re-fetching of the current article. If ARG (the prefix) is non-nil, show the raw article without any article massaging functions being run." (interactive "P") - (gnus-set-global-variables) (if (not arg) ;; Select the article the normal way. (gnus-summary-select-article nil 'force) @@ -6554,7 +6804,6 @@ If ARG is a positive number, turn header display on. If ARG is a negative number, turn header display off." (interactive "P") - (gnus-set-global-variables) (setq gnus-show-all-headers (cond ((or (not (numberp arg)) (zerop arg)) @@ -6568,7 +6817,6 @@ If ARG is a positive number, show the entire header. If ARG is a negative number, hide the unwanted header lines." (interactive "P") - (gnus-set-global-variables) (save-excursion (set-buffer gnus-article-buffer) (let* ((buffer-read-only nil) @@ -6587,21 +6835,19 @@ (setq e (1- (or (search-forward "\n\n" nil t) (point-max))))) (insert-buffer-substring gnus-original-article-buffer 1 e) (let ((article-inhibit-hiding t)) - (run-hooks 'gnus-article-display-hook)) + (gnus-run-hooks 'gnus-article-display-hook)) (when (or (not hidden) (and (numberp arg) (< arg 0))) (gnus-article-hide-headers))))) (defun gnus-summary-show-all-headers () "Make all header lines visible." (interactive) - (gnus-set-global-variables) (gnus-article-show-all-headers)) (defun gnus-summary-toggle-mime (&optional arg) "Toggle MIME processing. If ARG is a positive number, turn MIME processing on." (interactive "P") - (gnus-set-global-variables) (setq gnus-show-mime (if (null arg) (not gnus-show-mime) (> (prefix-numeric-value arg) 0))) @@ -6612,7 +6858,6 @@ The numerical prefix specifies how many places to rotate each letter forward." (interactive "P") - (gnus-set-global-variables) (gnus-summary-select-article) (let ((mail-header-separator "")) (gnus-eval-in-buffer-window gnus-article-buffer @@ -6626,14 +6871,14 @@ (defun gnus-summary-stop-page-breaking () "Stop page breaking in the current article." (interactive) - (gnus-set-global-variables) (gnus-summary-select-article) (gnus-eval-in-buffer-window gnus-article-buffer (widen) (when (gnus-visual-p 'page-marker) (let ((buffer-read-only nil)) (gnus-remove-text-with-property 'gnus-prev) - (gnus-remove-text-with-property 'gnus-next))))) + (gnus-remove-text-with-property 'gnus-next)) + (setq gnus-page-broken nil)))) (defun gnus-summary-move-article (&optional n to-newsgroup select-method action) @@ -6652,7 +6897,6 @@ (interactive "P") (unless action (setq action 'move)) - (gnus-set-global-variables) ;; Disable marking as read. (let (gnus-mark-article-hook) (save-window-excursion @@ -6718,9 +6962,9 @@ ((eq action 'copy) (save-excursion (set-buffer copy-buf) - (gnus-request-article-this-buffer article gnus-newsgroup-name) - (gnus-request-accept-article - to-newsgroup select-method (not articles)))) + (when (gnus-request-article-this-buffer article gnus-newsgroup-name) + (gnus-request-accept-article + to-newsgroup select-method (not articles))))) ;; Crosspost the article. ((eq action 'crosspost) (let ((xref (message-tokenize-header @@ -6760,15 +7004,10 @@ (gnus-summary-mark-article article gnus-canceled-mark) (gnus-message 4 "Deleted article %s" article)) (t - (let* ((entry - (or - (gnus-gethash (car art-group) gnus-newsrc-hashtb) - (gnus-gethash - (gnus-group-prefixed-name - (car art-group) - (or select-method - (gnus-find-method-for-group to-newsgroup))) - gnus-newsrc-hashtb))) + (let* ((pto-group (gnus-group-prefixed-name + (car art-group) to-method)) + (entry + (gnus-gethash pto-group gnus-newsrc-hashtb)) (info (nth 2 entry)) (to-group (gnus-info-group info))) ;; Update the group that has been moved to. @@ -6837,6 +7076,9 @@ (gnus-request-replace-article article gnus-newsgroup-name (current-buffer))))) + ;;;!!!Why is this necessary? + (set-buffer gnus-summary-buffer) + (gnus-summary-goto-subject article) (when (eq action 'move) (gnus-summary-mark-article article gnus-canceled-mark)))) @@ -6909,7 +7151,6 @@ (let ((ms-alist (mapcar (lambda (m) (cons (cadr m) m)) ms))) (cdr (assoc (completing-read "Server name: " ms-alist nil t) ms-alist)))))))) - (gnus-set-global-variables) (unless method (error "No method given for respooling")) (if (assoc (symbol-name @@ -6919,9 +7160,8 @@ (gnus-summary-copy-article n nil method))) (defun gnus-summary-import-article (file) - "Import a random file into a mail newsgroup." + "Import an arbitrary file into a mail newsgroup." (interactive "fImport file: ") - (gnus-set-global-variables) (let ((group gnus-newsgroup-name) (now (current-time)) atts lines) @@ -6931,7 +7171,7 @@ (not (file-regular-p file)) (error "Can't read %s" file)) (save-excursion - (set-buffer (get-buffer-create " *import file*")) + (set-buffer (gnus-get-buffer-create " *import file*")) (buffer-disable-undo (current-buffer)) (erase-buffer) (insert-file-contents file) @@ -6970,7 +7210,6 @@ (defun gnus-summary-expire-articles (&optional now) "Expire all articles that are marked as expirable in the current group." (interactive) - (gnus-set-global-variables) (when (gnus-check-backend-function 'request-expire-articles gnus-newsgroup-name) ;; This backend supports expiry. @@ -6980,7 +7219,7 @@ ;; We need to update the info for ;; this group for `gnus-list-of-read-articles' ;; to give us the right answer. - (run-hooks 'gnus-exit-group-hook) + (gnus-run-hooks 'gnus-exit-group-hook) (gnus-summary-update-info) (gnus-list-of-read-articles gnus-newsgroup-name)) (setq gnus-newsgroup-expirable @@ -6994,13 +7233,14 @@ ;; through the expiry process. (gnus-message 6 "Expiring articles...") ;; The list of articles that weren't expired is returned. - (if expiry-wait - (let ((nnmail-expiry-wait-function nil) - (nnmail-expiry-wait expiry-wait)) - (setq es (gnus-request-expire-articles - expirable gnus-newsgroup-name))) - (setq es (gnus-request-expire-articles - expirable gnus-newsgroup-name))) + (save-excursion + (if expiry-wait + (let ((nnmail-expiry-wait-function nil) + (nnmail-expiry-wait expiry-wait)) + (setq es (gnus-request-expire-articles + expirable gnus-newsgroup-name))) + (setq es (gnus-request-expire-articles + expirable gnus-newsgroup-name)))) (unless total (setq gnus-newsgroup-expirable es)) ;; We go through the old list of expirable, and mark all @@ -7020,7 +7260,6 @@ This means that *all* articles that are marked as expirable will be deleted forever, right now." (interactive) - (gnus-set-global-variables) (or gnus-expert-user (gnus-yes-or-no-p "Are you really, really, really sure you want to delete all these messages? ") @@ -7037,12 +7276,11 @@ If N is nil and articles have been marked with the process mark, delete these instead." (interactive "P") - (gnus-set-global-variables) (unless (gnus-check-backend-function 'request-expire-articles gnus-newsgroup-name) (error "The current newsgroup does not support article deletion")) ;; Compute the list of articles to delete. - (let ((articles (gnus-summary-work-articles n)) + (let ((articles (sort (copy-sequence (gnus-summary-work-articles n)) '<)) not-deleted) (if (and gnus-novice-user (not (gnus-yes-or-no-p @@ -7085,67 +7323,73 @@ (gnus-summary-select-article t)) (gnus-article-date-original) (gnus-article-edit-article - `(lambda () + `(lambda (no-highlight) (gnus-summary-edit-article-done ,(or (mail-header-references gnus-current-headers) "") - ,(gnus-group-read-only-p) ,gnus-summary-buffer))))) + ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight))))) (defalias 'gnus-summary-edit-article-postpone 'gnus-article-edit-exit) -(defun gnus-summary-edit-article-done (&optional references read-only buffer) +(defun gnus-summary-edit-article-done (&optional references read-only buffer + no-highlight) "Make edits to the current article permanent." (interactive) ;; Replace the article. - (if (and (not read-only) - (not (gnus-request-replace-article - (cdr gnus-article-current) (car gnus-article-current) - (current-buffer)))) - (error "Couldn't replace article") - ;; Update the summary buffer. - (if (and references - (equal (message-tokenize-header references " ") - (message-tokenize-header - (or (message-fetch-field "references") "") " "))) - ;; We only have to update this line. - (save-excursion - (save-restriction - (message-narrow-to-head) - (let ((head (buffer-string)) - header) - (nnheader-temp-write nil - (insert (format "211 %d Article retrieved.\n" - (cdr gnus-article-current))) - (insert head) - (insert ".\n") - (let ((nntp-server-buffer (current-buffer))) - (setq header (car (gnus-get-newsgroup-headers - (save-excursion - (set-buffer gnus-summary-buffer) - gnus-newsgroup-dependencies) - t)))) - (save-excursion - (set-buffer gnus-summary-buffer) - (gnus-data-set-header - (gnus-data-find (cdr gnus-article-current)) - header) - (gnus-summary-update-article-line - (cdr gnus-article-current) header)))))) - ;; Update threads. - (set-buffer (or buffer gnus-summary-buffer)) - (gnus-summary-update-article (cdr gnus-article-current))) - ;; Prettify the article buffer again. - (save-excursion - (set-buffer gnus-article-buffer) - (run-hooks 'gnus-article-display-hook) - (set-buffer gnus-original-article-buffer) - (gnus-request-article - (cdr gnus-article-current) (car gnus-article-current) (current-buffer))) - ;; Prettify the summary buffer line. - (when (gnus-visual-p 'summary-highlight 'highlight) - (run-hooks 'gnus-visual-mark-article-hook)))) + (let ((buf (current-buffer))) + (nnheader-temp-write nil + (insert-buffer buf) + (if (and (not read-only) + (not (gnus-request-replace-article + (cdr gnus-article-current) (car gnus-article-current) + (current-buffer)))) + (error "Couldn't replace article") + ;; Update the summary buffer. + (if (and references + (equal (message-tokenize-header references " ") + (message-tokenize-header + (or (message-fetch-field "references") "") " "))) + ;; We only have to update this line. + (save-excursion + (save-restriction + (message-narrow-to-head) + (let ((head (buffer-string)) + header) + (nnheader-temp-write nil + (insert (format "211 %d Article retrieved.\n" + (cdr gnus-article-current))) + (insert head) + (insert ".\n") + (let ((nntp-server-buffer (current-buffer))) + (setq header (car (gnus-get-newsgroup-headers + (save-excursion + (set-buffer gnus-summary-buffer) + gnus-newsgroup-dependencies) + t)))) + (save-excursion + (set-buffer gnus-summary-buffer) + (gnus-data-set-header + (gnus-data-find (cdr gnus-article-current)) + header) + (gnus-summary-update-article-line + (cdr gnus-article-current) header)))))) + ;; Update threads. + (set-buffer (or buffer gnus-summary-buffer)) + (gnus-summary-update-article (cdr gnus-article-current))) + ;; Prettify the article buffer again. + (unless no-highlight + (save-excursion + (set-buffer gnus-article-buffer) + (gnus-run-hooks 'gnus-article-display-hook) + (set-buffer gnus-original-article-buffer) + (gnus-request-article + (cdr gnus-article-current) + (car gnus-article-current) (current-buffer)))) + ;; Prettify the summary buffer line. + (when (gnus-visual-p 'summary-highlight 'highlight) + (gnus-run-hooks 'gnus-visual-mark-article-hook)))))) (defun gnus-summary-edit-wash (key) - "Perform editing command in the article buffer." + "Perform editing command KEY in the article buffer." (interactive (list (progn @@ -7158,17 +7402,16 @@ ;;; Respooling -(defun gnus-summary-respool-query (&optional silent) +(defun gnus-summary-respool-query (&optional silent trace) "Query where the respool algorithm would put this article." (interactive) - (gnus-set-global-variables) (let (gnus-mark-article-hook) (gnus-summary-select-article) (save-excursion (set-buffer gnus-original-article-buffer) (save-restriction (message-narrow-to-head) - (let ((groups (nnmail-article-group 'identity))) + (let ((groups (nnmail-article-group 'identity trace))) (unless silent (if groups (message "This message would go to %s" @@ -7176,6 +7419,12 @@ (message "This message would go to no groups")) groups)))))) +(defun gnus-summary-respool-trace () + "Trace where the respool algorithm would put this article. +Display a buffer showing all fancy splitting patterns which matched." + (interactive) + (gnus-summary-respool-query nil t)) + ;; Summary marking commands. (defun gnus-summary-kill-same-subject-and-select (&optional unmark) @@ -7183,7 +7432,6 @@ If UNMARK is positive, remove any kind of mark. If UNMARK is negative, tick articles." (interactive "P") - (gnus-set-global-variables) (when unmark (setq unmark (prefix-numeric-value unmark))) (let ((count @@ -7202,7 +7450,6 @@ If UNMARK is positive, remove any kind of mark. If UNMARK is negative, tick articles." (interactive "P") - (gnus-set-global-variables) (when unmark (setq unmark (prefix-numeric-value unmark))) (let ((count @@ -7253,7 +7500,6 @@ the process mark instead. The difference between N and the actual number of articles marked is returned." (interactive "p") - (gnus-set-global-variables) (let ((backward (< n 0)) (n (abs n))) (while (and @@ -7272,16 +7518,14 @@ (defun gnus-summary-unmark-as-processable (n) "Remove the process mark from the next N articles. -If N is negative, mark backward instead. The difference between N and -the actual number of articles marked is returned." +If N is negative, unmark backward instead. The difference between N and +the actual number of articles unmarked is returned." (interactive "p") - (gnus-set-global-variables) (gnus-summary-mark-as-processable n t)) (defun gnus-summary-unmark-all-processable () "Remove the process mark from all articles." (interactive) - (gnus-set-global-variables) (save-excursion (while gnus-newsgroup-processable (gnus-summary-remove-process-mark (car gnus-newsgroup-processable)))) @@ -7292,7 +7536,6 @@ If N is negative, mark backward instead. The difference between N and the actual number of articles marked is returned." (interactive "p") - (gnus-set-global-variables) (gnus-summary-mark-forward n gnus-expirable-mark)) (defun gnus-summary-mark-article-as-replied (article) @@ -7305,7 +7548,6 @@ (defun gnus-summary-set-bookmark (article) "Set a bookmark in current article." (interactive (list (gnus-summary-article-number))) - (gnus-set-global-variables) (when (or (not (get-buffer gnus-article-buffer)) (not gnus-current-article) (not gnus-article-current) @@ -7335,7 +7577,6 @@ (defun gnus-summary-remove-bookmark (article) "Remove the bookmark from the current article." (interactive (list (gnus-summary-article-number))) - (gnus-set-global-variables) ;; Remove old bookmark, if one exists. (let ((old (assq article gnus-newsgroup-bookmarks))) (if old @@ -7351,7 +7592,6 @@ If N is negative, mark backward instead. The difference between N and the actual number of articles marked is returned." (interactive "p") - (gnus-set-global-variables) (gnus-summary-mark-forward n gnus-dormant-mark)) (defun gnus-summary-set-process-mark (article) @@ -7361,6 +7601,7 @@ (delq article gnus-newsgroup-processable))) (when (gnus-summary-goto-subject article) (gnus-summary-show-thread) + (gnus-summary-goto-subject article) (gnus-summary-update-secondary-mark article))) (defun gnus-summary-remove-process-mark (article) @@ -7368,6 +7609,7 @@ (setq gnus-newsgroup-processable (delq article gnus-newsgroup-processable)) (when (gnus-summary-goto-subject article) (gnus-summary-show-thread) + (gnus-summary-goto-subject article) (gnus-summary-update-secondary-mark article))) (defun gnus-summary-set-saved-mark (article) @@ -7382,7 +7624,6 @@ The difference between N and the actual number of articles marked is returned." (interactive "p") - (gnus-set-global-variables) (let ((backward (< n 0)) (gnus-summary-goto-unread (and gnus-summary-goto-unread @@ -7426,6 +7667,8 @@ (= mark gnus-read-mark) (= mark gnus-souped-mark) (= mark gnus-duplicate-mark))) (setq mark gnus-expirable-mark) + ;; Let the backend know about the mark change. + (setq mark (gnus-request-update-mark gnus-newsgroup-name article mark)) (push article gnus-newsgroup-expirable)) ;; Set the mark in the buffer. (gnus-summary-update-mark mark 'unread) @@ -7433,36 +7676,41 @@ (defun gnus-summary-mark-article-as-unread (mark) "Mark the current article quickly as unread with MARK." - (let ((article (gnus-summary-article-number))) - (if (< article 0) - (gnus-error 1 "Unmarkable article") - (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked)) - (setq gnus-newsgroup-dormant (delq article gnus-newsgroup-dormant)) - (setq gnus-newsgroup-expirable (delq article gnus-newsgroup-expirable)) - (setq gnus-newsgroup-reads (delq article gnus-newsgroup-reads)) - (cond ((= mark gnus-ticked-mark) - (push article gnus-newsgroup-marked)) - ((= mark gnus-dormant-mark) - (push article gnus-newsgroup-dormant)) - (t - (push article gnus-newsgroup-unreads))) - (setq gnus-newsgroup-reads - (delq (assq article gnus-newsgroup-reads) - gnus-newsgroup-reads)) - - ;; See whether the article is to be put in the cache. - (and gnus-use-cache - (vectorp (gnus-summary-article-header article)) - (save-excursion - (gnus-cache-possibly-enter-article - gnus-newsgroup-name article - (gnus-summary-article-header article) - (= mark gnus-ticked-mark) - (= mark gnus-dormant-mark) (= mark gnus-unread-mark)))) - - ;; Fix the mark. - (gnus-summary-update-mark mark 'unread)) - t)) + (let* ((article (gnus-summary-article-number)) + (old-mark (gnus-summary-article-mark article))) + ;; Allow the backend to change the mark. + (setq mark (gnus-request-update-mark gnus-newsgroup-name article mark)) + (if (eq mark old-mark) + t + (if (<= article 0) + (progn + (gnus-error 1 "Can't mark negative article numbers") + nil) + (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked)) + (setq gnus-newsgroup-dormant (delq article gnus-newsgroup-dormant)) + (setq gnus-newsgroup-expirable (delq article gnus-newsgroup-expirable)) + (setq gnus-newsgroup-reads (delq article gnus-newsgroup-reads)) + (cond ((= mark gnus-ticked-mark) + (push article gnus-newsgroup-marked)) + ((= mark gnus-dormant-mark) + (push article gnus-newsgroup-dormant)) + (t + (push article gnus-newsgroup-unreads))) + (gnus-pull article gnus-newsgroup-reads) + + ;; See whether the article is to be put in the cache. + (and gnus-use-cache + (vectorp (gnus-summary-article-header article)) + (save-excursion + (gnus-cache-possibly-enter-article + gnus-newsgroup-name article + (gnus-summary-article-header article) + (= mark gnus-ticked-mark) + (= mark gnus-dormant-mark) (= mark gnus-unread-mark)))) + + ;; Fix the mark. + (gnus-summary-update-mark mark 'unread) + t)))) (defun gnus-summary-mark-article (&optional article mark no-expire) "Mark ARTICLE with MARK. MARK can be any character. @@ -7485,32 +7733,37 @@ (= mark gnus-duplicate-mark)))) (setq mark gnus-expirable-mark)) (let* ((mark (or mark gnus-del-mark)) - (article (or article (gnus-summary-article-number)))) - (unless article - (error "No article on current line")) - (if (or (= mark gnus-unread-mark) - (= mark gnus-ticked-mark) - (= mark gnus-dormant-mark)) - (gnus-mark-article-as-unread article mark) - (gnus-mark-article-as-read article mark)) - - ;; See whether the article is to be put in the cache. - (and gnus-use-cache - (not (= mark gnus-canceled-mark)) - (vectorp (gnus-summary-article-header article)) - (save-excursion - (gnus-cache-possibly-enter-article - gnus-newsgroup-name article - (gnus-summary-article-header article) - (= mark gnus-ticked-mark) - (= mark gnus-dormant-mark) (= mark gnus-unread-mark)))) - - (when (gnus-summary-goto-subject article nil t) - (let ((buffer-read-only nil)) - (gnus-summary-show-thread) - ;; Fix the mark. - (gnus-summary-update-mark mark 'unread) - t)))) + (article (or article (gnus-summary-article-number))) + (old-mark (gnus-summary-article-mark article))) + ;; Allow the backend to change the mark. + (setq mark (gnus-request-update-mark gnus-newsgroup-name article mark)) + (if (eq mark old-mark) + t + (unless article + (error "No article on current line")) + (if (not (if (or (= mark gnus-unread-mark) + (= mark gnus-ticked-mark) + (= mark gnus-dormant-mark)) + (gnus-mark-article-as-unread article mark) + (gnus-mark-article-as-read article mark))) + t + ;; See whether the article is to be put in the cache. + (and gnus-use-cache + (not (= mark gnus-canceled-mark)) + (vectorp (gnus-summary-article-header article)) + (save-excursion + (gnus-cache-possibly-enter-article + gnus-newsgroup-name article + (gnus-summary-article-header article) + (= mark gnus-ticked-mark) + (= mark gnus-dormant-mark) (= mark gnus-unread-mark)))) + + (when (gnus-summary-goto-subject article nil t) + (let ((buffer-read-only nil)) + (gnus-summary-show-thread) + ;; Fix the mark. + (gnus-summary-update-mark mark 'unread) + t)))))) (defun gnus-summary-update-secondary-mark (article) "Update the secondary (read, process, cache) mark." @@ -7526,7 +7779,7 @@ (t gnus-unread-mark)) 'replied) (when (gnus-visual-p 'summary-highlight 'highlight) - (run-hooks 'gnus-summary-update-hook)) + (gnus-run-hooks 'gnus-summary-update-hook)) t) (defun gnus-summary-update-mark (mark type) @@ -7561,29 +7814,33 @@ (push (cons article mark) gnus-newsgroup-reads) ;; Possibly remove from cache, if that is used. (when gnus-use-cache - (gnus-cache-enter-remove-article article)))) + (gnus-cache-enter-remove-article article)) + t)) (defun gnus-mark-article-as-unread (article &optional mark) "Enter ARTICLE in the pertinent lists and remove it from others." (let ((mark (or mark gnus-ticked-mark))) - (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked) - gnus-newsgroup-dormant (delq article gnus-newsgroup-dormant) - gnus-newsgroup-expirable (delq article gnus-newsgroup-expirable) - gnus-newsgroup-unreads (delq article gnus-newsgroup-unreads)) - - ;; Unsuppress duplicates? - (when gnus-suppress-duplicates - (gnus-dup-unsuppress-article article)) - - (cond ((= mark gnus-ticked-mark) - (push article gnus-newsgroup-marked)) - ((= mark gnus-dormant-mark) - (push article gnus-newsgroup-dormant)) - (t - (push article gnus-newsgroup-unreads))) - (setq gnus-newsgroup-reads - (delq (assq article gnus-newsgroup-reads) - gnus-newsgroup-reads)))) + (if (<= article 0) + (progn + (gnus-error 1 "Can't mark negative article numbers") + nil) + (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked) + gnus-newsgroup-dormant (delq article gnus-newsgroup-dormant) + gnus-newsgroup-expirable (delq article gnus-newsgroup-expirable) + gnus-newsgroup-unreads (delq article gnus-newsgroup-unreads)) + + ;; Unsuppress duplicates? + (when gnus-suppress-duplicates + (gnus-dup-unsuppress-article article)) + + (cond ((= mark gnus-ticked-mark) + (push article gnus-newsgroup-marked)) + ((= mark gnus-dormant-mark) + (push article gnus-newsgroup-dormant)) + (t + (push article gnus-newsgroup-unreads))) + (gnus-pull article gnus-newsgroup-reads) + t))) (defalias 'gnus-summary-mark-as-unread-forward 'gnus-summary-tick-article-forward) @@ -7684,7 +7941,6 @@ (defun gnus-summary-mark-below (score mark) "Mark articles with score less than SCORE with MARK." (interactive "P\ncMark: ") - (gnus-set-global-variables) (setq score (if score (prefix-numeric-value score) (or gnus-summary-default-score 0))) @@ -7700,25 +7956,21 @@ (defun gnus-summary-kill-below (&optional score) "Mark articles with score below SCORE as read." (interactive "P") - (gnus-set-global-variables) (gnus-summary-mark-below score gnus-killed-mark)) (defun gnus-summary-clear-above (&optional score) "Clear all marks from articles with score above SCORE." (interactive "P") - (gnus-set-global-variables) (gnus-summary-mark-above score gnus-unread-mark)) (defun gnus-summary-tick-above (&optional score) "Tick all articles with score above SCORE." (interactive "P") - (gnus-set-global-variables) (gnus-summary-mark-above score gnus-ticked-mark)) (defun gnus-summary-mark-above (score mark) "Mark articles with score over SCORE with MARK." (interactive "P\ncMark: ") - (gnus-set-global-variables) (setq score (if score (prefix-numeric-value score) (or gnus-summary-default-score 0))) @@ -7736,7 +7988,6 @@ (defun gnus-summary-limit-include-expunged (&optional no-error) "Display all the hidden articles that were expunged for low scores." (interactive) - (gnus-set-global-variables) (let ((buffer-read-only nil)) (let ((scored gnus-newsgroup-scored) headers h) @@ -7766,7 +8017,6 @@ in the current summary buffer limitation. The number of articles marked as read is returned." (interactive "P") - (gnus-set-global-variables) (prog1 (save-excursion (when (or quietly @@ -7781,20 +8031,20 @@ (not gnus-newsgroup-auto-expire) (not gnus-suppress-duplicates) (or (not gnus-use-cache) - (not (eq gnus-use-cache 'passive)))) + (eq gnus-use-cache 'passive))) (progn (when all (setq gnus-newsgroup-marked nil gnus-newsgroup-dormant nil)) - (setq gnus-newsgroup-unreads nil)) + (setq gnus-newsgroup-unreads gnus-newsgroup-downloadable)) ;; We actually mark all articles as canceled, which we ;; have to do when using auto-expiry or adaptive scoring. (gnus-summary-show-all-threads) - (when (gnus-summary-first-subject (not all)) + (when (gnus-summary-first-subject (not all) t) (while (and (if to-here (< (point) to-here) t) (gnus-summary-mark-article-as-read gnus-catchup-mark) - (gnus-summary-find-next (not all))))) + (gnus-summary-find-next (not all) nil nil t)))) (gnus-set-mode-line 'summary)) t)) (gnus-summary-position-point))) @@ -7803,7 +8053,6 @@ "Mark all unticked articles before the current one as read. If ALL is non-nil, also mark ticked and dormant articles as read." (interactive "P") - (gnus-set-global-variables) (save-excursion (gnus-save-hidden-threads (let ((beg (point))) @@ -7815,24 +8064,22 @@ (defun gnus-summary-catchup-all (&optional quietly) "Mark all articles in this newsgroup as read." (interactive "P") - (gnus-set-global-variables) (gnus-summary-catchup t quietly)) (defun gnus-summary-catchup-and-exit (&optional all quietly) "Mark all articles not marked as unread in this newsgroup as read, then exit. If prefix argument ALL is non-nil, all articles are marked as read." (interactive "P") - (gnus-set-global-variables) (when (gnus-summary-catchup all quietly nil 'fast) ;; Select next newsgroup or exit. - (if (eq gnus-auto-select-next 'quietly) + (if (and (not (gnus-group-quit-config gnus-newsgroup-name)) + (eq gnus-auto-select-next 'quietly)) (gnus-summary-next-group nil) (gnus-summary-exit)))) (defun gnus-summary-catchup-all-and-exit (&optional quietly) "Mark all articles in this newsgroup as read, and then exit." (interactive "P") - (gnus-set-global-variables) (gnus-summary-catchup-and-exit t quietly)) ;; Suggested by "Arne Eofsson" <arne@hodgkin.mbi.ucla.edu>. @@ -7841,7 +8088,6 @@ If given a prefix, mark all articles, unread as well as ticked, as read." (interactive "P") - (gnus-set-global-variables) (save-excursion (gnus-summary-catchup all)) (gnus-summary-next-article t nil nil t)) @@ -7888,7 +8134,6 @@ (defun gnus-summary-rethread-current () "Rethread the thread the current article is part of." (interactive) - (gnus-set-global-variables) (let* ((gnus-show-threads t) (article (gnus-summary-article-number)) (id (mail-header-id (gnus-summary-article-header))) @@ -7924,14 +8169,20 @@ (gnus-summary-article-header parent-article)))) (unless (and message-id (not (equal message-id ""))) (error "No message-id in desired parent")) - (gnus-summary-select-article t t nil current-article) + ;; We don't want the article to be marked as read. + (let (gnus-mark-article-hook) + (gnus-summary-select-article t t nil current-article)) (set-buffer gnus-original-article-buffer) (let ((buf (format "%s" (buffer-string)))) (nnheader-temp-write nil (insert buf) (goto-char (point-min)) - (if (search-forward-regexp "^References: " nil t) - (insert message-id " " ) + (if (re-search-forward "^References: " nil t) + (progn + (re-search-forward "^[^ \t]" nil t) + (forward-line -1) + (end-of-line) + (insert " " message-id)) (insert "References: " message-id "\n")) (unless (gnus-request-replace-article current-article (car gnus-article-current) @@ -7939,6 +8190,7 @@ (error "Couldn't replace article")))) (set-buffer gnus-summary-buffer) (gnus-summary-unmark-all-processable) + (gnus-summary-update-article current-article) (gnus-summary-rethread-current) (gnus-message 3 "Article %d is now the child of article %d" current-article parent-article))))) @@ -7947,7 +8199,6 @@ "Toggle showing conversation threads. If ARG is positive number, turn showing conversation threads on." (interactive "P") - (gnus-set-global-variables) (let ((current (or (gnus-summary-article-number) gnus-newsgroup-end))) (setq gnus-show-threads (if (null arg) (not gnus-show-threads) @@ -7960,7 +8211,6 @@ (defun gnus-summary-show-all-threads () "Show all threads." (interactive) - (gnus-set-global-variables) (save-excursion (let ((buffer-read-only nil)) (subst-char-in-region (point-min) (point-max) ?\^M ?\n t))) @@ -7970,7 +8220,6 @@ "Show thread subtrees. Returns nil if no thread was there to be shown." (interactive) - (gnus-set-global-variables) (let ((buffer-read-only nil) (orig (point)) ;; first goto end then to beg, to have point at beg after let @@ -7986,7 +8235,6 @@ (defun gnus-summary-hide-all-threads () "Hide all thread subtrees." (interactive) - (gnus-set-global-variables) (save-excursion (goto-char (point-min)) (gnus-summary-hide-thread) @@ -7998,7 +8246,6 @@ "Hide thread subtrees. Returns nil if no threads were there to be hidden." (interactive) - (gnus-set-global-variables) (let ((buffer-read-only nil) (start (point)) (article (gnus-summary-article-number))) @@ -8047,7 +8294,6 @@ If SILENT, don't output messages." (interactive "p") - (gnus-set-global-variables) (let ((backward (< n 0)) (n (abs n))) (while (and (> n 0) @@ -8064,7 +8310,6 @@ Returns the difference between N and the number of skips actually done." (interactive "p") - (gnus-set-global-variables) (gnus-summary-next-thread (- n))) (defun gnus-summary-go-down-thread () @@ -8085,7 +8330,6 @@ Returns the difference between N and how many steps down that were taken." (interactive "p") - (gnus-set-global-variables) (let ((up (< n 0)) (n (abs n))) (while (and (> n 0) @@ -8103,13 +8347,11 @@ Returns the difference between N and how many steps down that were taken." (interactive "p") - (gnus-set-global-variables) (gnus-summary-down-thread (- n))) (defun gnus-summary-top-thread () "Go to the top of the thread." (interactive) - (gnus-set-global-variables) (while (gnus-summary-go-up-thread)) (gnus-summary-article-number)) @@ -8118,7 +8360,6 @@ If the prefix argument is positive, remove any kinds of marks. If the prefix argument is negative, tick articles instead." (interactive "P") - (gnus-set-global-variables) (when unmark (setq unmark (prefix-numeric-value unmark))) (let ((articles (gnus-summary-articles-in-thread))) @@ -8187,7 +8428,6 @@ (defun gnus-summary-sort (predicate reverse) "Sort summary buffer by PREDICATE. REVERSE means reverse order." - (gnus-set-global-variables) (let* ((thread (intern (format "gnus-thread-sort-by-%s" predicate))) (article (intern (format "gnus-article-sort-by-%s" predicate))) (gnus-thread-sort-functions @@ -8220,7 +8460,6 @@ save those articles instead. The variable `gnus-default-article-saver' specifies the saver function." (interactive "P") - (gnus-set-global-variables) (let* ((articles (gnus-summary-work-articles n)) (save-buffer (save-excursion (nnheader-set-temp-buffer " *Gnus Save*"))) @@ -8257,7 +8496,6 @@ If N is nil and any articles have been marked with the process mark, pipe those articles instead." (interactive "P") - (gnus-set-global-variables) (let ((gnus-default-article-saver 'gnus-summary-save-in-pipe)) (gnus-summary-save-article arg t)) (gnus-configure-windows 'pipe)) @@ -8269,7 +8507,6 @@ If N is nil and any articles have been marked with the process mark, save those articles instead." (interactive "P") - (gnus-set-global-variables) (let ((gnus-default-article-saver 'gnus-summary-save-in-mail)) (gnus-summary-save-article arg))) @@ -8280,7 +8517,6 @@ If N is nil and any articles have been marked with the process mark, save those articles instead." (interactive "P") - (gnus-set-global-variables) (let ((gnus-default-article-saver 'gnus-summary-save-in-rmail)) (gnus-summary-save-article arg))) @@ -8291,7 +8527,6 @@ If N is nil and any articles have been marked with the process mark, save those articles instead." (interactive "P") - (gnus-set-global-variables) (let ((gnus-default-article-saver 'gnus-summary-save-in-file)) (gnus-summary-save-article arg))) @@ -8302,7 +8537,6 @@ If N is nil and any articles have been marked with the process mark, save those articles instead." (interactive "P") - (gnus-set-global-variables) (let ((gnus-default-article-saver 'gnus-summary-write-to-file)) (gnus-summary-save-article arg))) @@ -8313,17 +8547,14 @@ If N is nil and any articles have been marked with the process mark, save those articles instead." (interactive "P") - (gnus-set-global-variables) (let ((gnus-default-article-saver 'gnus-summary-save-body-in-file)) (gnus-summary-save-article arg))) (defun gnus-summary-pipe-message (program) "Pipe the current article through PROGRAM." (interactive "sProgram: ") - (gnus-set-global-variables) (gnus-summary-select-article) - (let ((mail-header-separator "") - (art-buf (get-buffer gnus-article-buffer))) + (let ((mail-header-separator "")) (gnus-eval-in-buffer-window gnus-article-buffer (save-restriction (widen) @@ -8501,7 +8732,7 @@ (cond ((assq 'execute props) (gnus-execute-command (cdr (assq 'execute props))))) (let ((gnus-current-article (gnus-summary-article-number))) - (run-hooks 'gnus-mark-article-hook))) + (gnus-run-hooks 'gnus-mark-article-hook))) (defun gnus-execute-command (command &optional automatic) (save-excursion @@ -8523,15 +8754,12 @@ (defun gnus-summary-edit-global-kill (article) "Edit the \"global\" kill file." (interactive (list (gnus-summary-article-number))) - (gnus-set-global-variables) (gnus-group-edit-global-kill article)) (defun gnus-summary-edit-local-kill () "Edit a local kill file applied to the current newsgroup." (interactive) - (gnus-set-global-variables) (setq gnus-current-headers (gnus-summary-article-header)) - (gnus-set-global-variables) (gnus-group-edit-local-kill (gnus-summary-article-number) gnus-newsgroup-name)) @@ -8555,6 +8783,14 @@ (not (gnus-summary-article-sparse-p (mail-header-number header)))) ;; We have found the header. header + ;; If this is a sparse article, we have to nix out its + ;; previous entry in the thread hashtb. + (when (and header + (gnus-summary-article-sparse-p (mail-header-number header))) + (let* ((parent (gnus-parent-id (mail-header-references header))) + (thread (and parent (gnus-id-to-thread parent)))) + (when thread + (delq (assq header thread) thread)))) ;; We have to really fetch the header to this article. (save-excursion (set-buffer nntp-server-buffer) @@ -8661,14 +8897,14 @@ (setq list (cdr list)))) (let ((face (cdar list))) (unless (eq face (get-text-property beg 'face)) - (gnus-put-text-property + (gnus-put-text-property-excluding-characters-with-faces beg end 'face (setq face (if (boundp face) (symbol-value face) face))) (when gnus-summary-highlight-line-function (funcall gnus-summary-highlight-line-function article face)))) (goto-char p))) -(defun gnus-update-read-articles (group unread) +(defun gnus-update-read-articles (group unread &optional compute) "Update the list of read articles in GROUP." (let* ((active (or gnus-newsgroup-active (gnus-active group))) (entry (gnus-gethash group gnus-newsrc-hashtb)) @@ -8700,20 +8936,22 @@ (setq unread (cdr unread))) (when (<= prev (cdr active)) (push (cons prev (cdr active)) read)) - (save-excursion - (set-buffer gnus-group-buffer) - (gnus-undo-register - `(progn - (gnus-info-set-marks ',info ',(gnus-info-marks info) t) - (gnus-info-set-read ',info ',(gnus-info-read info)) - (gnus-get-unread-articles-in-group ',info (gnus-active ,group)) - (gnus-group-update-group ,group t)))) - ;; Enter this list into the group info. - (gnus-info-set-read - info (if (> (length read) 1) (nreverse read) read)) - ;; Set the number of unread articles in gnus-newsrc-hashtb. - (gnus-get-unread-articles-in-group info (gnus-active group)) - t))) + (if compute + (if (> (length read) 1) (nreverse read) read) + (save-excursion + (set-buffer gnus-group-buffer) + (gnus-undo-register + `(progn + (gnus-info-set-marks ',info ',(gnus-info-marks info) t) + (gnus-info-set-read ',info ',(gnus-info-read info)) + (gnus-get-unread-articles-in-group ',info (gnus-active ,group)) + (gnus-group-update-group ,group t)))) + ;; Enter this list into the group info. + (gnus-info-set-read + info (if (> (length read) 1) (nreverse read) read)) + ;; Set the number of unread articles in gnus-newsrc-hashtb. + (gnus-get-unread-articles-in-group info (gnus-active group)) + t)))) (defun gnus-offer-save-summaries () "Offer to save all active summary buffers." @@ -8738,7 +8976,9 @@ (when buffers (map-y-or-n-p "Update summary buffer %s? " - (lambda (buf) (switch-to-buffer buf) (gnus-summary-exit)) + (lambda (buf) + (switch-to-buffer buf) + (gnus-summary-exit)) buffers))))) (gnus-ems-redefine)
--- a/lisp/gnus/gnus-topic.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/gnus-topic.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,8 +1,8 @@ ;;; gnus-topic.el --- a folding minor mode for Gnus group buffers -;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. ;; Author: Ilja Weis <kult@uni-paderborn.de> -;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news ;; This file is part of GNU Emacs. @@ -28,9 +28,12 @@ (eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl)) + (require 'gnus) (require 'gnus-group) (require 'gnus-start) +(require 'gnus-util) (defgroup gnus-topic nil "Group topics." @@ -73,6 +76,7 @@ (defvar gnus-topic-active-topology nil) (defvar gnus-topic-active-alist nil) +(defvar gnus-topic-unreads nil) (defvar gnus-topology-checked-p nil "Whether the topology has been checked in this session.") @@ -108,9 +112,7 @@ (defun gnus-topic-unread (topic) "Return the number of unread articles in TOPIC." - (or (save-excursion - (and (gnus-topic-goto-topic topic) - (gnus-group-topic-unread))) + (or (cdr (assoc topic gnus-topic-unreads)) 0)) (defun gnus-group-topic-p () @@ -166,9 +168,10 @@ (when result (symbol-name result)))) -(defun gnus-current-topics () - "Return a list of all current topics, lowest in hierarchy first." - (let ((topic (gnus-current-topic)) +(defun gnus-current-topics (&optional topic) + "Return a list of all current topics, lowest in hierarchy first. +If TOPIC, start with that topic." + (let ((topic (or topic (gnus-current-topic))) topics) (while topic (push topic topics) @@ -181,12 +184,12 @@ (beginning-of-line) (get-text-property (point) 'gnus-active))) -(defun gnus-topic-find-groups (topic &optional level all) +(defun gnus-topic-find-groups (topic &optional level all lowest) "Return entries for all visible groups in TOPIC." (let ((groups (cdr (assoc topic gnus-topic-alist))) - info clevel unread group lowest params visible-groups entry active) + info clevel unread group params visible-groups entry active) (setq lowest (or lowest 1)) - (setq level (or level 7)) + (setq level (or level gnus-level-unsubscribed)) ;; We go through the newsrc to look for matches. (while groups (when (setq group (pop groups)) @@ -199,7 +202,8 @@ active (- (1+ (cdr active)) (car active)))) clevel (or (gnus-info-level info) - (if (member group gnus-zombie-list) 8 9)))) + (if (member group gnus-zombie-list) + gnus-level-zombie gnus-level-killed)))) (and unread ; nil means that the group is dead. (<= clevel level) @@ -324,27 +328,32 @@ (defun gnus-group-topic-parameters (group) "Compute the group parameters for GROUP taking into account inheritance from topics." - (let ((params-list (list (gnus-group-get-parameter group))) - topics params param out) + (let ((params-list (copy-sequence (gnus-group-get-parameter group)))) (save-excursion (gnus-group-goto-group group) - (setq topics (gnus-current-topics)) - (while topics - (push (gnus-topic-parameters (pop topics)) params-list)) - ;; We probably have lots of nil elements here, so - ;; we remove them. Probably faster than doing this "properly". - (setq params-list (delq nil params-list)) - ;; Now we have all the parameters, so we go through them - ;; and do inheritance in the obvious way. - (while (setq params (pop params-list)) - (while (setq param (pop params)) - (when (atom param) - (setq param (cons param t))) - ;; Override any old versions of this param. - (setq out (delq (assq (car param) out) out)) - (push param out))) - ;; Return the resulting parameter list. - out))) + (nconc params-list + (gnus-topic-hierarchical-parameters (gnus-current-topic)))))) + +(defun gnus-topic-hierarchical-parameters (topic) + "Return a topic list computed for TOPIC." + (let ((topics (gnus-current-topics topic)) + params-list param out params) + (while topics + (push (gnus-topic-parameters (pop topics)) params-list)) + ;; We probably have lots of nil elements here, so + ;; we remove them. Probably faster than doing this "properly". + (setq params-list (delq nil params-list)) + ;; Now we have all the parameters, so we go through them + ;; and do inheritance in the obvious way. + (while (setq params (pop params-list)) + (while (setq param (pop params)) + (when (atom param) + (setq param (cons param t))) + ;; Override any old versions of this param. + (gnus-pull (car param) out) + (push param out))) + ;; Return the resulting parameter list. + out)) ;;; General utility functions @@ -355,8 +364,8 @@ ;;; Generating group buffers (defun gnus-group-prepare-topics (level &optional all lowest regexp list-topic topic-level) - "List all newsgroups with unread articles of level LEVEL or lower, and -use the `gnus-group-topics' to sort the groups. + "List all newsgroups with unread articles of level LEVEL or lower. +Use the `gnus-group-topics' to sort the groups. If ALL is non-nil, list groups that have no unread articles. If LOWEST is non-nil, list all newsgroups of level LOWEST or higher." (set-buffer gnus-group-buffer) @@ -371,7 +380,8 @@ (erase-buffer)) ;; List dead groups? - (when (and (>= level gnus-level-zombie) (<= lowest gnus-level-zombie)) + (when (and (>= level gnus-level-zombie) + (<= lowest gnus-level-zombie)) (gnus-group-prepare-flat-list-dead (setq gnus-zombie-list (sort gnus-zombie-list 'string<)) gnus-level-zombie ?Z @@ -389,20 +399,29 @@ (if list-topic (let ((top (gnus-topic-find-topology list-topic))) (gnus-topic-prepare-topic (cdr top) (car top) - (or topic-level level) all)) + (or topic-level level) all + nil lowest)) (gnus-topic-prepare-topic gnus-topic-topology 0 - (or topic-level level) all))) + (or topic-level level) all + nil lowest))) (gnus-group-set-mode-line) (setq gnus-group-list-mode (cons level all)) - (run-hooks 'gnus-group-prepare-hook)))) + (gnus-run-hooks 'gnus-group-prepare-hook)))) -(defun gnus-topic-prepare-topic (topicl level &optional list-level all silent) +(defun gnus-topic-prepare-topic (topicl level &optional list-level all silent + lowest) "Insert TOPIC into the group buffer. If SILENT, don't insert anything. Return the number of unread articles in the topic and its subtopics." (let* ((type (pop topicl)) - (entries (gnus-topic-find-groups (car type) list-level all)) + (entries (gnus-topic-find-groups + (car type) list-level + (or all + (cdr (assq 'visible + (gnus-topic-hierarchical-parameters + (car type))))) + lowest)) (visiblep (and (eq (nth 1 type) 'visible) (not silent))) (gnus-group-indentation (make-string (* gnus-topic-indent-level level) ? )) @@ -418,7 +437,7 @@ (incf unread (gnus-topic-prepare-topic (pop topicl) (1+ level) list-level all - (not visiblep)))) + (not visiblep) lowest))) (setq end (point)) (goto-char beg) ;; Insert all the groups that belong in this topic. @@ -427,7 +446,7 @@ (if (stringp entry) ;; Dead groups. (gnus-group-insert-group-line - entry (if (member entry gnus-zombie-list) 8 9) + entry (if (member entry gnus-zombie-list) gnus-level-zombie gnus-level-killed) nil (- (1+ (cdr (setq active (gnus-active entry)))) (car active)) nil) @@ -454,6 +473,7 @@ (car type) visiblep (not (eq (nth 2 type) 'hidden)) level all-entries unread)) + (gnus-topic-update-unreads (car type) unread) (goto-char end) unread)) @@ -508,7 +528,9 @@ (indentation (make-string (* gnus-topic-indent-level level) ? )) (total-number-of-articles unread) (number-of-groups (length entries)) - (active-topic (eq gnus-topic-alist gnus-topic-active-alist))) + (active-topic (eq gnus-topic-alist gnus-topic-active-alist)) + gnus-tmp-header) + (gnus-topic-update-unreads name unread) (beginning-of-line) ;; Insert the text. (gnus-add-text-properties @@ -521,6 +543,11 @@ 'gnus-active active-topic 'gnus-topic-visible visiblep)))) +(defun gnus-topic-update-unreads (topic unreads) + (setq gnus-topic-unreads (delq (assoc topic gnus-topic-unreads) + gnus-topic-unreads)) + (push (cons topic unreads) gnus-topic-unreads)) + (defun gnus-topic-update-topics-containing-group (group) "Update all topics that have GROUP as a member." (when (and (eq major-mode 'gnus-group-mode) @@ -602,7 +629,7 @@ (parent (gnus-topic-parent-topic topic-name)) (all-entries entries) (unread 0) - old-unread entry) + old-unread entry new-unread) (when (gnus-topic-goto-topic (car type)) ;; Tally all the groups that belong in this topic. (if reads @@ -618,11 +645,14 @@ (car type) (gnus-topic-visible-p) (not (eq (nth 2 type) 'hidden)) (gnus-group-topic-level) all-entries unread) - (gnus-delete-line)) + (gnus-delete-line) + (forward-line -1) + (setq new-unread (gnus-group-topic-unread))) (when parent (forward-line -1) (gnus-topic-update-topic-line - parent (- old-unread (gnus-group-topic-unread)))) + parent + (- (or old-unread 0) (or new-unread 0)))) unread)) (defun gnus-topic-group-indentation () @@ -729,55 +759,60 @@ "Run when changing levels to enter/remove groups from topics." (save-excursion (set-buffer gnus-group-buffer) - (gnus-group-goto-group (or (car (nth 2 previous)) group)) - (when (and gnus-topic-mode - gnus-topic-alist - (not gnus-topic-inhibit-change-level)) - ;; Remove the group from the topics. - (when (and (< oldlevel gnus-level-zombie) - (>= level gnus-level-zombie)) - (let (alist) - (forward-line -1) - (when (setq alist (assoc (gnus-current-topic) gnus-topic-alist)) - (setcdr alist (gnus-delete-first group (cdr alist)))))) - ;; If the group is subscribed we enter it into the topics. - (when (and (< level gnus-level-zombie) - (>= oldlevel gnus-level-zombie)) - (let* ((prev (gnus-group-group-name)) - (gnus-topic-inhibit-change-level t) - (gnus-group-indentation - (make-string - (* gnus-topic-indent-level - (or (save-excursion - (gnus-topic-goto-topic (gnus-current-topic)) - (gnus-group-topic-level)) - 0)) - ? )) - (yanked (list group)) - alist talist end) - ;; Then we enter the yanked groups into the topics they belong - ;; to. - (when (setq alist (assoc (save-excursion - (forward-line -1) - (or - (gnus-current-topic) - (caar gnus-topic-topology))) - gnus-topic-alist)) - (setq talist alist) - (when (stringp yanked) - (setq yanked (list yanked))) - (if (not prev) - (nconc alist yanked) - (if (not (cdr alist)) - (setcdr alist (nconc yanked (cdr alist))) - (while (and (not end) (cdr alist)) - (when (equal (cadr alist) prev) - (setcdr alist (nconc yanked (cdr alist))) - (setq end t)) - (setq alist (cdr alist))) - (unless end - (nconc talist yanked)))))) - (gnus-topic-update-topic))))) + (let ((buffer-read-only nil)) + (unless gnus-topic-inhibit-change-level + (gnus-group-goto-group (or (car (nth 2 previous)) group)) + (when (and gnus-topic-mode + gnus-topic-alist + (not gnus-topic-inhibit-change-level)) + ;; Remove the group from the topics. + (if (and (< oldlevel gnus-level-zombie) + (>= level gnus-level-zombie)) + (let ((alist gnus-topic-alist)) + (while (gnus-group-goto-group group) + (gnus-delete-line)) + (while alist + (when (member group (car alist)) + (setcdr (car alist) (delete group (cdar alist)))) + (pop alist))) + ;; If the group is subscribed we enter it into the topics. + (when (and (< level gnus-level-zombie) + (>= oldlevel gnus-level-zombie)) + (let* ((prev (gnus-group-group-name)) + (gnus-topic-inhibit-change-level t) + (gnus-group-indentation + (make-string + (* gnus-topic-indent-level + (or (save-excursion + (gnus-topic-goto-topic (gnus-current-topic)) + (gnus-group-topic-level)) + 0)) + ? )) + (yanked (list group)) + alist talist end) + ;; Then we enter the yanked groups into the topics they belong + ;; to. + (when (setq alist (assoc (save-excursion + (forward-line -1) + (or + (gnus-current-topic) + (caar gnus-topic-topology))) + gnus-topic-alist)) + (setq talist alist) + (when (stringp yanked) + (setq yanked (list yanked))) + (if (not prev) + (nconc alist yanked) + (if (not (cdr alist)) + (setcdr alist (nconc yanked (cdr alist))) + (while (and (not end) (cdr alist)) + (when (equal (cadr alist) prev) + (setcdr alist (nconc yanked (cdr alist))) + (setq end t)) + (setq alist (cdr alist))) + (unless end + (nconc talist yanked)))))) + (gnus-topic-update-topic)))))))) (defun gnus-topic-goto-next-group (group props) "Go to group or the next group after group." @@ -880,6 +915,10 @@ "Gp" gnus-topic-edit-parameters "#" gnus-topic-mark-topic "\M-#" gnus-topic-unmark-topic + [tab] gnus-topic-indent + [(meta tab)] gnus-topic-unindent + "\C-i" gnus-topic-indent + "\M-\C-i" gnus-topic-unindent gnus-mouse-2 gnus-mouse-pick-topic) ;; Define a new submap. @@ -899,7 +938,7 @@ "r" gnus-topic-rename "\177" gnus-topic-delete [delete] gnus-topic-delete - "h" gnus-topic-toggle-display-empty-topics) + "H" gnus-topic-toggle-display-empty-topics) (gnus-define-keys (gnus-topic-sort-map "S" gnus-group-topic-map) "s" gnus-topic-sort-groups @@ -943,15 +982,12 @@ (if (null arg) (not gnus-topic-mode) (> (prefix-numeric-value arg) 0))) ;; Infest Gnus with topics. - (if (not gnus-topic-mode) - (setq gnus-goto-missing-group-function nil) + (if (not gnus-topic-mode) + (setq gnus-goto-missing-group-function nil) (when (gnus-visual-p 'topic-menu 'menu) (gnus-topic-make-menu-bar)) - (setq gnus-topic-line-format-spec - (gnus-parse-format gnus-topic-line-format - gnus-topic-line-format-alist t)) + (gnus-set-format 'topic t) (gnus-add-minor-mode 'gnus-topic-mode " Topic" gnus-topic-mode-map) - (add-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic) (add-hook 'gnus-group-catchup-group-hook 'gnus-topic-update-topic) (set (make-local-variable 'gnus-group-prepare-function) 'gnus-group-prepare-topics) @@ -973,7 +1009,7 @@ ;; We check the topology. (when gnus-newsrc-alist (gnus-topic-check-topology)) - (run-hooks 'gnus-topic-mode-hook)) + (gnus-run-hooks 'gnus-topic-mode-hook)) ;; Remove topic infestation. (unless gnus-topic-mode (remove-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic) @@ -1178,7 +1214,7 @@ (if (not topic) (call-interactively 'gnus-group-mark-group) (save-excursion - (let ((groups (gnus-topic-find-groups topic 9 t))) + (let ((groups (gnus-topic-find-groups topic gnus-level-killed t))) (while groups (funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark) (gnus-info-group (nth 2 (pop groups))))))))) @@ -1243,6 +1279,14 @@ (let ((topic (gnus-current-topic))) (list topic (read-string (format "Rename %s to: " topic))))) + ;; Check whether the new name exists. + (when (gnus-topic-find-topology new-name) + (error "Topic '%s' already exists" new-name)) + ;; "nil" is an invalid name, for reasons I'd rather not go + ;; into here. Trust me. + (when (equal new-name "nil") + (error "Invalid name: %s" nil)) + ;; Do the renaming. (let ((top (gnus-topic-find-topology old-name)) (entry (assoc old-name gnus-topic-alist))) (when top @@ -1251,7 +1295,8 @@ (setcar entry new-name)) (forward-line -1) (gnus-dribble-touch) - (gnus-group-list-groups))) + (gnus-group-list-groups) + (forward-line 1))) (defun gnus-topic-indent (&optional unindent) "Indent a topic -- make it a sub-topic of the previous topic. @@ -1302,7 +1347,7 @@ (let ((gnus-topic-topology gnus-topic-active-topology) (gnus-topic-alist gnus-topic-active-alist) gnus-killed-list gnus-zombie-list) - (gnus-group-list-groups 9 nil 1))) + (gnus-group-list-groups gnus-level-killed nil 1))) (defun gnus-topic-toggle-display-empty-topics () "Show/hide topics that have no unread articles."
--- a/lisp/gnus/gnus-undo.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/gnus-undo.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ ;;; gnus-undo.el --- minor mode for undoing in Gnus -;; Copyright (C) 1996,97 Free Software Foundation, Inc. +;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news ;; This file is part of GNU Emacs. @@ -25,7 +25,7 @@ ;; This package allows arbitrary undoing in Gnus buffers. As all the ;; Gnus buffers aren't very text-oriented (what is in the buffers is -;; just some random representation of the actual data), normal Emacs +;; just some arbitrary representation of the actual data), normal Emacs ;; undoing doesn't work at all for Gnus. ;; ;; This package works by letting Gnus register functions for reversing @@ -46,14 +46,30 @@ (eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl)) + (require 'gnus-util) (require 'gnus) +(require 'custom) -(defvar gnus-undo-mode nil - "Minor mode for undoing in Gnus buffers.") +(defgroup gnus-undo nil + "Undoing in Gnus buffers." + :group 'gnus) + +(defcustom gnus-undo-limit 2000 + "The number of undoable actions recorded." + :type 'integer + :group 'gnus-undo) -(defvar gnus-undo-mode-hook nil - "Hook called in all `gnus-undo-mode' buffers.") +(defcustom gnus-undo-mode nil + "Minor mode for undoing in Gnus buffers." + :type 'boolean + :group 'gnus-undo) + +(defcustom gnus-undo-mode-hook nil + "Hook called in all `gnus-undo-mode' buffers." + :type 'hook + :group 'gnus-undo) ;;; Internal variables. @@ -100,7 +116,7 @@ (gnus-add-minor-mode 'gnus-undo-mode "" gnus-undo-mode-map) (make-local-hook 'post-command-hook) (add-hook 'post-command-hook 'gnus-undo-boundary nil t) - (run-hooks 'gnus-undo-mode-hook))) + (gnus-run-hooks 'gnus-undo-mode-hook))) ;;; Interface functions. @@ -148,6 +164,11 @@ ;; Initialize list. (t (setq gnus-undo-actions (list (list function))))) + ;; Limit the length of the undo list. + (let ((next (nthcdr gnus-undo-limit gnus-undo-actions))) + (when next + (setcdr next nil))) + ;; We are not at a boundary... (setq gnus-undo-boundary-inhibit t))) (defun gnus-undo (n)
--- a/lisp/gnus/gnus-util.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/gnus-util.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ ;;; gnus-util.el --- utility functions for Gnus -;; Copyright (C) 1996,97 Free Software Foundation, Inc. +;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news ;; This file is part of GNU Emacs. @@ -35,9 +35,13 @@ (require 'nnheader) (require 'timezone) (require 'message) +(eval-when-compile (require 'rmail)) (eval-and-compile - (autoload 'nnmail-date-to-time "nnmail")) + (autoload 'nnmail-date-to-time "nnmail") + (autoload 'rmail-insert-rmail-file-header "rmail") + (autoload 'rmail-count-new-messages "rmail") + (autoload 'rmail-show-message "rmail")) (defun gnus-boundp (variable) "Return non-nil if VARIABLE is bound and non-nil." @@ -72,9 +76,6 @@ (set symbol nil)) symbol)) -;; modified by MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; function `substring' might cut on a middle of multi-octet -;; character. (defun gnus-truncate-string (str width) (substring str 0 width)) @@ -90,7 +91,7 @@ "Return non-nil if FORM is funcallable." (or (and (symbolp form) (fboundp form)) (and (listp form) (eq (car form) 'lambda)) - (compiled-function-p form))) + (byte-code-function-p form))) (defsubst gnus-goto-char (point) (and point (goto-char point))) @@ -145,8 +146,8 @@ (defun gnus-byte-code (func) "Return a form that can be `eval'ed based on FUNC." - (let ((fval (symbol-function func))) - (if (compiled-function-p fval) + (let ((fval (indirect-function func))) + (if (byte-code-function-p fval) (let ((flist (append fval nil))) (setcar flist 'byte-code) flist) @@ -161,7 +162,6 @@ (setq address (substring from (match-beginning 0) (match-end 0)))) ;; Then we check whether the "name <address>" format is used. (and address - ;; Fix by MORIOKA Tomohiko <morioka@jaist.ac.jp> ;; Linear white space is not required. (string-match (concat "[ \t]*<" (regexp-quote address) ">") from) (and (setq name (substring from 0 (match-beginning 0))) @@ -175,7 +175,6 @@ (1- (match-end 0))))) (and (string-match "()" from) (setq name address)) - ;; Fix by MORIOKA Tomohiko <morioka@jaist.ac.jp>. ;; XOVER might not support folded From headers. (and (string-match "(.*" from) (setq name (substring from (1+ (match-beginning 0)) @@ -342,12 +341,11 @@ (yes-or-no-p prompt) (message ""))) -;; I suspect there's a better way, but I haven't taken the time to do -;; it yet. -erik selberg@cs.washington.edu (defun gnus-dd-mmm (messy-date) - "Return a string like DD-MMM from a big messy string" + "Return a string like DD-MMM from a big messy string." (let ((datevec (ignore-errors (timezone-parse-date messy-date)))) - (if (not datevec) + (if (or (not datevec) + (string-equal "0" (aref datevec 1))) "??-???" (format "%2s-%s" (condition-case () @@ -378,10 +376,10 @@ "Return a string of TIME in YYMMDDTHHMMSS format." (format-time-string "%Y%m%dT%H%M%S" time)) -(defun gnus-date-iso8601 (header) - "Convert the date field in HEADER to YYMMDDTHHMMSS" +(defun gnus-date-iso8601 (date) + "Convert the DATE to YYMMDDTHHMMSS." (condition-case () - (gnus-time-iso8601 (gnus-date-get-time (mail-header-date header))) + (gnus-time-iso8601 (gnus-date-get-time date)) (error ""))) (defun gnus-mode-string-quote (string) @@ -458,9 +456,7 @@ If N, return the Nth ancestor instead." (when references (let ((ids (inline (gnus-split-references references)))) - (while (nthcdr (or n 1) ids) - (setq ids (cdr ids))) - (car ids)))) + (car (last ids (or n 1)))))) (defsubst gnus-buffer-live-p (buffer) "Say whether BUFFER is alive or not." @@ -475,22 +471,23 @@ (let* ((orig (point)) (end (window-end (get-buffer-window (current-buffer) t))) (max 0)) - ;; Find the longest line currently displayed in the window. - (goto-char (window-start)) - (while (and (not (eobp)) - (< (point) end)) - (end-of-line) - (setq max (max max (current-column))) - (forward-line 1)) - (goto-char orig) - ;; Scroll horizontally to center (sort of) the point. - (if (> max (window-width)) - (set-window-hscroll - (get-buffer-window (current-buffer) t) - (min (- (current-column) (/ (window-width) 3)) - (+ 2 (- max (window-width))))) - (set-window-hscroll (get-buffer-window (current-buffer) t) 0)) - max))) + (when end + ;; Find the longest line currently displayed in the window. + (goto-char (window-start)) + (while (and (not (eobp)) + (< (point) end)) + (end-of-line) + (setq max (max max (current-column))) + (forward-line 1)) + (goto-char orig) + ;; Scroll horizontally to center (sort of) the point. + (if (> max (window-width)) + (set-window-hscroll + (get-buffer-window (current-buffer) t) + (min (- (current-column) (/ (window-width) 3)) + (+ 2 (- max (window-width))))) + (set-window-hscroll (get-buffer-window (current-buffer) t) 0)) + max)))) (defun gnus-read-event-char () "Get the next event." @@ -528,12 +525,11 @@ (defun gnus-kill-all-overlays () "Delete all overlays in the current buffer." - (unless gnus-xemacs - (let* ((overlayss (overlay-lists)) - (buffer-read-only nil) - (overlays (delq nil (nconc (car overlayss) (cdr overlayss))))) - (while overlays - (delete-overlay (pop overlays)))))) + (let* ((overlayss (overlay-lists)) + (buffer-read-only nil) + (overlays (delq nil (nconc (car overlayss) (cdr overlayss))))) + (while overlays + (delete-overlay (pop overlays))))) (defvar gnus-work-buffer " *gnus work*") @@ -543,7 +539,7 @@ (progn (set-buffer gnus-work-buffer) (erase-buffer)) - (set-buffer (get-buffer-create gnus-work-buffer)) + (set-buffer (gnus-get-buffer-create gnus-work-buffer)) (kill-all-local-variables) (buffer-disable-undo (current-buffer)))) @@ -580,14 +576,17 @@ (defun gnus-prin1 (form) "Use `prin1' on FORM in the current buffer. -Bind `print-quoted' to t while printing." +Bind `print-quoted' and `print-readably' to t while printing." (let ((print-quoted t) + (print-readably t) + (print-escape-multibyte nil) print-level print-length) (prin1 form (current-buffer)))) (defun gnus-prin1-to-string (form) - "The same as `prin1', but but `print-quoted' to t." - (let ((print-quoted t)) + "The same as `prin1', but bind `print-quoted' and `print-readably' to t." + (let ((print-quoted t) + (print-readably t)) (prin1-to-string form))) (defun gnus-make-directory (directory) @@ -604,14 +603,6 @@ ;; Write the buffer. (write-region (point-min) (point-max) file nil 'quietly)) -(defmacro gnus-delete-assq (key list) - `(let ((listval (eval ,list))) - (setq ,list (delq (assq ,key listval) listval)))) - -(defmacro gnus-delete-assoc (key list) - `(let ((listval ,list)) - (setq ,list (delq (assoc ,key listval) listval)))) - (defun gnus-delete-file (file) "Delete FILE if it exists." (when (file-exists-p file) @@ -630,9 +621,21 @@ (save-restriction (goto-char beg) (while (re-search-forward "[ \t]*\n" end 'move) - (put-text-property beg (match-beginning 0) prop val) + (gnus-put-text-property beg (match-beginning 0) prop val) (setq beg (point))) - (put-text-property beg (point) prop val))))) + (gnus-put-text-property beg (point) prop val))))) + +(defun gnus-put-text-property-excluding-characters-with-faces (beg end + prop val) + "The same as `put-text-property', but don't put props on characters with the `gnus-face' property." + (let ((b beg)) + (while (/= b end) + (when (get-text-property b 'gnus-face) + (setq b (next-single-property-change b 'gnus-face nil end))) + (when (/= b end) + (gnus-put-text-property + b (setq b (next-single-property-change b 'gnus-face nil end)) + prop val))))) ;;; Protected and atomic operations. dmoore@ucsd.edu 21.11.1996 ;;; The primary idea here is to try to protect internal datastructures @@ -755,13 +758,15 @@ (when msg (goto-char (point-min)) (widen) - (search-backward "\n\^_") - (narrow-to-region (point) (point-max)) + (search-backward "\n\^_") + (narrow-to-region (point) (point-max)) + (rmail-count-new-messages t) + (when (rmail-summary-exists) + (rmail-select-summary + (rmail-update-summary))) (rmail-count-new-messages t) - (if (rmail-summary-exists) - (rmail-select-summary - (rmail-update-summary))) - (rmail-show-message msg)))))) + (rmail-show-message msg)) + (save-buffer))))) (kill-buffer tmpbuf))) (defun gnus-output-to-mail (filename &optional ask) @@ -829,6 +834,155 @@ (goto-char (point-max)) (insert "\^_"))) +(defun gnus-map-function (funs arg) + "Applies the result of the first function in FUNS to the second, and so on. +ARG is passed to the first function." + (let ((myfuns funs)) + (while myfuns + (setq arg (funcall (pop myfuns) arg))) + arg)) + +(defun gnus-run-hooks (&rest funcs) + "Does the same as `run-hooks', but saves excursion." + (let ((buf (current-buffer))) + (unwind-protect + (apply 'run-hooks funcs) + (set-buffer buf)))) + +;;; +;;; .netrc and .authinforc parsing +;;; + +(defvar gnus-netrc-syntax-table + (let ((table (copy-syntax-table text-mode-syntax-table))) + (modify-syntax-entry ?@ "w" table) + (modify-syntax-entry ?- "w" table) + (modify-syntax-entry ?_ "w" table) + (modify-syntax-entry ?! "w" table) + (modify-syntax-entry ?. "w" table) + (modify-syntax-entry ?, "w" table) + (modify-syntax-entry ?: "w" table) + (modify-syntax-entry ?\; "w" table) + (modify-syntax-entry ?% "w" table) + (modify-syntax-entry ?) "w" table) + (modify-syntax-entry ?( "w" table) + table) + "Syntax table when parsing .netrc files.") + +(defun gnus-parse-netrc (file) + "Parse FILE and return an list of all entries in the file." + (if (not (file-exists-p file)) + () + (save-excursion + (let ((tokens '("machine" "default" "login" + "password" "account" "macdef" "force")) + alist elem result pair) + (nnheader-set-temp-buffer " *netrc*") + (unwind-protect + (progn + (set-syntax-table gnus-netrc-syntax-table) + (insert-file-contents file) + (goto-char (point-min)) + ;; Go through the file, line by line. + (while (not (eobp)) + (narrow-to-region (point) (gnus-point-at-eol)) + ;; For each line, get the tokens and values. + (while (not (eobp)) + (skip-chars-forward "\t ") + (unless (eobp) + (setq elem (buffer-substring + (point) (progn (forward-sexp 1) (point)))) + (cond + ((equal elem "macdef") + ;; We skip past the macro definition. + (widen) + (while (and (zerop (forward-line 1)) + (looking-at "$"))) + (narrow-to-region (point) (point))) + ((member elem tokens) + ;; Tokens that don't have a following value are ignored, + ;; except "default". + (when (and pair (or (cdr pair) + (equal (car pair) "default"))) + (push pair alist)) + (setq pair (list elem))) + (t + ;; Values that haven't got a preceding token are ignored. + (when pair + (setcdr pair elem) + (push pair alist) + (setq pair nil)))))) + (if alist + (push (nreverse alist) result)) + (setq alist nil + pair nil) + (widen) + (forward-line 1)) + (nreverse result)) + (kill-buffer " *netrc*")))))) + +(defun gnus-netrc-machine (list machine) + "Return the netrc values from LIST for MACHINE or for the default entry." + (let ((rest list)) + (while (and list + (not (equal (cdr (assoc "machine" (car list))) machine))) + (pop list)) + (car (or list + (progn (while (and rest (not (assoc "default" (car rest)))) + (pop rest)) + rest))))) + +(defun gnus-netrc-get (alist type) + "Return the value of token TYPE from ALIST." + (cdr (assoc type alist))) + +;;; Various + +(defvar gnus-group-buffer) ; Compiler directive +(defun gnus-alive-p () + "Say whether Gnus is running or not." + (and (boundp 'gnus-group-buffer) + (get-buffer gnus-group-buffer) + (save-excursion + (set-buffer gnus-group-buffer) + (eq major-mode 'gnus-group-mode)))) + +(defun gnus-remove-duplicates (list) + (let (new (tail list)) + (while tail + (or (member (car tail) new) + (setq new (cons (car tail) new))) + (setq tail (cdr tail))) + (nreverse new))) + +(defun gnus-delete-if (predicate list) + "Delete elements from LIST that satisfy PREDICATE." + (let (out) + (while list + (unless (funcall predicate (car list)) + (push (car list) out)) + (pop list)) + (nreverse out))) + +(defun gnus-delete-alist (key alist) + "Delete all entries in ALIST that have a key eq to KEY." + (let (entry) + (while (setq entry (assq key alist)) + (setq alist (delq entry alist))) + alist)) + +(defmacro gnus-pull (key alist) + "Modify ALIST to be without KEY." + (unless (symbolp alist) + (error "Not a symbol: %s" alist)) + `(setq ,alist (delq (assq ,key ,alist) ,alist))) + +(defun gnus-globalify-regexp (re) + "Returns a regexp that matches a whole line, iff RE matches a part of it." + (concat (unless (string-match "^\\^" re) "^.*") + re + (unless (string-match "\\$$" re) ".*$"))) + (provide 'gnus-util) ;;; gnus-util.el ends here
--- a/lisp/gnus/gnus-uu.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/gnus-uu.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ ;;; gnus-uu.el --- extract (uu)encoded files in Gnus -;; Copyright (C) 1985,86,87,93,94,95,96,97 Free Software Foundation, Inc. +;; Copyright (C) 1985,86,87,93,94,95,96,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Created: 2 Oct 1993 ;; Keyword: news @@ -28,6 +28,8 @@ (eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl)) + (require 'gnus) (require 'gnus-art) (require 'message) @@ -54,8 +56,8 @@ ;; Default viewing action rules (defcustom gnus-uu-default-view-rules - '(("\\.te?xt$\\|\\.doc$\\|read.*me\\|\\.c?$\\|\\.h$\\|\\.bat$\\|\\.asm$\\|makefile" "cat %s | sed s/\r//g") - ("\\.pas$" "cat %s | sed s/\r//g") + '(("\\.te?xt$\\|\\.doc$\\|read.*me\\|\\.c?$\\|\\.h$\\|\\.bat$\\|\\.asm$\\|makefile" "cat %s | sed 's/\r$//'") + ("\\.pas$" "cat %s | sed 's/\r$//'") ("\\.[1-9]$" "groff -mandoc -Tascii %s | sed s/\b.//g") ("\\.\\(jpe?g\\|gif\\|tiff?\\|p[pgb]m\\|xwd\\|xbm\\|pcx\\)$" "xv") ("\\.tga$" "tgatoppm %s | xv -") @@ -71,7 +73,7 @@ ("\\.\\(flc\\|fli\\|rle\\|iff\\|pfx\\|avi\\|sme\\|rpza\\|dl\\|qt\\|rsrc\\|mov\\)$" "xanim") ("\\.\\(tar\\|arj\\|zip\\|zoo\\|arc\\|gz\\|Z\\|lzh\\|ar\\|lha\\)$" "gnus-uu-archive")) - "Default actions to be taken when the user asks to view a file. + "*Default actions to be taken when the user asks to view a file. To change the behaviour, you can either edit this variable or set `gnus-uu-user-view-rules' to something useful. @@ -111,7 +113,7 @@ (defcustom gnus-uu-user-view-rules-end '(("" "file")) - "What actions are to be taken if no rule matched the file name. + "*What actions are to be taken if no rule matched the file name. See the documentation on the `gnus-uu-default-view-rules' variable for details." :group 'gnus-extract-view @@ -129,7 +131,7 @@ ("\\.Z$" "uncompress") ("\\.gz$" "gunzip") ("\\.arc$" "arc -x")) - "See `gnus-uu-user-archive-rules'." + "*See `gnus-uu-user-archive-rules'." :group 'gnus-extract-archive :type '(repeat (group regexp (string :tag "Command")))) @@ -283,10 +285,15 @@ :group 'gnus-extract :type 'boolean) +(defcustom gnus-uu-pre-uudecode-hook nil + "Hook run before sending a message to uudecode." + :group 'gnus-extract + :type 'hook) + (defcustom gnus-uu-digest-headers '("^Date:" "^From:" "^To:" "^Cc:" "^Subject:" "^Message-ID:" "^Keywords:" - "^Summary:" "^References:") - "List of regexps to match headers included in digested messages. + "^Summary:" "^References:" "^Content-Type:" "^Content-Transfer-Encoding:") + "*List of regexps to match headers included in digested messages. The headers will be included in the sequence they are matched." :group 'gnus-extract :type '(repeat regexp)) @@ -309,10 +316,10 @@ (defvar gnus-uu-saved-article-name nil) -(defconst gnus-uu-begin-string "^begin[ \t]+[0-7][0-7][0-7][ \t]+\\(.*\\)$") -(defconst gnus-uu-end-string "^end[ \t]*$") +(defvar gnus-uu-begin-string "^begin[ \t]+[0-7][0-7][0-7][ \t]+\\(.*\\)$") +(defvar gnus-uu-end-string "^end[ \t]*$") -(defconst gnus-uu-body-line "^M") +(defvar gnus-uu-body-line "^M") (let ((i 61)) (while (> (setq i (1- i)) 0) (setq gnus-uu-body-line (concat gnus-uu-body-line "[^a-z]"))) @@ -320,21 +327,21 @@ ;"^M.............................................................?$" -(defconst gnus-uu-shar-begin-string "^#! */bin/sh") +(defvar gnus-uu-shar-begin-string "^#! */bin/sh") (defvar gnus-uu-shar-file-name nil) -(defconst gnus-uu-shar-name-marker "begin [0-7][0-7][0-7][ \t]+\\(\\(\\w\\|\\.\\)*\\b\\)") +(defvar gnus-uu-shar-name-marker "begin [0-7][0-7][0-7][ \t]+\\(\\(\\w\\|\\.\\)*\\b\\)") -(defconst gnus-uu-postscript-begin-string "^%!PS-") -(defconst gnus-uu-postscript-end-string "^%%EOF$") +(defvar gnus-uu-postscript-begin-string "^%!PS-") +(defvar gnus-uu-postscript-end-string "^%%EOF$") (defvar gnus-uu-file-name nil) -(defconst gnus-uu-uudecode-process nil) +(defvar gnus-uu-uudecode-process nil) (defvar gnus-uu-binhex-article-name nil) (defvar gnus-uu-work-dir nil) -(defconst gnus-uu-output-buffer-name " *Gnus UU Output*") +(defvar gnus-uu-output-buffer-name " *Gnus UU Output*") (defvar gnus-uu-default-dir gnus-article-save-directory) (defvar gnus-uu-digest-from-subject nil) @@ -348,7 +355,9 @@ "v" gnus-uu-mark-over "s" gnus-uu-mark-series "r" gnus-uu-mark-region + "g" gnus-uu-unmark-region "R" gnus-uu-mark-by-regexp + "G" gnus-uu-unmark-by-regexp "t" gnus-uu-mark-thread "T" gnus-uu-unmark-thread "a" gnus-uu-mark-all @@ -506,12 +515,12 @@ (interactive "P") (let ((gnus-uu-save-in-digest t) (file (make-temp-name (nnheader-concat gnus-uu-tmp-dir "forward"))) - buf subject from newsgroups) + buf subject from) (gnus-setup-message 'forward (setq gnus-uu-digest-from-subject nil) (gnus-uu-decode-save n file) - (setq buf (switch-to-buffer (get-buffer-create " *gnus-uu-forward*"))) - (gnus-add-current-to-buffer-list) + (setq buf (switch-to-buffer + (gnus-get-buffer-create " *gnus-uu-forward*"))) (erase-buffer) (insert-file file) (let ((fs gnus-uu-digest-from-subject)) @@ -558,7 +567,6 @@ (defun gnus-uu-mark-by-regexp (regexp &optional unmark) "Ask for a regular expression and set the process mark on all articles that match." (interactive (list (read-from-minibuffer "Mark (regexp): "))) - (gnus-set-global-variables) (let ((articles (gnus-uu-find-articles-matching regexp))) (while articles (if unmark @@ -575,7 +583,6 @@ (defun gnus-uu-mark-series () "Mark the current series with the process mark." (interactive) - (gnus-set-global-variables) (let ((articles (gnus-uu-find-articles-matching))) (while articles (gnus-summary-set-process-mark (car articles)) @@ -586,7 +593,6 @@ (defun gnus-uu-mark-region (beg end &optional unmark) "Set the process mark on all articles between point and mark." (interactive "r") - (gnus-set-global-variables) (save-excursion (goto-char beg) (while (< (point) end) @@ -614,7 +620,6 @@ (defun gnus-uu-mark-thread () "Marks all articles downwards in this thread." (interactive) - (gnus-set-global-variables) (let ((level (gnus-summary-thread-level))) (while (and (gnus-summary-set-process-mark (gnus-summary-article-number)) (zerop (gnus-summary-next-subject 1)) @@ -624,7 +629,6 @@ (defun gnus-uu-unmark-thread () "Unmarks all articles downwards in this thread." (interactive) - (gnus-set-global-variables) (let ((level (gnus-summary-thread-level))) (while (and (gnus-summary-remove-process-mark (gnus-summary-article-number)) @@ -634,8 +638,9 @@ (defun gnus-uu-invert-processable () "Invert the list of process-marked articles." + (interactive) (let ((data gnus-newsgroup-data) - d number) + number) (save-excursion (while data (if (memq (setq number (gnus-data-number (pop data))) @@ -645,7 +650,7 @@ (gnus-summary-position-point)) (defun gnus-uu-mark-over (&optional score) - "Mark all articles with a score over SCORE (the prefix.)" + "Mark all articles with a score over SCORE (the prefix)." (interactive "P") (let ((score (gnus-score-default score)) (data gnus-newsgroup-data)) @@ -662,7 +667,6 @@ (defun gnus-uu-mark-sparse () "Mark all series that have some articles marked." (interactive) - (gnus-set-global-variables) (let ((marked (nreverse gnus-newsgroup-processable)) subject articles total headers) (unless marked @@ -687,7 +691,6 @@ (defun gnus-uu-mark-all () "Mark all articles in \"series\" order." (interactive) - (gnus-set-global-variables) (setq gnus-newsgroup-processable nil) (save-excursion (let ((data gnus-newsgroup-data) @@ -827,16 +830,15 @@ (mail-header-subject header)) gnus-uu-digest-from-subject)) (let ((name (file-name-nondirectory gnus-uu-saved-article-name)) - (delim (concat "^" (make-string 30 ?-) "$")) beg subj headers headline sorthead body end-string state) (if (or (eq in-state 'first) (eq in-state 'first-and-last)) (progn (setq state (list 'begin)) - (save-excursion (set-buffer (get-buffer-create "*gnus-uu-body*")) + (save-excursion (set-buffer (gnus-get-buffer-create "*gnus-uu-body*")) (erase-buffer)) (save-excursion - (set-buffer (get-buffer-create "*gnus-uu-pre*")) + (set-buffer (gnus-get-buffer-create "*gnus-uu-pre*")) (erase-buffer) (insert (format "Date: %s\nFrom: %s\nSubject: %s Digest\n\nTopics:\n" @@ -844,7 +846,7 @@ (when (not (eq in-state 'end)) (setq state (list 'middle)))) (save-excursion - (set-buffer (get-buffer "*gnus-uu-body*")) + (set-buffer "*gnus-uu-body*") (goto-char (setq beg (point-max))) (save-excursion (save-restriction @@ -858,10 +860,10 @@ (re-search-forward "\n\n") ;; Quote all 30-dash lines. (save-excursion - (while (re-search-forward delim nil t) + (while (re-search-forward "^-" nil t) (beginning-of-line) (delete-char 1) - (insert " "))) + (insert "- "))) (setq body (buffer-substring (1- (point)) (point-max))) (narrow-to-region (point-min) (point)) (if (not (setq headers gnus-uu-digest-headers)) @@ -886,16 +888,16 @@ (when (re-search-forward "^Subject: \\(.*\\)$" nil t) (setq subj (buffer-substring (match-beginning 1) (match-end 1))) (save-excursion - (set-buffer (get-buffer "*gnus-uu-pre*")) + (set-buffer "*gnus-uu-pre*") (insert (format " %s\n" subj))))) (when (or (eq in-state 'last) (eq in-state 'first-and-last)) (save-excursion - (set-buffer (get-buffer "*gnus-uu-pre*")) + (set-buffer "*gnus-uu-pre*") (insert (format "\n\n%s\n\n" (make-string 70 ?-))) (gnus-write-buffer gnus-uu-saved-article-name)) (save-excursion - (set-buffer (get-buffer "*gnus-uu-body*")) + (set-buffer "*gnus-uu-body*") (goto-char (point-max)) (insert (concat (setq end-string (format "End of %s Digest" name)) @@ -903,8 +905,8 @@ (insert (concat (make-string (length end-string) ?*) "\n")) (write-region (point-min) (point-max) gnus-uu-saved-article-name t)) - (kill-buffer (get-buffer "*gnus-uu-pre*")) - (kill-buffer (get-buffer "*gnus-uu-body*")) + (gnus-kill-buffer "*gnus-uu-pre*") + (gnus-kill-buffer "*gnus-uu-body*") (push 'end state)) (if (memq 'begin state) (cons gnus-uu-saved-article-name state) @@ -912,11 +914,11 @@ ;; Binhex treatment - not very advanced. -(defconst gnus-uu-binhex-body-line +(defvar gnus-uu-binhex-body-line "^[^:]...............................................................$") -(defconst gnus-uu-binhex-begin-line +(defvar gnus-uu-binhex-begin-line "^:...............................................................$") -(defconst gnus-uu-binhex-end-line +(defvar gnus-uu-binhex-end-line ":$") (defun gnus-uu-binhex-article (buffer in-state) @@ -969,7 +971,7 @@ (if (not (re-search-forward gnus-uu-postscript-end-string nil t)) (setq state (list 'wrong-type)) (setq end-char (point)) - (set-buffer (get-buffer-create gnus-uu-output-buffer-name)) + (set-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name)) (insert-buffer-substring process-buffer start-char end-char) (setq file-name (concat gnus-uu-work-dir (cdr gnus-article-current) ".ps")) @@ -1019,45 +1021,36 @@ (defun gnus-uu-reginize-string (string) ;; Takes a string and puts a \ in front of every special character; - ;; ignores any leading "version numbers" thingies that they use in - ;; the comp.binaries groups, and either replaces anything that looks - ;; like "2/3" with "[0-9]+/[0-9]+" or, if it can't find something - ;; like that, replaces the last two numbers with "[0-9]+". This, in - ;; my experience, should get most postings of a series. - (let ((count 2) - (vernum "v[0-9]+[a-z][0-9]+:") - beg) - (save-excursion - (set-buffer (get-buffer-create gnus-uu-output-buffer-name)) - (buffer-disable-undo (current-buffer)) - (erase-buffer) - (insert (regexp-quote string)) - (setq beg 1) + ;; replaces the last thing that looks like "2/3" with "[0-9]+/3" + ;; or, if it can't find something like that, tries "2 of 3", then + ;; finally just replaces the next to last number with "[0-9]+". + (save-excursion + (set-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name)) + (buffer-disable-undo (current-buffer)) + (erase-buffer) + (insert (regexp-quote string)) + + (setq case-fold-search nil) + + (end-of-line) + (if (re-search-backward "\\([^0-9]\\)[0-9]+/\\([0-9]+\\)" nil t) + (replace-match "\\1[0-9]+/\\2") - (setq case-fold-search nil) - (goto-char (point-min)) - (when (looking-at vernum) - (replace-match vernum t t) - (setq beg (length vernum))) - - (goto-char beg) - (if (re-search-forward "[ \t]*[0-9]+/[0-9]+" nil t) - (replace-match " [0-9]+/[0-9]+") + (end-of-line) + (if (re-search-backward "\\([^0-9]\\)[0-9]+[ \t]*of[ \t]*\\([0-9]+\\)" + nil t) + (replace-match "\\1[0-9]+ of \\2") - (goto-char beg) - (if (re-search-forward "[0-9]+[ \t]*of[ \t]*[0-9]+" nil t) - (replace-match "[0-9]+ of [0-9]+") + (end-of-line) + (if (re-search-backward "\\([^0-9]\\)[0-9]+\\([^0-9]+\\)[0-9]+" + nil t) + (replace-match "\\1[0-9]+\\2[0-9]+" t nil nil nil)))) - (end-of-line) - (if (re-search-backward "\\([^0-9]\\)[0-9]+\\([^0-9]+\\)[0-9]+" - nil t) - (replace-match "\\1[0-9]+\\2[0-9]+" t nil nil nil)))) + (goto-char 1) + (while (re-search-forward "[ \t]+" nil t) + (replace-match "[ \t]+" t t)) - (goto-char beg) - (while (re-search-forward "[ \t]+" nil t) - (replace-match "[ \t]*" t t)) - - (buffer-substring 1 (point-max))))) + (buffer-substring 1 (point-max)))) (defun gnus-uu-get-list-of-articles (n) ;; If N is non-nil, the article numbers of the N next articles @@ -1097,8 +1090,7 @@ (gnus-uu-reginize-string (gnus-summary-article-subject)))) list-of-subjects) (save-excursion - (if (not subject) - () + (when subject ;; Collect all subjects matching subject. (let ((case-fold-search t) (data gnus-newsgroup-data) @@ -1133,7 +1125,7 @@ (let ((out-list string-list) string) (save-excursion - (set-buffer (get-buffer-create gnus-uu-output-buffer-name)) + (set-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name)) (buffer-disable-undo (current-buffer)) (while string-list (erase-buffer) @@ -1208,6 +1200,7 @@ (defun gnus-uu-grab-articles (articles process-function &optional sloppy limit no-errors) (let ((state 'first) + (gnus-asynchronous nil) has-been-begin article result-file result-files process-state gnus-summary-display-article-function gnus-article-display-hook gnus-article-prepare-hook @@ -1219,119 +1212,121 @@ (not (memq 'end process-state)))) (setq article (pop articles)) - (push article article-series) + (when (vectorp (gnus-summary-article-header article)) + (push article article-series) - (unless articles - (if (eq state 'first) - (setq state 'first-and-last) - (setq state 'last))) + (unless articles + (if (eq state 'first) + (setq state 'first-and-last) + (setq state 'last))) - (let ((part (gnus-uu-part-number article))) - (gnus-message 6 "Getting article %d%s..." - article (if (string= part "") "" (concat ", " part)))) - (gnus-summary-display-article article) + (let ((part (gnus-uu-part-number article))) + (gnus-message 6 "Getting article %d%s..." + article (if (string= part "") "" (concat ", " part)))) + (gnus-summary-display-article article) - ;; Push the article to the processing function. - (save-excursion - (set-buffer gnus-original-article-buffer) - (let ((buffer-read-only nil)) - (save-excursion - (set-buffer gnus-summary-buffer) - (setq process-state - (funcall process-function - gnus-original-article-buffer state))))) + ;; Push the article to the processing function. + (save-excursion + (set-buffer gnus-original-article-buffer) + (let ((buffer-read-only nil)) + (save-excursion + (set-buffer gnus-summary-buffer) + (setq process-state + (funcall process-function + gnus-original-article-buffer state))))) - (gnus-summary-remove-process-mark article) + (gnus-summary-remove-process-mark article) - ;; If this is the beginning of a decoded file, we push it - ;; on to a list. - (when (or (memq 'begin process-state) - (and (or (eq state 'first) - (eq state 'first-and-last)) - (memq 'ok process-state))) - (when has-been-begin - ;; If there is a `result-file' here, that means that the - ;; file was unsuccessfully decoded, so we delete it. - (when (and result-file - (file-exists-p result-file) - (not gnus-uu-be-dangerous) - (or (eq gnus-uu-be-dangerous t) - (gnus-y-or-n-p - (format "Delete unsuccessfully decoded file %s" - result-file)))) - (delete-file result-file))) - (when (memq 'begin process-state) - (setq result-file (car process-state))) - (setq has-been-begin t)) + ;; If this is the beginning of a decoded file, we push it + ;; on to a list. + (when (or (memq 'begin process-state) + (and (or (eq state 'first) + (eq state 'first-and-last)) + (memq 'ok process-state))) + (when has-been-begin + ;; If there is a `result-file' here, that means that the + ;; file was unsuccessfully decoded, so we delete it. + (when (and result-file + (file-exists-p result-file) + (not gnus-uu-be-dangerous) + (or (eq gnus-uu-be-dangerous t) + (gnus-y-or-n-p + (format "Delete unsuccessfully decoded file %s" + result-file)))) + (delete-file result-file))) + (when (memq 'begin process-state) + (setq result-file (car process-state))) + (setq has-been-begin t)) - ;; Check whether we have decoded one complete file. - (when (memq 'end process-state) - (setq article-series nil) - (setq has-been-begin nil) - (if (stringp result-file) - (setq files (list result-file)) - (setq files result-file)) - (setq result-file (car files)) - (while files - (push (list (cons 'name (pop files)) - (cons 'article article)) - result-files)) - ;; Allow user-defined functions to be run on this file. - (when gnus-uu-grabbed-file-functions - (let ((funcs gnus-uu-grabbed-file-functions)) - (unless (listp funcs) - (setq funcs (list funcs))) - (while funcs - (funcall (pop funcs) result-file)))) - (setq result-file nil) - ;; Check whether we have decoded enough articles. - (and limit (= (length result-files) limit) - (setq articles nil))) + ;; Check whether we have decoded one complete file. + (when (memq 'end process-state) + (setq article-series nil) + (setq has-been-begin nil) + (if (stringp result-file) + (setq files (list result-file)) + (setq files result-file)) + (setq result-file (car files)) + (while files + (push (list (cons 'name (pop files)) + (cons 'article article)) + result-files)) + ;; Allow user-defined functions to be run on this file. + (when gnus-uu-grabbed-file-functions + (let ((funcs gnus-uu-grabbed-file-functions)) + (unless (listp funcs) + (setq funcs (list funcs))) + (while funcs + (funcall (pop funcs) result-file)))) + (setq result-file nil) + ;; Check whether we have decoded enough articles. + (and limit (= (length result-files) limit) + (setq articles nil))) - ;; If this is the last article to be decoded, and - ;; we still haven't reached the end, then we delete - ;; the partially decoded file. - (and (or (eq state 'last) (eq state 'first-and-last)) - (not (memq 'end process-state)) - result-file - (file-exists-p result-file) - (not gnus-uu-be-dangerous) - (or (eq gnus-uu-be-dangerous t) - (gnus-y-or-n-p (format "Delete incomplete file %s? " result-file))) - (delete-file result-file)) + ;; If this is the last article to be decoded, and + ;; we still haven't reached the end, then we delete + ;; the partially decoded file. + (and (or (eq state 'last) (eq state 'first-and-last)) + (not (memq 'end process-state)) + result-file + (file-exists-p result-file) + (not gnus-uu-be-dangerous) + (or (eq gnus-uu-be-dangerous t) + (gnus-y-or-n-p + (format "Delete incomplete file %s? " result-file))) + (delete-file result-file)) - ;; If this was a file of the wrong sort, then - (when (and (or (memq 'wrong-type process-state) - (memq 'error process-state)) - gnus-uu-unmark-articles-not-decoded) - (gnus-summary-tick-article article t)) + ;; If this was a file of the wrong sort, then + (when (and (or (memq 'wrong-type process-state) + (memq 'error process-state)) + gnus-uu-unmark-articles-not-decoded) + (gnus-summary-tick-article article t)) - ;; Set the new series state. - (if (and (not has-been-begin) - (not sloppy) - (or (memq 'end process-state) - (memq 'middle process-state))) - (progn - (setq process-state (list 'error)) - (gnus-message 2 "No begin part at the beginning") - (sleep-for 2)) - (setq state 'middle))) + ;; Set the new series state. + (if (and (not has-been-begin) + (not sloppy) + (or (memq 'end process-state) + (memq 'middle process-state))) + (progn + (setq process-state (list 'error)) + (gnus-message 2 "No begin part at the beginning") + (sleep-for 2)) + (setq state 'middle))) - ;; When there are no result-files, then something must be wrong. - (if result-files - (message "") - (cond - ((not has-been-begin) - (gnus-message 2 "Wrong type file")) - ((memq 'error process-state) - (gnus-message 2 "An error occurred during decoding")) - ((not (or (memq 'ok process-state) - (memq 'end process-state))) - (gnus-message 2 "End of articles reached before end of file"))) - ;; Make unsuccessfully decoded articles unread. - (when gnus-uu-unmark-articles-not-decoded - (while article-series - (gnus-summary-tick-article (pop article-series) t)))) + ;; When there are no result-files, then something must be wrong. + (if result-files + (message "") + (cond + ((not has-been-begin) + (gnus-message 2 "Wrong type file")) + ((memq 'error process-state) + (gnus-message 2 "An error occurred during decoding")) + ((not (or (memq 'ok process-state) + (memq 'end process-state))) + (gnus-message 2 "End of articles reached before end of file"))) + ;; Make unsuccessfully decoded articles unread. + (when gnus-uu-unmark-articles-not-decoded + (while article-series + (gnus-summary-tick-article (pop article-series) t))))) result-files)) @@ -1355,11 +1350,18 @@ (defun gnus-uu-part-number (article) (let* ((header (gnus-summary-article-header article)) - (subject (and header (mail-header-subject header)))) - (if (and subject - (string-match "[0-9]+ */[0-9]+\\|[0-9]+ * of *[0-9]+" subject)) - (match-string 0 subject) - ""))) + (subject (and header (mail-header-subject header))) + (part nil)) + (if subject + (while (string-match "[0-9]+/[0-9]+\\|[0-9]+[ \t]+of[ \t]+[0-9]+" + subject) + (setq part (match-string 0 subject)) + (setq subject (substring subject (match-end 0))))) + (or part + (while (string-match "\\([0-9]+\\)[^0-9]+\\([0-9]+\\)" subject) + (setq part (match-string 0 subject)) + (setq subject (substring subject (match-end 0))))) + (or part ""))) (defun gnus-uu-uudecode-sentinel (process event) (delete-process (get-process process))) @@ -1417,7 +1419,7 @@ (setq gnus-uu-uudecode-process (start-process "*uudecode*" - (get-buffer-create gnus-uu-output-buffer-name) + (gnus-get-buffer-create gnus-uu-output-buffer-name) shell-file-name shell-command-switch (format "cd %s %s uudecode" gnus-uu-work-dir gnus-shell-command-separator)))) @@ -1440,6 +1442,7 @@ ;; Try to correct mishandled uucode. (when gnus-uu-correct-stripped-uucode (gnus-uu-check-correct-stripped-uucode start-char (point))) + (gnus-run-hooks 'gnus-uu-pre-uudecode-hook) ;; Send the text to the process. (condition-case nil @@ -1482,7 +1485,7 @@ (setq start-char (point)) (call-process-region start-char (point-max) shell-file-name nil - (get-buffer-create gnus-uu-output-buffer-name) nil + (gnus-get-buffer-create gnus-uu-output-buffer-name) nil shell-command-switch (concat "cd " gnus-uu-work-dir " " gnus-shell-command-separator " sh")))) @@ -1545,13 +1548,13 @@ (setq command (format "cd %s ; %s" dir (gnus-uu-command action file-path))) (save-excursion - (set-buffer (get-buffer-create gnus-uu-output-buffer-name)) + (set-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name)) (erase-buffer)) (gnus-message 5 "Unpacking: %s..." (gnus-uu-command action file-path)) (if (= 0 (call-process shell-file-name nil - (get-buffer-create gnus-uu-output-buffer-name) + (gnus-get-buffer-create gnus-uu-output-buffer-name) nil shell-command-switch command)) (message "") (gnus-message 2 "Error during unpacking of archive") @@ -1696,7 +1699,7 @@ (defun gnus-quote-arg-for-sh-or-csh (arg) (let ((pos 0) new-pos accum) ;; *** bug: we don't handle newline characters properly - (while (setq new-pos (string-match "[!`\"$\\& \t{}]" arg pos)) + (while (setq new-pos (string-match "[;!`\"$\\& \t{}]" arg pos)) (push (substring arg pos new-pos) accum) (push "\\" accum) (push (list (aref arg new-pos)) accum) @@ -1839,7 +1842,8 @@ ;; Encodes with base64 and adds MIME headers (defun gnus-uu-post-encode-mime (path file-name) - (when (gnus-uu-post-encode-file "mmencode" path file-name) + (when (zerop (call-process shell-file-name nil t nil shell-command-switch + (format "%s %s -o %s" "mmencode" path file-name))) (gnus-uu-post-make-mime file-name "base64") t)) @@ -1897,8 +1901,10 @@ (goto-char (point-max)) (insert (format "\n%s\n" gnus-uu-post-binary-separator)) + ;; #### Unix-specific? (when (string-match "^~/" file-path) (setq file-path (concat "$HOME" (substring file-path 1)))) + ;; #### Unix-specific? (if (string-match "/[^/]*$" file-path) (setq file-name (substring file-path (1+ (match-beginning 0)))) (setq file-name file-path)) @@ -1906,7 +1912,7 @@ (unwind-protect (if (save-excursion (set-buffer (setq uubuf - (get-buffer-create uuencode-buffer-name))) + (gnus-get-buffer-create uuencode-buffer-name))) (erase-buffer) (funcall gnus-uu-post-encode-method file-path file-name)) (insert-buffer-substring uubuf) @@ -1921,7 +1927,7 @@ (top-string "[ cut here %s (%s %d/%d) %s gnus-uu ]") (separator (concat mail-header-separator "\n\n")) uubuf length parts header i end beg - beg-line minlen buf post-buf whole-len beg-binary end-binary) + beg-line minlen post-buf whole-len beg-binary end-binary) (setq post-buf (current-buffer)) @@ -1939,7 +1945,7 @@ (setq end-binary (point-max)) (save-excursion - (set-buffer (setq uubuf (get-buffer-create encoded-buffer-name))) + (set-buffer (setq uubuf (gnus-get-buffer-create encoded-buffer-name))) (erase-buffer) (insert-buffer-substring post-buf beg-binary end-binary) (goto-char (point-min)) @@ -1971,7 +1977,7 @@ (setq i 1) (setq beg 1) (while (not (> i parts)) - (set-buffer (get-buffer-create send-buffer-name)) + (set-buffer (gnus-get-buffer-create send-buffer-name)) (erase-buffer) (insert header) (when (and threaded gnus-uu-post-message-id)
--- a/lisp/gnus/gnus-vm.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/gnus-vm.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,5 +1,5 @@ ;;; gnus-vm.el --- vm interface for Gnus -;; Copyright (C) 1994,95,96,97 Free Software Foundation, Inc. +;; Copyright (C) 1994,95,96,97,98 Free Software Foundation, Inc. ;; Author: Per Persson <pp@gnu.ai.mit.edu> ;; Keywords: news, mail @@ -88,12 +88,10 @@ (defun gnus-summary-save-in-vm (&optional folder) (interactive) (setq folder - (cond ((eq folder 'default) default-name) - (folder folder) - (t (gnus-read-save-file-name - "Save %s in VM folder:" folder - gnus-mail-save-name gnus-newsgroup-name - gnus-current-headers 'gnus-newsgroup-last-mail)))) + (gnus-read-save-file-name + "Save %s in VM folder:" folder + gnus-mail-save-name gnus-newsgroup-name + gnus-current-headers 'gnus-newsgroup-last-mail)) (gnus-eval-in-buffer-window gnus-original-article-buffer (save-excursion (save-restriction
--- a/lisp/gnus/gnus-win.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/gnus-win.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ ;;; gnus-win.el --- window configuration functions for Gnus -;; Copyright (C) 1996,97 Free Software Foundation, Inc. +;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news ;; This file is part of GNU Emacs. @@ -27,6 +27,8 @@ (eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl)) + (require 'gnus) (defgroup gnus-windows nil @@ -137,9 +139,6 @@ (vertical 1.0 (article 0.5) (message 1.0 point))) - (draft - (vertical 1.0 - (draft 1.0 point))) (pipe (vertical 1.0 (summary 0.25 point) @@ -157,6 +156,13 @@ (vertical 1.0 (summary 0.5 point) ("*Score Words*" 1.0))) + (split-trace + (vertical 1.0 + (summary 0.5 point) + ("*Split Trace*" 1.0))) + (category + (vertical 1.0 + (category 1.0))) (compose-bounce (vertical 1.0 (article 0.5) @@ -182,10 +188,12 @@ (mail . gnus-message-buffer) (post-news . gnus-message-buffer) (faq . gnus-faq-buffer) - (picons . "*Picons*") + (picons . gnus-picons-buffer-name) (tree . gnus-tree-buffer) (score-trace . "*Score Trace*") + (split-trace . "*Split Trace*") (info . gnus-info-buffer) + (category . gnus-category-buffer) (article-copy . gnus-article-copy) (draft . gnus-draft-buffer)) "Mapping from short symbols to buffer names or buffer variables.") @@ -196,6 +204,7 @@ "The most recently set window configuration.") (defvar gnus-created-frames nil) +(defvar gnus-window-frame-focus nil) (defun gnus-kill-gnus-frames () "Kill all frames Gnus has created." @@ -266,6 +275,16 @@ (defvar gnus-frame-list nil) +(defun gnus-window-to-buffer-helper (obj) + (cond ((not (symbolp obj)) + obj) + ((boundp obj) + (symbol-value obj)) + ((fboundp obj) + (funcall obj)) + (t + nil))) + (defun gnus-configure-frame (split &optional window) "Split WINDOW according to SPLIT." (unless window @@ -299,15 +318,13 @@ ;; This is a buffer to be selected. ((not (memq type '(frame horizontal vertical))) (let ((buffer (cond ((stringp type) type) - (t (cdr (assq type gnus-window-to-buffer))))) - buf) + (t (cdr (assq type gnus-window-to-buffer)))))) (unless buffer (error "Illegal buffer type: %s" type)) - (unless (setq buf (get-buffer (if (symbolp buffer) - (symbol-value buffer) buffer))) - (setq buf (get-buffer-create (if (symbolp buffer) - (symbol-value buffer) buffer)))) - (switch-to-buffer buf) + (switch-to-buffer (gnus-get-buffer-create + (gnus-window-to-buffer-helper buffer))) + (when (memq 'frame-focus split) + (setq gnus-window-frame-focus window)) ;; We return the window if it has the `point' spec. (and (memq 'point split) window))) ;; This is a frame split. @@ -431,20 +448,14 @@ (select-frame frame))) (switch-to-buffer nntp-server-buffer) - (gnus-configure-frame split (get-buffer-window (current-buffer)))))) + (let (gnus-window-frame-focus) + (gnus-configure-frame split (get-buffer-window (current-buffer))) + (when gnus-window-frame-focus + (select-frame (window-frame gnus-window-frame-focus))))))) (defun gnus-delete-windows-in-gnusey-frames () "Do a `delete-other-windows' in all frames that have Gnus windows." - (let ((buffers - (mapcar - (lambda (elem) - (if (symbolp (cdr elem)) - (when (and (boundp (cdr elem)) - (symbol-value (cdr elem))) - (get-buffer (symbol-value (cdr elem)))) - (when (cdr elem) - (get-buffer (cdr elem))))) - gnus-window-to-buffer))) + (let ((buffers (gnus-buffers))) (mapcar (lambda (frame) (unless (eq (cdr (assq 'minibuffer @@ -492,12 +503,9 @@ (t (cdr (assq type gnus-window-to-buffer))))) (unless buffer (error "Illegal buffer type: %s" type)) - (when (setq buf (get-buffer (if (symbolp buffer) - (symbol-value buffer) - buffer))) - (setq win (get-buffer-window buf t))) - (if win - (when (memq 'point split) + (if (and (setq buf (get-buffer (gnus-window-to-buffer-helper buffer))) + (setq win (get-buffer-window buf t))) + (if (memq 'point split) (setq all-visible win)) (setq all-visible nil))) (t @@ -511,42 +519,22 @@ (nth 1 (window-edges window))) (defun gnus-remove-some-windows () - (let ((buffers gnus-window-to-buffer) + (let ((buffers (gnus-buffers)) buf bufs lowest-buf lowest) (save-excursion ;; Remove windows on all known Gnus buffers. - (while buffers - (setq buf (cdar buffers)) - (when (symbolp buf) - (setq buf (and (boundp buf) (symbol-value buf)))) - (and buf - (get-buffer-window buf) - (progn - (push buf bufs) - (pop-to-buffer buf) - (when (or (not lowest) - (< (gnus-window-top-edge) lowest)) - (setq lowest (gnus-window-top-edge)) - (setq lowest-buf buf)))) - (setq buffers (cdr buffers))) - ;; Remove windows on *all* summary buffers. - (walk-windows - (lambda (win) - (let ((buf (window-buffer win))) - (when (string-match "^\\*Summary" (buffer-name buf)) - (push buf bufs) - (pop-to-buffer buf) - (when (or (not lowest) - (< (gnus-window-top-edge) lowest)) - (setq lowest-buf buf) - (setq lowest (gnus-window-top-edge))))))) + (while (setq buf (pop buffers)) + (when (get-buffer-window buf) + (push buf bufs) + (pop-to-buffer buf) + (when (or (not lowest) + (< (gnus-window-top-edge) lowest)) + (setq lowest (gnus-window-top-edge) + lowest-buf buf)))) (when lowest-buf (pop-to-buffer lowest-buf) (switch-to-buffer nntp-server-buffer)) - (while bufs - (when (not (eq (car bufs) lowest-buf)) - (delete-windows-on (car bufs))) - (setq bufs (cdr bufs)))))) + (mapcar (lambda (b) (delete-windows-on b t)) bufs)))) (provide 'gnus-win)
--- a/lisp/gnus/gnus.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/gnus.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,8 +1,8 @@ ;;; gnus.el --- a newsreader for GNU Emacs -;; Copyright (C) 1987,88,89,90,93,94,95,96,97 Free Software Foundation, Inc. +;; Copyright (C) 1987,88,89,90,93,94,95,96,97,98 Free Software Foundation, Inc. ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> -;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news, mail ;; This file is part of GNU Emacs. @@ -30,8 +30,12 @@ (eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl)) + (require 'custom) -(require 'gnus-load) +(eval-and-compile + (if (< emacs-major-version 20) + (require 'gnus-load))) (require 'message) (defgroup gnus nil @@ -39,6 +43,10 @@ :group 'news :group 'mail) +(defgroup gnus-cache nil + "Cache interface." + :group 'gnus) + (defgroup gnus-start nil "Starting your favorite newsreader." :group 'gnus) @@ -203,6 +211,10 @@ :group 'gnus :group 'faces) +(defgroup gnus-agent nil + "Offline support for Gnus." + :group 'gnus) + (defgroup gnus-files nil "Files used by Gnus." :group 'gnus) @@ -240,7 +252,7 @@ :link '(custom-manual "(gnus)Exiting Gnus") :group 'gnus) -(defconst gnus-version-number "5.5" +(defconst gnus-version-number "5.7" "Version number for this version of Gnus.") (defconst gnus-version (format "Gnus v%s" gnus-version-number) @@ -262,6 +274,7 @@ (unless (featurep 'gnus-xmas) (defalias 'gnus-make-overlay 'make-overlay) + (defalias 'gnus-delete-overlay 'delete-overlay) (defalias 'gnus-overlay-put 'overlay-put) (defalias 'gnus-move-overlay 'move-overlay) (defalias 'gnus-overlay-end 'overlay-end) @@ -276,47 +289,10 @@ (defalias 'gnus-put-text-property 'put-text-property) (defalias 'gnus-mode-line-buffer-identification 'identity) (defalias 'gnus-characterp 'numberp) + (defalias 'gnus-deactivate-mark 'deactivate-mark) + (defalias 'gnus-window-edges 'window-edges) (defalias 'gnus-key-press-event-p 'numberp)) -;; The XEmacs people think this is evil, so it must go. -(defun custom-face-lookup (&optional fg bg stipple bold italic underline) - "Lookup or create a face with specified attributes." - (let ((name (intern (format "custom-face-%s-%s-%s-%S-%S-%S" - (or fg "default") - (or bg "default") - (or stipple "default") - bold italic underline)))) - (if (and (custom-facep name) - (fboundp 'make-face)) - () - (copy-face 'default name) - (when (and fg - (not (string-equal fg "default"))) - (ignore-errors - (set-face-foreground name fg))) - (when (and bg - (not (string-equal bg "default"))) - (ignore-errors - (set-face-background name bg))) - (when (and stipple - (not (string-equal stipple "default")) - (not (eq stipple 'custom:asis)) - (fboundp 'set-face-stipple)) - (set-face-stipple name stipple)) - (when (and bold - (not (eq bold 'custom:asis))) - (ignore-errors - (make-face-bold name))) - (when (and italic - (not (eq italic 'custom:asis))) - (ignore-errors - (make-face-italic name))) - (when (and underline - (not (eq underline 'custom:asis))) - (ignore-errors - (set-face-underline-p name t)))) - name)) - ;; We define these group faces here to avoid the display ;; update forced when creating new faces. @@ -626,6 +602,33 @@ "Face used for normal interest read articles.") +;;; +;;; Gnus buffers +;;; + +(defvar gnus-buffers nil) + +(defun gnus-get-buffer-create (name) + "Do the same as `get-buffer-create', but store the created buffer." + (or (get-buffer name) + (car (push (get-buffer-create name) gnus-buffers)))) + +(defun gnus-add-buffer () + "Add the current buffer to the list of Gnus buffers." + (push (current-buffer) gnus-buffers)) + +(defun gnus-buffers () + "Return a list of live Gnus buffers." + (while (and gnus-buffers + (not (buffer-name (car gnus-buffers)))) + (pop gnus-buffers)) + (let ((buffers gnus-buffers)) + (while (cdr buffers) + (if (buffer-name (cadr buffers)) + (pop buffers) + (setcdr buffers (cddr buffers))))) + gnus-buffers) + ;;; Splash screen. (defvar gnus-group-buffer "*Group*") @@ -636,17 +639,17 @@ (defface gnus-splash-face '((((class color) (background dark)) - (:foreground "red")) + (:foreground "ForestGreen")) (((class color) (background light)) - (:foreground "red")) + (:foreground "ForestGreen")) (t ())) "Level 1 newsgroup face.") (defun gnus-splash () (save-excursion - (switch-to-buffer gnus-group-buffer) + (switch-to-buffer (gnus-get-buffer-create gnus-group-buffer)) (let ((buffer-read-only nil)) (erase-buffer) (unless gnus-inhibit-startup-message @@ -714,9 +717,10 @@ (eval-when (load) (let ((command (format "%s" this-command))) - (when (and (string-match "gnus" command) - (not (string-match "gnus-other-frame" command))) - (gnus-splash)))) + (if (and (string-match "gnus" command) + (not (string-match "gnus-other-frame" command))) + (gnus-splash) + (gnus-get-buffer-create gnus-group-buffer)))) ;;; Do the rest. @@ -732,7 +736,12 @@ (defcustom gnus-directory (or (getenv "SAVEDIR") (nnheader-concat gnus-home-directory "News/")) - "Directory variable from which all other Gnus file variables are derived." + "*Directory variable from which all other Gnus file variables are derived. + +Note that Gnus is mostly loaded when the `.gnus.el' file is read. +This means that other directory variables that are initialized from +this variable won't be set properly if you set this variable in `.gnus.el'. +Set this variable in `.emacs' instead." :group 'gnus-files :type 'directory) @@ -774,7 +783,7 @@ (or (getenv "NNTPSERVER") (and (file-readable-p gnus-nntpserver-file) (save-excursion - (set-buffer (get-buffer-create " *gnus nntp*")) + (set-buffer (gnus-get-buffer-create " *gnus nntp*")) (buffer-disable-undo (current-buffer)) (insert-file-contents gnus-nntpserver-file) (let ((name (buffer-string))) @@ -799,7 +808,7 @@ nil (list gnus-nntp-service))) (error nil)) - "Default method for selecting a newsgroup. + "*Default method for selecting a newsgroup. This variable should be a list, where the first element is how the news is to be fetched, the second is the address. @@ -827,7 +836,7 @@ ,(nnheader-concat message-directory "archive/active")) (nnfolder-get-new-mail nil) (nnfolder-inhibit-expiry t)) - "Method used for archiving messages you've sent. + "*Method used for archiving messages you've sent. This should be a mail method. It's probably not a very effective to change this variable once you've @@ -859,6 +868,7 @@ \"nnml+private:mail.misc\", for instance." :group 'gnus-message :type '(choice (const :tag "none" nil) + sexp string)) (defcustom gnus-secondary-servers nil @@ -932,7 +942,7 @@ "/ftp@nctuccca.edu.tw:/USENET/FAQ/" "/ftp@hwarang.postech.ac.kr:/pub/usenet/" "/ftp@ftp.hk.super.net:/mirror/faqs/") - "Directory where the group FAQs are stored. + "*Directory where the group FAQs are stored. This will most commonly be on a remote machine, and the file will be fetched by ange-ftp. @@ -1090,7 +1100,7 @@ (defcustom gnus-summary-prepare-exit-hook '(gnus-summary-expire-articles) - "A hook called when preparing to exit from the summary buffer. + "*A hook called when preparing to exit from the summary buffer. It calls `gnus-summary-expire-articles' by default." :group 'gnus-summary-exit :type 'hook) @@ -1104,7 +1114,8 @@ (defcustom gnus-expert-user nil "*Non-nil means that you will never be asked for confirmation about anything. -And that means *anything*." +That doesn't mean *anything* anything; particularly destructive +commands will still require prompting." :group 'gnus-meta :type 'boolean) @@ -1154,9 +1165,11 @@ ("nnsoup" post-mail address) ("nndraft" post-mail) ("nnfolder" mail respool address) - ("nngateway" none address prompt-address physical-address) - ("nnweb" none)) - "An alist of valid select methods. + ("nngateway" post-mail address prompt-address physical-address) + ("nnweb" none) + ("nnlistserv" none) + ("nnagent" post-mail)) + "*An alist of valid select methods. The first element of each list lists should be a string with the name of the select method. The other elements may be the category of this method (i. e., `post', `mail', `none' or whatever) or other @@ -1283,7 +1296,7 @@ browse-menu server-menu page-marker tree-menu binary-menu pick-menu grouplens-menu) - "Enable visual features. + "*Enable visual features. If `visual' is disabled, there will be no menus and few faces. Most of the visual customization options below will be ignored. Gnus will use less space and be faster as a result. @@ -1326,7 +1339,7 @@ 'highlight) 'default) (error 'highlight)) - "Face used for group or summary buffer mouse highlighting. + "*Face used for group or summary buffer mouse highlighting. The line beneath the mouse pointer will be highlighted with this face." :group 'gnus-visual @@ -1344,7 +1357,7 @@ gnus-article-hide-boring-headers gnus-article-treat-overstrike gnus-article-maybe-highlight)) - "Controls how the article buffer will look. + "*Controls how the article buffer will look. If you leave the list empty, the article will appear exactly as it is stored on the disk. The list entries will hide or highlight various @@ -1391,12 +1404,22 @@ :group 'gnus-article-saving :type 'directory) +(defvar gnus-plugged t + "Whether Gnus is plugged or not.") + ;;; Internal variables (defvar gnus-group-get-parameter-function 'gnus-group-get-parameter) (defvar gnus-original-article-buffer " *Original Article*") (defvar gnus-newsgroup-name nil) +(defvar gnus-ephemeral-servers nil) + +(defvar gnus-agent nil + "Whether we want to use the Gnus agent or not.") + +(defvar gnus-command-method nil + "Dynamically bound variable that says what the current backend is.") (defvar gnus-current-select-method nil "The current method for selecting a newsgroup.") @@ -1409,7 +1432,6 @@ ;; Variable holding the user answers to all method prompts. (defvar gnus-method-history nil) -(defvar gnus-group-history nil) ;; Variable holding the user answers to all mail method prompts. (defvar gnus-mail-method-history nil) @@ -1420,12 +1442,19 @@ (defvar gnus-server-alist nil "List of available servers.") +(defcustom gnus-cache-directory + (nnheader-concat gnus-directory "cache/") + "*The directory where cached articles will be stored." + :group 'gnus-cache + :type 'directory) + (defvar gnus-predefined-server-alist `(("cache" - (nnspool "cache" - (nnspool-spool-directory "~/News/cache/") - (nnspool-nov-directory "~/News/cache/") - (nnspool-active-file "~/News/cache/active")))) + nnspool "cache" + (nnspool-spool-directory ,gnus-cache-directory) + (nnspool-nov-directory ,gnus-cache-directory) + (nnspool-active-file + ,(nnheader-concat gnus-cache-directory "active")))) "List of predefined (convenience) servers.") (defvar gnus-topic-indentation "") ;; Obsolete variable. @@ -1435,7 +1464,8 @@ (expirable . expire) (killed . killed) (bookmarks . bookmark) (dormant . dormant) (scored . score) (saved . save) - (cached . cache))) + (cached . cache) (downloadable . download) + (unsendable . unsend))) (defvar gnus-headers-retrieved-by nil) (defvar gnus-article-reply nil) @@ -1466,9 +1496,6 @@ (defvar gnus-article-buffer "*Article*") (defvar gnus-server-buffer "*Server*") -(defvar gnus-buffer-list nil - "Gnus buffers that should be killed on exit.") - (defvar gnus-slave nil "Whether this Gnus is a slave or not.") @@ -1548,6 +1575,7 @@ ("pp" pp pp-to-string pp-eval-expression) ("ps-print" ps-print-preprint) ("mail-extr" mail-extract-address-components) + ("browse-url" browse-url) ("message" :interactive t message-send-and-exit message-yank-original) ("nnmail" nnmail-split-fancy nnmail-article-group nnmail-date-to-time) @@ -1556,7 +1584,8 @@ timezone-make-sortable-date timezone-make-time-string) ("rmailout" rmail-output) ("rmail" rmail-insert-rmail-file-header rmail-count-new-messages - rmail-show-message) + rmail-show-message rmail-summary-exists + rmail-select-summary rmail-update-summary) ("gnus-audio" :interactive t gnus-audio-play) ("gnus-xmas" gnus-xmas-splash) ("gnus-soup" :interactive t @@ -1577,7 +1606,8 @@ gnus-tree-open gnus-tree-close gnus-carpal-setup-buffer) ("gnus-nocem" gnus-nocem-scan-groups gnus-nocem-close gnus-nocem-unwanted-article-p) - ("gnus-srvr" gnus-enter-server-buffer gnus-server-set-info) + ("gnus-srvr" gnus-enter-server-buffer gnus-server-set-info + gnus-server-server-name) ("gnus-srvr" gnus-browse-foreign-server) ("gnus-cite" :interactive t gnus-article-highlight-citation gnus-article-hide-citation-maybe @@ -1623,8 +1653,10 @@ gnus-uu-decode-binhex gnus-uu-decode-uu-view gnus-uu-decode-uu-and-save-view gnus-uu-decode-unshar-view gnus-uu-decode-unshar-and-save-view gnus-uu-decode-save-view - gnus-uu-decode-binhex-view) - ("gnus-uu" gnus-uu-delete-work-dir gnus-quote-arg-for-sh-or-csh) + gnus-uu-decode-binhex-view gnus-uu-unmark-thread + gnus-uu-mark-over gnus-uu-post-news gnus-uu-post-news) + ("gnus-uu" gnus-uu-delete-work-dir gnus-quote-arg-for-sh-or-csh + gnus-uu-unmark-thread) ("gnus-msg" (gnus-summary-send-map keymap) gnus-article-mail gnus-copy-article-buffer gnus-extended-version) ("gnus-msg" :interactive t @@ -1639,7 +1671,11 @@ gnus-post-news gnus-summary-reply gnus-summary-reply-with-original gnus-summary-mail-forward gnus-summary-mail-other-window gnus-summary-resend-message gnus-summary-resend-bounced-mail - gnus-bug) + gnus-summary-wide-reply gnus-summary-followup-to-mail + gnus-summary-followup-to-mail-with-original gnus-bug + gnus-summary-wide-reply-with-original + gnus-summary-post-forward gnus-summary-wide-reply-with-original + gnus-summary-post-forward) ("gnus-picon" :interactive t gnus-article-display-picons gnus-group-display-picons gnus-picons-article-display-x-face gnus-picons-display-x-face) @@ -1650,12 +1686,16 @@ ("gnus-sum" gnus-summary-insert-line gnus-summary-read-group gnus-list-of-unread-articles gnus-list-of-read-articles gnus-offer-save-summaries gnus-make-thread-indent-array - gnus-summary-exit gnus-update-read-articles) + gnus-summary-exit gnus-update-read-articles gnus-summary-last-subject + gnus-summary-skip-intangible gnus-summary-article-number + gnus-data-header gnus-data-find) ("gnus-group" gnus-group-insert-group-line gnus-group-quit gnus-group-list-groups gnus-group-first-unread-group gnus-group-set-mode-line gnus-group-set-info gnus-group-save-newsrc gnus-group-setup-buffer gnus-group-get-new-news - gnus-group-make-help-group gnus-group-update-group) + gnus-group-make-help-group gnus-group-update-group + gnus-clear-inboxes-moved gnus-group-iterate + gnus-group-group-name) ("gnus-bcklg" gnus-backlog-request-article gnus-backlog-enter-article gnus-backlog-remove-article) ("gnus-art" gnus-article-read-summary-keys gnus-article-save @@ -1675,10 +1715,11 @@ gnus-article-date-original gnus-article-date-lapsed gnus-article-show-all-headers gnus-article-edit-mode gnus-article-edit-article - gnus-article-edit-done gnus-decode-rfc1522 article-decode-rfc1522) + gnus-article-edit-done gnus-decode-rfc1522 article-decode-rfc1522 + gnus-start-date-timer gnus-stop-date-timer) ("gnus-int" gnus-request-type) ("gnus-start" gnus-newsrc-parse-options gnus-1 gnus-no-server-1 - gnus-dribble-enter) + gnus-dribble-enter gnus-read-init-file gnus-dribble-touch) ("gnus-dup" gnus-dup-suppress-articles gnus-dup-unsuppress-article gnus-dup-enter-articles) ("gnus-range" gnus-copy-sequence) @@ -1690,13 +1731,20 @@ ("gnus-async" gnus-async-request-fetched-article gnus-async-prefetch-next gnus-async-prefetch-article gnus-async-prefetch-remove-group gnus-async-halt-prefetch) + ("gnus-agent" gnus-open-agent gnus-agent-get-function + gnus-agent-save-groups gnus-agent-save-active gnus-agent-method-p + gnus-agent-get-undownloaded-list gnus-agent-fetch-session + gnus-summary-set-agent-mark gnus-agent-save-group-info) + ("gnus-agent" :interactive t + gnus-unplugged gnus-agentize gnus-agent-batch) ("gnus-vm" :interactive t gnus-summary-save-in-vm - gnus-summary-save-article-vm)))) + gnus-summary-save-article-vm) + ("gnus-draft" :interactive t gnus-draft-mode gnus-group-send-drafts)))) ;;; gnus-sum.el thingies -(defcustom gnus-summary-line-format "%U\%R\%z\%I\%(%[%4L: %-20,20n%]%) %s\n" +(defcustom gnus-summary-line-format "%U%R%z%I%(%[%4L: %-20,20n%]%) %s\n" "*The format specification of the lines in the summary buffer. It works along the same lines as a normal formatting string, @@ -1732,6 +1780,7 @@ %l GroupLens score (string). %V Total thread score (number). %P The line number (number). +%O Download mark (character). %u User defined specifier. The next character in the format string should be a letter. Gnus will call the function gnus-user-format-function-X, where X is the letter following %u. The function will be passed the @@ -1763,7 +1812,7 @@ (defun gnus-suppress-keymap (keymap) (suppress-keymap keymap) - (let ((keys `([delete] "\177" "\M-u"))) ;gnus-mouse-2 + (let ((keys `([backspace] [delete] "\177" "\M-u"))) ;gnus-mouse-2 (while keys (define-key keymap (pop keys) 'undefined)))) @@ -1818,14 +1867,6 @@ "Set GROUP's active info." `(gnus-sethash ,group ,active gnus-active-hashtb)) -(defun gnus-alive-p () - "Say whether Gnus is running or not." - (and gnus-group-buffer - (get-buffer gnus-group-buffer) - (save-excursion - (set-buffer gnus-group-buffer) - (eq major-mode 'gnus-group-mode)))) - ;; Info access macros. (defmacro gnus-info-group (info) @@ -1930,6 +1971,7 @@ ;;; Gnus Utility Functions ;;; + (defmacro gnus-string-or (&rest strings) "Return the first element of STRINGS that is a non-blank string. STRINGS will be evaluated in normal `or' order." @@ -1944,43 +1986,27 @@ (setq strings nil))) string)) -;; Add the current buffer to the list of buffers to be killed on exit. -(defun gnus-add-current-to-buffer-list () - (or (memq (current-buffer) gnus-buffer-list) - (push (current-buffer) gnus-buffer-list))) - (defun gnus-version (&optional arg) "Version number of this version of Gnus. If ARG, insert string at point." (interactive "P") - (let ((methods gnus-valid-select-methods) - (mess gnus-version) - meth) - ;; Go through all the legal select methods and add their version - ;; numbers to the total version string. Only the backends that are - ;; currently in use will have their message numbers taken into - ;; consideration. - (while methods - (setq meth (intern (concat (caar methods) "-version"))) - (and (boundp meth) - (stringp (symbol-value meth)) - (setq mess (concat mess "; " (symbol-value meth)))) - (setq methods (cdr methods))) - (if arg - (insert (message mess)) - (message mess)))) + (if arg + (insert (message gnus-version)) + (message gnus-version))) (defun gnus-continuum-version (version) "Return VERSION as a floating point number." (when (or (string-match "^\\([^ ]+\\)? ?Gnus v?\\([0-9.]+\\)$" version) (string-match "^\\(.?\\)gnus-\\([0-9.]+\\)$" version)) - (let* ((alpha (and (match-beginning 1) (match-string 1 version))) - (number (match-string 2 version)) - major minor least) - (string-match "\\([0-9]\\)\\.\\([0-9]+\\)\\.?\\([0-9]+\\)?" number) - (setq major (string-to-number (match-string 1 number))) - (setq minor (string-to-number (match-string 2 number))) - (setq least (if (match-beginning 3) + (let ((alpha (and (match-beginning 1) (match-string 1 version))) + (number (match-string 2 version)) + major minor least) + (unless (string-match + "\\([0-9]\\)\\.\\([0-9]+\\)\\.?\\([0-9]+\\)?" number) + (error "Invalid version string: %s" version)) + (setq major (string-to-number (match-string 1 number)) + minor (string-to-number (match-string 2 number)) + least (if (match-beginning 3) (string-to-number (match-string 3 number)) 0)) (string-to-number @@ -1989,7 +2015,11 @@ (cond ((member alpha '("(ding)" "d")) "4.99") ((member alpha '("September" "s")) "5.01") - ((member alpha '("Red" "r")) "5.03")) + ((member alpha '("Red" "r")) "5.03") + ((member alpha '("Quassia" "q")) "5.05") + ((member alpha '("p")) "5.07") + ((member alpha '("o")) "5.09") + ((member alpha '("n")) "5.11")) minor least) (format "%d.%02d%02d" major minor least)))))) @@ -2002,6 +2032,124 @@ (setq gnus-info-buffer (current-buffer)) (gnus-configure-windows 'info))) +;;; +;;; gnus-interactive +;;; + +(defvar gnus-current-prefix-symbol nil + "Current prefix symbol.") + +(defvar gnus-current-prefix-symbols nil + "List of current prefix symbols.") + +(defun gnus-interactive (string &optional params) + "Return a list that can be fed to `interactive'. +See `interactive' for full documentation. + +Adds the following specs: + +y -- The current symbolic prefix. +Y -- A list of the current symbolic prefix(es). +A -- Article number. +H -- Article header. +g -- Group name." + (let ((i 0) + out c prompt) + (while (< i (length string)) + (string-match ".\\([^\n]*\\)\n?" string i) + (setq c (aref string i)) + (when (match-end 1) + (setq prompt (match-string 1 string))) + (setq i (match-end 0)) + ;; We basically emulate just about everything that + ;; `interactive' does, but add the specs listed above. + (push + (cond + ((= c ?a) + (completing-read prompt obarray 'fboundp t)) + ((= c ?b) + (read-buffer prompt (current-buffer) t)) + ((= c ?B) + (read-buffer prompt (other-buffer (current-buffer)))) + ((= c ?c) + (read-char)) + ((= c ?C) + (completing-read prompt obarray 'commandp t)) + ((= c ?d) + (point)) + ((= c ?D) + (read-file-name prompt nil default-directory 'lambda)) + ((= c ?f) + (read-file-name prompt nil nil 'lambda)) + ((= c ?F) + (read-file-name prompt)) + ((= c ?k) + (read-key-sequence prompt)) + ((= c ?K) + (error "Not implemented spec")) + ((= c ?e) + (error "Not implemented spec")) + ((= c ?m) + (mark)) + ((= c ?N) + (error "Not implemented spec")) + ((= c ?n) + (string-to-number (read-from-minibuffer prompt))) + ((= c ?p) + (prefix-numeric-value current-prefix-arg)) + ((= c ?P) + current-prefix-arg) + ((= c ?r) + 'gnus-prefix-nil) + ((= c ?s) + (read-string prompt)) + ((= c ?S) + (intern (read-string prompt))) + ((= c ?v) + (read-variable prompt)) + ((= c ?x) + (read-minibuffer prompt)) + ((= c ?x) + (eval-minibuffer prompt)) + ;; And here the new specs come. + ((= c ?y) + gnus-current-prefix-symbol) + ((= c ?Y) + gnus-current-prefix-symbols) + ((= c ?g) + (gnus-group-group-name)) + ((= c ?A) + (gnus-summary-skip-intangible) + (or (get-text-property (point) 'gnus-number) + (gnus-summary-last-subject))) + ((= c ?H) + (gnus-data-header (gnus-data-find (gnus-summary-article-number)))) + (t + (error "Non-implemented spec"))) + out) + (cond + ((= c ?r) + (push (if (< (point) (mark) (point) (mark))) out) + (push (if (> (point) (mark) (point) (mark))) out)))) + (setq out (delq 'gnus-prefix-nil out)) + (nreverse out))) + +(defun gnus-symbolic-argument (&optional arg) + "Read a symbolic argument and a command, and then execute command." + (interactive "P") + (let* ((in-command (this-command-keys)) + (command in-command) + gnus-current-prefix-symbols + gnus-current-prefix-symbol + syms) + (while (equal in-command command) + (message "%s-" (key-description (this-command-keys))) + (push (intern (char-to-string (read-char))) syms) + (setq command (read-key-sequence nil t))) + (setq gnus-current-prefix-symbols (nreverse syms) + gnus-current-prefix-symbol (car gnus-current-prefix-symbols)) + (call-interactively (key-binding command t)))) + ;;; More various functions. (defsubst gnus-check-backend-function (func group) @@ -2055,7 +2203,14 @@ "Return non-nil if GROUP (and ARTICLE) come from a news server." (or (gnus-member-of-valid 'post group) ; Ordinary news group. (and (gnus-member-of-valid 'post-mail group) ; Combined group. - (eq (gnus-request-type group article) 'news)))) + (if (or (null article) + (not (< article 0))) + (eq (gnus-request-type group article) 'news) + (if (not (vectorp article)) + nil + ;; It's a real article. + (eq (gnus-request-type group (mail-header-id article)) + 'news)))))) ;; Returns a list of writable groups. (defun gnus-writable-groups () @@ -2086,11 +2241,11 @@ (defun gnus-ephemeral-group-p (group) "Say whether GROUP is ephemeral or not." - (gnus-group-get-parameter group 'quit-config)) + (gnus-group-get-parameter group 'quit-config t)) (defun gnus-group-quit-config (group) "Return the quit-config of GROUP." - (gnus-group-get-parameter group 'quit-config)) + (gnus-group-get-parameter group 'quit-config t)) (defun gnus-kill-ephemeral-group (group) "Remove ephemeral GROUP from relevant structures." @@ -2124,9 +2279,11 @@ (gnus-server-to-method method)) ((equal method gnus-select-method) gnus-select-method) - ((and (stringp (car method)) group) + ((and (stringp (car method)) + group) (gnus-server-extend-method group method)) - ((and method (not group) + ((and method + (not group) (equal (cadr method) "")) method) (t @@ -2200,7 +2357,8 @@ (defun gnus-group-prefixed-name (group method) "Return the whole name from GROUP and METHOD." (and (stringp method) (setq method (gnus-server-to-method method))) - (if (not method) + (if (or (not method) + (gnus-server-equal method "native")) group (concat (format "%s" (car method)) (when (and @@ -2253,6 +2411,15 @@ (setq methods (cdr methods))) methods)) +(defun gnus-groups-from-server (server) + "Return a list of all groups that are fetched from SERVER." + (let ((alist (cdr gnus-newsrc-alist)) + info groups) + (while (setq info (pop alist)) + (when (gnus-server-equal (gnus-info-method info) server) + (push (gnus-info-group info) groups))) + (sort groups 'string<))) + (defun gnus-group-foreign-p (group) "Say whether a group is foreign or not." (and (not (gnus-group-native-p group)) @@ -2266,28 +2433,41 @@ "Say whether the group is secondary or not." (gnus-secondary-method-p (gnus-find-method-for-group group))) -(defun gnus-group-find-parameter (group &optional symbol) +(defun gnus-group-find-parameter (group &optional symbol allow-list) "Return the group parameters for GROUP. If SYMBOL, return the value of that symbol in the group parameters." (save-excursion (set-buffer gnus-group-buffer) (let ((parameters (funcall gnus-group-get-parameter-function group))) (if symbol - (gnus-group-parameter-value parameters symbol) + (gnus-group-parameter-value parameters symbol allow-list) parameters)))) -(defun gnus-group-get-parameter (group &optional symbol) +(defun gnus-group-get-parameter (group &optional symbol allow-list) "Return the group parameters for GROUP. -If SYMBOL, return the value of that symbol in the group parameters." +If SYMBOL, return the value of that symbol in the group parameters. +Most functions should use `gnus-group-find-parameter', which +also examines the topic parameters." (let ((params (gnus-info-params (gnus-get-info group)))) (if symbol - (gnus-group-parameter-value params symbol) + (gnus-group-parameter-value params symbol allow-list) params))) -(defun gnus-group-parameter-value (params symbol) +(defun gnus-group-parameter-value (params symbol &optional allow-list) "Return the value of SYMBOL in group PARAMS." - (or (car (memq symbol params)) ; It's either a simple symbol - (cdr (assq symbol params)))) ; or a cons. + ;; We only wish to return group parameters (dotted lists) and + ;; not local variables, which may have the same names. + ;; But first we handle single elements... + (or (car (memq symbol params)) + ;; Handle alist. + (let (elem) + (catch 'found + (while (setq elem (pop params)) + (when (and (consp elem) + (eq (car elem) symbol) + (or allow-list + (atom (cdr elem)))) + (throw 'found (cdr elem)))))))) (defun gnus-group-add-parameter (group param) "Add parameter PARAM to GROUP." @@ -2320,7 +2500,7 @@ (when params (setq params (delq name params)) (while (assq name params) - (setq params (delq (assq name params) params))) + (gnus-pull name params)) (gnus-info-set-params info params)))))) (defun gnus-group-add-score (group &optional score) @@ -2335,7 +2515,10 @@ "Collapse GROUP name LEVELS. Select methods are stripped and any remote host name is stripped down to just the host name." - (let* ((name "") (foreign "") (depth -1) (skip 1) + (let* ((name "") + (foreign "") + (depth 0) + (skip 1) (levels (or levels (progn (while (string-match "\\." group skip) @@ -2532,11 +2715,14 @@ (defun gnus-read-method (prompt) "Prompt the user for a method. Allow completion over sensible values." - (let ((method - (completing-read - prompt (append gnus-valid-select-methods gnus-predefined-server-alist - gnus-server-alist) - nil t nil 'gnus-method-history))) + (let* ((servers + (append gnus-valid-select-methods + gnus-predefined-server-alist + gnus-server-alist)) + (method + (completing-read + prompt servers + nil t nil 'gnus-method-history))) (cond ((equal method "") (setq method gnus-select-method)) @@ -2546,7 +2732,7 @@ (assoc method gnus-valid-select-methods)) (read-string "Address: ") ""))) - ((assoc method gnus-server-alist) + ((assoc method servers) method) (t (list (intern method) ""))))) @@ -2555,7 +2741,7 @@ ;;;###autoload (defun gnus-slave-no-server (&optional arg) - "Read network news as a slave, without connecting to local server" + "Read network news as a slave, without connecting to local server." (interactive "P") (gnus-no-server arg t))
--- a/lisp/gnus/message.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/message.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ ;;; message.el --- composing mail and news messages -;; Copyright (C) 1996,97 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: mail, news ;; This file is part of GNU Emacs. @@ -31,9 +31,7 @@ (eval-when-compile (require 'cl)) -(require 'sendmail) (require 'mailheader) -(require 'rmail) (require 'nnheader) (require 'timezone) (require 'easymenu) @@ -158,8 +156,8 @@ :group 'message-headers) (defcustom message-syntax-checks nil - ;; Guess this one shouldn't be easy to customize... - "Controls what syntax checks should not be performed on outgoing posts. + ; Guess this one shouldn't be easy to customize... + "*Controls what syntax checks should not be performed on outgoing posts. To disable checking of long signatures, for instance, add `(signature . disabled)' to this list. @@ -168,14 +166,14 @@ Checks include subject-cmsg multiple-headers sendsys message-id from long-lines control-chars size new-text redirected-followup signature approved sender empty empty-headers message-id from subject -shorten-followup-to existing-newsgroups." +shorten-followup-to existing-newsgroups buffer-file-name unchanged." :group 'message-news) (defcustom message-required-news-headers '(From Newsgroups Subject Date Message-ID (optional . Organization) Lines (optional . X-Newsreader)) - "Headers to be generated or prompted for when posting an article. + "*Headers to be generated or prompted for when posting an article. RFC977 and RFC1036 require From, Date, Newsgroups, Subject, Message-ID. Organization, Lines, In-Reply-To, Expires, and X-Newsreader are optional. If don't you want message to insert some @@ -187,7 +185,7 @@ (defcustom message-required-mail-headers '(From Subject Date (optional . In-Reply-To) Message-ID Lines (optional . X-Mailer)) - "Headers to be generated or prompted for when mailing a message. + "*Headers to be generated or prompted for when mailing a message. RFC822 required that From, Date, To, Subject and Message-ID be included. Organization, Lines and X-Mailer are optional." :group 'message-mail @@ -200,13 +198,13 @@ :type 'sexp) (defcustom message-ignored-news-headers - "^NNTP-Posting-Host:\\|^Xref:\\|^Bcc:\\|^Gcc:\\|^Fcc:\\|^Resent-Fcc:" + "^NNTP-Posting-Host:\\|^Xref:\\|^[BGF]cc:\\|^Resent-Fcc:" "*Regexp of headers to be removed unconditionally before posting." :group 'message-news :group 'message-headers :type 'regexp) -(defcustom message-ignored-mail-headers "^Gcc:\\|^Fcc:\\|^Resent-Fcc:" +(defcustom message-ignored-mail-headers "^[GF]cc:\\|^Resent-Fcc:\\|^Xref:" "*Regexp of headers to be removed unconditionally before mailing." :group 'message-mail :group 'message-headers @@ -219,6 +217,11 @@ :group 'message-interface :type 'regexp) +(defcustom message-subject-re-regexp "^[ \t]*\\([Rr][Ee]:[ \t]*\\)*[ \t]*" + "*Regexp matching \"Re: \" in the subject line." + :group 'message-various + :type 'regexp) + ;;;###autoload (defcustom message-signature-separator "^-- *$" "Regexp matching the signature separator." @@ -226,7 +229,9 @@ :group 'message-various) (defcustom message-elide-elipsis "\n[...]\n\n" - "*The string which is inserted for elided text.") + "*The string which is inserted for elided text." + :type 'string + :group 'message-various) (defcustom message-interactive nil "Non-nil means when sending a message wait for and display errors. @@ -236,7 +241,7 @@ :type 'boolean) (defcustom message-generate-new-buffers t - "*Non-nil means that a new message buffer will be created whenever `mail-setup' is called. + "*Non-nil means that a new message buffer will be created whenever `message-setup' is called. If this is a function, call that function with three parameters: The type, the to address and the group name. (Any of these may be nil.) The function should return the new buffer name." @@ -269,13 +274,6 @@ :type 'file :group 'message-headers) -(defcustom message-auto-save-directory "~/" - ; (concat (file-name-as-directory message-directory) "drafts/") - "*Directory where message auto-saves buffers. -If nil, message won't auto-save." - :group 'message-buffers - :type 'directory) - (defcustom message-forward-start-separator "------- Start of forwarded message -------\n" "*Delimiter inserted before forwarded messages." @@ -294,11 +292,32 @@ :type 'boolean) (defcustom message-included-forward-headers - "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-\\|^Message-ID:\\|^References:" + "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-\\|^Message-ID:\\|^References:\\|^Content-Transfer-Encoding:\\|^Content-Type:\\|^Mime-Version:" "*Regexp matching headers to be included in forwarded messages." :group 'message-forwarding :type 'regexp) +(defcustom message-make-forward-subject-function + 'message-forward-subject-author-subject + "*A list of functions that are called to generate a subject header for forwarded messages. +The subject generated by the previous function is passed into each +successive function. + +The provided functions are: + +* message-forward-subject-author-subject (Source of article (author or + newsgroup)), in brackets followed by the subject +* message-forward-subject-fwd (Subject of article with 'Fwd:' prepended + to it." + :group 'message-forwarding + :type '(radio (function-item message-forward-subject-author-subject) + (function-item message-forward-subject-fwd))) + +(defcustom message-wash-forwarded-subjects nil + "*If non-nil, try to remove as much old cruft as possible from the subject of messages before generating the new subject of a forward." + :group 'message-forwarding + :type 'boolean) + (defcustom message-ignored-resent-headers "^Return-receipt" "*All headers that match this regexp will be deleted when resending a message." :group 'message-interface @@ -322,10 +341,12 @@ variable `mail-header-separator'. Legal values include `message-send-mail-with-sendmail' (the default), -`message-send-mail-with-mh' and `message-send-mail-with-qmail'." +`message-send-mail-with-mh', `message-send-mail-with-qmail' and +`smtpmail-send-it'." :type '(radio (function-item message-send-mail-with-sendmail) (function-item message-send-mail-with-mh) (function-item message-send-mail-with-qmail) + (function-item smtpmail-send-it) (function :tag "Other")) :group 'message-sending :group 'message-mail) @@ -397,12 +418,15 @@ (defvar gnus-select-method) (defcustom message-post-method (cond ((and (boundp 'gnus-post-method) + (listp gnus-post-method) gnus-post-method) gnus-post-method) ((boundp 'gnus-select-method) gnus-select-method) (t '(nnspool ""))) - "Method used to post news." + "*Method used to post news. +Note that when posting from inside Gnus, for instance, this +variable isn't used." :group 'message-news :group 'message-sending ;; This should be the `gnus-select-method' widget, but that might @@ -438,8 +462,7 @@ :type 'hook) (defcustom message-header-setup-hook nil - "Hook called narrowed to the headers when setting up a message -buffer." + "Hook called narrowed to the headers when setting up a message buffer." :group 'message-various :type 'hook) @@ -463,12 +486,11 @@ :type 'integer) ;;;###autoload -(defcustom message-cite-function - 'message-cite-original +(defcustom message-cite-function 'message-cite-original "*Function for citing an original message. Predefined functions include `message-cite-original' and `message-cite-original-without-signature'. -Note that `message-cite-original' uses `mail-citation-hook'if that is non-nil." +Note that `message-cite-original' uses `mail-citation-hook' if that is non-nil." :type '(radio (function-item message-cite-original) (function-item sc-cite-original) (function :tag "Other")) @@ -538,25 +560,31 @@ (defvar message-postpone-actions nil "A list of actions to be performed after postponing a message.") +(define-widget 'message-header-lines 'text + "All header lines must be LFD terminated." + :format "%t:%n%v" + :valid-regexp "^\\'" + :error "All header lines must be newline terminated") + (defcustom message-default-headers "" "*A string containing header lines to be inserted in outgoing messages. It is inserted before you edit the message, so you can edit or delete these lines." :group 'message-headers - :type 'string) + :type 'message-header-lines) (defcustom message-default-mail-headers "" "*A string of header lines to be inserted in outgoing mails." :group 'message-headers :group 'message-mail - :type 'string) + :type 'message-header-lines) (defcustom message-default-news-headers "" "*A string of header lines to be inserted in outgoing news articles." :group 'message-headers :group 'message-news - :type 'string) + :type 'message-header-lines) ;; Note: could use /usr/ucb/mail instead of sendmail; ;; options -t, and -v if not interactive. @@ -578,7 +606,7 @@ ;; 33 and 126, except colon)", i. e., any chars except ctl chars, ;; space, or colon. '(looking-at "[ \t]\\|[][!\"#$%&'()*+,-./0-9;<=>?@A-Z\\\\^_`a-z{|}~]+:")) - "Set this non-nil if the system's mailer runs the header and body together. + "*Set this non-nil if the system's mailer runs the header and body together. \(This problem exists on Sunos 4 when sendmail is run in remote mode.) The value should be an expression to test whether the problem will actually occur." @@ -616,6 +644,13 @@ The default is `abbrev', which uses mailabbrev. nil switches mail aliases off.") +(defcustom message-auto-save-directory + (nnheader-concat message-directory "drafts/") + "*Directory where Message auto-saves buffers if Gnus isn't running. +If nil, Message won't auto-save." + :group 'message-buffers + :type 'directory) + ;;; Internal variables. ;;; Well, not really internal. @@ -684,7 +719,7 @@ (defface message-header-other-face '((((class color) (background dark)) - (:foreground "red4")) + (:foreground "#b00000")) (((class color) (background light)) (:foreground "steel blue")) @@ -720,7 +755,7 @@ (defface message-separator-face '((((class color) (background dark)) - (:foreground "blue4")) + (:foreground "blue3")) (((class color) (background light)) (:foreground "brown")) @@ -763,14 +798,21 @@ (,(concat "^\\(X-[A-Za-z0-9-]+\\|In-Reply-To\\):" content) (1 'message-header-name-face) (2 'message-header-name-face)) - (,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$") - 1 'message-separator-face) + ,@(if (and mail-header-separator + (not (equal mail-header-separator ""))) + `((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$") + 1 'message-separator-face)) + nil) (,(concat "^[ \t]*" "\\([" cite-prefix "]+[" cite-suffix "]*\\)?" - "[>|}].*") + "[:>|}].*") (0 'message-cited-text-face)))) "Additional expressions to highlight in Message mode.") +;; XEmacs does it like this. For Emacs, we have to set the +;; `font-lock-defaults' buffer-local variable. +(put 'message-mode 'font-lock-defaults '(message-font-lock-keywords t)) + (defvar message-face-alist '((bold . bold-region) (underline . underline-region) @@ -801,11 +843,15 @@ :group 'message-various :type 'hook) +(defvar message-send-coding-system 'binary + "Coding system to encode outgoing mail.") + ;;; Internal variables. (defvar message-buffer-list nil) (defvar message-this-is-news nil) (defvar message-this-is-mail nil) +(defvar message-draft-article nil) ;; Byte-compiler warning (defvar gnus-active-hashtb) @@ -864,7 +910,7 @@ "\\(remote from .*\\)?" "\n")) - nil) + "Regexp matching the delimiter of messages in UNIX mail format.") (defvar message-unsent-separator (concat "^ *---+ +Unsent message follows +---+ *$\\|" @@ -890,19 +936,26 @@ (Lines) (Expires) (Message-ID) - (References) + (References . message-shorten-references) (X-Mailer) (X-Newsreader)) "Alist used for formatting headers.") (eval-and-compile (autoload 'message-setup-toolbar "messagexmas") + (autoload 'mh-new-draft-name "mh-comp") (autoload 'mh-send-letter "mh-comp") (autoload 'gnus-point-at-eol "gnus-util") (autoload 'gnus-point-at-bol "gnus-util") (autoload 'gnus-output-to-mail "gnus-util") (autoload 'gnus-output-to-rmail "gnus-util") - (autoload 'mail-abbrev-in-expansion-header-p "mailabbrev")) + (autoload 'mail-abbrev-in-expansion-header-p "mailabbrev") + (autoload 'nndraft-request-associate-buffer "nndraft") + (autoload 'nndraft-request-expire-articles "nndraft") + (autoload 'gnus-open-server "gnus-int") + (autoload 'gnus-request-post "gnus-int") + (autoload 'gnus-alive-p "gnus-util") + (autoload 'rmail-output "rmail")) @@ -965,7 +1018,8 @@ (defun message-fetch-field (header &optional not-all) "The same as `mail-fetch-field', only remove all newlines." - (let ((value (mail-fetch-field header nil (not not-all)))) + (let* ((inhibit-point-motion-hooks t) + (value (mail-fetch-field header nil (not not-all)))) (when value (nnheader-replace-chars-in-string value ?\n ? )))) @@ -1003,11 +1057,11 @@ "Return non-nil if FORM is funcallable." (or (and (symbolp form) (fboundp form)) (and (listp form) (eq (car form) 'lambda)) - (compiled-function-p form))) + (byte-code-function-p form))) (defun message-strip-subject-re (subject) "Remove \"Re:\" from subject lines." - (if (string-match "^[Rr][Ee]: *" subject) + (if (string-match message-subject-re-regexp subject) (substring subject (match-end 0)) subject)) @@ -1017,7 +1071,7 @@ If FIRST, only remove the first instance of the header. Return the number of headers removed." (goto-char (point-min)) - (let ((regexp (if is-regexp header (concat "^" header ":"))) + (let ((regexp (if is-regexp header (concat "^" (regexp-quote header) ":"))) (number 0) (case-fold-search t) last) @@ -1068,21 +1122,24 @@ (defun message-news-p () "Say whether the current buffer contains a news message." - (or message-this-is-news - (save-excursion - (save-restriction - (message-narrow-to-headers) - (message-fetch-field "newsgroups"))))) + (and (not message-this-is-mail) + (or message-this-is-news + (save-excursion + (save-restriction + (message-narrow-to-headers) + (and (message-fetch-field "newsgroups") + (not (message-fetch-field "posted-to")))))))) (defun message-mail-p () "Say whether the current buffer contains a mail message." - (or message-this-is-mail - (save-excursion - (save-restriction - (message-narrow-to-headers) - (or (message-fetch-field "to") - (message-fetch-field "cc") - (message-fetch-field "bcc")))))) + (and (not message-this-is-news) + (or message-this-is-mail + (save-excursion + (save-restriction + (message-narrow-to-headers) + (or (message-fetch-field "to") + (message-fetch-field "cc") + (message-fetch-field "bcc"))))))) (defun message-next-header () "Go to the beginning of the next header." @@ -1170,6 +1227,9 @@ (define-key message-mode-map "\C-c\C-d" 'message-dont-send) (define-key message-mode-map "\C-c\C-e" 'message-elide-region) + (define-key message-mode-map "\C-c\C-v" 'message-delete-not-region) + (define-key message-mode-map "\C-c\C-z" 'message-kill-to-signature) + (define-key message-mode-map "\M-\r" 'message-newline-and-reformat) (define-key message-mode-map "\t" 'message-tab)) @@ -1183,11 +1243,15 @@ ["Caesar (rot13) Message" message-caesar-buffer-body t] ["Caesar (rot13) Region" message-caesar-region (mark t)] ["Elide Region" message-elide-region (mark t)] + ["Delete Outside Region" message-delete-not-region (mark t)] + ["Kill To Signature" message-kill-to-signature t] + ["Newline and Reformat" message-newline-and-reformat t] ["Rename buffer" message-rename-buffer t] ["Spellcheck" ispell-message t] "----" ["Send Message" message-send-and-exit t] - ["Abort Message" message-dont-send t])) + ["Abort Message" message-dont-send t] + ["Kill Message" message-kill-buffer t])) (easy-menu-define message-mode-field-menu message-mode-map "" @@ -1230,23 +1294,24 @@ C-c C-y message-yank-original (insert current message, if any). C-c C-q message-fill-yanked-message (fill what was yanked). C-c C-e message-elide-region (elide the text between point and mark). +C-c C-z message-kill-to-signature (kill the text up to the signature). C-c C-r message-caesar-buffer-body (rot13 the message body)." (interactive) (kill-all-local-variables) (make-local-variable 'message-reply-buffer) (setq message-reply-buffer nil) - (make-local-variable 'message-send-actions) - (make-local-variable 'message-exit-actions) + (make-local-variable 'message-send-actions) + (make-local-variable 'message-exit-actions) (make-local-variable 'message-kill-actions) (make-local-variable 'message-postpone-actions) + (make-local-variable 'message-draft-article) + (make-local-hook 'kill-buffer-hook) (set-syntax-table message-mode-syntax-table) (use-local-map message-mode-map) (setq local-abbrev-table message-mode-abbrev-table) (setq major-mode 'message-mode) (setq mode-name "Message") (setq buffer-offer-save t) - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '(message-font-lock-keywords t)) (make-local-variable 'facemenu-add-face-function) (make-local-variable 'facemenu-remove-face-function) (setq facemenu-add-face-function @@ -1264,9 +1329,9 @@ ;; Lines containing just >= 3 dashes, perhaps after whitespace, ;; are also sometimes used and should be separators. (setq paragraph-start (concat (regexp-quote mail-header-separator) - "$\\|[ \t]*[a-z0-9A-Z]*>+[ \t]*$\\|[ \t]*$\\|" - "-- $\\|---+$\\|" - page-delimiter)) + "$\\|[ \t]*[a-z0-9A-Z]*>+[ \t]*$\\|[ \t]*$\\|" + "-- $\\|---+$\\|" + page-delimiter)) (setq paragraph-separate paragraph-start) (make-local-variable 'message-reply-headers) (setq message-reply-headers nil) @@ -1294,7 +1359,20 @@ (when (eq message-mail-alias-type 'abbrev) (if (fboundp 'mail-abbrevs-setup) (mail-abbrevs-setup) - (funcall (intern "mail-aliases-setup")))) + (mail-aliases-setup))) + (message-set-auto-save-file-name) + (unless (string-match "XEmacs" emacs-version) + (set (make-local-variable 'font-lock-defaults) + '(message-font-lock-keywords t))) + (make-local-variable 'adaptive-fill-regexp) + (setq adaptive-fill-regexp + (concat "[ \t]*[-a-z0-9A-Z]*>+[ \t]*\\|" adaptive-fill-regexp)) + (unless (boundp 'adaptive-fill-first-line-regexp) + (setq adaptive-fill-first-line-regexp nil)) + (make-local-variable 'adaptive-fill-first-line-regexp) + (setq adaptive-fill-first-line-regexp + (concat "[ \t]*[-a-z0-9A-Z]*>+[ \t]*\\|" + adaptive-fill-first-line-regexp)) (run-hooks 'text-mode-hook 'message-mode-hook)) @@ -1367,13 +1445,22 @@ (goto-char (point-min)) (search-forward (concat "\n" mail-header-separator "\n") nil t)) +(defun message-goto-eoh () + "Move point to the end of the headers." + (interactive) + (message-goto-body) + (forward-line -2)) + (defun message-goto-signature () - "Move point to the beginning of the message signature." + "Move point to the beginning of the message signature. +If there is no signature in the article, go to the end and +return nil." (interactive) (goto-char (point-min)) (if (re-search-forward message-signature-separator nil t) (forward-line 1) - (goto-char (point-max)))) + (goto-char (point-max)) + nil)) @@ -1408,6 +1495,49 @@ ;;; Various commands +(defun message-delete-not-region (beg end) + "Delete everything in the body of the current message that is outside of the region." + (interactive "r") + (save-excursion + (goto-char end) + (delete-region (point) (if (not (message-goto-signature)) + (point) + (forward-line -2) + (point))) + (insert "\n") + (goto-char beg) + (delete-region beg (progn (message-goto-body) + (forward-line 2) + (point)))) + (when (message-goto-signature) + (forward-line -2))) + +(defun message-kill-to-signature () + "Deletes all text up to the signature." + (interactive) + (let ((point (point))) + (message-goto-signature) + (unless (eobp) + (forward-line -2)) + (kill-region point (point)) + (unless (bolp) + (insert "\n")))) + +(defun message-newline-and-reformat () + "Insert four newlines, and then reformat if inside quoted text." + (interactive) + (let ((point (point)) + quoted) + (save-excursion + (beginning-of-line) + (setq quoted (looking-at (regexp-quote message-yank-prefix)))) + (insert "\n\n\n\n") + (when quoted + (insert message-yank-prefix)) + (fill-paragraph nil) + (goto-char point) + (forward-line 2))) + (defun message-insert-signature (&optional force) "Insert a signature. See documentation for the `message-signature' variable." (interactive (list 0)) @@ -1447,8 +1577,9 @@ (or (bolp) (insert "\n"))))) (defun message-elide-region (b e) - "Elide the text between point and mark. An ellipsis (from -message-elide-elipsis) will be inserted where the text was killed." + "Elide the text between point and mark. +An ellipsis (from `message-elide-elipsis') will be inserted where the +text was killed." (interactive "r") (kill-region b e) (unless (bolp) @@ -1499,7 +1630,7 @@ (defun message-caesar-buffer-body (&optional rotnum) "Caesar rotates all letters in the current buffer by 13 places. -Used to encode/decode possibly offensive messages (commonly in net.jokes). +Used to encode/decode possiblyun offensive messages (commonly in net.jokes). With prefix arg, specifies the number of places to rotate each letter forward. Mail and USENET news headers are not rotated." (interactive (if current-prefix-arg @@ -1544,9 +1675,7 @@ (name-default (concat "*message* " mail-trimmed-to)) (name (if enter-string (read-string "New buffer name: " name-default) - name-default)) - (default-directory - (file-name-as-directory message-auto-save-directory))) + name-default))) (rename-buffer name t))))) (defun message-fill-yanked-message (&optional justifyp) @@ -1627,26 +1756,52 @@ (unless (bolp) (insert ?\n)) (unless modified - (setq message-checksum (cons (message-checksum) (buffer-size))))))) - + (setq message-checksum (message-checksum)))))) + +(defun message-cite-original-without-signature () + "Cite function in the standard Message manner." + (let ((start (point)) + (end (mark t)) + (functions + (when message-indent-citation-function + (if (listp message-indent-citation-function) + message-indent-citation-function + (list message-indent-citation-function))))) + (goto-char end) + (when (re-search-backward "^-- $" start t) + ;; Also peel off any blank lines before the signature. + (forward-line -1) + (while (looking-at "^[ \t]*$") + (forward-line -1)) + (forward-line 1) + (delete-region (point) end)) + (goto-char start) + (while functions + (funcall (pop functions))) + (when message-citation-line-function + (unless (bolp) + (insert "\n")) + (funcall message-citation-line-function)))) + +(defvar mail-citation-hook) ;Compiler directive (defun message-cite-original () "Cite function in the standard Message manner." (if (and (boundp 'mail-citation-hook) - mail-citation-hook) + mail-citation-hook) (run-hooks 'mail-citation-hook) (let ((start (point)) - (functions - (when message-indent-citation-function - (if (listp message-indent-citation-function) - message-indent-citation-function - (list message-indent-citation-function))))) + (functions + (when message-indent-citation-function + (if (listp message-indent-citation-function) + message-indent-citation-function + (list message-indent-citation-function))))) (goto-char start) (while functions - (funcall (pop functions))) + (funcall (pop functions))) (when message-citation-line-function - (unless (bolp) - (insert "\n")) - (funcall message-citation-line-function))))) + (unless (bolp) + (insert "\n")) + (funcall message-citation-line-function))))) (defun message-insert-citation-line () "Function that inserts a simple citation line." @@ -1721,11 +1876,14 @@ (bury-buffer buf) (when (eq buf (current-buffer)) (message-bury buf))) - (message-do-actions actions)))) + (message-do-actions actions) + t))) (defun message-dont-send () "Don't send the message you have been editing." (interactive) + (set-buffer-modified-p t) + (save-buffer) (let ((actions message-postpone-actions)) (message-bury (current-buffer)) (message-do-actions actions))) @@ -1736,6 +1894,7 @@ (when (or (not (buffer-modified-p)) (yes-or-no-p "Message modified; kill anyway? ")) (let ((actions message-kill-actions)) + (setq buffer-file-name nil) (kill-buffer (current-buffer)) (message-do-actions actions)))) @@ -1756,13 +1915,10 @@ Otherwise any failure is reported in a message back to the user from the mailer." (interactive "P") - (when (if buffer-file-name - (y-or-n-p (format "Send buffer contents as %s message? " - (if (message-mail-p) - (if (message-news-p) "mail and news" "mail") - "news"))) - (or (buffer-modified-p) - (y-or-n-p "No changes in the buffer; really send? "))) + ;; Disabled test. + (when (or (buffer-modified-p) + (message-check-element 'unchanged) + (y-or-n-p "No changes in the buffer; really send? ")) ;; Make it possible to undo the coming changes. (undo-boundary) (let ((inhibit-read-only t)) @@ -1790,10 +1946,10 @@ ;; (mail-hist-put-headers-into-history)) (run-hooks 'message-sent-hook) (message "Sending...done") - ;; If buffer has no file, mark it as unmodified and delete auto-save. - (unless buffer-file-name - (set-buffer-modified-p nil) - (delete-auto-save-file-if-necessary t)) + ;; Mark the buffer as unmodified and delete auto-save. + (set-buffer-modified-p nil) + (delete-auto-save-file-if-necessary t) + (message-disassociate-draft) ;; Delete other mail buffers and stuff. (message-do-send-housekeeping) (message-do-actions message-send-actions) @@ -1801,7 +1957,7 @@ t)))) (defun message-send-via-mail (arg) - "Send the current message via mail." + "Send the current message via mail." (message-send-mail arg)) (defun message-send-via-news (arg) @@ -1813,7 +1969,13 @@ ;; Make sure there's a newline at the end of the message. (goto-char (point-max)) (unless (bolp) - (insert "\n"))) + (insert "\n")) + ;; Make all invisible text visible. + ;;(when (text-property-any (point-min) (point-max) 'invisible t) + ;; (put-text-property (point-min) (point-max) 'invisible nil) + ;; (unless (yes-or-no-p "Invisible text found and made visible; continue posting?") + ;; (error "Invisible text found and made visible"))) + ) (defun message-add-action (action &rest types) "Add ACTION to be performed when doing an exit of type TYPES." @@ -1905,7 +2067,7 @@ (set-buffer errbuf) (erase-buffer)))) (let ((default-directory "/") - (coding-system-for-write (select-message-coding-system))) + (coding-system-for-write message-send-coding-system)) (apply 'call-process-region (append (list (point-min) (point-max) (if (boundp 'sendmail-program) @@ -1953,28 +2115,28 @@ (run-hooks 'message-send-mail-hook) ;; send the message (case - (let ((coding-system-for-write (select-message-coding-system))) - (apply - 'call-process-region 1 (point-max) message-qmail-inject-program - nil nil nil - ;; qmail-inject's default behaviour is to look for addresses on the - ;; command line; if there're none, it scans the headers. - ;; yes, it does The Right Thing w.r.t. Resent-To and it's kin. - ;; - ;; in general, ALL of qmail-inject's defaults are perfect for simply - ;; reading a formatted (i. e., at least a To: or Resent-To header) - ;; message from stdin. - ;; - ;; qmail also has the advantage of not having been raped by - ;; various vendors, so we don't have to allow for that, either -- - ;; compare this with message-send-mail-with-sendmail and weep - ;; for sendmail's lost innocence. - ;; - ;; all this is way cool coz it lets us keep the arguments entirely - ;; free for -inject-arguments -- a big win for the user and for us - ;; since we don't have to play that double-guessing game and the user - ;; gets full control (no gestapo'ish -f's, for instance). --sj - message-qmail-inject-args)) + (let ((coding-system-for-write message-send-coding-system)) + (apply + 'call-process-region 1 (point-max) message-qmail-inject-program + nil nil nil + ;; qmail-inject's default behaviour is to look for addresses on the + ;; command line; if there're none, it scans the headers. + ;; yes, it does The Right Thing w.r.t. Resent-To and it's kin. + ;; + ;; in general, ALL of qmail-inject's defaults are perfect for simply + ;; reading a formatted (i. e., at least a To: or Resent-To header) + ;; message from stdin. + ;; + ;; qmail also has the advantage of not having been raped by + ;; various vendors, so we don't have to allow for that, either -- + ;; compare this with message-send-mail-with-sendmail and weep + ;; for sendmail's lost innocence. + ;; + ;; all this is way cool coz it lets us keep the arguments entirely + ;; free for -inject-arguments -- a big win for the user and for us + ;; since we don't have to play that double-guessing game and the user + ;; gets full control (no gestapo'ish -f's, for instance). --sj + message-qmail-inject-args)) ;; qmail-inject doesn't say anything on it's stdout/stderr, ;; we have to look at the retval instead (0 nil) @@ -1986,10 +2148,7 @@ (defun message-send-mail-with-mh () "Send the prepared message buffer with mh." (let ((mh-previous-window-config nil) - (name (make-temp-name - (concat (file-name-as-directory - (expand-file-name message-auto-save-directory)) - "msg.")))) + (name (mh-new-draft-name))) (setq buffer-file-name name) ;; MH wants to generate these headers itself. (when message-mh-deletable-headers @@ -2055,12 +2214,14 @@ (replace-match "\n") (backward-char 1)) (run-hooks 'message-send-news-hook) - (require (car method)) - (funcall (intern (format "%s-open-server" (car method))) - (cadr method) (cddr method)) - (setq result - (funcall (intern (format "%s-request-post" (car method))) - (cadr method)))) + ;;(require (car method)) + ;;(funcall (intern (format "%s-open-server" (car method))) + ;;(cadr method) (cddr method)) + ;;(setq result + ;; (funcall (intern (format "%s-request-post" (car method))) + ;; (cadr method))) + (gnus-open-server method) + (setq result (gnus-request-post method))) (kill-buffer tembuf)) (set-buffer messbuf) (if result @@ -2184,8 +2345,12 @@ (let* ((case-fold-search t) (message-id (message-fetch-field "message-id" t))) (or (not message-id) + ;; Is there an @ in the ID? (and (string-match "@" message-id) - (string-match "@[^\\.]*\\." message-id)) + ;; Is there a dot in the ID? + (string-match "@[^.]*\\." message-id) + ;; Does the ID end with a dot? + (not (string-match "\\.>" message-id))) (y-or-n-p (format "The Message-ID looks strange: \"%s\". Really post? " message-id))))) @@ -2325,8 +2490,7 @@ (message-check 'new-text (or (not message-checksum) - (not (and (eq (message-checksum) (car message-checksum)) - (eq (buffer-size) (cdr message-checksum)))) + (not (eq (message-checksum) message-checksum)) (y-or-n-p "It looks like no new text has been added. Really post? "))) ;; Check the length of the signature. @@ -2408,31 +2572,32 @@ ;; Remove empty lines in the header. (save-restriction (message-narrow-to-headers) + ;; Remove blank lines. (while (re-search-forward "^[ \t]*\n" nil t) - (replace-match "" t t))) - - ;; Correct Newsgroups and Followup-To headers: change sequence of - ;; spaces to comma and eliminate spaces around commas. Eliminate - ;; embedded line breaks. - (goto-char (point-min)) - (while (re-search-forward "^\\(Newsgroups\\|Followup-To\\): +" nil t) - (save-restriction - (narrow-to-region - (point) - (if (re-search-forward "^[^ \t]" nil t) - (match-beginning 0) - (forward-line 1) - (point))) - (goto-char (point-min)) - (while (re-search-forward "\n[ \t]+" nil t) - (replace-match " " t t)) ;No line breaks (too confusing) - (goto-char (point-min)) - (while (re-search-forward "[ \t\n]*,[ \t\n]*\\|[ \t]+" nil t) - (replace-match "," t t)) - (goto-char (point-min)) - ;; Remove trailing commas. - (when (re-search-forward ",+$" nil t) - (replace-match "" t t))))) + (replace-match "" t t)) + + ;; Correct Newsgroups and Followup-To headers: Change sequence of + ;; spaces to comma and eliminate spaces around commas. Eliminate + ;; embedded line breaks. + (goto-char (point-min)) + (while (re-search-forward "^\\(Newsgroups\\|Followup-To\\): +" nil t) + (save-restriction + (narrow-to-region + (point) + (if (re-search-forward "^[^ \t]" nil t) + (match-beginning 0) + (forward-line 1) + (point))) + (goto-char (point-min)) + (while (re-search-forward "\n[ \t]+" nil t) + (replace-match " " t t)) ;No line breaks (too confusing) + (goto-char (point-min)) + (while (re-search-forward "[ \t\n]*,[ \t\n]*\\|[ \t]+" nil t) + (replace-match "," t t)) + (goto-char (point-min)) + ;; Remove trailing commas. + (when (re-search-forward ",+$" nil t) + (replace-match "" t t)))))) (defun message-make-date () "Make a valid data header." @@ -2504,11 +2669,10 @@ (defun message-make-organization () "Make an Organization header." (let* ((organization - (or (getenv "ORGANIZATION") - (when message-user-organization + (when message-user-organization (if (message-functionp message-user-organization) (funcall message-user-organization) - message-user-organization))))) + message-user-organization)))) (save-excursion (message-set-work-buffer) (cond ((stringp organization) @@ -2542,7 +2706,9 @@ (when from (let ((stop-pos (string-match " *at \\| *@ \\| *(\\| *<" from))) - (concat (if stop-pos (substring from 0 stop-pos) from) + (concat (if (and stop-pos + (not (zerop stop-pos))) + (substring from 0 stop-pos) from) "'s message of \"" (if (or (not date) (string= date "")) "(unknown date)" date) @@ -2667,7 +2833,8 @@ (string-match "\\." mail-host-address)) mail-host-address) ;; We try `user-mail-address' as a backup. - ((and (string-match "\\." user-mail) + ((and user-mail + (string-match "\\." user-mail) (string-match "@\\(.*\\)\\'" user-mail)) (match-string 1 user-mail)) ;; Default to this bogus thing. @@ -2731,7 +2898,13 @@ (setq header (car elem))) (setq header elem)) (when (or (not (re-search-forward - (concat "^" (downcase (symbol-name header)) ":") + (concat "^" + (regexp-quote + (downcase + (if (stringp header) + header + (symbol-name header)))) + ":") nil t)) (progn ;; The header was found. We insert a space after the @@ -2773,7 +2946,8 @@ (progn ;; This header didn't exist, so we insert it. (goto-char (point-max)) - (insert (symbol-name header) ": " value "\n") + (insert (if (stringp header) header (symbol-name header)) + ": " value "\n") (forward-line -1)) ;; The value of this header was empty, so we clear ;; totally and insert the new value. @@ -2808,7 +2982,7 @@ (insert "Original-") (beginning-of-line)) (when (or (message-news-p) - (string-match "^[^@]@.+\\..+" secure-sender)) + (string-match "@.+\\.." secure-sender)) (insert "Sender: " secure-sender "\n"))))))) (defun message-insert-courtesy-copy () @@ -2864,7 +3038,7 @@ (defun message-fill-header (header value) (let ((begin (point)) - (fill-column 78) + (fill-column 990) (fill-prefix "\t")) (insert (capitalize (symbol-name header)) ": " @@ -2883,6 +3057,24 @@ (replace-match " " t t)) (goto-char (point-max))))) +(defun message-shorten-references (header references) + "Limit REFERENCES to be shorter than 988 characters." + (let ((max 988) + (cut 4) + refs) + (nnheader-temp-write nil + (insert references) + (goto-char (point-min)) + (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"))) + (defun message-position-point () "Move point to where the user probably wants to find it." (message-narrow-to-headers) @@ -2935,9 +3127,9 @@ (not (y-or-n-p "Message already being composed; erase? "))) (error "Message being composed"))) - (set-buffer (pop-to-buffer name)))) - (erase-buffer) - (message-mode)) + (set-buffer (pop-to-buffer name))) + (erase-buffer) + (message-mode))) (defun message-do-send-housekeeping () "Kill old message buffers." @@ -2986,7 +3178,8 @@ headers) (delete-region (point) (progn (forward-line -1) (point))) (when message-default-headers - (insert message-default-headers)) + (insert message-default-headers) + (or (bolp) (insert ?\n))) (put-text-property (point) (progn @@ -2996,7 +3189,8 @@ (forward-line -1) (when (message-news-p) (when message-default-news-headers - (insert message-default-news-headers)) + (insert message-default-news-headers) + (or (bolp) (insert ?\n))) (when message-generate-headers-first (message-generate-headers (delq 'Lines @@ -3004,7 +3198,8 @@ (copy-sequence message-required-news-headers)))))) (when (message-mail-p) (when message-default-mail-headers - (insert message-default-mail-headers)) + (insert message-default-mail-headers) + (or (bolp) (insert ?\n))) (when message-generate-headers-first (message-generate-headers (delq 'Lines @@ -3012,7 +3207,6 @@ (copy-sequence message-required-mail-headers)))))) (run-hooks 'message-signature-setup-hook) (message-insert-signature) - (message-set-auto-save-file-name) (save-restriction (message-narrow-to-headers) (run-hooks 'message-header-setup-hook)) @@ -3025,25 +3219,19 @@ (defun message-set-auto-save-file-name () "Associate the message buffer with a file in the drafts directory." (when message-auto-save-directory - (unless (file-exists-p message-auto-save-directory) - (make-directory message-auto-save-directory t)) - (let ((name (make-temp-name - (expand-file-name - (concat (file-name-as-directory message-auto-save-directory) - "msg." - (nnheader-replace-chars-in-string - (nnheader-replace-chars-in-string - (buffer-name) ?* ?.) - ?/ ?-)))))) - (setq buffer-auto-save-file-name - (save-excursion - (prog1 - (progn - (set-buffer (get-buffer-create " *draft tmp*")) - (setq buffer-file-name name) - (make-auto-save-file-name)) - (kill-buffer (current-buffer))))) - (clear-visited-file-modtime)))) + (if (gnus-alive-p) + (setq message-draft-article + (nndraft-request-associate-buffer "drafts")) + (setq buffer-file-name (expand-file-name "*message*" + message-auto-save-directory)) + (setq buffer-auto-save-file-name (make-auto-save-file-name))) + (clear-visited-file-modtime))) + +(defun message-disassociate-draft () + "Disassociate the message buffer from the drafts directory." + (when message-draft-article + (nndraft-request-expire-articles + (list message-draft-article) "drafts" nil t))) @@ -3055,7 +3243,8 @@ (defun message-mail (&optional to subject other-headers continue switch-function yank-action send-actions) - "Start editing a mail message to be sent." + "Start editing a mail message to be sent. +OTHER-HEADERS is an alist of header/value pairs." (interactive) (let ((message-this-is-mail t)) (message-pop-to-buffer (message-buffer-name "mail" to)) @@ -3074,7 +3263,7 @@ (Subject . ,(or subject "")))))) ;;;###autoload -(defun message-reply (&optional to-address wide ignore-reply-to) +(defun message-reply (&optional to-address wide) "Start editing a reply to the article in the current buffer." (interactive) (let ((cur (current-buffer)) @@ -3101,12 +3290,12 @@ to (message-fetch-field "to") cc (message-fetch-field "cc") mct (message-fetch-field "mail-copies-to") - reply-to (unless ignore-reply-to (message-fetch-field "reply-to")) + reply-to (message-fetch-field "reply-to") references (message-fetch-field "references") message-id (message-fetch-field "message-id" t)) ;; Remove any (buggy) Re:'s that are present and make a ;; proper one. - (when (string-match "^[ \t]*[Rr][Ee]:[ \t]*" subject) + (when (string-match message-subject-re-regexp subject) (setq subject (substring subject (match-end 0)))) (setq subject (concat "Re: " subject)) @@ -3125,7 +3314,10 @@ (unless follow-to (if (or (not wide) to-address) - (setq follow-to (list (cons 'To (or to-address reply-to from)))) + (progn + (setq follow-to (list (cons 'To (or to-address reply-to from)))) + (when (and wide mct) + (push (cons 'Cc mct) follow-to))) (let (ccalist) (save-excursion (message-set-work-buffer) @@ -3178,10 +3370,10 @@ cur))) ;;;###autoload -(defun message-wide-reply (&optional to-address ignore-reply-to) +(defun message-wide-reply (&optional to-address) "Make a \"wide\" reply to the message in the current buffer." (interactive) - (message-reply to-address t ignore-reply-to)) + (message-reply to-address t)) ;;;###autoload (defun message-followup (&optional to-newsgroups) @@ -3224,7 +3416,7 @@ (setq distribution nil)) ;; Remove any (buggy) Re:'s that are present and make a ;; proper one. - (when (string-match "^[ \t]*[Rr][Ee]:[ \t]*" subject) + (when (string-match message-subject-re-regexp subject) (setq subject (substring subject (match-end 0)))) (setq subject (concat "Re: " subject)) (widen)) @@ -3301,19 +3493,25 @@ (unless (message-news-p) (error "This is not a news article; canceling is impossible")) (when (yes-or-no-p "Do you really want to cancel this article? ") - (let (from newsgroups message-id distribution buf) + (let (from newsgroups message-id distribution buf sender) (save-excursion ;; Get header info. from original article. (save-restriction (message-narrow-to-head) (setq from (message-fetch-field "from") + sender (message-fetch-field "sender") newsgroups (message-fetch-field "newsgroups") message-id (message-fetch-field "message-id" t) distribution (message-fetch-field "distribution"))) ;; Make sure that this article was written by the user. - (unless (string-equal - (downcase (cadr (mail-extract-address-components from))) - (downcase (message-make-address))) + (unless (or (and sender + (string-equal + (downcase sender) + (downcase (message-make-sender)))) + (string-equal + (downcase (cadr (mail-extract-address-components from))) + (downcase (cadr (mail-extract-address-components + (message-make-from)))))) (error "This article is not yours")) ;; Make control message. (setq buf (set-buffer (get-buffer-create " *message cancel*"))) @@ -3341,12 +3539,18 @@ This is done simply by taking the old article and adding a Supersedes header line with the old Message-ID." (interactive) - (let ((cur (current-buffer))) + (let ((cur (current-buffer)) + (sender (message-fetch-field "sender")) + (from (message-fetch-field "from"))) ;; Check whether the user owns the article that is to be superseded. - (unless (string-equal - (downcase (cadr (mail-extract-address-components - (message-fetch-field "from")))) - (downcase (message-make-address))) + (unless (or (and sender + (string-equal + (downcase sender) + (downcase (message-make-sender)))) + (string-equal + (downcase (cadr (mail-extract-address-components from))) + (downcase (cadr (mail-extract-address-components + (message-make-from)))))) (error "This article is not yours")) ;; Get a normal message buffer. (message-pop-to-buffer (message-buffer-name "supersede")) @@ -3382,18 +3586,79 @@ (insert-file-contents file-name nil))) (t (error "message-recover cancelled"))))) +;;; Washing Subject: + +(defun message-wash-subject (subject) + "Remove junk like \"Re:\", \"(fwd)\", etc. that was added to the subject by previous forwarders, replyers, etc." + (nnheader-temp-write nil + (insert-string subject) + (goto-char (point-min)) + ;; strip Re/Fwd stuff off the beginning + (while (re-search-forward + "\\([Rr][Ee]:\\|[Ff][Ww][Dd]\\(\\[[0-9]*\\]\\)?:\\|[Ff][Ww]:\\)" nil t) + (replace-match "")) + + ;; and gnus-style forwards [foo@bar.com] subject + (goto-char (point-min)) + (while (re-search-forward "\\[[^ \t]*\\(@\\|\\.\\)[^ \t]*\\]" nil t) + (replace-match "")) + + ;; and off the end + (goto-char (point-max)) + (while (re-search-backward "([Ff][Ww][Dd])" nil t) + (replace-match "")) + + ;; and finally, any whitespace that was left-over + (goto-char (point-min)) + (while (re-search-forward "^[ \t]+" nil t) + (replace-match "")) + (goto-char (point-max)) + (while (re-search-backward "[ \t]+$" nil t) + (replace-match "")) + + (buffer-string))) + ;;; Forwarding messages. +(defun message-forward-subject-author-subject (subject) + "Generate a subject for a forwarded message. +The form is: [Source] Subject, where if the original message was mail, +Source is the sender, and if the original message was news, Source is +the list of newsgroups is was posted to." + (concat "[" + (or (message-fetch-field + (if (message-news-p) "newsgroups" "from")) + "(nowhere)") + "] " subject)) + +(defun message-forward-subject-fwd (subject) + "Generate a subject for a forwarded message. +The form is: Fwd: Subject, where Subject is the original subject of +the message." + (concat "Fwd: " subject)) + (defun message-make-forward-subject () "Return a Subject header suitable for the message in the current buffer." (save-excursion (save-restriction (current-buffer) (message-narrow-to-head) - (concat "[" (or (message-fetch-field - (if (message-news-p) "newsgroups" "from")) - "(nowhere)") - "] " (or (message-fetch-field "Subject") ""))))) + (let ((funcs message-make-forward-subject-function) + (subject (if message-wash-forwarded-subjects + (message-wash-subject + (or (message-fetch-field "Subject") "")) + (or (message-fetch-field "Subject") "")))) + ;; Make sure funcs is a list. + (and funcs + (not (listp funcs)) + (setq funcs (list funcs))) + ;; Apply funcs in order, passing subject generated by previous + ;; func to the next one. + (while funcs + (when (message-functionp (car funcs)) + (setq subject (funcall (car funcs) subject))) + (setq funcs (cdr funcs))) + subject)))) ;;;###autoload (defun message-forward (&optional news) @@ -3466,7 +3731,7 @@ (goto-char (point-max))) (insert mail-header-separator) ;; Rename all old ("Also-")Resent headers. - (while (re-search-backward "^\\(Also-\\)?Resent-" beg t) + (while (re-search-backward "^\\(Also-\\)*Resent-" beg t) (beginning-of-line) (insert "Also-")) ;; Quote any "From " lines at the beginning. @@ -3533,7 +3798,8 @@ (same-window-buffer-names nil) (same-window-regexps nil)) (message-pop-to-buffer (message-buffer-name "mail" to))) - (message-setup `((To . ,(or to "")) (Subject . ,(or subject ""))))) + (let ((message-this-is-mail t)) + (message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))))) ;;;###autoload (defun message-mail-other-frame (&optional to subject) @@ -3545,7 +3811,8 @@ (same-window-buffer-names nil) (same-window-regexps nil)) (message-pop-to-buffer (message-buffer-name "mail" to))) - (message-setup `((To . ,(or to "")) (Subject . ,(or subject ""))))) + (let ((message-this-is-mail t)) + (message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))))) ;;;###autoload (defun message-news-other-window (&optional newsgroups subject) @@ -3557,8 +3824,9 @@ (same-window-buffer-names nil) (same-window-regexps nil)) (message-pop-to-buffer (message-buffer-name "news" nil newsgroups))) - (message-setup `((Newsgroups . ,(or newsgroups "")) - (Subject . ,(or subject ""))))) + (let ((message-this-is-news t)) + (message-setup `((Newsgroups . ,(or newsgroups "")) + (Subject . ,(or subject "")))))) ;;;###autoload (defun message-news-other-frame (&optional newsgroups subject) @@ -3570,8 +3838,9 @@ (same-window-buffer-names nil) (same-window-regexps nil)) (message-pop-to-buffer (message-buffer-name "news" nil newsgroups))) - (message-setup `((Newsgroups . ,(or newsgroups "")) - (Subject . ,(or subject ""))))) + (let ((message-this-is-news t)) + (message-setup `((Newsgroups . ,(or newsgroups "")) + (Subject . ,(or subject "")))))) ;;; underline.el @@ -3630,6 +3899,7 @@ (defvar gnus-active-hashtb) (defun message-expand-group () + "Expand the group name under point." (let* ((b (save-excursion (save-restriction (narrow-to-region @@ -3640,10 +3910,10 @@ (point)) (skip-chars-backward "^, \t\n") (point)))) (completion-ignore-case t) - (string (buffer-substring b (point))) + (string (buffer-substring b (progn (skip-chars-forward "^,\t\n ") + (point)))) (hashtb (and (boundp 'gnus-active-hashtb) gnus-active-hashtb)) (completions (all-completions string hashtb)) - (cur (current-buffer)) comp) (delete-region b (point)) (cond @@ -3716,13 +3986,29 @@ (regexp "^gnus\\|^nn\\|^message")) (mapcar (lambda (local) - (when (and (car local) + (when (and (consp local) + (car local) (string-match regexp (symbol-name (car local)))) (ignore-errors (set (make-local-variable (car local)) (cdr local))))) locals))) +;;; Miscellaneous functions + +;; stolen (and renamed) from nnheader.el +(defun message-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)) + (run-hooks 'message-load-hook) (provide 'message)
--- a/lisp/gnus/messcompat.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/messcompat.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ ;;; messcompat.el --- making message mode compatible with mail mode -;; Copyright (C) 1996,97 Free Software Foundation, Inc. +;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: mail, news ;; This file is part of GNU Emacs. @@ -56,8 +56,9 @@ "Normal hook, run each time a new outgoing message is initialized. The function `message-setup' runs this hook.") -(defvar message-mode-hook mail-mode-hook - "Hook run in message mode buffers.") +(if (boundp 'mail-mode-hook) + (defvar message-mode-hook mail-mode-hook + "Hook run in message mode buffers.")) (defvar message-indentation-spaces mail-indentation-spaces "*Number of spaces to insert at the beginning of each cited line. @@ -69,9 +70,8 @@ If a function, the result from the function will be used instead. If a form, the result from the form will be used instead.") -;; Deleted the autoload cookie because this crashes in loaddefs.el. (defvar message-signature-file mail-signature-file - "*File containing the text inserted at end of message. buffer.") + "*File containing the text inserted at end of the message buffer.") (defvar message-default-headers mail-default-headers "*A string containing header lines to be inserted in outgoing messages. @@ -81,6 +81,11 @@ (defvar message-send-hook mail-send-hook "Hook run before sending messages.") +(defvar message-send-mail-function send-mail-function + "Function to call to send the current buffer as mail. +The headers should be delimited by a line whose contents match the +variable `mail-header-separator'.") + (provide 'messcompat) ;;; messcompat.el ends here
--- a/lisp/gnus/nnbabyl.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/nnbabyl.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ ;;; nnbabyl.el --- rmail mbox access for Gnus -;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> ;; Keywords: news, mail @@ -30,7 +30,9 @@ ;;; Code: (require 'nnheader) -(require 'rmail) +(condition-case nil + (require 'rmail) + (t (nnheader-message 5 "Ignore rmail errors from this file, you don't have rmail"))) (require 'nnmail) (require 'nnoo) (eval-when-compile (require 'cl)) @@ -240,7 +242,7 @@ (nnmail-activate 'nnbabyl) (unless (assoc group nnbabyl-group-alist) (push (list group (cons 1 0)) - nnbabyl-group-alist) + nnbabyl-group-alist) (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)) t) @@ -643,7 +645,7 @@ (when (buffer-modified-p (current-buffer)) (save-buffer)) (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file) - (message "")))) + (nnheader-message 5 "")))) (provide 'nnbabyl)
--- a/lisp/gnus/nndir.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/nndir.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ ;;; nndir.el --- single directory newsgroup access for Gnus -;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news ;; This file is part of GNU Emacs. @@ -88,11 +88,11 @@ (nnoo-map-functions nndir (nnml-retrieve-headers 0 nndir-current-group 0 0) - (nnmh-request-article 0 nndir-current-group 0 0) + (nnml-request-article 0 nndir-current-group 0 0) (nnmh-request-group nndir-current-group 0 0) (nnml-close-group nndir-current-group 0) - (nnmh-request-list (nnoo-current-server 'nndir) nndir-directory) - (nnmh-request-newsgroups (nnoo-current-server 'nndir) nndir-directory)) + (nnml-request-list (nnoo-current-server 'nndir) nndir-directory) + (nnml-request-newsgroups (nnoo-current-server 'nndir) nndir-directory)) (provide 'nndir)
--- a/lisp/gnus/nndoc.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/nndoc.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ ;;; nndoc.el --- single file access for Gnus -;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> ;; Keywords: news @@ -30,6 +30,7 @@ (require 'message) (require 'nnmail) (require 'nnoo) +(require 'gnus-util) (eval-when-compile (require 'cl)) (nnoo-declare nndoc) @@ -37,12 +38,17 @@ (defvoo nndoc-article-type 'guess "*Type of the file. One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward', -`rfc934', `rfc822-forward', `mime-digest', `standard-digest', +`rfc934', `rfc822-forward', `mime-digest', `mime-parts', `standard-digest', `slack-digest', `clari-briefs' or `guess'.") (defvoo nndoc-post-type 'mail "*Whether the nndoc group is `mail' or `post'.") +(defvoo nndoc-open-document-hook 'nnheader-ms-strip-cr + "Hook run after opening a document. +The default function removes all trailing carriage returns +from the document.") + (defvar nndoc-type-alist `((mmdf (article-begin . "^\^A\^A\^A\^A\n") @@ -81,13 +87,16 @@ (body-end . "") (file-end . "") (subtype digest guess)) + (mime-parts + (generate-head-function . nndoc-generate-mime-parts-head) + (article-transform-function . nndoc-transform-mime-parts)) (standard-digest - (first-article . ,(concat "^" (make-string 70 ?-) "\n\n+")) - (article-begin . ,(concat "^\n" (make-string 30 ?-) "\n\n+")) + (first-article . ,(concat "^" (make-string 70 ?-) "\n *\n+")) + (article-begin . ,(concat "^\n" (make-string 30 ?-) "\n *\n+")) (prepare-body-function . nndoc-unquote-dashes) (body-end-function . nndoc-digest-body-end) - (head-end . "^ ?$") - (body-begin . "^ ?\n") + (head-end . "^ *$") + (body-begin . "^ *\n") (file-end . "^End of .*digest.*[0-9].*\n\\*\\*\\|^End of.*Digest *$") (subtype digest guess)) (slack-digest @@ -122,10 +131,8 @@ (subtype nil)))) - (defvoo nndoc-file-begin nil) (defvoo nndoc-first-article nil) -(defvoo nndoc-article-end nil) (defvoo nndoc-article-begin nil) (defvoo nndoc-head-begin nil) (defvoo nndoc-head-end nil) @@ -135,6 +142,11 @@ (defvoo nndoc-body-begin-function nil) (defvoo nndoc-head-begin-function nil) (defvoo nndoc-body-end nil) +;; nndoc-dissection-alist is a list of sublists. Each sublist holds the +;; following items. ARTICLE is an ordinal starting at 1. HEAD-BEGIN, +;; HEAD-END, BODY-BEGIN and BODY-END are positions in the `nndoc' buffer. +;; LINE-COUNT is a count of lines in the body. SUBJECT, MESSAGE-ID and +;; REFERENCES, only present for MIME dissections, are field values. (defvoo nndoc-dissection-alist nil) (defvoo nndoc-prepare-body-function nil) (defvoo nndoc-generate-head-function nil) @@ -146,6 +158,8 @@ (defvoo nndoc-current-buffer nil "Current nndoc news buffer.") (defvoo nndoc-address nil) +(defvoo nndoc-mime-header nil) +(defvoo nndoc-mime-subject nil) (defconst nndoc-version "nndoc 1.0" "nndoc version.") @@ -279,14 +293,17 @@ (erase-buffer) (if (stringp nndoc-address) (nnheader-insert-file-contents nndoc-address) - (insert-buffer-substring nndoc-address))))) + (insert-buffer-substring nndoc-address)) + (run-hooks 'nndoc-open-document-hook)))) ;; Initialize the nndoc structures according to this new document. (when (and nndoc-current-buffer (not nndoc-dissection-alist)) (save-excursion (set-buffer nndoc-current-buffer) (nndoc-set-delims) - (nndoc-dissect-buffer))) + (if (eq nndoc-article-type 'mime-parts) + (nndoc-dissect-mime-parts) + (nndoc-dissect-buffer)))) (unless nndoc-current-buffer (nndoc-close-server)) ;; Return whether we managed to select a file. @@ -300,7 +317,8 @@ "Set the nndoc delimiter variables according to the type of the document." (let ((vars '(nndoc-file-begin nndoc-first-article - nndoc-article-end nndoc-head-begin nndoc-head-end + nndoc-article-begin-function + nndoc-head-begin nndoc-head-end nndoc-file-end nndoc-article-begin nndoc-body-begin nndoc-body-end-function nndoc-body-end nndoc-prepare-body-function nndoc-article-transform-function @@ -334,7 +352,7 @@ (error "Document is not of any recognized type")) (if result (car entry) - (cadar (sort results (lambda (r1 r2) (< (car r1) (car r2)))))))) + (cadar (sort results 'car-less-than-car))))) ;;; ;;; Built-in type predicates and functions @@ -390,7 +408,7 @@ (defun nndoc-babyl-body-begin () (re-search-forward "^\n" nil t) - (when (looking-at "\*\*\* EOOH \*\*\*") + (when (looking-at "\\*\\*\\* EOOH \\*\\*\\*") (let ((next (or (save-excursion (re-search-forward nndoc-article-begin nil t)) (point-max)))) @@ -402,7 +420,7 @@ (defun nndoc-babyl-head-begin () (when (re-search-forward "^[0-9].*\n" nil t) - (when (looking-at "\*\*\* EOOH \*\*\*") + (when (looking-at "\\*\\*\\* EOOH \\*\\*\\*") (forward-line 1)) t)) @@ -429,6 +447,44 @@ (defun nndoc-rfc822-forward-body-end-function () (goto-char (point-max))) +(defun nndoc-mime-parts-type-p () + (let ((case-fold-search t) + (limit (search-forward "\n\n" nil t))) + (goto-char (point-min)) + (when (and limit + (re-search-forward + (concat "\ +^Content-Type:[ \t]*multipart/[a-z]+;\\(.*;\\)*" + "[ \t\n]*[ \t]boundary=\"?[^\"\n]*[^\" \t\n]") + limit t)) + t))) + +(defun nndoc-transform-mime-parts (article) + (unless (= article 1) + ;; Ensure some MIME-Version. + (goto-char (point-min)) + (search-forward "\n\n") + (let ((case-fold-search nil) + (limit (point))) + (goto-char (point-min)) + (or (save-excursion (re-search-forward "^MIME-Version:" limit t)) + (insert "Mime-Version: 1.0\n"))) + ;; Generate default header before entity fields. + (goto-char (point-min)) + (nndoc-generate-mime-parts-head article t))) + +(defun nndoc-generate-mime-parts-head (article &optional body-present) + (let ((entry (cdr (assq (if body-present 1 article) nndoc-dissection-alist)))) + (let ((subject (if body-present + nndoc-mime-subject + (concat "<" (nth 5 entry) ">"))) + (message-id (nth 6 entry)) + (references (nth 7 entry))) + (insert nndoc-mime-header) + (and subject (insert "Subject: " subject "\n")) + (and message-id (insert "Message-ID: " message-id "\n")) + (and references (insert "References: " references "\n"))))) + (defun nndoc-clari-briefs-type-p () (when (let ((case-fold-search nil)) (re-search-forward "^\t[^a-z]+ ([^a-z]+) --" nil t)) @@ -466,7 +522,7 @@ (when (and (re-search-forward (concat "^Content-Type: *multipart/digest;[ \t\n]*[ \t]" - "boundary=\"\\([^\"\n]*[^\" \t\n]\\)\"") + "boundary=\"?\\([^\"\n]*[^\" \t\n]\\)") nil t) (match-beginning 1)) (setq boundary-id (match-string 1) @@ -530,6 +586,9 @@ (insert "From: " (or from "unknown") "\nSubject: " (or subject "(no subject)") "\n"))) +(deffoo nndoc-request-accept-article (group &optional server last) + nil) + ;;; @@ -562,7 +621,7 @@ (funcall nndoc-head-begin-function)) (nndoc-head-begin (nndoc-search nndoc-head-begin))) - (if (or (>= (point) (point-max)) + (if (or (eobp) (and nndoc-file-end (looking-at nndoc-file-end))) (goto-char (point-max)) @@ -599,6 +658,104 @@ (while (re-search-forward "^- -"nil t) (replace-match "-" t t))) +;; Against compiler warnings. +(defvar nndoc-mime-split-ordinal) + +(defun nndoc-dissect-mime-parts () + "Go through a MIME composite article and partition it into sub-articles. +When a MIME entity contains sub-entities, dissection produces one article for +the header of this entity, and one article per sub-entity." + (setq nndoc-dissection-alist nil + nndoc-mime-split-ordinal 0) + (save-excursion + (set-buffer nndoc-current-buffer) + (message-narrow-to-head) + (let ((case-fold-search t) + (message-id (message-fetch-field "Message-ID")) + (references (message-fetch-field "References"))) + (setq nndoc-mime-header (buffer-substring (point-min) (point-max)) + nndoc-mime-subject (message-fetch-field "Subject")) + (while (string-match "\ +^\\(Subject\\|Message-ID\\|References\\|Lines\\|\ +MIME-Version\\|Content-Type\\|Content-Transfer-Encoding\\|\ +\\):.*\n\\([ \t].*\n\\)*" + nndoc-mime-header) + (setq nndoc-mime-header (replace-match "" t t nndoc-mime-header))) + (widen) + (nndoc-dissect-mime-parts-sub (point-min) (point-max) + nil message-id references)))) + +(defun nndoc-dissect-mime-parts-sub (begin end position message-id references) + "Dissect an entity within a composite MIME message. +The article, which corresponds to a MIME entity, extends from BEGIN to END. +The string POSITION holds a dotted decimal representation of the article +position in the hierarchical structure, it is nil for the outer entity. +The generated article should use MESSAGE-ID and REFERENCES field values." + ;; Note: `case-fold-search' is already `t' from the calling function. + (let ((head-begin begin) + (body-end end) + head-end body-begin type subtype composite comment) + (save-excursion + ;; Gracefully handle a missing body. + (goto-char head-begin) + (if (search-forward "\n\n" body-end t) + (setq head-end (1- (point)) + body-begin (point)) + (setq head-end end + body-begin end)) + ;; Save MIME attributes. + (goto-char head-begin) + (if (re-search-forward "\ +^Content-Type: *\\([^ \t\n/;]+\\)/\\([^ \t\n/;]+\\)" + head-end t) + (setq type (downcase (match-string 1)) + subtype (downcase (match-string 2))) + (setq type "text" + subtype "plain")) + (setq composite (string= type "multipart") + comment (concat position + (when (and position composite) ".") + (when composite "*") + (when (or position composite) " ") + (cond ((string= subtype "plain") type) + ((string= subtype "basic") type) + (t subtype)))) + ;; Generate dissection information for this entity. + (push (list (incf nndoc-mime-split-ordinal) + head-begin head-end body-begin body-end + (count-lines body-begin body-end) + comment message-id references) + nndoc-dissection-alist) + ;; Recurse for all sub-entities, if any. + (goto-char head-begin) + (when (re-search-forward + (concat "\ +^Content-Type: *multipart/\\([a-z]+\\);\\(.*;\\)*" + "[ \t\n]*[ \t]boundary=\"?\\([^\"\n]*[^\" \t\n]\\)") + head-end t) + (let ((boundary (concat "\n--" (match-string 3) "\\(--\\)?[ \t]*\n")) + (part-counter 0) + begin end eof-flag) + (goto-char head-end) + (setq eof-flag (not (re-search-forward boundary body-end t))) + (while (not eof-flag) + (setq begin (point)) + (cond ((re-search-forward boundary body-end t) + (or (not (match-string 1)) + (string= (match-string 1) "") + (setq eof-flag t)) + (forward-line -1) + (setq end (point)) + (forward-line 1)) + (t (setq end body-end + eof-flag t))) + (nndoc-dissect-mime-parts-sub begin end + (concat position (when position ".") + (format "%d" + (incf part-counter))) + (nnmail-message-id) + message-id))))))) + ;;;###autoload (defun nndoc-add-type (definition &optional position) "Add document DEFINITION to the list of nndoc document definitions. @@ -607,9 +764,7 @@ first definition, and if any other symbol, add after that symbol in the alist." ;; First remove any old instances. - (setq nndoc-type-alist - (delq (assq (car definition) nndoc-type-alist) - nndoc-type-alist)) + (gnus-pull (car definition) nndoc-type-alist) ;; Then enter the new definition in the proper place. (cond ((or (null position) (eq position 'last))
--- a/lisp/gnus/nndraft.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/nndraft.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ ;;; nndraft.el --- draft article access for Gnus -;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news ;; This file is part of GNU Emacs. @@ -26,22 +26,30 @@ ;;; Code: (require 'nnheader) +(require 'nnmail) +(require 'gnus-start) (require 'nnmh) (require 'nnoo) -(eval-and-compile (require 'cl)) - -(nnoo-declare nndraft) +(eval-when-compile + (require 'cl) + ;; This is just to shut up the byte-compiler. + (fset 'nndraft-request-group 'ignore)) -(eval-and-compile - (autoload 'mail-send-and-exit "sendmail")) +(nnoo-declare nndraft + nnmh) -(defvoo nndraft-directory nil - "Where nndraft will store its directory.") +(defvoo nndraft-directory (nnheader-concat gnus-directory "drafts/") + "Where nndraft will store its files." + nnmh-directory) +(defvoo nndraft-current-group "" nil nnmh-current-group) +(defvoo nndraft-get-new-mail nil nil nnmh-get-new-mail) +(defvoo nndraft-current-directory nil nil nnmh-current-directory) + (defconst nndraft-version "nndraft 1.0") -(defvoo nndraft-status-string "") +(defvoo nndraft-status-string "" nil nnmh-status-string) @@ -49,7 +57,23 @@ (nnoo-define-basics nndraft) +(deffoo nndraft-open-server (server &optional defs) + (nnoo-change-server 'nndraft server defs) + (cond + ((not (file-exists-p nndraft-directory)) + (nndraft-close-server) + (nnheader-report 'nndraft "No such file or directory: %s" + nndraft-directory)) + ((not (file-directory-p (file-truename nndraft-directory))) + (nndraft-close-server) + (nnheader-report 'nndraft "Not a directory: %s" nndraft-directory)) + (t + (nnheader-report 'nndraft "Opened server %s using directory %s" + server nndraft-directory) + t))) + (deffoo nndraft-retrieve-headers (articles &optional group server fetch-old) + (nndraft-possibly-change-group group) (save-excursion (set-buffer nntp-server-buffer) (erase-buffer) @@ -79,24 +103,8 @@ (nnheader-fold-continuation-lines) 'headers)))) -(deffoo nndraft-open-server (server &optional defs) - (nnoo-change-server 'nndraft server defs) - (unless (assq 'nndraft-directory defs) - (setq nndraft-directory server)) - (cond - ((not (file-exists-p nndraft-directory)) - (nndraft-close-server) - (nnheader-report 'nndraft "No such file or directory: %s" - nndraft-directory)) - ((not (file-directory-p (file-truename nndraft-directory))) - (nndraft-close-server) - (nnheader-report 'nndraft "Not a directory: %s" nndraft-directory)) - (t - (nnheader-report 'nndraft "Opened server %s using directory %s" - server nndraft-directory) - t))) - (deffoo nndraft-request-article (id &optional group server buffer) + (nndraft-possibly-change-group group) (when (numberp id) ;; We get the newest file of the auto-saved file and the ;; "real" file. @@ -118,119 +126,92 @@ (deffoo nndraft-request-restore-buffer (article &optional group server) "Request a new buffer that is restored to the state of ARTICLE." - (let ((file (nndraft-article-filename article ".state")) - nndraft-point nndraft-mode nndraft-buffer-name) - (when (file-exists-p file) - (load file t t t) - (when nndraft-buffer-name - (set-buffer (get-buffer-create - (generate-new-buffer-name nndraft-buffer-name))) - (nndraft-request-article article group server (current-buffer)) - (funcall nndraft-mode) - (let ((gnus-verbose-backends nil)) - (nndraft-request-expire-articles (list article) group server t)) - (goto-char nndraft-point)) - nndraft-buffer-name))) + (nndraft-possibly-change-group group) + (when (nndraft-request-article article group server (current-buffer)) + (message-remove-header "xref") + (message-remove-header "lines") + t)) (deffoo nndraft-request-update-info (group info &optional server) - (setcar (cddr info) nil) - (when (nth 3 info) - (setcar (nthcdr 3 info) nil)) + (nndraft-possibly-change-group group) + (gnus-info-set-read + info + (gnus-update-read-articles (gnus-group-prefixed-name group '(nndraft "")) + (nndraft-articles) t)) + (let (marks) + (when (setq marks (nth 3 info)) + (setcar (nthcdr 3 info) + (if (assq 'unsend marks) + (list (assq 'unsend marks)) + nil)))) t) (deffoo nndraft-request-associate-buffer (group) "Associate the current buffer with some article in the draft group." - (let* ((gnus-verbose-backends nil) - (article (cdr (nndraft-request-accept-article - group (nnoo-current-server 'nndraft) t 'noinsert))) - (file (nndraft-article-filename article))) - (setq buffer-file-name file) + (nndraft-open-server "") + (nndraft-request-group group) + (nndraft-possibly-change-group group) + (let ((gnus-verbose-backends nil) + (buf (current-buffer)) + article file) + (nnheader-temp-write nil + (insert-buffer buf) + (setq article (nndraft-request-accept-article + group (nnoo-current-server 'nndraft) t 'noinsert)) + (setq file (nndraft-article-filename article))) + (setq buffer-file-name (expand-file-name file)) (setq buffer-auto-save-file-name (make-auto-save-file-name)) (clear-visited-file-modtime) article)) -(deffoo nndraft-request-group (group &optional server dont-check) - (prog1 - (nndraft-execute-nnmh-command - `(nnmh-request-group group "" ,dont-check)) - (nnheader-report 'nndraft nnmh-status-string))) - -(deffoo nndraft-request-list (&optional server dir) - (nndraft-execute-nnmh-command - `(nnmh-request-list nil ,dir))) - -(deffoo nndraft-request-newgroups (date &optional server) - (nndraft-execute-nnmh-command - `(nnmh-request-newgroups ,date ,server))) - -(deffoo nndraft-request-expire-articles - (articles group &optional server force) - (let ((res (nndraft-execute-nnmh-command - `(nnmh-request-expire-articles - ',articles group ,server ,force))) - article) +(deffoo nndraft-request-expire-articles (articles group &optional server force) + (nndraft-possibly-change-group group) + (let* ((nnmh-allow-delete-final t) + (res (nnoo-parent-function 'nndraft + 'nnmh-request-expire-articles + (list articles group server force))) + article) ;; Delete all the "state" files of articles that have been expired. (while articles (unless (memq (setq article (pop articles)) res) - (let ((file (nndraft-article-filename article ".state")) - (auto (nndraft-auto-save-file-name + (let ((auto (nndraft-auto-save-file-name (nndraft-article-filename article)))) - (when (file-exists-p file) - (funcall nnmail-delete-file-function file)) (when (file-exists-p auto) (funcall nnmail-delete-file-function auto))))) res)) (deffoo nndraft-request-accept-article (group &optional server last noinsert) - (let* ((point (point)) - (mode major-mode) - (name (buffer-name)) - (gnus-verbose-backends nil) - (gart (nndraft-execute-nnmh-command - `(nnmh-request-accept-article group ,server ,last noinsert))) - (state - (nndraft-article-filename (cdr gart) ".state"))) - ;; Write the "state" file. - (save-excursion - (nnheader-set-temp-buffer " *draft state*") - (insert (format "%S\n" `(setq nndraft-mode (quote ,mode) - nndraft-point ,point - nndraft-buffer-name ,name))) - (write-region (point-min) (point-max) state nil 'silent) - (kill-buffer (current-buffer))) - gart)) - -(deffoo nndraft-close-group (group &optional server) - t) + (nndraft-possibly-change-group group) + (let ((gnus-verbose-backends nil)) + (nnoo-parent-function 'nndraft 'nnmh-request-accept-article + (list group server last noinsert)))) (deffoo nndraft-request-create-group (group &optional server args) - (if (file-exists-p nndraft-directory) - (if (file-directory-p nndraft-directory) + (nndraft-possibly-change-group group) + (if (file-exists-p nndraft-current-directory) + (if (file-directory-p nndraft-current-directory) t nil) (condition-case () (progn - (gnus-make-directory nndraft-directory) + (gnus-make-directory nndraft-current-directory) t) (file-error nil)))) ;;; Low-Level Interface -(defun nndraft-execute-nnmh-command (command) - (let ((dir (expand-file-name nndraft-directory))) - (when (string-match "/$" dir) - (setq dir (substring dir 0 (match-beginning 0)))) - (string-match "/[^/]+$" dir) - (let ((group (substring dir (1+ (match-beginning 0)))) - (nnmh-directory (substring dir 0 (1+ (match-beginning 0)))) - (nnmail-keep-last-article nil) - (nnmh-get-new-mail nil)) - (eval command)))) +(defun nndraft-possibly-change-group (group) + (when (and group + (not (equal group nndraft-current-group))) + (nndraft-open-server "") + (setq nndraft-current-group group) + (setq nndraft-current-directory + (nnheader-concat nndraft-directory group)))) (defun nndraft-article-filename (article &rest args) (apply 'concat - (file-name-as-directory nndraft-directory) + (file-name-as-directory nndraft-current-directory) (int-to-string article) args)) @@ -243,6 +224,24 @@ (make-auto-save-file-name)) (kill-buffer (current-buffer))))) +(defun nndraft-articles () + "Return the list of messages in the group." + (gnus-make-directory nndraft-current-directory) + (sort + (mapcar 'string-to-int + (directory-files nndraft-current-directory nil "\\`[0-9]+\\'" t)) + '<)) + +(nnoo-import nndraft + (nnmh + nnmh-retrieve-headers + nnmh-request-group + nnmh-close-group + nnmh-request-list + nnmh-request-newsgroups + nnmh-request-move-article + nnmh-request-replace-article)) + (provide 'nndraft) ;;; nndraft.el ends here
--- a/lisp/gnus/nneething.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/nneething.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ -;;; nneething.el --- random file access for Gnus -;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. +;;; nneething.el --- arbitrary file access for Gnus +;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> ;; Keywords: news, mail @@ -64,9 +64,12 @@ (defvoo nneething-map nil) (defvoo nneething-read-only nil) (defvoo nneething-active nil) +(defvoo nneething-address nil) +(autoload 'gnus-encode-coding-string "gnus-ems") + ;;; Interface functions. (nnoo-define-basics nneething) @@ -100,11 +103,11 @@ (and large (zerop (% count 20)) - (message "nneething: Receiving headers... %d%%" + (nnheader-message 5 "nneething: Receiving headers... %d%%" (/ (* count 100) number)))) (when large - (message "nneething: Receiving headers...done")) + (nnheader-message 5 "nneething: Receiving headers...done")) (nnheader-fold-continuation-lines) 'headers)))) @@ -155,8 +158,8 @@ (nnheader-init-server-buffer) (if (nneething-server-opened server) t - (unless (assq 'nneething-directory defs) - (setq defs (append defs (list (list 'nneething-directory server))))) + (unless (assq 'nneething-address defs) + (setq defs (append defs (list (list 'nneething-address server))))) (nnoo-change-server 'nneething server defs))) @@ -182,9 +185,9 @@ (defun nneething-create-mapping () ;; Read nneething-active and nneething-map. - (when (file-exists-p nneething-directory) + (when (file-exists-p nneething-address) (let ((map-file (nneething-map-file)) - (files (directory-files nneething-directory)) + (files (directory-files nneething-address)) touched map-files) (when (file-exists-p map-file) (ignore-errors @@ -341,7 +344,7 @@ (defun nneething-file-name (article) "Return the file name of ARTICLE." - (concat (file-name-as-directory nneething-directory) + (concat (file-name-as-directory nneething-address) (if (numberp article) (cadr (assq article nneething-map)) article)))
--- a/lisp/gnus/nnfolder.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/nnfolder.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,8 +1,8 @@ ;;; nnfolder.el --- mail folder access for Gnus -;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. ;; Author: Scott Byer <byer@mv.us.adobe.com> -;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> ;; Keywords: mail @@ -31,7 +31,7 @@ (require 'message) (require 'nnmail) (require 'nnoo) -(require 'cl) +(eval-when-compile (require 'cl)) (require 'gnus-util) (nnoo-declare nnfolder) @@ -101,24 +101,16 @@ (save-excursion (set-buffer nntp-server-buffer) (erase-buffer) - (let (article art-string start stop) + (let (article start stop) (nnfolder-possibly-change-group group server) (when nnfolder-current-buffer (set-buffer nnfolder-current-buffer) (goto-char (point-min)) (if (stringp (car articles)) 'headers - (while articles - (setq article (car articles)) - (setq art-string (nnfolder-article-string article)) + (while (setq article (pop articles)) (set-buffer nnfolder-current-buffer) - (when (or (search-forward art-string nil t) - ;; Don't search the whole file twice! Also, articles - ;; probably have some locality by number, so searching - ;; backwards will be faster. Especially if we're at the - ;; beginning of the buffer :-). -SLB - (search-backward art-string nil t)) - (nnmail-search-unix-mail-delim-backward) + (when (nnfolder-goto-article article) (setq start (point)) (search-forward "\n\n" nil t) (setq stop (1- (point))) @@ -126,8 +118,7 @@ (insert (format "221 %d Article retrieved.\n" article)) (insert-buffer-substring nnfolder-current-buffer start stop) (goto-char (point-max)) - (insert ".\n")) - (setq articles (cdr articles))) + (insert ".\n"))) (set-buffer nntp-server-buffer) (nnheader-fold-continuation-lines) @@ -165,9 +156,8 @@ (save-excursion (set-buffer nnfolder-current-buffer) (goto-char (point-min)) - (when (search-forward (nnfolder-article-string article) nil t) + (when (nnfolder-goto-article article) (let (start stop) - (nnmail-search-unix-mail-delim-backward) (setq start (point)) (forward-line 1) (unless (and (nnmail-search-unix-mail-delim) @@ -283,11 +273,8 @@ (deffoo nnfolder-request-list (&optional server) (nnfolder-possibly-change-group nil server) (save-excursion - ;; 1997/8/14 by MORIOKA Tomohiko - ;; for XEmacs/mule. (let ((nnmail-file-coding-system nnmail-active-file-coding-system) - (file-name-coding-system 'binary) ; for Emacs 20 - (pathname-coding-system 'binary)) ; for XEmacs/mule + (pathname-coding-system 'binary)) (nnmail-find-file nnfolder-active-file) (setq nnfolder-group-alist (nnmail-get-active))) t)) @@ -312,7 +299,7 @@ (set-buffer nnfolder-current-buffer) (while (and articles is-old) (goto-char (point-min)) - (when (search-forward (nnfolder-article-string (car articles)) nil t) + (when (nnfolder-goto-article (car articles)) (if (setq is-old (nnmail-expired-article-p newsgroup @@ -332,85 +319,99 @@ (nnmail-save-active nnfolder-group-alist nnfolder-active-file) (nconc rest articles)))) -(deffoo nnfolder-request-move-article - (article group server accept-form &optional last) - (let ((buf (get-buffer-create " *nnfolder move*")) - result) - (and - (nnfolder-request-article article group server) - (save-excursion - (set-buffer buf) - (buffer-disable-undo (current-buffer)) - (erase-buffer) - (insert-buffer-substring nntp-server-buffer) - (goto-char (point-min)) - (while (re-search-forward - (concat "^" nnfolder-article-marker) - (save-excursion (search-forward "\n\n" nil t) (point)) t) - (delete-region (progn (beginning-of-line) (point)) - (progn (forward-line 1) (point)))) - (setq result (eval accept-form)) - (kill-buffer buf) - result) - (save-excursion - (nnfolder-possibly-change-group group server) - (set-buffer nnfolder-current-buffer) - (goto-char (point-min)) - (when (search-forward (nnfolder-article-string article) nil t) - (nnfolder-delete-mail)) - (when last - (nnfolder-save-buffer) - (nnfolder-adjust-min-active group) - (nnmail-save-active nnfolder-group-alist nnfolder-active-file)))) - result)) +(deffoo nnfolder-request-move-article (article group server + accept-form &optional last) + (save-excursion + (let ((buf (get-buffer-create " *nnfolder move*")) + result) + (and + (nnfolder-request-article article group server) + (save-excursion + (set-buffer buf) + (buffer-disable-undo (current-buffer)) + (erase-buffer) + (insert-buffer-substring nntp-server-buffer) + (goto-char (point-min)) + (while (re-search-forward + (concat "^" nnfolder-article-marker) + (save-excursion (search-forward "\n\n" nil t) (point)) t) + (delete-region (progn (beginning-of-line) (point)) + (progn (forward-line 1) (point)))) + (setq result (eval accept-form)) + (kill-buffer buf) + result) + (save-excursion + (nnfolder-possibly-change-group group server) + (set-buffer nnfolder-current-buffer) + (goto-char (point-min)) + (when (nnfolder-goto-article article) + (nnfolder-delete-mail)) + (when last + (nnfolder-save-buffer) + (nnfolder-adjust-min-active group) + (nnmail-save-active nnfolder-group-alist nnfolder-active-file)))) + result))) (deffoo nnfolder-request-accept-article (group &optional server last) - (nnfolder-possibly-change-group group server) - (nnmail-check-syntax) - (let ((buf (current-buffer)) - result art-group) - (goto-char (point-min)) - (when (looking-at "X-From-Line: ") - (replace-match "From ")) - (and - (nnfolder-request-list) - (save-excursion - (set-buffer buf) - (goto-char (point-min)) - (search-forward "\n\n" nil t) - (forward-line -1) - (while (re-search-backward (concat "^" nnfolder-article-marker) nil t) - (delete-region (point) (progn (forward-line 1) (point)))) - (when nnmail-cache-accepted-message-ids - (nnmail-cache-insert (nnmail-fetch-field "message-id"))) - (setq result (if (stringp group) - (list (cons group (nnfolder-active-number group))) - (setq art-group - (nnmail-article-group 'nnfolder-active-number)))) - (if (and (null result) - (yes-or-no-p "Moved to `junk' group; delete article? ")) - (setq result 'junk) - (setq result - (car (nnfolder-save-mail result))))) - (when last + (save-excursion + (nnfolder-possibly-change-group group server) + (nnmail-check-syntax) + (let ((buf (current-buffer)) + result art-group) + (goto-char (point-min)) + (when (looking-at "X-From-Line: ") + (replace-match "From ")) + (and + (nnfolder-request-list) (save-excursion - (nnfolder-possibly-change-folder (or (caar art-group) group)) - (nnfolder-save-buffer) + (set-buffer buf) + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (forward-line -1) + (while (re-search-backward (concat "^" nnfolder-article-marker) nil t) + (delete-region (point) (progn (forward-line 1) (point)))) (when nnmail-cache-accepted-message-ids - (nnmail-cache-close))))) - (nnmail-save-active nnfolder-group-alist nnfolder-active-file) - (unless result - (nnheader-report 'nnfolder "Couldn't store article")) - result)) + (nnmail-cache-insert (nnmail-fetch-field "message-id"))) + (setq result (if (stringp group) + (list (cons group (nnfolder-active-number group))) + (setq art-group + (nnmail-article-group 'nnfolder-active-number)))) + (if (and (null result) + (yes-or-no-p "Moved to `junk' group; delete article? ")) + (setq result 'junk) + (setq result + (car (nnfolder-save-mail result))))) + (when last + (save-excursion + (nnfolder-possibly-change-folder (or (caar art-group) group)) + (nnfolder-save-buffer) + (when nnmail-cache-accepted-message-ids + (nnmail-cache-close))))) + (nnmail-save-active nnfolder-group-alist nnfolder-active-file) + (unless result + (nnheader-report 'nnfolder "Couldn't store article")) + result))) (deffoo nnfolder-request-replace-article (article group buffer) (nnfolder-possibly-change-group group) (save-excursion + (set-buffer buffer) + (goto-char (point-min)) + (let (xfrom) + (while (re-search-forward "^X-From-Line: \\(.*\\)$" nil t) + (setq xfrom (match-string 1)) + (gnus-delete-line)) + (goto-char (point-min)) + (if xfrom + (insert "From " xfrom "\n") + (unless (looking-at message-unix-mail-delimiter) + (insert "From nobody " (current-time-string) "\n")))) + (nnfolder-normalize-buffer) (set-buffer nnfolder-current-buffer) (goto-char (point-min)) - (if (not (search-forward (nnfolder-article-string article) nil t)) + (if (not (nnfolder-goto-article article)) nil - (nnfolder-delete-mail t t) + (nnfolder-delete-mail) (insert-buffer-substring buffer) (nnfolder-save-buffer) t))) @@ -472,10 +473,9 @@ (goto-char (point-min)) (while (and (search-forward marker nil t) (re-search-forward number nil t)) - (setq activemin (min activemin - (string-to-number (buffer-substring - (match-beginning 0) - (match-end 0)))))) + (let ((newnum (string-to-number (match-string 0)))) + (if (nnmail-within-headers-p) + (setq activemin (min activemin newnum))))) (setcar active activemin)))) (defun nnfolder-article-string (article) @@ -483,21 +483,45 @@ (concat "\n" nnfolder-article-marker (int-to-string article) " ") (concat "\nMessage-ID: " article))) -(defun nnfolder-delete-mail (&optional force leave-delim) - "Delete the message that point is in." - (save-excursion - (delete-region - (save-excursion - (nnmail-search-unix-mail-delim-backward) - (if leave-delim (progn (forward-line 1) (point)) - (point))) - (progn - (forward-line 1) - (if (nnmail-search-unix-mail-delim) - (if (and (not (bobp)) leave-delim) - (progn (forward-line -2) (point)) - (point)) - (point-max)))))) +(defun nnfolder-goto-article (article) + "Place point at the start of the headers of ARTICLE. +ARTICLE can be an article number or a Message-ID. +Returns t if successful, nil otherwise." + (let ((art-string (nnfolder-article-string article)) + start found) + ;; It is likely that we are at or before the delimiter line. + ;; We therefore go to the end of the previous line, and start + ;; searching from there. + (beginning-of-line) + (unless (bobp) + (forward-char -1)) + (setq start (point)) + ;; First search forward. + (while (and (setq found (search-forward art-string nil t)) + (not (nnmail-within-headers-p)))) + ;; If unsuccessful, search backward from where we started, + (unless found + (goto-char start) + (while (and (setq found (search-backward art-string nil t)) + (not (nnmail-within-headers-p))))) + (when found + (nnmail-search-unix-mail-delim-backward)))) + +(defun nnfolder-delete-mail (&optional leave-delim) + "Delete the message that point is in. +If optional argument LEAVE-DELIM is t, then mailbox delimiter is not +deleted. Point is left where the deleted region was." + (delete-region + (save-excursion + (forward-line 1) ; in case point is at beginning of message already + (nnmail-search-unix-mail-delim-backward) + (if leave-delim (progn (forward-line 1) (point)) + (point))) + (progn + (forward-line 1) + (if (nnmail-search-unix-mail-delim) + (point) + (point-max))))) (defun nnfolder-possibly-change-group (group &optional server dont-check) ;; Change servers. @@ -541,7 +565,8 @@ (setq nnfolder-current-group group) (when (or (not nnfolder-current-buffer) - (not (verify-visited-file-modtime nnfolder-current-buffer))) + (not (verify-visited-file-modtime + nnfolder-current-buffer))) (save-excursion (setq file (nnfolder-group-pathname group)) ;; See whether we need to create the new file. @@ -564,8 +589,13 @@ (unless (looking-at message-unix-mail-delimiter) (insert "From nobody " (current-time-string) "\n") (goto-char (point-min))) + (forward-line 1) + ;; Quote subsequent "From " lines in the header. + (while (looking-at message-unix-mail-delimiter) + (delete-region (point) (+ (point) 4)) + (insert "X-From-Line:") + (forward-line 1)) ;; Quote all "From " lines in the article. - (forward-line 1) (let (case-fold-search) (while (re-search-forward "^From " nil t) (beginning-of-line) @@ -594,16 +624,19 @@ (obuf (current-buffer))) (nnfolder-possibly-change-folder (car group-art)) (let ((buffer-read-only nil)) - (goto-char (point-max)) - (unless (eolp) - (insert "\n")) - (unless (bobp) - (insert "\n")) + (nnfolder-normalize-buffer) (insert-buffer-substring obuf beg end))))) ;; Did we save it anywhere? save-list)) +(defun nnfolder-normalize-buffer () + "Make sure there are two newlines at the end of the buffer." + (goto-char (point-max)) + (skip-chars-backward "\n") + (delete-region (point) (point-max)) + (insert "\n\n")) + (defun nnfolder-insert-newsgroup-line (group-art) (save-excursion (goto-char (point-min)) @@ -657,7 +690,11 @@ (if (equal (cadr (assoc group nnfolder-scantime-alist)) (nth 5 (file-attributes file))) ;; This looks up-to-date, so we don't do any scanning. - buffer + (if (file-exists-p file) + buffer + (push (list group buffer) nnfolder-buffer-alist) + (set-buffer-modified-p t) + (save-buffer)) ;; Parse the damn thing. (save-excursion (nnmail-activate 'nnfolder) @@ -686,8 +723,9 @@ (while (and (search-forward marker nil t) (re-search-forward number nil t)) (let ((newnum (string-to-number (match-string 0)))) - (setq maxid (max maxid newnum)) - (setq minid (min minid newnum)))) + (if (nnmail-within-headers-p) + (setq maxid (max maxid newnum) + minid (min minid newnum))))) (setcar active (max 1 (min minid maxid))) (setcdr active (max maxid (cdr active))) (goto-char (point-min))) @@ -761,7 +799,7 @@ (nnfolder-possibly-change-folder file) (nnfolder-possibly-change-group file) (nnfolder-close-group file)))) - (message ""))) + (nnheader-message 5 ""))) (defun nnfolder-group-pathname (group) "Make pathname for GROUP."
--- a/lisp/gnus/nngateway.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/nngateway.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ ;;; nngateway.el --- posting news via mail gateways -;; Copyright (C) 1996,97 Free Software Foundation, Inc. +;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news, mail ;; This file is part of GNU Emacs. @@ -63,7 +63,8 @@ (insert mail-header-separator "\n") (widen) (let (message-required-mail-headers) - (funcall message-send-mail-function)))))) + (funcall message-send-mail-function)) + t)))) ;;; Internal functions @@ -76,6 +77,13 @@ (insert "To: " (nnheader-replace-chars-in-string newsgroups ?. ?-) "@" gateway "\n"))) +(defun nngateway-mail2news-header-transformation (gateway) + "Transform the headers for sending to a mail2news gateway." + (message-remove-header "to") + (message-remove-header "cc") + (goto-char (point-min)) + (insert "To: " gateway "\n")) + (nnoo-define-skeleton nngateway) (provide 'nngateway)
--- a/lisp/gnus/nnheader.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/nnheader.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,8 +1,8 @@ ;;; nnheader.el --- header access macros for Gnus and its backends -;; Copyright (C) 1987,88,89,90,93,94,95,96,97 Free Software Foundation, Inc. +;; Copyright (C) 1987,88,89,90,93,94,95,96,97,98 Free Software Foundation, Inc. ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> -;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news ;; This file is part of GNU Emacs. @@ -39,6 +39,8 @@ (eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl)) + (require 'mail-utils) (defvar nnheader-max-head-length 4096 @@ -59,7 +61,10 @@ (autoload 'mail-position-on-field "sendmail") (autoload 'message-remove-header "message") (autoload 'cancel-function-timers "timers") - (autoload 'gnus-point-at-eol "gnus-util")) + (autoload 'gnus-point-at-eol "gnus-util") + (autoload 'gnus-delete-line "gnus-util") + (autoload 'gnus-buffer-live-p "gnus-util") + (autoload 'gnus-encode-coding-string "gnus-ems")) ;;; Header access macros. @@ -166,7 +171,7 @@ (let ((case-fold-search t) (cur (current-buffer)) (buffer-read-only nil) - in-reply-to lines p) + in-reply-to lines p ref) (goto-char (point-min)) (when naked (insert "\n")) @@ -214,8 +219,9 @@ (goto-char p) (if (search-forward "\nmessage-id:" nil t) (buffer-substring - (1- (or (search-forward "<" nil t) (point))) - (or (search-forward ">" nil t) (point))) + (1- (or (search-forward "<" (gnus-point-at-eol) t) + (point))) + (or (search-forward ">" (gnus-point-at-eol) t) (point))) ;; If there was no message-id, we just fake one to make ;; subsequent routines simpler. (nnheader-generate-fake-message-id))) @@ -230,9 +236,16 @@ (if (and (search-forward "\nin-reply-to: " nil t) (setq in-reply-to (nnheader-header-value)) (string-match "<[^>]+>" in-reply-to)) - (substring in-reply-to (match-beginning 0) - (match-end 0)) - ""))) + (let (ref2) + (setq ref (substring in-reply-to (match-beginning 0) + (match-end 0))) + (while (string-match "<[^>]+>" in-reply-to (match-end 0)) + (setq ref2 (substring in-reply-to (match-beginning 0) + (match-end 0))) + (when (> (length ref2) (length ref)) + (setq ref ref2))) + ref) + nil))) ;; Chars. 0 ;; Lines. @@ -341,7 +354,10 @@ (eobp)) (setq found t) (setq prev (point)) - (cond ((> (setq num (read cur)) article) + (while (and (not (numberp (setq num (read cur)))) + (not (eobp))) + (gnus-delete-line)) + (cond ((> num article) (setq max (point))) ((< num article) (setq min (point))) @@ -386,7 +402,6 @@ (unless (gnus-buffer-live-p nntp-server-buffer) (setq nntp-server-buffer (get-buffer-create " *nntpd*"))) (set-buffer nntp-server-buffer) - (buffer-disable-undo (current-buffer)) (erase-buffer) (kill-all-local-variables) (setq case-fold-search t) ;Should ignore case. @@ -549,7 +564,7 @@ (defsubst nnheader-file-to-number (file) "Take a file name and return the article number." - (if (not (boundp 'jka-compr-compression-info-list)) + (if (string= nnheader-numerical-short-files "^[0-9]+$") (string-to-int file) (string-match nnheader-numerical-short-files file) (string-to-int (match-string 0 file)))) @@ -581,21 +596,27 @@ "Fold continuation lines in the current buffer." (nnheader-replace-regexp "\\(\r?\n[ \t]+\\)+" " ")) -(defun nnheader-translate-file-chars (file) +(defun nnheader-translate-file-chars (file &optional full) + "Translate FILE into something that can be a file name. +If FULL, translate everything." (if (null nnheader-file-name-translation-alist) ;; No translation is necessary. file - ;; We translate -- but only the file name. We leave the directory - ;; alone. (let* ((i 0) trans leaf path len) - (if (string-match "/[^/]+\\'" file) - ;; This is needed on NT's and stuff. - (setq leaf (substring file (1+ (match-beginning 0))) - path (substring file 0 (1+ (match-beginning 0)))) - ;; Fall back on this. - (setq leaf (file-name-nondirectory file) - path (file-name-directory file))) + (if full + ;; Do complete translation. + (setq leaf (copy-sequence file) + path "") + ;; We translate -- but only the file name. We leave the directory + ;; alone. + (if (string-match "/[^/]+\\'" file) + ;; This is needed on NT's and stuff. + (setq leaf (substring file (1+ (match-beginning 0))) + path (substring file 0 (1+ (match-beginning 0)))) + ;; Fall back on this. + (setq leaf (file-name-nondirectory file) + path (file-name-directory file)))) (setq len (length leaf)) (while (< i len) (when (setq trans (cdr (assq (aref leaf i) @@ -616,9 +637,9 @@ (defun nnheader-get-report (backend) "Get the most recent report from BACKEND." (condition-case () - (message "%s" (symbol-value (intern (format "%s-status-string" + (nnheader-message 5 "%s" (symbol-value (intern (format "%s-status-string" backend)))) - (error (message "")))) + (error (nnheader-message 5 "")))) (defun nnheader-insert (format &rest args) "Clear the communication buffer and insert FORMAT and ARGS into the buffer. @@ -669,6 +690,9 @@ (or (not (numberp gnus-verbose-backends)) (<= level gnus-verbose-backends))) +(defvar nnheader-pathname-coding-system 'iso-8859-1 + "*Coding system for pathname.") + ;; 1997/8/10 by MORIOKA Tomohiko (defvar nnheader-pathname-coding-system 'iso-8859-1 @@ -743,6 +767,9 @@ (when (string-match (car ange-ftp-path-format) path) (ange-ftp-re-read-dir path))))) +(defvar nnheader-file-coding-system 'raw-text + "Coding system used in file backends of Gnus.") + ;; 1997/5/4 by MORIOKA Tomohiko <morioka@jaist.ac.jp> (defvar nnheader-file-coding-system nil "Coding system used in file backends of Gnus.") @@ -756,8 +783,9 @@ (let ((format-alist nil) (auto-mode-alist (nnheader-auto-mode-alist)) (default-major-mode 'fundamental-mode) + (enable-local-variables nil) (after-insert-file-functions nil) - ;; 1997/5/4 by MORIOKA Tomohiko <morioka@jaist.ac.jp> + (find-file-hooks nil) (coding-system-for-read nnheader-file-coding-system)) (insert-file-contents filename visit beg end replace))) @@ -767,7 +795,7 @@ (default-major-mode 'fundamental-mode) (enable-local-variables nil) (after-insert-file-functions nil) - ;; 1997/5/16 by MORIOKA Tomohiko <morioka@jaist.ac.jp> + (find-file-hooks nil) (coding-system-for-read nnheader-file-coding-system)) (apply 'find-file-noselect args))) @@ -791,6 +819,16 @@ (pop files)) (nreverse out))) +(defun nnheader-directory-files (&rest args) + "Same as `directory-files', but prune \".\" and \"..\"." + (let ((files (apply 'directory-files args)) + out) + (while files + (unless (member (file-name-nondirectory (car files)) '("." "..")) + (push (car files) out)) + (pop files)) + (nreverse out))) + (defmacro nnheader-skeleton-replace (from &optional to regexp) `(let ((new (generate-new-buffer " *nnheader replace*")) (cur (current-buffer))
--- a/lisp/gnus/nnkiboze.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/nnkiboze.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ ;;; nnkiboze.el --- select virtual news access for Gnus -;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news ;; This file is part of GNU Emacs. @@ -115,6 +115,8 @@ (save-excursion (set-buffer nntp-server-buffer) (erase-buffer) + (unless (file-exists-p nov-file) + (nnkiboze-request-scan group)) (if (not (file-exists-p nov-file)) (nnheader-report 'nnkiboze "Can't select group %s" group) (nnheader-insert-file-contents nov-file) @@ -153,17 +155,17 @@ (deffoo nnkiboze-request-delete-group (group &optional force server) (nnkiboze-possibly-change-group group) (when force - (let ((files (list (nnkiboze-nov-file-name) - (concat nnkiboze-directory - (nnheader-translate-file-chars - (concat group ".newsrc"))) - (nnkiboze-score-file group)))) + (let ((files (nconc + (nnkiboze-score-file group) + (list (nnkiboze-nov-file-name) + (nnkiboze-nov-file-name ".newsrc"))))) (while files (and (file-exists-p (car files)) (file-writable-p (car files)) (delete-file (car files))) (setq files (cdr files))))) - (setq nnkiboze-current-group nil)) + (setq nnkiboze-current-group nil) + t) (nnoo-define-skeleton nnkiboze) @@ -178,7 +180,7 @@ ;;;###autoload (defun nnkiboze-generate-groups () - "Usage: emacs -batch -l nnkiboze -f nnkiboze-generate-groups + "\"Usage: emacs -batch -l nnkiboze -f nnkiboze-generate-groups\". Finds out what articles are to be part of the nnkiboze groups." (interactive) (let ((nnmail-spool-file nil) @@ -222,7 +224,7 @@ (gnus-verbose (min gnus-verbose 3)) gnus-select-group-hook gnus-summary-prepare-hook gnus-thread-sort-functions gnus-show-threads - gnus-visual gnus-suppress-duplicates) + gnus-visual gnus-suppress-duplicates num-unread) (unless info (error "No such group: %s" group)) ;; Load the kiboze newsrc file for this group. @@ -265,7 +267,9 @@ (gnus-group-jump-to-group (caar newsrc)) (gnus-message 3 "nnkiboze: Checking %s..." (caar newsrc)) (setq ginfo (gnus-get-info (gnus-group-group-name)) - orig-info (gnus-copy-sequence ginfo)) + orig-info (gnus-copy-sequence ginfo) + num-unread (car (gnus-gethash (caar newsrc) + gnus-newsrc-hashtb))) (unwind-protect (progn ;; We set all list of article marks to nil. Since we operate @@ -283,7 +287,8 @@ (car ginfo))) 0)) (progn - (gnus-group-select-group nil) + (ignore-errors + (gnus-group-select-group nil)) (eq major-mode 'gnus-summary-mode))) ;; We are now in the group where we want to be. (setq method (gnus-find-method-for-group @@ -302,10 +307,13 @@ gnus-newsgroup-name)) (setq gnus-newsgroup-scored (cdr gnus-newsgroup-scored))) ;; That's it. We exit this group. - (gnus-summary-exit-no-update))) + (when (eq major-mode 'gnus-summary-mode) + (kill-buffer (current-buffer))))) ;; Restore the proper info. (when ginfo - (setcdr ginfo (cdr orig-info))))) + (setcdr ginfo (cdr orig-info))) + (setcar (gnus-gethash (caar newsrc) gnus-newsrc-hashtb) + num-unread))) (setcdr (car newsrc) (car active)) (gnus-message 3 "nnkiboze: Checking %s...done" (caar newsrc)) (setq newsrc (cdr newsrc)))) @@ -313,17 +321,18 @@ (nnheader-temp-write newsrc-file (insert "(setq nnkiboze-newsrc '") (gnus-prin1 nnkiboze-newsrc) - (insert ")\n")) - t)) + (insert ")\n"))) + (save-excursion + (set-buffer gnus-group-buffer) + (gnus-group-list-groups)) + t) (defun nnkiboze-enter-nov (buffer header group) (save-excursion (set-buffer buffer) (goto-char (point-max)) - (let ((xref (mail-header-xref header)) - (prefix (gnus-group-real-prefix group)) + (let ((prefix (gnus-group-real-prefix group)) (oheader (copy-sequence header)) - (first t) article) (if (zerop (forward-line -1)) (progn @@ -339,16 +348,17 @@ ;; The first Xref has to be the group this article ;; really came for - this is the article nnkiboze ;; will request when it is asked for the article. - (insert group ":" + (insert " " group ":" (int-to-string (mail-header-number header)) " ") (while (re-search-forward " [^ ]+:[0-9]+" nil t) (goto-char (1+ (match-beginning 0))) (insert prefix))))) -(defun nnkiboze-nov-file-name () +(defun nnkiboze-nov-file-name (&optional suffix) (concat (file-name-as-directory nnkiboze-directory) (nnheader-translate-file-chars - (concat (nnkiboze-prefixed-name nnkiboze-current-group) ".nov")))) + (concat (nnkiboze-prefixed-name nnkiboze-current-group) + (or suffix ".nov"))))) (provide 'nnkiboze)
--- a/lisp/gnus/nnmail.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/nnmail.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ ;;; nnmail.el --- mail support functions for the Gnus mail backends -;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news, mail ;; This file is part of GNU Emacs. @@ -31,9 +31,12 @@ (require 'timezone) (require 'message) (require 'custom) +(require 'gnus-util) (eval-and-compile - (autoload 'gnus-error "gnus-util")) + (autoload 'gnus-error "gnus-util") + (autoload 'gnus-buffer-live-p "gnus-util") + (autoload 'gnus-encode-coding-string "gnus-ems")) (defgroup nnmail nil "Reading mail with Gnus." @@ -74,7 +77,7 @@ (defcustom nnmail-split-methods '(("mail.misc" "")) - "Incoming mail will be split according to this variable. + "*Incoming mail will be split according to this variable. If you'd like, for instance, one mail group for mail from the \"4ad-l\" mailing list, one group for junk mail and one for everything @@ -171,7 +174,7 @@ (defcustom nnmail-spool-file (or (getenv "MAIL") (concat "/usr/spool/mail/" (user-login-name))) - "Where the mail backends will look for incoming mail. + "*Where the mail backends will look for incoming mail. This variable is \"/usr/spool/mail/$user\" by default. If this variable is nil, no mail backends will read incoming mail. If this variable is a list, all files mentioned in this list will be @@ -179,7 +182,8 @@ If this variable is a directory (i. e., it's name ends with a \"/\"), treat all files in that directory as incoming spool files." :group 'nnmail-files - :type 'file) + :type '(choice (file :tag "File") + (repeat :tag "Files" file))) (defcustom nnmail-crash-box "~/.gnus-crash-box" "File where Gnus will store mail while processing it." @@ -216,10 +220,10 @@ :type 'function) (defcustom nnmail-crosspost-link-function - (if (string-match "windows-nt\\|emx" (format "%s" system-type)) + (if (string-match "windows-nt\\|emx" (symbol-name system-type)) 'copy-file 'add-name-to-file) - "Function called to create a copy of a file. + "*Function called to create a copy of a file. This is `add-name-to-file' by default, which means that crossposts will use hard links. If your file system doesn't allow hard links, you could set this variable to `copy-file' instead." @@ -248,7 +252,7 @@ (if (eq system-type 'windows-nt) '(nnheader-ms-strip-cr) nil) - "Hook that will be run after the incoming mail has been transferred. + "*Hook that will be run after the incoming mail has been transferred. The incoming mail is moved from `nnmail-spool-file' (which normally is something like \"/usr/spool/mail/$user\") to the user's home directory. This hook is called after the incoming mail box has been @@ -300,8 +304,8 @@ This can also be a list of regexps." :group 'nnmail-prepare :type '(choice (const :tag "none" nil) - regexp - (repeat regexp))) + (regexp :value ".*") + (repeat :value (".*") regexp))) (defcustom nnmail-pre-get-new-mail-hook nil "Hook called just before starting to handle new incoming mail." @@ -341,7 +345,7 @@ "Incoming mail can be split according to this fancy variable. To enable this, set `nnmail-split-methods' to `nnmail-split-fancy'. -The format is this variable is SPLIT, where SPLIT can be one of +The format of this variable is SPLIT, where SPLIT can be one of the following: GROUP: Mail will be stored in GROUP (a string). @@ -401,7 +405,7 @@ (from . "from\\|sender\\|resent-from") (nato . "to\\|cc\\|resent-to\\|resent-cc") (naany . "from\\|to\\|cc\\|sender\\|resent-from\\|resent-to\\|resent-cc")) - "Alist of abbreviations allowed in `nnmail-split-fancy'." + "*Alist of abbreviations allowed in `nnmail-split-fancy'." :group 'nnmail-split :type '(repeat (cons :format "%v" symbol regexp))) @@ -445,6 +449,8 @@ (defvar nnmail-split-history nil "List of group/article elements that say where the previous split put messages.") +(defvar nnmail-current-spool nil) + (defvar nnmail-pop-password nil "*Password to use when reading mail from a POP server, if required.") @@ -464,6 +470,9 @@ (defvar nnmail-internal-password nil) +(defvar nnmail-split-tracing nil) +(defvar nnmail-split-trace nil) + (defconst nnmail-version "nnmail 1.0" @@ -474,7 +483,9 @@ (defun nnmail-request-post (&optional server) (mail-send-and-exit nil)) -;; 1997/5/4 by MORIOKA Tomohiko <morioka@jaist.ac.jp> +(defvar nnmail-file-coding-system 'raw-text + "Coding system used in nnmail.") + (defvar nnmail-file-coding-system nil "Coding system used in nnmail.") @@ -485,16 +496,13 @@ (let ((format-alist nil) (after-insert-file-functions nil)) (condition-case () - ;; 1997/5/4 by MORIOKA Tomohiko <morioka@jaist.ac.jp> (let ((coding-system-for-read nnmail-file-coding-system) - ;; 1997/8/12 by MORIOKA Tomohiko - (file-name-coding-system 'binary) ; for Emacs 20 - (pathname-coding-system 'binary)) ; for XEmacs/mule + (file-name-coding-system 'binary) + (pathname-coding-system 'binary)) (insert-file-contents file) t) (file-error nil)))) -;; 1997/8/10 by MORIOKA Tomohiko (defvar nnmail-pathname-coding-system 'iso-8859-1 "*Coding system for pathname.") @@ -503,6 +511,7 @@ "Make pathname for GROUP." (concat (let ((dir (file-name-as-directory (expand-file-name dir)))) + (setq group (nnheader-translate-file-chars group)) ;; If this directory exists, we use it directly. (if (or nnmail-use-long-file-names (file-directory-p (concat dir group))) @@ -527,7 +536,8 @@ (aref t1 2) (aref t1 1) (aref t1 0) (aref d1 2) (aref d1 1) (aref d1 0) (number-to-string - (* 60 (timezone-zone-to-minute (aref d1 4)))))))) + (* 60 (timezone-zone-to-minute + (or (aref d1 4) (current-time-zone))))))))) ;; If we get an error, then we just return a 0 time. (error (list 0 0)))) @@ -541,7 +551,7 @@ "Convert DAYS into time." (let* ((seconds (* 1.0 days 60 60 24)) (rest (expt 2 16)) - (ms (condition-case nil (round (/ seconds rest)) + (ms (condition-case nil (floor (/ seconds rest)) (range-error (expt 2 16))))) (list ms (condition-case nil (round (- seconds (* ms rest))) (range-error (expt 2 16)))))) @@ -591,12 +601,12 @@ (nnmail-read-passwd (format "Password for %s: " (substring inbox (+ popmail 3)))))) - (message "Getting mail from the post office...")) + (nnheader-message 5 "Getting mail from the post office...")) (when (or (and (file-exists-p tofile) (/= 0 (nnheader-file-size tofile))) (and (file-exists-p inbox) (/= 0 (nnheader-file-size inbox)))) - (message "Getting mail from %s..." inbox))) + (nnheader-message 5 "Getting mail from %s..." inbox))) ;; Set TOFILE if have not already done so, and ;; rename or copy the file INBOX to TOFILE if and as appropriate. (cond @@ -615,17 +625,17 @@ (save-excursion (setq errors (generate-new-buffer " *nnmail loss*")) (buffer-disable-undo errors) - (let ((default-directory "/")) - (if (nnheader-functionp nnmail-movemail-program) - (condition-case err - (progn - (funcall nnmail-movemail-program inbox tofile) - (setq result 0)) - (error - (save-excursion - (set-buffer errors) - (insert (prin1-to-string err)) - (setq result 255)))) + (if (nnheader-functionp nnmail-movemail-program) + (condition-case err + (progn + (funcall nnmail-movemail-program inbox tofile) + (setq result 0)) + (error + (save-excursion + (set-buffer errors) + (insert (prin1-to-string err)) + (setq result 255)))) + (let ((default-directory "/")) (setq result (apply 'call-process @@ -636,14 +646,14 @@ nil errors nil inbox tofile) (when nnmail-internal-password (list nnmail-internal-password))))))) + (push inbox nnmail-moved-inboxes) (if (and (not (buffer-modified-p errors)) (zerop result)) ;; No output => movemail won (progn (unless popmail (when (file-exists-p tofile) - (set-file-modes tofile nnmail-default-file-modes))) - (push inbox nnmail-moved-inboxes)) + (set-file-modes tofile nnmail-default-file-modes)))) (set-buffer errors) ;; There may be a warning about older revisions. We ;; ignore those. @@ -652,9 +662,12 @@ (progn (unless popmail (when (file-exists-p tofile) - (set-file-modes tofile nnmail-default-file-modes))) - (push inbox nnmail-moved-inboxes)) + (set-file-modes + tofile nnmail-default-file-modes)))) ;; Probably a real error. + ;; We nix out the password in case the error + ;; was because of a wrong password being given. + (setq nnmail-internal-password nil) (subst-char-in-region (point-min) (point-max) ?\n ?\ ) (goto-char (point-max)) (skip-chars-backward " \t") @@ -667,7 +680,7 @@ (buffer-string) result)) (error "%s" (buffer-string))) (setq tofile nil))))))) - (message "Getting mail from %s...done" inbox) + (nnheader-message 5 "Getting mail from %s...done" inbox) (and errors (buffer-name errors) (kill-buffer errors)) @@ -690,9 +703,7 @@ group-assoc))) group-assoc)) -;; 1997/8/12 by MORIOKA Tomohiko -(defvar nnmail-active-file-coding-system - 'iso-8859-1 +(defvar nnmail-active-file-coding-system 'binary "*Coding system for active file.") (defun nnmail-save-active (group-assoc file-name) @@ -718,10 +729,12 @@ is a spool. If not using procmail, return GROUP." (if (or (eq nnmail-spool-file 'procmail) nnmail-use-procmail) - (if (string-match (concat "^" (expand-file-name - (file-name-as-directory - nnmail-procmail-directory)) - "\\([^/]*\\)" nnmail-procmail-suffix "$") + (if (string-match (concat "^" (regexp-quote + (expand-file-name + (file-name-as-directory + nnmail-procmail-directory))) + "\\([^/]*\\)" + nnmail-procmail-suffix "$") (expand-file-name file)) (let ((procmail-group (substring (expand-file-name file) (match-beginning 1) @@ -737,8 +750,8 @@ (defun nnmail-process-babyl-mail-format (func artnum-func) (let ((case-fold-search t) start message-id content-length do-search end) - (goto-char (point-min)) (while (not (eobp)) + (goto-char (point-min)) (re-search-forward " \n0, *unseen,+\n\\(\\*\\*\\* EOOH \\*\\*\\*\n\\)?" nil t) (goto-char (match-end 0)) @@ -875,7 +888,9 @@ (if (not (and (re-search-forward "^From " nil t) (goto-char (match-beginning 0)))) ;; Possibly wrong format? - (error "Error, unknown mail format! (Possibly corrupted.)") + (progn + (pop-to-buffer (nnheader-find-file-noselect nnmail-current-spool)) + (error "Error, unknown mail format! (Possibly corrupted.)")) ;; Carry on until the bitter end. (while (not (eobp)) (setq start (point) @@ -960,7 +975,9 @@ (if (not (and (re-search-forward delim nil t) (forward-line 1))) ;; Possibly wrong format? - (error "Error, unknown mail format! (Possibly corrupted.)") + (progn + (pop-to-buffer (nnheader-find-file-noselect nnmail-current-spool)) + (error "Error, unknown mail format! (Possibly corrupted.)")) ;; Carry on until the bitter end. (while (not (eobp)) (setq start (point)) @@ -1038,15 +1055,15 @@ (funcall exit-func)) (kill-buffer (current-buffer))))) -;; Mail crossposts suggested by Brian Edmonds <edmonds@cs.ubc.ca>. -(defun nnmail-article-group (func) +(defun nnmail-article-group (func &optional trace) "Look at the headers and return an alist of groups that match. FUNC will be called with the group name to determine the article number." (let ((methods nnmail-split-methods) (obuf (current-buffer)) (beg (point-min)) - end group-art method) - (if (and (sequencep methods) (= (length methods) 1)) + end group-art method regrepp) + (if (and (sequencep methods) + (= (length methods) 1)) ;; If there is only just one group to put everything in, we ;; just return a list with just this one method in. (setq group-art @@ -1064,8 +1081,21 @@ (goto-char (point-min)) (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t) (replace-match " " t t)) + ;; Nuke pathologically long headers. Since Gnus applies + ;; pathologically complex regexps to the buffer, lines + ;; that are looong will take longer than the Universe's + ;; existence to process. + (goto-char (point-min)) + (while (not (eobp)) + (end-of-line) + (if (> (current-column) 1024) + (gnus-delete-line) + (forward-line 1))) ;; Allow washing. + (goto-char (point-min)) (run-hooks 'nnmail-split-hook) + (when (setq nnmail-split-tracing trace) + (setq nnmail-split-trace nil)) (if (and (symbolp nnmail-split-methods) (fboundp nnmail-split-methods)) (let ((split @@ -1076,10 +1106,11 @@ (or (funcall nnmail-split-methods) '("bogus")) (error - (message + (nnheader-message 5 "Error in `nnmail-split-methods'; using `bogus' mail group") (sit-for 1) '("bogus"))))) + (setq split (gnus-remove-duplicates split)) ;; The article may be "cross-posted" to `junk'. What ;; to do? Just remove the `junk' spec. Don't really ;; see anything else to do... @@ -1092,21 +1123,30 @@ (lambda (group) (cons group (funcall func group))) split)))) ;; Go through the split methods to find a match. - (while (and methods (or nnmail-crosspost (not group-art))) + (while (and methods + (or nnmail-crosspost + (not group-art))) (goto-char (point-max)) - (setq method (pop methods)) + (setq method (pop methods) + regrepp nil) (if (or methods (not (equal "" (nth 1 method)))) (when (and (ignore-errors (if (stringp (nth 1 method)) - (re-search-backward (cadr method) nil t) + (progn + (setq regrepp + (string-match "\\\\[0-9&]" (car method))) + (re-search-backward (cadr method) nil t)) ;; Function to say whether this is a match. (funcall (nth 1 method) (car method)))) ;; Don't enter the article into the same ;; group twice. (not (assoc (car method) group-art))) - (push (cons (car method) (funcall func (car method))) + (push (cons (if regrepp + (nnmail-expand-newtext (car method)) + (car method)) + (funcall func (car method))) group-art)) ;; This is the final group, which is used as a ;; catch-all. @@ -1114,6 +1154,18 @@ (setq group-art (list (cons (car method) (funcall func (car method))))))))) + ;; Produce a trace if non-empty. + (when (and trace nnmail-split-trace) + (let ((trace (nreverse nnmail-split-trace)) + (restore (current-buffer))) + (nnheader-set-temp-buffer "*Split Trace*") + (gnus-add-buffer) + (while trace + (insert (car trace) "\n") + (setq trace (cdr trace))) + (goto-char (point-min)) + (gnus-configure-windows 'split-trace) + (set-buffer restore))) ;; See whether the split methods returned `junk'. (if (equal group-art '(junk)) nil @@ -1154,8 +1206,9 @@ (insert (format "Xref: %s" (system-name))) (while group-alist (insert (format " %s:%d" - (gnus-encode-coding-string (caar group-alist) - nnmail-pathname-coding-system) + (gnus-encode-coding-string + (caar group-alist) + nnmail-pathname-coding-system) (cdar group-alist))) (setq group-alist (cdr group-alist))) (insert "\n")))) @@ -1185,7 +1238,6 @@ ;;; Utility functions -;; Written by byer@mv.us.adobe.com (Scott Byer). (defun nnmail-make-complex-temp-name (prefix) (let ((newname (make-temp-name prefix)) (newprefix prefix)) @@ -1211,81 +1263,87 @@ (defun nnmail-split-it (split) ;; Return a list of groups matching SPLIT. - (cond - ;; nil split - ((null split) - nil) + (let (cached-pair) + (cond + ;; nil split + ((null split) + nil) - ;; A group name. Do the \& and \N subs into the string. - ((stringp split) - (list (nnmail-expand-newtext split))) - - ;; Junk the message. - ((eq split 'junk) - (list 'junk)) + ;; A group name. Do the \& and \N subs into the string. + ((stringp split) + (when nnmail-split-tracing + (push (format "\"%s\"" split) nnmail-split-trace)) + (list (nnmail-expand-newtext split))) - ;; Builtin & operation. - ((eq (car split) '&) - (apply 'nconc (mapcar 'nnmail-split-it (cdr split)))) + ;; Junk the message. + ((eq split 'junk) + (when nnmail-split-tracing + (push "junk" nnmail-split-trace)) + (list 'junk)) + + ;; Builtin & operation. + ((eq (car split) '&) + (apply 'nconc (mapcar 'nnmail-split-it (cdr split)))) - ;; Builtin | operation. - ((eq (car split) '|) - (let (done) - (while (and (not done) (cdr split)) - (setq split (cdr split) - done (nnmail-split-it (car split)))) - done)) + ;; Builtin | operation. + ((eq (car split) '|) + (let (done) + (while (and (not done) (cdr split)) + (setq split (cdr split) + done (nnmail-split-it (car split)))) + done)) - ;; Builtin : operation. - ((eq (car split) ':) - (nnmail-split-it (eval (cdr split)))) + ;; Builtin : operation. + ((eq (car split) ':) + (nnmail-split-it (save-excursion (eval (cdr split))))) - ;; Check the cache for the regexp for this split. - ;; FIX FIX FIX could avoid calling assq twice here - ((assq split nnmail-split-cache) - (goto-char (point-max)) - ;; FIX FIX FIX problem with re-search-backward is that if you have - ;; a split: (from "foo-\\(bar\\|baz\\)@gnus.org "mail.foo.\\1") - ;; and someone mails a message with 'To: foo-bar@gnus.org' and - ;; 'CC: foo-baz@gnus.org', we'll pick 'mail.foo.baz' as the group - ;; if the cc line is a later header, even though the other choice - ;; is probably better. Also, this routine won't do a crosspost - ;; when there are two different matches. - ;; I guess you could just make this more determined, and it could - ;; look for still more matches prior to this one, and recurse - ;; on each of the multiple matches hit. Of course, then you'd - ;; want to make sure that nnmail-article-group or nnmail-split-fancy - ;; removed duplicates, since there might be more of those. - ;; I guess we could also remove duplicates in the & split case, since - ;; that's the only thing that can introduce them. - (when (re-search-backward (cdr (assq split nnmail-split-cache)) nil t) - ;; Someone might want to do a \N sub on this match, so get the - ;; correct match positions. - (goto-char (match-end 0)) - (let ((value (nth 1 split))) - (re-search-backward (if (symbolp value) - (cdr (assq value nnmail-split-abbrev-alist)) - value) - (match-end 1))) - (nnmail-split-it (nth 2 split)))) + ;; Check the cache for the regexp for this split. + ((setq cached-pair (assq split nnmail-split-cache)) + (goto-char (point-max)) + ;; FIX FIX FIX problem with re-search-backward is that if you have + ;; a split: (from "foo-\\(bar\\|baz\\)@gnus.org "mail.foo.\\1") + ;; and someone mails a message with 'To: foo-bar@gnus.org' and + ;; 'CC: foo-baz@gnus.org', we'll pick 'mail.foo.baz' as the group + ;; if the cc line is a later header, even though the other choice + ;; is probably better. Also, this routine won't do a crosspost + ;; when there are two different matches. + ;; I guess you could just make this more determined, and it could + ;; look for still more matches prior to this one, and recurse + ;; on each of the multiple matches hit. Of course, then you'd + ;; want to make sure that nnmail-article-group or nnmail-split-fancy + ;; removed duplicates, since there might be more of those. + ;; I guess we could also remove duplicates in the & split case, since + ;; that's the only thing that can introduce them. + (when (re-search-backward (cdr cached-pair) nil t) + (when nnmail-split-tracing + (push (cdr cached-pair) nnmail-split-trace)) + ;; Someone might want to do a \N sub on this match, so get the + ;; correct match positions. + (goto-char (match-end 0)) + (let ((value (nth 1 split))) + (re-search-backward (if (symbolp value) + (cdr (assq value nnmail-split-abbrev-alist)) + value) + (match-end 1))) + (nnmail-split-it (nth 2 split)))) - ;; Not in cache, compute a regexp for the field/value pair. - (t - (let* ((field (nth 0 split)) - (value (nth 1 split)) - (regexp (concat "^\\(\\(" - (if (symbolp field) - (cdr (assq field nnmail-split-abbrev-alist)) - field) - "\\):.*\\)\\<\\(" - (if (symbolp value) - (cdr (assq value nnmail-split-abbrev-alist)) - value) - "\\)\\>"))) - (push (cons split regexp) nnmail-split-cache) - ;; Now that it's in the cache, just call nnmail-split-it again - ;; on the same split, which will find it immediately in the cache. - (nnmail-split-it split))))) + ;; Not in cache, compute a regexp for the field/value pair. + (t + (let* ((field (nth 0 split)) + (value (nth 1 split)) + (regexp (concat "^\\(\\(" + (if (symbolp field) + (cdr (assq field nnmail-split-abbrev-alist)) + field) + "\\):.*\\)\\<\\(" + (if (symbolp value) + (cdr (assq value nnmail-split-abbrev-alist)) + value) + "\\)\\>"))) + (push (cons split regexp) nnmail-split-cache) + ;; Now that it's in the cache, just call nnmail-split-it again + ;; on the same split, which will find it immediately in the cache. + (nnmail-split-it split)))))) (defun nnmail-expand-newtext (newtext) (let ((len (length newtext)) @@ -1299,14 +1357,14 @@ (unless (= beg pos) (push (substring newtext beg pos) expanded)) (when (< pos len) - ;; we hit a \, expand it. - (setq did-expand t) - (setq pos (1+ pos)) - (setq c (aref newtext pos)) + ;; We hit a \; expand it. + (setq did-expand t + pos (1+ pos) + c (aref newtext pos)) (if (not (or (= c ?\&) (and (>= c ?1) (<= c ?9)))) - ;; \ followed by some character we don't expand + ;; \ followed by some character we don't expand. (push (char-to-string c) expanded) ;; \& or \N (if (= c ?\&) @@ -1333,7 +1391,7 @@ nnmail-use-procmail) (directory-files nnmail-procmail-directory - t (concat (if group (concat "^" group) "") + t (concat (if group (concat "^" (regexp-quote group)) "") nnmail-procmail-suffix "$")))) (p procmails) (crash (when (and (file-exists-p nnmail-crash-box) @@ -1386,6 +1444,7 @@ ;; If FORCE, re-read the active file even if the backend is ;; already activated. (defun nnmail-activate (backend &optional force) + (nnheader-init-server-buffer) (let (file timestamp file-time) (if (or (not (symbol-value (intern (format "%s-group-alist" backend)))) force @@ -1531,12 +1590,9 @@ (defun nnmail-get-new-mail (method exit-func temp &optional group spool-func) "Read new incoming mail." - ;; Nix out the previous split history. - (unless group - (setq nnmail-split-history nil)) (let* ((spools (nnmail-get-spool-files group)) (group-in group) - incoming incomings spool) + nnmail-current-spool incoming incomings spool) (when (and (nnmail-get-value "%s-get-new-mail" method) nnmail-spool-file) ;; We first activate all the groups. @@ -1558,6 +1614,7 @@ (nnheader-message 3 "%s: Reading incoming mail..." method) (when (and (nnmail-move-inbox spool) (file-exists-p nnmail-crash-box)) + (setq nnmail-current-spool spool) ;; There is new mail. We first find out if all this mail ;; is supposed to go to some specific group. (setq group (nnmail-get-split-group spool group-in)) @@ -1575,6 +1632,8 @@ (file-name-nondirectory (concat (file-name-as-directory temp) "Incoming"))) (concat (file-name-as-directory temp) "Incoming"))))) + (unless (file-exists-p (file-name-directory incoming)) + (make-directory (file-name-directory incoming) t)) (rename-file nnmail-crash-box incoming t) (push incoming incomings)))) ;; If we did indeed read any incoming spools, we save all info. @@ -1647,11 +1706,8 @@ (defun nnmail-write-region (start end filename &optional append visit lockname) "Do a `write-region', and then set the file modes." - ;; 1997/5/4 by MORIOKA Tomohiko <morioka@jaist.ac.jp> (let ((coding-system-for-write nnmail-file-coding-system) - ;; 1997/8/12 by MORIOKA Tomohiko - (file-name-coding-system 'binary) ; for Emacs 20 - (pathname-coding-system 'binary)) ; for XEmacs/mule + (pathname-coding-system 'binary)) (write-region start end filename append visit lockname) (set-file-modes filename nnmail-default-file-modes))) @@ -1729,6 +1785,15 @@ ", ")) (princ "\n"))))) +(defun nnmail-purge-split-history (group) + "Remove all instances of GROUP from `nnmail-split-history'." + (let ((history nnmail-split-history)) + (while history + (setcar history (gnus-delete-if (lambda (e) (string= (car e) group)) + (car history))) + (pop history)) + (setq nnmail-split-history (delq nil nnmail-split-history)))) + (defun nnmail-new-mail-p (group) "Say whether GROUP has new mail." (let ((his nnmail-split-history) @@ -1748,6 +1813,14 @@ (substring inbox (match-end (string-match "^po:" inbox))))) (pop3-movemail crashbox))) +(defun nnmail-within-headers-p () + "Check to see if point is within the headers of a unix mail message. +Doesn't change point." + (let ((pos (point))) + (save-excursion + (and (nnmail-search-unix-mail-delim-backward) + (not (search-forward "\n\n" pos t)))))) + (run-hooks 'nnmail-load-hook) (provide 'nnmail)
--- a/lisp/gnus/nnmbox.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/nnmbox.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ ;;; nnmbox.el --- mail mbox access for Gnus -;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> ;; Keywords: news, mail @@ -12,11 +12,6 @@ ;; 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, @@ -207,6 +202,14 @@ (deffoo nnmbox-close-group (group &optional server) t) +(deffoo nnmbox-request-create-group (group &optional server args) + (nnmail-activate 'nnmbox) + (unless (assoc group nnmbox-group-alist) + (push (list group (cons 1 0)) + nnmbox-group-alist) + (nnmail-save-active nnmbox-group-alist nnmbox-active-file)) + t) + (deffoo nnmbox-request-list (&optional server) (save-excursion (nnmail-find-file nnmbox-active-file)
--- a/lisp/gnus/nnmh.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/nnmh.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ ;;; nnmh.el --- mhspool access for Gnus -;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> ;; Keywords: news, mail @@ -60,6 +60,7 @@ (defvoo nnmh-status-string "") (defvoo nnmh-group-alist nil) +(defvoo nnmh-allow-delete-final nil) @@ -76,9 +77,8 @@ (large (and (numberp nnmail-large-newsgroup) (> number nnmail-large-newsgroup))) (count 0) - ;; 1997/8/12 by MORIOKA Tomohiko - (file-name-coding-system 'binary) ; for Emacs 20 - (pathname-coding-system 'binary) ; for XEmacs/mule + (file-name-coding-system 'binary) + (pathname-coding-system 'binary) beg article) (nnmh-possibly-change-directory newsgroup server) ;; We don't support fetching by Message-ID. @@ -105,11 +105,11 @@ (and large (zerop (% count 20)) - (message "nnmh: Receiving headers... %d%%" + (nnheader-message 5 "nnmh: Receiving headers... %d%%" (/ (* count 100) number)))) (when large - (message "nnmh: Receiving headers...done")) + (nnheader-message 5 "nnmh: Receiving headers...done")) (nnheader-fold-continuation-lines) 'headers)))) @@ -137,9 +137,8 @@ (let ((file (if (stringp id) nil (concat nnmh-current-directory (int-to-string id)))) - ;; 1997/8/12 by MORIOKA Tomohiko - (file-name-coding-system 'binary) ; for Emacs 20 - (pathname-coding-system 'binary) ; for XEmacs/mule + (pathname-coding-system 'binary) + (file-name-coding-system 'binary) (nntp-server-buffer (or buffer nntp-server-buffer))) (and (stringp file) (file-exists-p file) @@ -148,10 +147,11 @@ (string-to-int (file-name-nondirectory file))))) (deffoo nnmh-request-group (group &optional server dont-check) + (nnheader-init-server-buffer) + (nnmh-possibly-change-directory group server) (let ((pathname (nnmail-group-pathname group nnmh-directory)) - ;; 1997/8/12 by MORIOKA Tomohiko - (file-name-coding-system 'binary) ; for Emacs 20 - (pathname-coding-system 'binary) ; for XEmacs/mule. + (pathname-coding-system 'binary) + (file-name-coding-system 'binary) dir) (cond ((not (file-directory-p pathname)) @@ -190,10 +190,11 @@ (deffoo nnmh-request-list (&optional server dir) (nnheader-insert "") - (let ((file-name-coding-system 'binary) - (pathname-coding-system 'binary) - (nnmh-toplev - (file-truename (or dir (file-name-as-directory nnmh-directory))))) + (nnmh-possibly-change-directory nil server) + (let* ((pathname-coding-system 'binary) + (file-name-coding-system 'binary) + (nnmh-toplev + (file-truename (or dir (file-name-as-directory nnmh-directory))))) (nnmh-request-list-1 nnmh-toplev)) (setq nnmh-group-alist (nnmail-get-active)) t) @@ -204,14 +205,15 @@ ;; Recurse down all directories. (let ((dirs (and (file-readable-p dir) (> (nth 1 (file-attributes (file-chase-links dir))) 2) - (directory-files dir t nil t))) - dir) + (nnheader-directory-files dir t nil t))) + rdir) ;; Recurse down directories. - (while (setq dir (pop dirs)) - (when (and (not (member (file-name-nondirectory dir) '("." ".."))) - (file-directory-p dir) - (file-readable-p dir)) - (nnmh-request-list-1 dir)))) + (while (setq rdir (pop dirs)) + (when (and (file-directory-p rdir) + (file-readable-p rdir) + (not (equal (file-truename rdir) + (file-truename dir)))) + (nnmh-request-list-1 rdir)))) ;; For each directory, generate an active file line. (unless (string= (expand-file-name nnmh-toplev) dir) (let ((files (mapcar @@ -231,8 +233,8 @@ (expand-file-name nnmh-toplev)))) dir) (nnheader-replace-chars-in-string - (decode-coding-string (substring dir (match-end 0)) - nnmail-pathname-coding-system) + (gnus-decode-coding-string (substring dir (match-end 0)) + nnmail-pathname-coding-system) ?/ ?.)) (apply 'max files) (apply 'min files))))))) @@ -244,15 +246,9 @@ (deffoo nnmh-request-expire-articles (articles newsgroup &optional server force) (nnmh-possibly-change-directory newsgroup server) - (let* ((active-articles - (mapcar - (function - (lambda (name) - (string-to-int name))) - (directory-files nnmh-current-directory nil "^[0-9]+$" t))) - (is-old t) + (let* ((is-old t) article rest mod-time) - (nnmail-activate 'nnmh) + (nnheader-init-server-buffer) (while (and articles is-old) (setq article (concat nnmh-current-directory @@ -272,7 +268,7 @@ (push (car articles) rest)))) (push (car articles) rest))) (setq articles (cdr articles))) - (message "") + (nnheader-message 5 "") (nconc rest articles))) (deffoo nnmh-close-group (group &optional server) @@ -305,20 +301,19 @@ (nnmail-check-syntax) (when nnmail-cache-accepted-message-ids (nnmail-cache-insert (nnmail-fetch-field "message-id"))) + (nnheader-init-server-buffer) (prog1 (if (stringp group) - (and - (nnmail-activate 'nnmh) - (car (nnmh-save-mail - (list (cons group (nnmh-active-number group))) - noinsert))) - (and - (nnmail-activate 'nnmh) - (let ((res (nnmail-article-group 'nnmh-active-number))) - (if (and (null res) - (yes-or-no-p "Moved to `junk' group; delete article? ")) - 'junk - (car (nnmh-save-mail res noinsert)))))) + (if noinsert + (nnmh-active-number group) + (car (nnmh-save-mail + (list (cons group (nnmh-active-number group))) + noinsert))) + (let ((res (nnmail-article-group 'nnmh-active-number))) + (if (and (null res) + (yes-or-no-p "Moved to `junk' group; delete article? ")) + 'junk + (car (nnmh-save-mail res noinsert))))) (when (and last nnmail-cache-accepted-message-ids) (nnmail-cache-close)))) @@ -335,7 +330,7 @@ t))) (deffoo nnmh-request-create-group (group &optional server args) - (nnmail-activate 'nnmh) + (nnheader-init-server-buffer) (unless (assoc group nnmh-group-alist) (let (active) (push (list group (setq active (cons 1 0))) @@ -410,9 +405,8 @@ (nnmh-open-server server)) (when newsgroup (let ((pathname (nnmail-group-pathname newsgroup nnmh-directory)) - ;; 1997/8/12 by MORIOKA Tomohiko - (file-name-coding-system 'binary) ; for Emacs 20 - (pathname-coding-system 'binary)) ; for XEmacs/mule + (file-name-coding-system 'binary) + (pathname-coding-system 'binary)) (if (file-directory-p pathname) (setq nnmh-current-directory pathname) (error "No such newsgroup: %s" newsgroup))))) @@ -461,16 +455,15 @@ "Compute the next article number in GROUP." (let ((active (cadr (assoc group nnmh-group-alist))) (dir (nnmail-group-pathname group nnmh-directory)) - ;; 1997/8/14 by MORIOKA Tomohiko - (file-name-coding-system 'binary) ; for Emacs 20 - (pathname-coding-system 'binary)) ; for XEmacs/mule + (file-name-coding-system 'binary) + (pathname-coding-system 'binary)) (unless active ;; The group wasn't known to nnmh, so we just create an active ;; entry for it. (setq active (cons 1 0)) (push (list group active) nnmh-group-alist) (unless (file-exists-p dir) - (make-directory dir)) + (gnus-make-directory dir)) ;; Find the highest number in the group. (let ((files (sort (mapcar @@ -557,9 +550,12 @@ (let ((path (concat nnmh-current-directory (int-to-string article)))) ;; Writable. (and (file-writable-p path) - ;; We can never delete the last article in the group. - (not (eq (cdr (nth 1 (assoc group nnmh-group-alist))) - article))))) + (or + ;; We can never delete the last article in the group. + (not (eq (cdr (nth 1 (assoc group nnmh-group-alist))) + article)) + ;; Well, we can. + nnmh-allow-delete-final)))) (provide 'nnmh)
--- a/lisp/gnus/nnml.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/nnml.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ ;;; nnml.el --- mail spool access for Gnus -;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> ;; Keywords: news, mail @@ -84,6 +84,8 @@ (defvoo nnml-generate-active-function 'nnml-generate-active-info) +(defvar nnml-nov-buffer-file-name nil) + ;;; Interface functions. @@ -98,9 +100,8 @@ (let ((file nil) (number (length sequence)) (count 0) - ;; 1997/8/12 by MORIOKA Tomohiko - (file-name-coding-system 'binary) ; for Emacs 20 - (pathname-coding-system 'binary) ; for XEmacs/mule + (file-name-coding-system 'binary) + (pathname-coding-system 'binary) beg article) (if (stringp (car sequence)) 'headers @@ -163,9 +164,8 @@ (deffoo nnml-request-article (id &optional group server buffer) (nnml-possibly-change-directory group server) (let* ((nntp-server-buffer (or buffer nntp-server-buffer)) - ;; 1997/8/12 by MORIOKA Tomohiko - (file-name-coding-system 'binary) ; for Emacs 20 - (pathname-coding-system 'binary) ; for XEmacs/mule + (file-name-coding-system 'binary) + (pathname-coding-system 'binary) path gpath group-num) (if (stringp id) (when (and (setq group-num (nnml-find-group-number id)) @@ -194,9 +194,8 @@ (string-to-int (file-name-nondirectory path))))))) (deffoo nnml-request-group (group &optional server dont-check) - ;; 1997/8/12 by MORIOKA Tomohiko - (let ((file-name-coding-system 'binary) ; for Emacs 20 - (pathname-coding-system 'binary)) ; for XEmacs/mule + (let ((pathname-coding-system 'binary) + (file-name-coding-system 'binary)) (cond ((not (nnml-possibly-change-directory group server)) (nnheader-report 'nnml "Invalid group (no such directory)")) @@ -230,7 +229,14 @@ (deffoo nnml-request-create-group (group &optional server args) (nnmail-activate 'nnml) - (unless (assoc group nnml-group-alist) + (cond + ((assoc group nnml-group-alist) + t) + ((and (file-exists-p (nnmail-group-pathname group nnml-directory)) + (not (file-directory-p (nnmail-group-pathname group nnml-directory)))) + (nnheader-report 'nnml "%s is a file" + (nnmail-group-pathname group nnml-directory))) + (t (let (active) (push (list group (setq active (cons 1 0))) nnml-group-alist) @@ -240,16 +246,14 @@ (when articles (setcar active (apply 'min articles)) (setcdr active (apply 'max articles)))) - (nnmail-save-active nnml-group-alist nnml-active-file))) - t) + (nnmail-save-active nnml-group-alist nnml-active-file) + t)))) (deffoo nnml-request-list (&optional server) (save-excursion - ;; 1997/8/12 by MORIOKA Tomohiko - ;; for XEmacs/mule. (let ((nnmail-file-coding-system nnmail-active-file-coding-system) - (file-name-coding-system 'binary) ; for Emacs 20 - (pathname-coding-system 'binary)) ; for XEmacs/mule + (file-name-coding-system 'binary) + (pathname-coding-system 'binary)) (nnmail-find-file nnml-active-file) ) (setq nnml-group-alist (nnmail-get-active)) @@ -265,12 +269,17 @@ (deffoo nnml-request-expire-articles (articles group &optional server force) (nnml-possibly-change-directory group server) - (let* ((active-articles - (nnheader-directory-articles nnml-current-directory)) - (is-old t) - article rest mod-time number) + (let ((active-articles + (nnheader-directory-articles nnml-current-directory)) + (is-old t) + article rest mod-time number) (nnmail-activate 'nnml) + (setq active-articles (sort active-articles '<)) + ;; Articles not listed in active-articles are already gone, + ;; so don't try to expire them. + (setq articles (gnus-sorted-intersection articles active-articles)) + (while (and articles is-old) (when (setq article (nnml-article-to-file (setq number (pop articles)))) (when (setq mod-time (nth 5 (file-attributes article))) @@ -480,8 +489,8 @@ ;; Just to make sure nothing went wrong when reading over NFS -- ;; check once more. (when (file-exists-p - (setq file (concat nnml-current-directory "/" - (number-to-string article)))) + (setq file (expand-file-name (number-to-string article) + nnml-current-directory))) (nnml-update-file-alist t) file)))) @@ -563,9 +572,8 @@ (if (not group) t (let ((pathname (nnmail-group-pathname group nnml-directory)) - ;; 1997/8/14 by MORIOKA Tomohiko - (file-name-coding-system 'binary) ; for Emacs 20 - (pathname-coding-system 'binary)) ; for XEmacs/mule + (file-name-coding-system 'binary) + (pathname-coding-system 'binary)) (when (not (equal pathname nnml-current-directory)) (setq nnml-current-directory pathname nnml-current-group group @@ -635,7 +643,7 @@ (setq nnml-article-file-alist (sort (nnheader-article-to-file-alist nnml-current-directory) - (lambda (a1 a2) (< (car a1) (car a2)))))) + 'car-less-than-car))) (setq active (if nnml-article-file-alist (cons (caar nnml-article-file-alist) @@ -664,10 +672,10 @@ "Parse the head of the current buffer." (save-excursion (save-restriction - (goto-char (point-min)) - (narrow-to-region - (point) - (1- (or (search-forward "\n\n" nil t) (point-max)))) + (unless (zerop (buffer-size)) + (narrow-to-region + (goto-char (point-min)) + (if (search-forward "\n\n" nil t) (1- (point)) (point-max)))) ;; Fold continuation lines. (goto-char (point-min)) (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t) @@ -681,12 +689,15 @@ (defun nnml-open-nov (group) (or (cdr (assoc group nnml-nov-buffer-alist)) - (let ((buffer (nnheader-find-file-noselect - (concat (nnmail-group-pathname group nnml-directory) - nnml-nov-file-name)))) + (let ((buffer (get-buffer-create (format " *nnml overview %s*" group)))) (save-excursion (set-buffer buffer) - (buffer-disable-undo (current-buffer))) + (set (make-local-variable 'nnml-nov-buffer-file-name) + (concat (nnmail-group-pathname group nnml-directory) + nnml-nov-file-name)) + (erase-buffer) + (when (file-exists-p nnml-nov-buffer-file-name) + (nnheader-insert-file-contents nnml-nov-buffer-file-name))) (push (cons group buffer) nnml-nov-buffer-alist) buffer))) @@ -696,7 +707,8 @@ (when (buffer-name (cdar nnml-nov-buffer-alist)) (set-buffer (cdar nnml-nov-buffer-alist)) (when (buffer-modified-p) - (nnmail-write-region 1 (point-max) (buffer-file-name) nil 'nomesg)) + (nnmail-write-region 1 (point-max) nnml-nov-buffer-file-name + nil 'nomesg)) (set-buffer-modified-p nil) (kill-buffer (current-buffer))) (setq nnml-nov-buffer-alist (cdr nnml-nov-buffer-alist))))) @@ -731,8 +743,13 @@ (nnml-generate-nov-databases-1 dir seen)))) ;; Do this directory. (let ((files (sort (nnheader-article-to-file-alist dir) - (lambda (a b) (< (car a) (car b)))))) - (when files + 'car-less-than-car))) + (if (not files) + (let* ((group (nnheader-file-to-group + (directory-file-name dir) nnml-directory)) + (info (cadr (assoc group nnml-group-alist)))) + (when info + (setcar info (1+ (cdr info))))) (funcall nnml-generate-active-function dir) ;; Generate the nov file. (nnml-generate-nov-file dir files)
--- a/lisp/gnus/nnoo.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/nnoo.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ ;;; nnoo.el --- OO Gnus Backends -;; Copyright (C) 1996,97 Free Software Foundation, Inc. +;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news ;; This file is part of GNU Emacs. @@ -30,6 +30,7 @@ (defvar nnoo-definition-alist nil) (defvar nnoo-state-alist nil) +(defvar nnoo-parent-backend nil) (defmacro defvoo (var init &optional doc &rest map) "The same as `defvar', only takes list of variables to MAP to." @@ -88,25 +89,42 @@ (or (cdr imp) (nnoo-functions (car imp)))) (while functions - (unless (fboundp (setq function - (nnoo-symbol backend (nnoo-rest-symbol - (car functions))))) + (unless (fboundp + (setq function + (nnoo-symbol backend + (nnoo-rest-symbol (car functions))))) (eval `(deffoo ,function (&rest args) (,call-function ',backend ',(car functions) args)))) (pop functions))))) (defun nnoo-parent-function (backend function args) - (let* ((pbackend (nnoo-backend function))) - (nnoo-change-server pbackend (nnoo-current-server backend) + (let ((pbackend (nnoo-backend function)) + (nnoo-parent-backend backend)) + (nnoo-change-server pbackend + (nnoo-current-server backend) (cdr (assq pbackend (nnoo-parents backend)))) - (apply function args))) + (prog1 + (apply function args) + ;; Copy the changed variables back into the child. + (let ((vars (cdr (assq pbackend (nnoo-parents backend))))) + (while vars + (set (cadar vars) (symbol-value (caar vars))) + (setq vars (cdr vars))))))) (defun nnoo-execute (backend function &rest args) "Execute FUNCTION on behalf of BACKEND." - (let* ((pbackend (nnoo-backend function))) - (nnoo-change-server pbackend (nnoo-current-server backend) + (let ((pbackend (nnoo-backend function)) + (nnoo-parent-backend backend)) + (nnoo-change-server pbackend + (nnoo-current-server backend) (cdr (assq pbackend (nnoo-parents backend)))) - (apply function args))) + (prog1 + (apply function args) + ;; Copy the changed variables back into the child. + (let ((vars (cdr (assq pbackend (nnoo-parents backend))))) + (while vars + (set (cadar vars) (symbol-value (caar vars))) + (setq vars (cdr vars))))))) (defmacro nnoo-map-functions (backend &rest maps) `(nnoo-map-functions-1 ',backend ',maps)) @@ -157,8 +175,13 @@ (let* ((bstate (cdr (assq backend nnoo-state-alist))) (current (car bstate)) (parents (nnoo-parents backend)) + (server (if nnoo-parent-backend + (format "%s+%s" nnoo-parent-backend server) + server)) (bvariables (nnoo-variables backend)) state def) + ;; If we don't have a current state, we push an empty state + ;; onto the alist. (unless bstate (push (setq bstate (list backend nil)) nnoo-state-alist) @@ -178,10 +201,12 @@ (nconc bvariables (list (cons (car def) (and (boundp (car def)) (symbol-value (car def))))))) - (set (car def) (cadr def)))) + (if (equal server "*internal-non-initialized-backend*") + (set (car def) (symbol-value (cadr def))) + (set (car def) (cadr def))))) (while parents (nnoo-change-server - (caar parents) server + (caar parents) (format "%s+%s" backend server) (mapcar (lambda (def) (list (car def) (symbol-value (cadr def)))) (cdar parents))) (pop parents)))) @@ -208,7 +233,10 @@ (nconc bstate (list (cons current state)))))) (defsubst nnoo-current-server-p (backend server) - (equal (nnoo-current-server backend) server)) + (equal (nnoo-current-server backend) + (if nnoo-parent-backend + (format "%s+%s" nnoo-parent-backend server) + server))) (defun nnoo-current-server (backend) (nth 1 (assq backend nnoo-state-alist)))
--- a/lisp/gnus/nnsoup.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/nnsoup.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ ;;; nnsoup.el --- SOUP access for Gnus -;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> ;; Keywords: news, mail @@ -69,6 +69,11 @@ (defvoo nnsoup-packet-regexp "Soupout" "*Regular expression matching SOUP packets in `nnsoup-packet-directory'.") +(defvoo nnsoup-always-save t + "If non nil commit the reply buffer on each message send. +This is necessary if using message mode outside Gnus with nnsoup as a +backend for the messages.") + (defconst nnsoup-version "nnsoup 0.0" @@ -82,7 +87,6 @@ (defvoo nnsoup-current-group nil) (defvoo nnsoup-group-alist-touched nil) (defvoo nnsoup-article-alist nil) - ;;; Interface functions. @@ -413,7 +417,7 @@ (while (setq area (pop areas)) ;; Change the name to the permanent name and move the files. (setq cur-prefix (nnsoup-next-prefix)) - (message "Incorporating file %s..." cur-prefix) + (nnheader-message 5 "Incorporating file %s..." cur-prefix) (when (file-exists-p (setq file (concat nnsoup-tmp-directory (gnus-soup-area-prefix area) ".IDX"))) @@ -544,13 +548,13 @@ nnsoup-packet-directory t nnsoup-packet-regexp)) packet) (while (setq packet (pop packets)) - (message "nnsoup: unpacking %s..." packet) + (nnheader-message 5 "nnsoup: unpacking %s..." packet) (if (not (gnus-soup-unpack-packet nnsoup-tmp-directory nnsoup-unpacker packet)) - (message "Couldn't unpack %s" packet) + (nnheader-message 5 "Couldn't unpack %s" packet) (delete-file packet) (nnsoup-read-areas) - (message "Unpacking...done"))))) + (nnheader-message 5 "Unpacking...done"))))) (defun nnsoup-narrow-to-article (article &optional area head) (let* ((area (or area (nnsoup-article-to-area article nnsoup-current-group))) @@ -614,7 +618,7 @@ "Make an outbound package of SOUP replies." (interactive) (unless (file-exists-p nnsoup-replies-directory) - (message "No such directory: %s" nnsoup-replies-directory)) + (nnheader-message 5 "No such directory: %s" nnsoup-replies-directory)) ;; Write all data buffers. (gnus-soup-save-areas) ;; Write the active file. @@ -662,6 +666,8 @@ (require 'mail-utils) (let ((tembuf (generate-new-buffer " message temp")) (case-fold-search nil) + (real-header-separator mail-header-separator) + (mail-header-separator "") delimline (mailbuf (current-buffer))) (unwind-protect @@ -687,7 +693,7 @@ ;; Change header-delimiter to be what sendmail expects. (goto-char (point-min)) (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "\n")) + (concat "^" (regexp-quote real-header-separator) "\n")) (replace-match "\n") (backward-char 1) (setq delimline (point-marker)) @@ -707,8 +713,10 @@ (set-buffer msg-buf) (goto-char (point-min)) (while (re-search-forward "^#! *rnews" nil t) - (incf num))) - (message "Stored %d messages" num))) + (incf num)) + (when nnsoup-always-save + (save-buffer))) + (nnheader-message 5 "Stored %d messages" num))) (nnsoup-write-replies) (kill-buffer tembuf)))))) @@ -746,7 +754,7 @@ (set-buffer (get-buffer-create " *nnsoup work*")) (buffer-disable-undo (current-buffer)) (while files - (message "Doing %s..." (car files)) + (nnheader-message 5 "Doing %s..." (car files)) (erase-buffer) (nnheader-insert-file-contents (car files)) (goto-char (point-min)) @@ -771,7 +779,7 @@ (vector ident group "ncm" "" lines)))) (setcdr (cadr elem) (+ min lines))) (setq files (cdr files))) - (message "") + (nnheader-message 5 "") (setq nnsoup-group-alist active) (nnsoup-write-active-file t)))
--- a/lisp/gnus/nnspool.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/nnspool.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,8 +1,8 @@ ;;; nnspool.el --- spool access for GNU Emacs -;; Copyright (C) 1988,89,90,93,94,95,96,97 Free Software Foundation, Inc. +;; Copyright (C) 1988,89,90,93,94,95,96,97,98 Free Software Foundation, Inc. ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> -;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news ;; This file is part of GNU Emacs. @@ -82,6 +82,9 @@ (defvoo nnspool-rejected-article-hook nil "*A hook that will be run when an article has been rejected by the server.") +(defvoo nnspool-file-coding-system nnheader-file-coding-system + "Coding system for nnspool.") + ;; 1997/8/14 by MORIOKA Tomohiko (defvoo nnspool-file-coding-system nnheader-file-coding-system "Coding system for nnspool.") @@ -113,8 +116,6 @@ (default-directory nnspool-current-directory) (do-message (and (numberp nnspool-large-newsgroup) (> number nnspool-large-newsgroup))) - ;; 1997/8/14 by MORIOKA Tomohiko - ;; for Win32 (nnheader-file-coding-system nnspool-file-coding-system) file beg article ag) (if (and (numberp (car articles)) @@ -147,11 +148,11 @@ (and do-message (zerop (% (incf count) 20)) - (message "nnspool: Receiving headers... %d%%" + (nnheader-message 5 "nnspool: Receiving headers... %d%%" (/ (* count 100) number)))) (when do-message - (message "nnspool: Receiving headers...done")) + (nnheader-message 5 "nnspool: Receiving headers...done")) ;; Fold continuation lines. (nnheader-fold-continuation-lines) @@ -346,7 +347,7 @@ (while (re-search-forward "[ \t\n]+" nil t) (replace-match " " t t)) (nnheader-report 'nnspool "%s" (buffer-string)) - (message "nnspool: %s" nnspool-status-string) + (nnheader-message 5 "nnspool: %s" nnspool-status-string) (ding) (run-hooks 'nnspool-rejected-article-hook)))) @@ -356,8 +357,6 @@ (let ((nov (nnheader-group-pathname nnspool-current-group nnspool-nov-directory ".overview")) (arts articles) - ;; 1997/8/14 by MORIOKA Tomohiko - ;; for Win32 (nnheader-file-coding-system nnspool-file-coding-system) last) (if (not (file-exists-p nov)) @@ -440,8 +439,6 @@ (set-buffer nntp-server-buffer) (erase-buffer) (condition-case () - ;; 1997/8/14 by MORIOKA Tomohiko - ;; for Win32 (let ((nnheader-file-coding-system nnspool-file-coding-system)) (nnheader-insert-file-contents file) t)
--- a/lisp/gnus/nntp.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/nntp.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ -;;; nntp.el --- nntp access for Gnus -;;; Copyright (C) 1987,88,89,90,92,93,94,95,96,97 Free Software Foundation, Inc. +;;; nntp.el --- nntp access for Gnus Copyright (C) 1987-90,92-97 Free +;;; Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news ;; This file is part of GNU Emacs. @@ -45,13 +45,11 @@ (defvoo nntp-server-opened-hook '(nntp-send-mode-reader) "*Hook used for sending commands to the server at startup. The default value is `nntp-send-mode-reader', which makes an innd -server spawn an nnrpd server. Another useful function to put in this -hook might be `nntp-send-authinfo', which will prompt for a password -to allow posting from the server. Note that this is only necessary to -do on servers that use strict access control.") +server spawn an nnrpd server.") (defvoo nntp-authinfo-function 'nntp-send-authinfo - "Function used to send AUTHINFO to the server.") + "Function used to send AUTHINFO to the server. +It is called with no parameters.") (defvoo nntp-server-action-alist '(("nntpd 1\\.5\\.11t" @@ -79,8 +77,12 @@ `nntp-open-telnet' which telnets to a remote system, logs in and does the same.") +(defvoo nntp-rlogin-program "rsh" + "*Program used to log in on remote machines. +The default is \"rsh\", but \"ssh\" is a popular alternative.") + (defvoo nntp-rlogin-parameters '("telnet" "-8" "${NNTPSERVER:=news}" "nntp") - "*Parameters to `nntp-open-login'. + "*Parameters to `nntp-open-rlogin'. That function may be used as `nntp-open-connection-function'. In that case, this list will be used as the parameter list given to rsh.") @@ -99,6 +101,12 @@ (defvoo nntp-telnet-passwd nil "Password to use to log in via telnet with.") +(defvoo nntp-open-telnet-envuser nil + "*If non-nil, telnet session (client and server both) will support the ENVIRON option and not prompt for login name.") + +(defvoo nntp-telnet-shell-prompt "bash\\|\$ *\r?$\\|> *\r?" + "*Regular expression to match the shell prompt on the remote machine.") + (defvoo nntp-telnet-command "telnet" "Command used to start telnet.") @@ -134,21 +142,41 @@ If the gap between two consecutive articles is bigger than this variable, split the XOVER request into two requests.") -(defvoo nntp-connection-timeout nil - "*Number of seconds to wait before an nntp connection times out. -If this variable is nil, which is the default, no timers are set.") - (defvoo nntp-prepare-server-hook nil "*Hook run before a server is opened. If can be used to set up a server remotely, for instance. Say you have an account at the machine \"other.machine\". This machine has access to an NNTP server that you can't access locally. You could then use this hook to rsh to the remote machine and start a proxy NNTP -server there that you can connect to. See also `nntp-open-connection-function'") +server there that you can connect to. See also +`nntp-open-connection-function'") (defvoo nntp-warn-about-losing-connection t "*If non-nil, beep when a server closes connection.") +(defvoo nntp-coding-system-for-read 'binary + "*Coding system to read from NNTP.") + +(defvoo nntp-coding-system-for-write 'binary + "*Coding system to write to NNTP.") + +(defcustom nntp-authinfo-file "~/.authinfo" + ".netrc-like file that holds nntp authinfo passwords." + :type + '(choice file + (repeat :tag "Entries" + :menu-tag "Inline" + (list :format "%v" + :value ("" ("login" . "") ("password" . "")) + (string :tag "Host") + (checklist :inline t + (cons :format "%v" + (const :format "" "login") + (string :format "Login: %v")) + (cons :format "%v" + (const :format "" "password") + (string :format "Password: %v"))))))) + ;; 1997/5/4 by MORIOKA Tomohiko <morioka@jaist.ac.jp> (defvoo nntp-coding-system-for-read 'binary "*Coding system to read from NNTP.") @@ -158,8 +186,15 @@ +(defvoo nntp-connection-timeout nil + "*Number of seconds to wait before an nntp connection times out. +If this variable is nil, which is the default, no timers are set.") + ;;; Internal variables. +(defvar nntp-record-commands nil + "*If non-nil, nntp will record all commands in the \"*nntp-log*\" buffer.") + (defvar nntp-have-messaged nil) (defvar nntp-process-wait-for nil) @@ -168,6 +203,10 @@ (defvar nntp-process-decode nil) (defvar nntp-process-start-point nil) (defvar nntp-inside-change-function nil) +(defvoo nntp-last-command-time nil) +(defvoo nntp-last-command nil) +(defvoo nntp-authinfo-password nil) +(defvoo nntp-authinfo-user nil) (defvar nntp-connection-list nil) @@ -182,7 +221,8 @@ (defvoo nntp-server-list-active-group 'try) (eval-and-compile - (autoload 'nnmail-read-passwd "nnmail")) + (autoload 'nnmail-read-passwd "nnmail") + (autoload 'open-ssl-stream "ssl")) @@ -190,32 +230,53 @@ (defsubst nntp-send-string (process string) "Send STRING to PROCESS." + ;; We need to store the time to provide timeouts, and + ;; to store the command so the we can replay the command + ;; if the server gives us an AUTHINFO challenge. + (setq nntp-last-command-time (current-time) + nntp-last-command string) + (when nntp-record-commands + (nntp-record-command string)) (process-send-string process (concat string nntp-end-of-line))) +(defun nntp-record-command (string) + "Record the command STRING." + (save-excursion + (set-buffer (get-buffer-create "*nntp-log*")) + (goto-char (point-max)) + (let ((time (current-time))) + (insert (format-time-string "%Y%m%dT%H%M%S" time) + "." (format "%03d" (/ (nth 2 time) 1000)) + " " nntp-address " " string "\n")))) + (defsubst nntp-wait-for (process wait-for buffer &optional decode discard) "Wait for WAIT-FOR to arrive from PROCESS." (save-excursion (set-buffer (process-buffer process)) (goto-char (point-min)) - (while (or (not (memq (char-after (point)) '(?2 ?3 ?4 ?5))) - (looking-at "480")) + (while (and (or (not (memq (char-after (point)) '(?2 ?3 ?4 ?5))) + (looking-at "480")) + (memq (process-status process) '(open run))) (when (looking-at "480") - (erase-buffer) - (funcall nntp-authinfo-function)) + (nntp-handle-authinfo process)) (nntp-accept-process-output process) (goto-char (point-min))) (prog1 - (if (looking-at "[45]") - (progn - (nntp-snarf-error-message) - nil) + (cond + ((looking-at "[45]") + (progn + (nntp-snarf-error-message) + nil)) + ((not (memq (process-status process) '(open run))) + (nnheader-report 'nntp "Server closed connection")) + (t (goto-char (point-max)) (let ((limit (point-min))) (while (not (re-search-backward wait-for limit t)) + (nntp-accept-process-output process) ;; We assume that whatever we wait for is less than 1000 ;; characters long. (setq limit (max (- (point-max) 1000) (point-min))) - (nntp-accept-process-output process) (goto-char (point-max)))) (nntp-decode-text (not decode)) (unless discard @@ -226,8 +287,8 @@ ;; Nix out "nntp reading...." message. (when nntp-have-messaged (setq nntp-have-messaged nil) - (message "")) - t))) + (nnheader-message 5 "")) + t)))) (unless discard (erase-buffer))))) @@ -259,7 +320,7 @@ (process-buffer process)))) (defsubst nntp-retrieve-data (command address port buffer - &optional wait-for callback decode) + &optional wait-for callback decode) "Use COMMAND to retrieve data into BUFFER from PORT on ADDRESS." (let ((process (or (nntp-find-connection buffer) (nntp-open-connection buffer)))) @@ -342,6 +403,24 @@ (nnoo-define-basics nntp) +(defsubst nntp-next-result-arrived-p () + (cond + ;; A result that starts with a 2xx code is terminated by + ;; a line with only a "." on it. + ((eq (following-char) ?2) + (if (re-search-forward "\n\\.\r?\n" nil t) + t + nil)) + ;; A result that starts with a 3xx or 4xx code is terminated + ;; by a newline. + ((looking-at "[34]") + (if (search-forward "\n" nil t) + t + nil)) + ;; No result here. + (t + nil))) + (deffoo nntp-retrieve-headers (articles &optional group server fetch-old) "Retrieve the headers of ARTICLES." (nntp-possibly-change-group group server) @@ -360,49 +439,39 @@ (received 0) (last-point (point-min)) (buf (nntp-find-connection-buffer nntp-server-buffer)) - (nntp-inhibit-erase t)) - ;; Send HEAD command. - (while articles - (nntp-send-command - nil - "HEAD" (if (numberp (car articles)) - (int-to-string (car articles)) - ;; `articles' is either a list of article numbers - ;; or a list of article IDs. - (car articles))) - (setq articles (cdr articles) - count (1+ count)) - ;; Every 400 header requests we have to read the stream in - ;; order to avoid deadlocks. - (when (or (null articles) ;All requests have been sent. - (zerop (% count nntp-maximum-request))) - (nntp-accept-response) - (while (progn - (progn - (set-buffer buf) - (goto-char last-point)) - ;; Count replies. - (while (re-search-forward "^[0-9]" nil t) - (incf received)) + (nntp-inhibit-erase t) + article) + ;; Send HEAD commands. + (while (setq article (pop articles)) + (nntp-send-command + nil + "HEAD" (if (numberp article) + (int-to-string article) + ;; `articles' is either a list of article numbers + ;; or a list of article IDs. + article)) + (incf count) + ;; Every 400 requests we have to read the stream in + ;; order to avoid deadlocks. + (when (or (null articles) ;All requests have been sent. + (zerop (% count nntp-maximum-request))) + (nntp-accept-response) + (while (progn + (set-buffer buf) + (goto-char last-point) + ;; Count replies. + (while (nntp-next-result-arrived-p) (setq last-point (point)) - (< received count)) - ;; If number of headers is greater than 100, give - ;; informative messages. - (and (numberp nntp-large-newsgroup) - (> number nntp-large-newsgroup) - (zerop (% received 20)) - (nnheader-message 6 "NNTP: Receiving headers... %d%%" - (/ (* received 100) number))) - (nntp-accept-response)))) - ;; Wait for text of last command. - (goto-char (point-max)) - (re-search-backward "^[0-9]" nil t) - (when (looking-at "^[23]") - (while (progn - (goto-char (point-max)) - (forward-line -1) - (not (looking-at "^\\.\r?\n"))) - (nntp-accept-response))) + (incf received)) + (< received count)) + ;; If number of headers is greater than 100, give + ;; informative messages. + (and (numberp nntp-large-newsgroup) + (> number nntp-large-newsgroup) + (zerop (% received 20)) + (nnheader-message 6 "NNTP: Receiving headers... %d%%" + (/ (* received 100) number))) + (nntp-accept-response)))) (and (numberp nntp-large-newsgroup) (> number nntp-large-newsgroup) (nnheader-message 6 "NNTP: Receiving headers...done")) @@ -487,10 +556,10 @@ (nntp-inhibit-erase t) (map (apply 'vector articles)) (point 1) - article alist) + article) (set-buffer buf) (erase-buffer) - ;; Send HEAD command. + ;; Send ARTICLE command. (while (setq article (pop articles)) (nntp-send-command nil @@ -506,14 +575,13 @@ (zerop (% count nntp-maximum-request))) (nntp-accept-response) (while (progn - (progn - (set-buffer buf) - (goto-char last-point)) + (set-buffer buf) + (goto-char last-point) ;; Count replies. (while (nntp-next-result-arrived-p) (aset map received (cons (aref map received) (point))) + (setq last-point (point)) (incf received)) - (setq last-point (point)) (< received count)) ;; If number of headers is greater than 100, give ;; informative messages. @@ -525,12 +593,13 @@ (nntp-accept-response)))) (and (numberp nntp-large-newsgroup) (> number nntp-large-newsgroup) - (nnheader-message 6 "NNTP: Receiving headers...done")) + (nnheader-message 6 "NNTP: Receiving articles...done")) ;; Now we have all the responses. We go through the results, - ;; washes it and copies it over to the server buffer. + ;; wash it and copy it over to the server buffer. (set-buffer nntp-server-buffer) (erase-buffer) + (setq last-point (point-min)) (mapcar (lambda (entry) (narrow-to-region @@ -538,25 +607,12 @@ (progn (insert-buffer-substring buf last-point (cdr entry)) (point-max))) + (setq last-point (cdr entry)) (nntp-decode-text) (widen) (cons (car entry) point)) map)))) -(defun nntp-next-result-arrived-p () - (let ((point (point))) - (cond - ((looking-at "2") - (if (re-search-forward "\n.\r?\n" nil t) - t - (goto-char point) - nil)) - ((looking-at "[34]") - (forward-line 1) - t) - (t - nil)))) - (defun nntp-try-list-active (group) (nntp-list-active-group group) (save-excursion @@ -603,7 +659,7 @@ (deffoo nntp-request-group (group &optional server dont-check) (nntp-possibly-change-group nil server) - (when (nntp-send-command "^2.*\n" "GROUP" group) + (when (nntp-send-command "^[245].*\n" "GROUP" group) (let ((entry (nntp-find-connection-entry nntp-server-buffer))) (setcar (cddr entry) group)))) @@ -633,22 +689,34 @@ (deffoo nntp-close-server (&optional server) (nntp-possibly-change-group nil server t) - (let (process) - (while (setq process (car (pop nntp-connection-alist))) + (let ((process (nntp-find-connection nntp-server-buffer))) + (while process (when (memq (process-status process) '(open run)) - (set-process-sentinel process nil) - (nntp-send-string process "QUIT")) + (ignore-errors + (nntp-send-string process "QUIT") + (unless (eq nntp-open-connection-function 'nntp-open-network-stream) + ;; Ok, this is evil, but when using telnet and stuff + ;; as the connection method, it's important that the + ;; QUIT command actually is sent out before we kill + ;; the process. + (sleep-for 1)))) (when (buffer-name (process-buffer process)) - (kill-buffer (process-buffer process)))) + (kill-buffer (process-buffer process))) + (setq process (car (pop nntp-connection-alist)))) (nnoo-close-server 'nntp))) (deffoo nntp-request-close () (let (process) (while (setq process (pop nntp-connection-list)) (when (memq (process-status process) '(open run)) - (set-process-sentinel process nil) (ignore-errors - (nntp-send-string process "QUIT"))) + (nntp-send-string process "QUIT") + (unless (eq nntp-open-connection-function 'nntp-open-network-stream) + ;; Ok, this is evil, but when using telnet and stuff + ;; as the connection method, it's important that the + ;; QUIT command actually is sent out before we kill + ;; the process. + (sleep-for 1)))) (when (buffer-name (process-buffer process)) (kill-buffer (process-buffer process)))))) @@ -664,16 +732,11 @@ (nntp-possibly-change-group nil server) (save-excursion (set-buffer nntp-server-buffer) - (let* ((date (timezone-parse-date date)) - (time-string - (format "%s%02d%02d %s%s%s" - (substring (aref date 0) 2) (string-to-int (aref date 1)) - (string-to-int (aref date 2)) (substring (aref date 3) 0 2) - (substring - (aref date 3) 3 5) (substring (aref date 3) 6 8)))) - (prog1 - (nntp-send-command "^\\.\r?\n" "NEWGROUPS" time-string) - (nntp-decode-text))))) + (prog1 + (nntp-send-command + "^\\.\r?\n" "NEWGROUPS" + (format-time-string "%y%m%d %H%M%S" (nnmail-date-to-time date))) + (nntp-decode-text)))) (deffoo nntp-request-post (&optional server) (nntp-possibly-change-group nil server) @@ -695,40 +758,72 @@ reading." (nntp-send-command "^.*\r?\n" "MODE READER")) -(defun nntp-send-nosy-authinfo () +(defun nntp-send-authinfo (&optional send-if-force) "Send the AUTHINFO to the nntp server. -This function is supposed to be called from `nntp-server-opened-hook'. -It will prompt for a password." - (nntp-send-command - "^.*\r?\n" "AUTHINFO USER" - (read-string (format "NNTP (%s) user name: " nntp-address))) - (nntp-send-command - "^.*\r?\n" "AUTHINFO PASS" - (nnmail-read-passwd "NNTP (%s) password: " nntp-address))) +It will look in the \"~/.authinfo\" file for matching entries. If +nothing suitable is found there, it will prompt for a user name +and a password. -(defun nntp-send-authinfo () - "Send the AUTHINFO to the nntp server. -This function is supposed to be called from `nntp-server-opened-hook'. -It will prompt for a password." - (nntp-send-command "^.*\r?\n" "AUTHINFO USER" (user-login-name)) - (nntp-send-command - "^.*\r?\n" "AUTHINFO PASS" - (nnmail-read-passwd (format "NNTP (%s) password: " nntp-address)))) +If SEND-IF-FORCE, only send authinfo to the server if the +.authinfo file has the FORCE token." + (let* ((list (gnus-parse-netrc nntp-authinfo-file)) + (alist (gnus-netrc-machine list nntp-address)) + (force (gnus-netrc-get alist "force")) + (user (or (gnus-netrc-get alist "login") nntp-authinfo-user)) + (passwd (gnus-netrc-get alist "password"))) + (when (or (not send-if-force) + force) + (unless user + (setq user (read-string (format "NNTP (%s) user name: " nntp-address)) + nntp-authinfo-user user)) + (unless (member user '(nil "")) + (nntp-send-command "^3.*\r?\n" "AUTHINFO USER" user) + (when t ;???Should check if AUTHINFO succeeded + (nntp-send-command + "^2.*\r?\n" "AUTHINFO PASS" + (or passwd + nntp-authinfo-password + (setq nntp-authinfo-password + (nnmail-read-passwd (format "NNTP (%s@%s) password: " + user nntp-address)))))))))) + +(defun nntp-send-nosy-authinfo () + "Send the AUTHINFO to the nntp server." + (let ((user (read-string (format "NNTP (%s) user name: " nntp-address)))) + (unless (member user '(nil "")) + (nntp-send-command "^3.*\r?\n" "AUTHINFO USER" user) + (when t ;???Should check if AUTHINFO succeeded + (nntp-send-command "^2.*\r?\n" "AUTHINFO PASS" + (nnmail-read-passwd "NNTP (%s@%s) password: " + user nntp-address)))))) (defun nntp-send-authinfo-from-file () "Send the AUTHINFO to the nntp server. -This function is supposed to be called from `nntp-server-opened-hook'." + +The authinfo login name is taken from the user's login name and the +password contained in '~/.nntp-authinfo'." (when (file-exists-p "~/.nntp-authinfo") (nnheader-temp-write nil (insert-file-contents "~/.nntp-authinfo") (goto-char (point-min)) - (nntp-send-command "^.*\r?\n" "AUTHINFO USER" (user-login-name)) + (nntp-send-command "^3.*\r?\n" "AUTHINFO USER" (user-login-name)) (nntp-send-command - "^.*\r?\n" "AUTHINFO PASS" + "^2.*\r?\n" "AUTHINFO PASS" (buffer-substring (point) (progn (end-of-line) (point))))))) ;;; Internal functions. +(defun nntp-handle-authinfo (process) + "Take care of an authinfo response from the server." + (let ((last nntp-last-command)) + (funcall nntp-authinfo-function) + ;; We have to re-send the function that was interrupted by + ;; the authinfo request. + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer)) + (nntp-send-string process last))) + (defun nntp-make-process-buffer (buffer) "Create a new, fresh buffer usable for nntp process connections." (save-excursion @@ -736,7 +831,7 @@ (generate-new-buffer (format " *server %s %s %s*" nntp-address nntp-port-number - (buffer-name (get-buffer buffer))))) + (gnus-buffer-exists-p buffer)))) (buffer-disable-undo (current-buffer)) (set (make-local-variable 'after-change-functions) nil) (set (make-local-variable 'nntp-process-wait-for) nil) @@ -750,15 +845,24 @@ "Open a connection to PORT on ADDRESS delivering output to BUFFER." (run-hooks 'nntp-prepare-server-hook) (let* ((pbuffer (nntp-make-process-buffer buffer)) + (timer + (and nntp-connection-timeout + (nnheader-run-at-time + nntp-connection-timeout nil + `(lambda () + (when (buffer-name ,pbuffer) + (kill-buffer ,pbuffer)))))) (process (condition-case () - ;; 1997/5/4 by MORIOKA Tomohiko <morioka@jaist.ac.jp> (let ((coding-system-for-read nntp-coding-system-for-read) - (coding-system-for-write nntp-coding-system-for-write)) + (coding-system-for-write nntp-coding-system-for-write)) (funcall nntp-open-connection-function pbuffer)) (error nil) (quit nil)))) - (when process + (when timer + (nnheader-cancel-timer timer)) + (when (and (buffer-name pbuffer) + process) (process-kill-without-query process) (nntp-wait-for process "^.*\n" buffer nil t) (if (memq (process-status process) '(open run)) @@ -771,7 +875,8 @@ (erase-buffer) (set-buffer nntp-server-buffer) (let ((nnheader-callback-function nil)) - (run-hooks 'nntp-server-opened-hook)))) + (run-hooks 'nntp-server-opened-hook) + (nntp-send-authinfo t)))) (when (buffer-name (process-buffer process)) (kill-buffer (process-buffer process))) nil)))) @@ -779,6 +884,16 @@ (defun nntp-open-network-stream (buffer) (open-network-stream "nntpd" buffer nntp-address nntp-port-number)) +(defun nntp-open-ssl-stream (buffer) + (let* ((ssl-program-arguments '("-connect" (concat host ":" service))) + (proc (open-ssl-stream "nntpd" buffer nntp-address nntp-port-number))) + (save-excursion + (set-buffer buffer) + (nntp-wait-for-string "^\r*20[01]") + (beginning-of-line) + (delete-region (point-min) (point)) + proc))) + (defun nntp-read-server-type () "Find out what the name of the server we have connected to is." ;; Wait for the status string to arrive. @@ -804,18 +919,18 @@ (save-excursion (goto-char beg) (if (looking-at "480") - (funcall nntp-authinfo-function) + (nntp-handle-authinfo nntp-process-to-buffer) (nntp-snarf-error-message) (funcall nntp-process-callback nil))) (goto-char end) (when (and (> (point) nntp-process-start-point) (re-search-backward nntp-process-wait-for nntp-process-start-point t)) - (when (buffer-name (get-buffer nntp-process-to-buffer)) + (when (gnus-buffer-exists-p nntp-process-to-buffer) (let ((cur (current-buffer)) (start nntp-process-start-point)) (save-excursion - (set-buffer (get-buffer nntp-process-to-buffer)) + (set-buffer nntp-process-to-buffer) (goto-char (point-max)) (let ((b (point))) (insert-buffer-substring cur start) @@ -1072,13 +1187,20 @@ (case-fold-search t)) (when (memq (process-status proc) '(open run)) (process-send-string proc "set escape \^X\n") - (process-send-string proc (concat "open " nntp-address "\n")) - (nntp-wait-for-string "^\r*.?login:") - (process-send-string - proc (concat - (or nntp-telnet-user-name - (setq nntp-telnet-user-name (read-string "login: "))) - "\n")) + (cond + ((and nntp-open-telnet-envuser nntp-telnet-user-name) + (process-send-string proc (concat "open " "-l" nntp-telnet-user-name + nntp-address "\n"))) + (t + (process-send-string proc (concat "open " nntp-address "\n")))) + (cond + ((not nntp-open-telnet-envuser) + (nntp-wait-for-string "^\r*.?login:") + (process-send-string + proc (concat + (or nntp-telnet-user-name + (setq nntp-telnet-user-name (read-string "login: "))) + "\n")))) (nntp-wait-for-string "^\r*.?password:") (process-send-string proc (concat @@ -1087,10 +1209,10 @@ (nnmail-read-passwd "Password: "))) "\n")) (erase-buffer) - (nntp-wait-for-string "bash\\|\$ *\r?$\\|> *\r?") + (nntp-wait-for-string nntp-telnet-shell-prompt) (process-send-string proc (concat (mapconcat 'identity nntp-telnet-parameters " ") "\n")) - (nntp-wait-for-string "^\r*200") + (nntp-wait-for-string "^\r*20[01]") (beginning-of-line) (delete-region (point-min) (point)) (process-send-string proc "\^]") @@ -1106,20 +1228,19 @@ (defun nntp-open-rlogin (buffer) "Open a connection to SERVER using rsh." (let ((proc (if nntp-rlogin-user-name - (start-process - "nntpd" buffer "rsh" - nntp-address "-l" nntp-rlogin-user-name - (mapconcat 'identity - nntp-rlogin-parameters " ")) - (start-process - "nntpd" buffer "rsh" nntp-address - (mapconcat 'identity - nntp-rlogin-parameters " "))))) - (set-buffer buffer) - (nntp-wait-for-string "^\r*200") - (beginning-of-line) - (delete-region (point-min) (point)) - proc)) + (apply 'start-process + "nntpd" buffer nntp-rlogin-program + nntp-address "-l" nntp-rlogin-user-name + nntp-rlogin-parameters) + (apply 'start-process + "nntpd" buffer nntp-rlogin-program nntp-address + nntp-rlogin-parameters)))) + (save-excursion + (set-buffer buffer) + (nntp-wait-for-string "^\r*20[01]") + (beginning-of-line) + (delete-region (point-min) (point)) + proc))) (defun nntp-find-group-and-number () (save-excursion
--- a/lisp/gnus/nnvirtual.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/nnvirtual.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,8 +1,8 @@ ;;; nnvirtual.el --- virtual newsgroups access for Gnus -;; Copyright (C) 1994,95,96,97 Free Software Foundation, Inc. +;; Copyright (C) 1994,95,96,97,98 Free Software Foundation, Inc. ;; Author: David Moore <dmoore@ucsd.edu> -;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> ;; Keywords: news @@ -38,11 +38,12 @@ (require 'gnus-util) (require 'gnus-start) (require 'gnus-sum) +(require 'gnus-msg) (eval-when-compile (require 'cl)) (nnoo-declare nnvirtual) -(defvoo nnvirtual-always-rescan nil +(defvoo nnvirtual-always-rescan t "*If non-nil, always scan groups for unread articles when entering a group. If this variable is nil (which is the default) and you read articles in a component group after the virtual group has been activated, the @@ -258,10 +259,14 @@ (setq nnvirtual-current-group nil) (nnheader-report 'nnvirtual "No component groups in %s" group)) (t + (setq nnvirtual-current-group group) (when (or (not dont-check) nnvirtual-always-rescan) - (nnvirtual-create-mapping)) - (setq nnvirtual-current-group group) + (nnvirtual-create-mapping) + (when nnvirtual-always-rescan + (nnvirtual-request-update-info + (nnvirtual-current-group) + (gnus-get-info (nnvirtual-current-group))))) (nnheader-insert "211 %d 1 %d %s\n" nnvirtual-mapping-len nnvirtual-mapping-len group)))) @@ -269,9 +274,12 @@ (deffoo nnvirtual-request-type (group &optional article) (if (not article) 'unknown - (let ((mart (nnvirtual-map-article article))) - (when mart - (gnus-request-type (car mart) (cdr mart)))))) + (if (numberp article) + (let ((mart (nnvirtual-map-article article))) + (if mart + (gnus-request-type (car mart) (cdr mart)))) + (gnus-request-type + nnvirtual-last-accessed-component-group nil)))) (deffoo nnvirtual-request-update-mark (group article mark) (let* ((nart (nnvirtual-map-article article)) @@ -342,6 +350,15 @@ "Return the real group and article for virtual GROUP and ARTICLE." (nnvirtual-map-article article)) + +(deffoo nnvirtual-request-post (&optional server) + (if (not gnus-message-group-art) + (nnheader-report 'nnvirtual "Can't post to an nnvirtual group") + (let ((group (car (nnvirtual-find-group-art + (car gnus-message-group-art) + (cdr gnus-message-group-art))))) + (gnus-request-post (gnus-find-method-for-group group))))) + ;;; Internal functions. @@ -387,7 +404,7 @@ (replace-match "" t t)) (goto-char (point-min)) (when (re-search-forward - (concat (gnus-group-real-name group) ":[0-9]+") + (concat (regexp-quote (gnus-group-real-name group)) ":[0-9]+") nil t) (replace-match "" t t)) (unless (= (point) (point-max)) @@ -560,27 +577,28 @@ (defun nnvirtual-reverse-map-article (group article) "Return the virtual article number corresponding to the given component GROUP and ARTICLE." - (let ((table nnvirtual-mapping-table) - (group-pos 0) - entry) - (while (not (string= group (car (aref nnvirtual-mapping-offsets + (when (numberp article) + (let ((table nnvirtual-mapping-table) + (group-pos 0) + entry) + (while (not (string= group (car (aref nnvirtual-mapping-offsets + group-pos)))) + (setq group-pos (1+ group-pos))) + (setq article (- article (cdr (aref nnvirtual-mapping-offsets group-pos)))) - (setq group-pos (1+ group-pos))) - (setq article (- article (cdr (aref nnvirtual-mapping-offsets - group-pos)))) - (while (and table - (> article (aref (car table) 0))) - (setq table (cdr table))) - (setq entry (car table)) - (when (and entry - (> article 0) - (< group-pos (aref entry 2))) ; article not out of range below - (+ (aref entry 4) - group-pos - (* (- article (aref entry 1)) - (aref entry 2)) - 1)) - )) + (while (and table + (> article (aref (car table) 0))) + (setq table (cdr table))) + (setq entry (car table)) + (when (and entry + (> article 0) + (< group-pos (aref entry 2))) ; article not out of range below + (+ (aref entry 4) + group-pos + (* (- article (aref entry 1)) + (aref entry 2)) + 1)) + ))) (defsubst nnvirtual-reverse-map-sequence (group articles)
--- a/lisp/gnus/nnweb.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/nnweb.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ ;;; nnweb.el --- retrieving articles via web search engines -;; Copyright (C) 1996,97 Free Software Foundation, Inc. +;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news ;; This file is part of GNU Emacs. @@ -30,6 +30,8 @@ (eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl)) + (require 'nnoo) (require 'message) (require 'gnus-util) @@ -52,14 +54,22 @@ "Where nnweb will save its files.") (defvoo nnweb-type 'dejanews - "What search engine type is being used.") + "What search engine type is being used. +Valid types include `dejanews', `dejanewsold', `reference', +and `altavista'.") -(defvar nnweb-type-definition +(defvoo nnweb-type-definition '((dejanews (article . nnweb-dejanews-wash-article) (map . nnweb-dejanews-create-mapping) (search . nnweb-dejanews-search) - (address . "http://xp9.dejanews.com/dnquery.xp") + (address . "http://x8.dejanews.com/dnquery.xp") + (identifier . nnweb-dejanews-identity)) + (dejanewsold + (article . nnweb-dejanews-wash-article) + (map . nnweb-dejanews-create-mapping) + (search . nnweb-dejanewsold-search) + (address . "http://x8.dejanews.com/dnquery.xp") (identifier . nnweb-dejanews-identity)) (reference (article . nnweb-reference-wash-article) @@ -79,7 +89,7 @@ (defvoo nnweb-search nil "Search string to feed to DejaNews.") -(defvoo nnweb-max-hits 100 +(defvoo nnweb-max-hits 999 "Maximum number of hits to display.") (defvoo nnweb-ephemeral-p nil @@ -206,7 +216,7 @@ (deffoo nnweb-request-delete-group (group &optional force server) (nnweb-possibly-change-server group server) - (gnus-delete-assoc group nnweb-group-alist) + (gnus-pull group nnweb-group-alist) (gnus-delete-file (nnweb-overview-file group)) t) @@ -379,49 +389,53 @@ (case-fold-search t) (active (or (cadr (assoc nnweb-group nnweb-group-alist)) (cons 1 0))) - Subject Score Date Newsgroup Author + Subject (Score "0") Date Newsgroup Author map url) (while more ;; Go through all the article hits on this page. (goto-char (point-min)) (nnweb-decode-entities) (goto-char (point-min)) - (while (re-search-forward "^ +[0-9]+\\." nil t) + (while (re-search-forward "^ <P>\n" nil t) (narrow-to-region (point) - (cond ((re-search-forward "^ +[0-9]+\\." nil t) + (cond ((re-search-forward "^ <P>\n" nil t) (match-beginning 0)) ((search-forward "\n\n" nil t) (point)) (t (point-max)))) (goto-char (point-min)) - (when (looking-at ".*HREF=\"\\([^\"]+\\)\"") - (setq url (match-string 1))) - (nnweb-remove-markup) - (goto-char (point-min)) - (while (search-forward "\t" nil t) - (replace-match " ")) - (goto-char (point-min)) - (while (re-search-forward "^ +\\([^:]+\\): +\\(.*\\)$" nil t) - (set (intern (match-string 1)) (match-string 2))) + (looking-at ".*HREF=\"\\([^\"]+\\)\"\\(.*\\)") + (setq url (match-string 1)) + (let ((begin (point))) + (nnweb-remove-markup) + (goto-char begin) + (while (search-forward "\t" nil t) + (replace-match " ")) + (goto-char begin) + (end-of-line) + (setq Subject (buffer-substring begin (point))) + (if (re-search-forward + "^ Newsgroup: \\(.*\\)\n Posted on \\([0-9/]+\\) by \\(.*\\)$" nil t) + (setq Newsgroup (match-string 1) + Date (match-string 2) + Author (match-string 3)))) (widen) - (when (string-match "#[0-9]+/[0-9]+ *$" Subject) - (setq Subject (substring Subject 0 (match-beginning 0)))) (incf i) (unless (nnweb-get-hashtb url) (push (list (incf (cdr active)) (make-full-mail-header - (cdr active) (concat "(" Newsgroup ") " Subject) Author Date + (cdr active) Subject Author Date (concat "<" (nnweb-identifier url) "@dejanews>") nil 0 (string-to-int Score) url)) map) (nnweb-set-hashtb (cadar map) (car map)))) ;; See whether there is a "Get next 20 hits" button here. (if (or (not (re-search-forward - "HREF=\"\\([^\"]+\\)\">Get next" nil t)) + "HREF=\"\\([^\"]+\\)\"[<>b]+Next result" nil t)) (>= i nnweb-max-hits)) (setq more nil) ;; Yup -- fetch it. @@ -430,8 +444,7 @@ (url-insert-file-contents more))) ;; Return the articles in the right order. (setq nnweb-articles - (sort (nconc nnweb-articles map) - (lambda (s1 s2) (< (car s1) (car s2))))))))) + (sort (nconc nnweb-articles map) 'car-less-than-car)))))) (defun nnweb-dejanews-wash-article () (let ((case-fold-search t)) @@ -461,9 +474,23 @@ ("defaultOp" . "AND") ("svcclass" . "dncurrent") ("maxhits" . "100") - ("format" . "verbose") + ("format" . "verbose2") ("threaded" . "0") - ("showsort" . "score") + ("showsort" . "date") + ("agesign" . "1") + ("ageweight" . "1"))) + t) + +(defun nnweb-dejanewsold-search (search) + (nnweb-fetch-form + (nnweb-definition 'address) + `(("query" . ,search) + ("defaultOp" . "AND") + ("svcclass" . "dnold") + ("maxhits" . "100") + ("format" . "verbose2") + ("threaded" . "0") + ("showsort" . "date") ("agesign" . "1") ("ageweight" . "1"))) t) @@ -530,8 +557,7 @@ (setq more nil)) ;; Return the articles in the right order. (setq nnweb-articles - (sort (nconc nnweb-articles map) - (lambda (s1 s2) (< (car s1) (car s2))))))))) + (sort (nconc nnweb-articles map) 'car-less-than-car)))))) (defun nnweb-reference-wash-article () (let ((case-fold-search t)) @@ -657,8 +683,7 @@ (setq more nil))) ;; Return the articles in the right order. (setq nnweb-articles - (sort (nconc nnweb-articles map) - (lambda (s1 s2) (< (car s1) (car s2)))))))))) + (sort (nconc nnweb-articles map) 'car-less-than-car))))))) (defun nnweb-altavista-wash-article () (goto-char (point-min))
--- a/lisp/gnus/pop3.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/pop3.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,10 +1,10 @@ ;;; pop3.el --- Post Office Protocol (RFC 1460) interface -;; Copyright (C) 1996,1997 Free Software Foundation, Inc. +;; Copyright (C) 1996,1997,1998 Free Software Foundation, Inc. ;; Author: Richard L. Pieri <ratinox@peorth.gweep.net> ;; Keywords: mail, pop3 -;; Version: 1.3g +;; Version: 1.3m ;; This file is part of GNU Emacs. @@ -37,9 +37,9 @@ (require 'mail-utils) (provide 'pop3) -(defconst pop3-version "1.3g") +(defconst pop3-version "1.3m") -(defvar pop3-maildrop (or user-login-name (getenv "LOGNAME") (getenv "USER") nil) +(defvar pop3-maildrop (or (user-login-name) (getenv "LOGNAME") (getenv "USER") nil) "*POP3 maildrop.") (defvar pop3-mailhost (or (getenv "MAILHOST") nil) "*POP3 mailhost.") @@ -72,9 +72,15 @@ (let* ((process (pop3-open-server pop3-mailhost pop3-port)) (crashbuf (get-buffer-create " *pop3-retr*")) (n 1) - message-count) + message-count + (pop3-password pop3-password) + ) ;; for debugging only (if pop3-debug (switch-to-buffer (process-buffer process))) + ;; query for password + (if (and pop3-password-required (not pop3-password)) + (setq pop3-password + (pop3-read-passwd (format "Password for %s: " pop3-maildrop)))) (cond ((equal 'apop pop3-authentication-scheme) (pop3-apop process pop3-maildrop)) ((equal 'pass pop3-authentication-scheme) @@ -110,14 +116,16 @@ (let ((process-buffer (get-buffer-create (format "trace of POP session to %s" mailhost))) (process) - (coding-system-for-read 'no-conversion) - (coding-system-for-write 'no-conversion)) + (coding-system-for-read 'binary) + (coding-system-for-write 'binary) + ) (save-excursion (set-buffer process-buffer) - (erase-buffer)) + (erase-buffer) + (setq pop3-read-point (point-min)) + ) (setq process (open-network-stream "POP" process-buffer mailhost port)) - (setq pop3-read-point (point-min)) (let ((response (pop3-read-response process t))) (setq pop3-timestamp (substring response (or (string-match "<" response) 0) @@ -257,31 +265,10 @@ (defun pop3-pass (process) "Send authentication information to the server." - (let ((pass pop3-password)) - (if (and pop3-password-required (not pass)) - (setq pass - (pop3-read-passwd (format "Password for %s: " pop3-maildrop)))) - (if pass - (progn - (pop3-send-command process (format "PASS %s" pass)) - (let ((response (pop3-read-response process t))) - (if (not (and response (string-match "+OK" response))) - (pop3-quit process))))) - )) - -(defvar pop3-md5-program "md5" - "*Program to encode its input in MD5.") - -(defun pop3-md5 (string) - (with-temp-buffer - (insert string) - (call-process-region (point-min) (point-max) - (or shell-file-name "/bin/sh") - t (current-buffer) nil - "-c" pop3-md5-program) - ;; The meaningful output is the first 32 characters. - ;; Don't return the newline that follows them! - (buffer-substring (point-min) (+ (point-min) 32)))) + (pop3-send-command process (format "PASS %s" pop3-password)) + (let ((response (pop3-read-response process t))) + (if (not (and response (string-match "+OK" response))) + (pop3-quit process)))) (defun pop3-apop (process user) "Send alternate authentication information to the server." @@ -299,6 +286,20 @@ ;; TRANSACTION STATE +(defvar pop3-md5-program "md5" + "*Program to encode its input in MD5.") + +(defun pop3-md5 (string) + (with-temp-buffer + (insert string) + (call-process-region (point-min) (point-max) + (or shell-file-name "/bin/sh") + t (current-buffer) nil + "-c" pop3-md5-program) + ;; The meaningful output is the first 32 characters. + ;; Don't return the newline that follows them! + (buffer-substring (point-min) (+ (point-min) 32)))) + (defun pop3-stat (process) "Return the number of messages in the maildrop and the maildrop's size." (pop3-send-command process "STAT") @@ -321,12 +322,17 @@ (while (not (re-search-forward "^\\.\r\n" nil t)) (accept-process-output process 3) ;; bill@att.com ... to save wear and tear on the heap + ;; uncommented because the condensed version below is a problem for + ;; some. (if (> (buffer-size) 20000) (sleep-for 1)) (if (> (buffer-size) 50000) (sleep-for 1)) (if (> (buffer-size) 100000) (sleep-for 1)) (if (> (buffer-size) 200000) (sleep-for 1)) (if (> (buffer-size) 500000) (sleep-for 1)) ;; bill@att.com + ;; condensed into: + ;; (sometimes causes problems for really large messages.) +; (if (> (buffer-size) 20000) (sleep-for (/ (buffer-size) 20000))) (goto-char start)) (setq pop3-read-point (point-marker)) ;; this code does not seem to work for some POP servers...
--- a/lisp/gnus/score-mode.el Sat Feb 20 13:52:45 1999 +0000 +++ b/lisp/gnus/score-mode.el Sat Feb 20 14:05:57 1999 +0000 @@ -1,7 +1,7 @@ ;;; score-mode.el --- mode for editing Gnus score files ;; Copyright (C) 1996 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news, mail ;; This file is part of GNU Emacs. @@ -45,6 +45,12 @@ (define-key gnus-score-mode-map "\C-c\C-d" 'gnus-score-edit-insert-date) (define-key gnus-score-mode-map "\C-c\C-p" 'gnus-score-pretty-print)) +(defvar score-mode-syntax-table + (let ((table (copy-syntax-table lisp-mode-syntax-table))) + (modify-syntax-entry ?| "w" table) + table) + "Syntax table used in score-mode buffers.") + ;;;###autoload (defun gnus-score-mode () "Mode for editing Gnus score files. @@ -55,7 +61,7 @@ (kill-all-local-variables) (use-local-map gnus-score-mode-map) (gnus-score-make-menu-bar) - (set-syntax-table emacs-lisp-mode-syntax-table) + (set-syntax-table score-mode-syntax-table) (setq major-mode 'gnus-score-mode) (setq mode-name "Score") (lisp-mode-variables nil) @@ -83,7 +89,8 @@ (goto-char (point-min)) (let ((form (read (current-buffer)))) (erase-buffer) - (pp form (current-buffer))) + (let ((emacs-lisp-mode-syntax-table score-mode-syntax-table)) + (pp form (current-buffer)))) (goto-char (point-min))) (defun gnus-score-edit-exit ()