diff options
Diffstat (limited to 'lisp')
59 files changed, 6450 insertions, 4135 deletions
diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index c0ce2c5be9f..c777830a5a2 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -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 @@ If `gnus-visible-headers' is non-nil, this variable will be ignored." :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 @@ If this variable is non-nil, `gnus-ignored-headers' will be ignored." (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 @@ this list." (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 @@ longer (in lines) than that number. If it is a function, the function 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 @@ regexp. If it matches, the text in question is not a signature." (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 @@ asynchronously. The compressed face will be piped to this command." (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 @@ Esample: (_/*word*/_)." (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 @@ each invocation of the saving commands." :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 @@ LAST-FILE." (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 @@ If this form or function returns a string, this string will be used as 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 @@ The function is called from the article buffer." "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 @@ If you want to run a special decoding program like nkf, use this hook." (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 @@ Obsolete; use the face `gnus-signature-face' for customizations instead." (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 @@ Obsolete; use the face `gnus-signature-face' for customizations instead." (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 @@ Obsolete; use the face `gnus-signature-face' for customizations instead." (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 @@ Obsolete; use the face `gnus-signature-face' for customizations instead." ("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 @@ displayed by the first non-nil matching CONTENT face." ;;; 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 @@ Initialized from `text-mode-syntax-table.") (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 @@ Initialized from `text-mode-syntax-table.") 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 @@ Initialized from `text-mode-syntax-table.") 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 @@ always hide." (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 @@ always hide." (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 @@ always hide." (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 @@ always hide." (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 @@ always hide." (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 @@ always hide." 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 @@ always hide." (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 @@ always hide." (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))))) - - (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)))) + (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))))) (defun gnus-article-search-signature () "Search the current buffer for the signature separator. @@ -1142,7 +1228,8 @@ Put point at the beginning of the signature separator." (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 @@ means show, 0 means toggle." (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 @@ how much time has lapsed since DATE." 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 @@ how much time has lapsed since DATE." (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 @@ how much time has lapsed since DATE." ((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 @@ how much time has lapsed since DATE." 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 @@ how much time has lapsed since DATE." ;; 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 @@ function and want to see what the date was before converting." (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 @@ This format is defined by the `gnus-article-time-format' variable." (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 @@ This format is defined by the `gnus-article-time-format' variable." (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 @@ This format is defined by the `gnus-article-time-format' variable." "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 @@ Directory to save to is default to `gnus-article-save-directory'." (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 @@ Directory to save to is default to `gnus-article-save-directory'." (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 @@ Directory to save to is default to `gnus-article-save-directory'." (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 @@ The directory to save in defaults to `gnus-article-save-directory'." (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 @@ If variable `gnus-use-long-file-name' is non-nil, it is 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 @@ If variable `gnus-use-long-file-name' is non-nil, it is ["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 @@ If variable `gnus-use-long-file-name' is non-nil, it is ["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 @@ commands: (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 @@ commands: (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 @@ commands: (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 @@ If ALL-HEADERS is non-nil, no headers are hidden." (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 @@ If ALL-HEADERS is non-nil, no headers are hidden." (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 @@ If ALL-HEADERS is non-nil, no headers are hidden." ;; `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 @@ If ALL-HEADERS is non-nil, no headers are hidden." (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 @@ If ALL-HEADERS is non-nil, no headers are hidden." (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 ALL-HEADERS is non-nil, no headers are hidden." (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 @@ Argument LINES specifies lines to be scrolled down." (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 @@ Argument LINES specifies lines to be scrolled down." (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 @@ Argument LINES specifies lines to be scrolled down." "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 @@ Argument LINES specifies lines to be scrolled down." "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 @@ If given a prefix, show the hidden text instead." (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 @@ If given a prefix, show the hidden text instead." (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 @@ If given a prefix, show the hidden text instead." (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 @@ If given a prefix, show the hidden text instead." ((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 @@ If given a prefix, show the hidden text instead." ;; 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 @@ If given a prefix, show the hidden text instead." (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 @@ If given a prefix, show the hidden text instead." ;; 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 @@ If given a prefix, show the hidden text instead." (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 @@ This is an extended text-mode. \\{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 @@ This is an extended text-mode. (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 @@ groups." (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 @@ groups." (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 @@ groups." :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 @@ variable it the real callback function." ("^[^:]+:" ,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 @@ call it with the value of the `gnus-data' text property." (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 @@ specified by `gnus-button-alist'." (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 @@ forbidden in URL encoding." ;; 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 @@ forbidden in URL encoding." (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 @@ forbidden in URL encoding." (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 @@ forbidden in URL encoding." (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." diff --git a/lisp/gnus/gnus-async.el b/lisp/gnus/gnus-async.el index 5c8a5bf1b71..01d02a59cf6 100644 --- a/lisp/gnus/gnus-async.el +++ b/lisp/gnus/gnus-async.el @@ -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 @@ It should return non-nil if the article is to be prefetched." (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 @@ It should return non-nil if the article is to be prefetched." 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 @@ It should return non-nil if the article is to be prefetched." (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 @@ It should return non-nil if the article is to be prefetched." (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))) diff --git a/lisp/gnus/gnus-audio.el b/lisp/gnus/gnus-audio.el index e72804a3bc6..f3bb686d8c9 100644 --- a/lisp/gnus/gnus-audio.el +++ b/lisp/gnus/gnus-audio.el @@ -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") -(defvar gnus-audio-wav-player "/usr/local/bin/play" - "Executable program for playing WAV 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.") -;;; 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) diff --git a/lisp/gnus/gnus-bcklg.el b/lisp/gnus/gnus-bcklg.el index ead87fe19a3..323bb9ff041 100644 --- a/lisp/gnus/gnus-bcklg.el +++ b/lisp/gnus/gnus-bcklg.el @@ -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) diff --git a/lisp/gnus/gnus-cache.el b/lisp/gnus/gnus-cache.el index 3a7cd8df8b5..ce97a82a6ea 100644 --- a/lisp/gnus/gnus-cache.el +++ b/lisp/gnus/gnus-cache.el @@ -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 @@ variable to \"^nnml\"." (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 @@ variable to \"^nnml\"." 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 @@ variable to \"^nnml\"." (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 @@ variable to \"^nnml\"." 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 @@ Returns the list of articles entered." 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 @@ Returns the list of articles entered." 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 @@ Returns the list of articles removed." (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 @@ Returns the list of articles removed." (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 @@ Returns the list of articles removed." ;; 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 @@ Returns the list of articles removed." 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 @@ Returns the list of articles removed." (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 @@ $ emacs -batch -l ~/.emacs -l gnus -f gnus-jog-cache" "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 LOW, update the lower bound instead." (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 @@ If LOW, update the lower bound instead." (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 @@ If LOW, update the lower bound instead." ;; 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))) diff --git a/lisp/gnus/gnus-cite.el b/lisp/gnus/gnus-cite.el index 09d688c0416..b7093c99adc 100644 --- a/lisp/gnus/gnus-cite.el +++ b/lisp/gnus/gnus-cite.el @@ -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 @@ article has citations." :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 @@ Set it to nil to parse all articles." 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 @@ Set it to nil to parse all articles." (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 @@ The first regexp group should match the Supercite attribution." :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 @@ It is merged with the face for the cited text belonging to the attribution." '(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 @@ This should make it easier to see who wrote what." ;;; 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 @@ This should make it easier to see who wrote what." ;; 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 @@ Lines matching `gnus-cite-attribution-suffix' and perhaps (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 @@ See the documentation for `gnus-article-highlight-citation'. 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 @@ always hide." (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 @@ always hide." (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 @@ percent and at least `gnus-cite-hide-absolute' lines of the body is 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 @@ See also the documentation for `gnus-article-highlight-citation'." (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 @@ See also the documentation for `gnus-article-highlight-citation'." (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 @@ See also the documentation for `gnus-article-highlight-citation'." ;; 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 @@ See also the documentation for `gnus-article-highlight-citation'." (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 @@ See also the documentation for `gnus-article-highlight-citation'." (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) diff --git a/lisp/gnus/gnus-cus.el b/lisp/gnus/gnus-cus.el index 37c0bf955c3..025273b6add 100644 --- a/lisp/gnus/gnus-cus.el +++ b/lisp/gnus/gnus-cus.el @@ -51,7 +51,7 @@ if that value is non-nil." (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 @@ Which articles to display on entering the group. 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 @@ DOC is a documentation string for the parameter.") (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 @@ DOC is a documentation string for the parameter.") (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 @@ number will be marked as read and removed from the summary buffer. `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 @@ eh?"))) ,(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 @@ articles in the thread. (provide 'gnus-cus) ;;; gnus-cus.el ends here - diff --git a/lisp/gnus/gnus-demon.el b/lisp/gnus/gnus-demon.el index 0900784af84..58f26e85d51 100644 --- a/lisp/gnus/gnus-demon.el +++ b/lisp/gnus/gnus-demon.el @@ -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 @@ time Emacs has been idle for IDLE `gnus-demon-timestep's." (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 @@ time Emacs has been idle for IDLE `gnus-demon-timestep's." "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 @@ time Emacs has been idle for IDLE `gnus-demon-timestep's." (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 @@ time Emacs has been idle for IDLE `gnus-demon-timestep's." (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 @@ time Emacs has been idle for IDLE `gnus-demon-timestep's." (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 @@ time Emacs has been idle for IDLE `gnus-demon-timestep's." (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." diff --git a/lisp/gnus/gnus-dup.el b/lisp/gnus/gnus-dup.el index dd0bce1f051..ac0ac315fb1 100644 --- a/lisp/gnus/gnus-dup.el +++ b/lisp/gnus/gnus-dup.el @@ -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 @@ seen in the same session." (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)) diff --git a/lisp/gnus/gnus-eform.el b/lisp/gnus/gnus-eform.el index b8df3d3c89e..6a93242feaf 100644 --- a/lisp/gnus/gnus-eform.el +++ b/lisp/gnus/gnus-eform.el @@ -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-done-function nil) (defvar gnus-edit-form-buffer "*Gnus edit form*") +(defvar gnus-edit-form-done-function nil) (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 @@ It is a slightly enhanced emacs-lisp-mode. (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) diff --git a/lisp/gnus/gnus-ems.el b/lisp/gnus/gnus-ems.el index f2eae20dd1a..39bb98d1d5f 100644 --- a/lisp/gnus/gnus-ems.el +++ b/lisp/gnus/gnus-ems.el @@ -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: diff --git a/lisp/gnus/gnus-gl.el b/lisp/gnus/gnus-gl.el index 786cda40b86..93ef91564a4 100644 --- a/lisp/gnus/gnus-gl.el +++ b/lisp/gnus/gnus-gl.el @@ -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 @@ If this times out we give up and assume that something has died..." ) (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 @@ If this times out we give up and assume that something has died..." ) ;;;; 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 @@ If this times out we give up and assume that something has died..." ) (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 @@ If this times out we give up and assume that something has died..." ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (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 @@ recommend using both scores and grouplens predictions together." (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 @@ recommend using both scores and grouplens predictions together." 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 @@ recommend using both scores and grouplens predictions together." (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 @@ recommend using both scores and grouplens predictions together." '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 @@ recommend using both scores and grouplens predictions together." (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) diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index 5caa86ec704..4eea2c01923 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -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 @@ unread articles in the groups. 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 @@ variable." :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 @@ variable." (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 @@ variable." 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 @@ ticked: The number of ticked articles." "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 @@ ticked: The number of ticked articles." (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 @@ ticked: The number of ticked articles." ["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 @@ The following commands are available: (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 @@ The following commands are available: (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 @@ If REGEXP, only list groups matching REGEXP." (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 @@ If REGEXP, only list groups matching REGEXP." (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 @@ If REGEXP, only list groups matching REGEXP." 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 @@ If REGEXP, only list groups matching REGEXP." (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 @@ If REGEXP, only list groups matching REGEXP." (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 @@ already." 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 @@ already." (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 @@ already." (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 @@ already." (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 @@ already." (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 @@ already." (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 @@ Take into consideration N (the prefix) and the list of marked groups." (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 @@ Take into consideration N (the prefix) and the list of marked groups." (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 @@ group." (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 @@ If ALL is a number, fetch this number of articles." "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 @@ be permanent." 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 @@ be permanent." 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 @@ Return the name of the group is selection was successful." (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 @@ Return the name of the group is selection was successful." (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 @@ ADDRESS." (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 @@ and NEW-NAME will be prompted for." (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 @@ and NEW-NAME will be prompted for." (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 @@ and NEW-NAME will be prompted for." "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 @@ If REVERSE, sort in reverse order." (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 @@ If REVERSE, sort in reverse order." (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 @@ or nil if no action could be taken." (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 @@ group line." '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 @@ of groups killed." (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 @@ entail asking the server for the groups." (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 @@ re-scanning. If ARG is non-nil and not a number, this will force \"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 @@ re-scanning. If ARG is non-nil and not a number, this will force (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 @@ If N is negative, this group and the N-1 previous groups will be checked." (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 @@ to use." (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 @@ to use." (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 @@ to use." (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 @@ group." (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 @@ If GROUP, edit that local kill file instead." 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 @@ The hook `gnus-exit-gnus-hook' is called before actually exiting." (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 @@ The hook `gnus-exit-gnus-hook' is called before actually exiting." ;; 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 @@ The hook `gnus-exit-gnus-hook' is called before actually exiting." (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 @@ and the second element is the address." ;; 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 @@ and the second element is the address." (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 @@ or `gnus-group-catchup-group-hook'." (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." diff --git a/lisp/gnus/gnus-int.el b/lisp/gnus/gnus-int.el index b11ad1a01a0..d441a1b6287 100644 --- a/lisp/gnus/gnus-int.el +++ b/lisp/gnus/gnus-int.el @@ -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 @@ If CONFIRM is non-nil, the user will be asked for an NNTP server." (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 @@ If it is down, start it up (again)." (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 @@ If it is down, start it up (again)." (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 @@ If it is down, start it up (again)." ;;; 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 @@ If it is down, start it up (again)." 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-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-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-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-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 (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 (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 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))))) - -(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-status-message (method) - "Return the status message from METHOD. -If METHOD is a string, it is interpreted as a group name. The method + (funcall func date (nth 1 gnus-command-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 (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)))) - -(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-group (group &optional dont-check 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 (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 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)))) - -(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))) + (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-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 @@ If BUFFER, insert the article in that group." ;; 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 @@ If BUFFER, insert the article in that group." (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)))) + (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-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))) - -(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)))) - -(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-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))) + +(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 @@ If GROUP is nil, all groups on METHOD are scanned." 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) diff --git a/lisp/gnus/gnus-kill.el b/lisp/gnus/gnus-kill.el index f2fad665805..3ca8b20f08f 100644 --- a/lisp/gnus/gnus-kill.el +++ b/lisp/gnus/gnus-kill.el @@ -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 @@ gnus-kill-file-mode-hook with no arguments, if that value is non-nil." (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 @@ Returns the number of articles marked as read." () (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 @@ Returns the number of articles marked as read." (?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 @@ COMMAND must be a lisp expression or a string representing a key sequence." (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 @@ marked as read or ticked are ignored." ;;;###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 @@ score the alt hierarchy, you'd say \"!alt.all\"." (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 @@ score the alt hierarchy, you'd say \"!alt.all\"." (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)))) diff --git a/lisp/gnus/gnus-logic.el b/lisp/gnus/gnus-logic.el index 106fde52c81..a6028352bf5 100644 --- a/lisp/gnus/gnus-logic.el +++ b/lisp/gnus/gnus-logic.el @@ -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)) diff --git a/lisp/gnus/gnus-mh.el b/lisp/gnus/gnus-mh.el index 0cf74b11e9d..fa01f5aa074 100644 --- a/lisp/gnus/gnus-mh.el +++ b/lisp/gnus/gnus-mh.el @@ -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 @@ Optional argument FOLDER specifies folder name." (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 diff --git a/lisp/gnus/gnus-move.el b/lisp/gnus/gnus-move.el index f00fb3b5ac1..b461952185e 100644 --- a/lisp/gnus/gnus-move.el +++ b/lisp/gnus/gnus-move.el @@ -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 @@ Update the .newsrc.eld file to reflect the change of nntp server." (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 diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el index fc94bb2d2a8..23653e54e14 100644 --- a/lisp/gnus/gnus-msg.el +++ b/lisp/gnus/gnus-msg.el @@ -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. -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 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. + +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 @@ the group.") (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 @@ the second with the current group name.") (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 @@ Thank you for your help in stamping out bugs. (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 @@ Thank you for your help in stamping out bugs. (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 @@ Thank you for your help in stamping out bugs. 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 @@ If ARG is 1, prompt for a group name." (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 @@ If prefix argument YANK is non-nil, original article is yanked automatically." (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 @@ If prefix argument YANK is non-nil, original article is yanked automatically." (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 @@ If prefix argument YANK is non-nil, original article is yanked automatically." 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 @@ header line with the old Message-ID." (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 @@ header line with the old Message-ID." ;; 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 @@ header line with the old Message-ID." (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 @@ header line with the old Message-ID." (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 SILENT, don't prompt the user." ;; 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 @@ If SILENT, don't prompt the user." (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 @@ If SILENT, don't prompt the user." ;;; 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 @@ If SILENT, don't prompt the user." ;; 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 @@ If SILENT, don't prompt the user." (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 @@ If SILENT, don't prompt the user." (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 @@ automatically." (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 @@ The original article will be yanked." "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 @@ The current group name will be inserted at \"%s\".") (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 @@ If YANK is non-nil, include the original article." (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 @@ The source file has to be in the Emacs load path." "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 @@ The source file has to be in the Emacs load path." (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 @@ this is a reply." "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 @@ this is a reply." (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 @@ this is a reply." (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 @@ this is a reply." (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 @@ this is a reply." (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)))))) - -(gnus-add-shutdown 'gnus-inews-close 'gnus) - -(defun gnus-inews-close () - (setq gnus-inews-sent-ids nil)) +;;; Posting styles. + +(defvar gnus-message-style-insertions nil) + +(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-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. diff --git a/lisp/gnus/gnus-mule.el b/lisp/gnus/gnus-mule.el index 2a149bef3f9..4d22cecc169 100644 --- a/lisp/gnus/gnus-mule.el +++ b/lisp/gnus/gnus-mule.el @@ -125,12 +125,15 @@ coding-system for reading and writing respectively." ;; 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 @@ coding-system for reading and writing respectively." 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) diff --git a/lisp/gnus/gnus-nocem.el b/lisp/gnus/gnus-nocem.el index 637743a50a7..1020c729880 100644 --- a/lisp/gnus/gnus-nocem.el +++ b/lisp/gnus/gnus-nocem.el @@ -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 @@ matches an previously scanned and verified nocem message." "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 @@ active file." (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 @@ active file." (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 @@ active file." (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) diff --git a/lisp/gnus/gnus-range.el b/lisp/gnus/gnus-range.el index 6b86f4df3ca..71684707de3 100644 --- a/lisp/gnus/gnus-range.el +++ b/lisp/gnus/gnus-range.el @@ -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)) diff --git a/lisp/gnus/gnus-salt.el b/lisp/gnus/gnus-salt.el index 1f680e29416..73d949fc22f 100644 --- a/lisp/gnus/gnus-salt.el +++ b/lisp/gnus/gnus-salt.el @@ -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 @@ It accepts the same format specs that `gnus-summary-line-format' does." (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 @@ It accepts the same format specs that `gnus-summary-line-format' does." ["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 @@ It accepts the same format specs that `gnus-summary-line-format' does." (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 @@ If given a prefix, mark all unpicked articles as read." (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 @@ This must be bound to a button-down mouse event." (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 @@ This must be bound to a button-down mouse event." ;; 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)) - - (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))))))))))) + (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))))))))))) (when (consp event) (let ((fun (key-binding (vector (car event))))) ;; Run the binding of the terminating up-event, if possible. @@ -336,7 +351,7 @@ This must be bound to a button-down mouse event." (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 @@ This must be bound to a button-down mouse event." "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 @@ Two predefined functions are available: (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 @@ Two predefined functions are available: (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 @@ Two predefined functions are available: (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 @@ Two predefined functions are available: (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 @@ Two predefined functions are available: (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 @@ Two predefined functions are available: (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 @@ The following commands are available: (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)))) diff --git a/lisp/gnus/gnus-score.el b/lisp/gnus/gnus-score.el index 19c9c3ae51e..31b3017d833 100644 --- a/lisp/gnus/gnus-score.el +++ b/lisp/gnus/gnus-score.el @@ -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 @@ See the documentation to these functions for more information. 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 @@ score alists." (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 @@ It can be: :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 @@ This variable allows the same syntax as `gnus-home-score-file'." :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 @@ This variable allows the same syntax as `gnus-home-score-file'." (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 @@ This variable allows the same syntax as `gnus-home-score-file'." "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 @@ This variable allows the same syntax as `gnus-home-score-file'." (,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 @@ Should be one of the following symbols. 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 @@ If nil, the user will be asked for a match type." (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 @@ If nil, the user will be asked for a duration." :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 @@ of the last successful match.") (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 @@ of the last successful match.") ;; 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 @@ used as score." (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 @@ used as score." (?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 @@ used as score." (?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 @@ used as score." ;; 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 @@ used as score." (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 @@ used as score." 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 @@ SCORE is the score to add. 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 @@ If optional argument `SILENT' is nil, show effect of score entry." (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 @@ SCORE is the score to add." "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 @@ SCORE is the score to add." (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 @@ SCORE is the score to add." (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 @@ SCORE is the score to add." (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 @@ SCORE is the score to add." (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 @@ SCORE is the score to add." ;; 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 @@ SCORE is the score to add." 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 @@ SCORE is the score to add." (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 @@ SCORE is the score to add." (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 @@ SCORE is the score to add." (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 @@ SCORE is the score to add." (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 @@ SCORE is the score to add." 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 @@ SCORE is the score to add." (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 @@ SCORE is the score to add." ;; 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 @@ SCORE is the score to add." (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 @@ SCORE is the score to add." 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 @@ SCORE is the score to add." (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 @@ SCORE is the score to add." (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 @@ SCORE is the score to add." 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 @@ SCORE is the score to add." 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 @@ SCORE is the score to add." (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 @@ SCORE is the score to add." (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 @@ SCORE is the score to add." (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 @@ SCORE is the score to add." (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 @@ SCORE is the score to add." (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 @@ SCORE is the score to add." (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 @@ SCORE is the score to add." ;; 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 @@ SCORE is the score to add." 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 @@ SCORE is the score to add." (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 @@ GROUP using BNews sys file syntax." (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 @@ Destroys the current buffer." 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 @@ The list is determined from the variable gnus-score-file-alist." (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 @@ The list is determined from the variable gnus-score-file-alist." ((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 @@ The list is determined from the variable gnus-score-file-alist." (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 @@ If ADAPT, return the home adaptive file instead." (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 @@ If ADAPT, return the home adaptive file instead." (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 @@ If ADAPT, return the home adaptive file instead." ;; 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 diff --git a/lisp/gnus/gnus-soup.el b/lisp/gnus/gnus-soup.el index 2143f9dc437..09b58a7c8a3 100644 --- a/lisp/gnus/gnus-soup.el +++ b/lisp/gnus/gnus-soup.el @@ -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 a negative number, add the N previous articles. 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 @@ move those articles instead." (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 matching on group names. 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 @@ If NOT-ALL, don't pack ticked articles." (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 @@ The vector contain five strings, [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 @@ Return whether the unpacking was successful." ".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 @@ Return whether the unpacking was successful." t) (t (buffer-disable-undo msg-buf) - (buffer-disable-undo tmp-buf) (set-buffer msg-buf) (goto-char (point-min)) (while (not (eobp)) diff --git a/lisp/gnus/gnus-spec.el b/lisp/gnus/gnus-spec.el index df440c97b3b..403b5169583 100644 --- a/lisp/gnus/gnus-spec.el +++ b/lisp/gnus/gnus-spec.el @@ -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 @@ If PROPS, insert the result." (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 @@ If PROPS, insert the result." (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 diff --git a/lisp/gnus/gnus-srvr.el b/lisp/gnus/gnus-srvr.el index 05fb4ae18a0..dc3dd1a6fdb 100644 --- a/lisp/gnus/gnus-srvr.el +++ b/lisp/gnus/gnus-srvr.el @@ -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: + +%h backend +%n name +%w address +%s status") -(defvar gnus-server-mode-line-format "Gnus List of servers" +(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 @@ with some simple extensions.") (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 @@ with some simple extensions.") ["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 @@ with some simple extensions.") (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 - - "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 + (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 + + "g" gnus-server-regenerate-server "\C-c\C-i" gnus-info-find-node "\C-c\C-b" gnus-bug)) @@ -158,13 +166,13 @@ The following commands are available: (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 @@ The following commands are available: (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 @@ The following commands are available: "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 @@ The following commands are available: ;; 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 @@ The following commands are available: (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 @@ The following commands are available: (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 @@ The following commands are available: (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 @@ The following commands are available: '("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 @@ The following commands are available: 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 @@ The following commands are available: (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 @@ buffer. (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 @@ buffer. ;; 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)) diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el index f2f41ad9bbd..01c75bbf395 100644 --- a/lisp/gnus/gnus-start.el +++ b/lisp/gnus/gnus-start.el @@ -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 @@ If a file with the `.el' or `.elc' suffixes exists, it will be read instead." (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 @@ saved will be used." :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 @@ might take a while. By setting this variable to nil, you'll save time, 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 @@ not match this regexp will be removed before saving the list." "[][\"#'()]" ; 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 @@ for your decision; `gnus-subscribe-killed' kills all new groups; (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 @@ hierarchy in its entirety." :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 @@ This hook is called after Gnus is connected to the NNTP server." :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 @@ This hook is called after Gnus is connected to the NNTP server." (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 @@ Can be used to turn version control on or off." :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 @@ Can be used to turn version control on or off." (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 @@ Can be used to turn version control on or off." (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 @@ the first newsgroup." (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 @@ the first newsgroup." 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 @@ the first newsgroup." (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 @@ startup level. If ARG is non-nil and not a positive number, Gnus will 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 @@ prompt the user for the name of an NNTP server to use." (> arg 0) (max (car gnus-group-list-mode) arg)))) - (gnus-splash) (gnus-clear-system) + (gnus-splash) + (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 @@ prompt the user for the name of an NNTP server to use." (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 @@ prompt the user for the name of an NNTP server to use." ;; 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 @@ prompt the user for the name of an NNTP server to use." (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 @@ prompt the user for the name of an NNTP server to use." (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 @@ prompt the user for the name of an NNTP server to use." (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 @@ If LEVEL is non-nil, the news will be set up at level LEVEL." ;; 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 @@ If LEVEL is non-nil, the news will be set up at level LEVEL." ;; 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 @@ If LEVEL is non-nil, the news will be set up at level LEVEL." "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 @@ for new groups." (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 @@ for new groups." 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 @@ for new groups." (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 @@ newsgroup." (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 @@ newsgroup." 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 @@ newsgroup." ;; 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 @@ newsgroup." 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 @@ newsgroup." (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 @@ newsgroup." (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 @@ newsgroup." (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 @@ newsgroup." (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 @@ newsgroup." (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 FORCE is non-nil, the .newsrc file is read." (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 @@ If FORCE is non-nil, the .newsrc file is read." (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 @@ If FORCE is non-nil, the .newsrc file is read." (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 @@ If FORCE is non-nil, the .newsrc file is read." (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 @@ If FORCE is non-nil, the .newsrc file is read." (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 @@ If FORCE is non-nil, the .newsrc file is read." (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 FORCE is non-nil, the .newsrc file is read." (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 @@ If FORCE is non-nil, the .newsrc file is read." ;;; 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 @@ If FORCE is non-nil, the .newsrc file is read." () ; 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 @@ If FORCE is non-nil, the .newsrc file is read." (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") diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index d48cce763ab..8445b475db1 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -1,7 +1,7 @@ ;;; gnus-sum.el --- summary 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,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 @@ If an unread article in the group refers to an older, already read (or 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 @@ The server has to support NOV for any of this to work." 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 @@ comparing subjects." (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 @@ non-nil and non-`some', fill in all gaps that Gnus manages to guess." (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 @@ headers of the articles to find matches." (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 @@ to expose hidden threads." :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 @@ will go to the next group without confirmation." (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 @@ and non-`vertical', do both horizontal and vertical recentering." "*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 @@ The articles will simply be fed to the function given by "*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))) + :type '(repeat (choice (list :value (fun) function) + (cons :value ("" "") regexp (repeat string)) + (sexp :value nil)))) -(defcustom gnus-unread-mark ? +(defcustom gnus-unread-mark ? ;space "*Mark used for unread articles." :group 'gnus-summary-marks :type 'character) @@ -413,6 +435,21 @@ It uses the same syntax as the `gnus-split-methods' variable." :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 @@ It uses the same syntax as the `gnus-split-methods' variable." :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 @@ list of parameters to that command." :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 @@ with some simple extensions: %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 @@ Some functions you can use are `+', `max', or `min'." :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 @@ Some functions you can use are `+', `max', or `min'." (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 @@ If you want to modify the summary buffer, you can use this hook." :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 @@ is not run if `gnus-visual' is nil." :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 @@ automatically when it is selected." . 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 @@ automatically when it is selected." . 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 @@ mark: The articles mark." :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 @@ mark: The articles mark." (?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 @@ variable (string, integer, character, etc).") (?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 @@ variable (string, integer, character, etc).") (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 @@ variable (string, integer, character, etc).") 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 @@ variable (string, integer, character, etc).") ;; 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 @@ gnus-simplify-subject-fuzzy-regexp." (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 @@ See gnus-simplify-buffer-fuzzy for details." (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 @@ See gnus-simplify-buffer-fuzzy for details." 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 @@ increase the score of each group you read." " " 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 @@ increase the score of each group you read." "\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 @@ increase the score of each group you read." "\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 @@ increase the score of each group you read." "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 @@ increase the score of each group you read." [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 @@ increase the score of each group you read." "^" 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 @@ increase the score of each group you read." "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 @@ increase the score of each group you read." "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 @@ increase the score of each group you read." "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 @@ increase the score of each group you read." "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 @@ increase the score of each group you read." "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 the score of each group you read." ["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 @@ increase the score of each group you read." ["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 @@ increase the score of each group you read." '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 @@ increase the score of each group you read." ["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 @@ The following commands are available: (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 @@ The following commands are available: (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 @@ The following commands are available: (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 @@ article number." (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 @@ article number." ,(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 @@ article number." 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 @@ article number." (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 @@ This is all marks except unread, ticked, dormant, and expirable." (= 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 @@ This is all marks except unread, ticked, dormant, and expirable." ;; 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 @@ This is all marks except unread, ticked, dormant, and expirable." (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 @@ This is all marks except unread, ticked, dormant, and expirable." (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 @@ This is all marks except unread, ticked, dormant, and expirable." (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 @@ This is all marks except unread, ticked, dormant, and expirable." 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 @@ This is all marks except unread, ticked, dormant, and expirable." (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 @@ This is all marks except unread, ticked, dormant, and expirable." (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 @@ This is all marks except unread, ticked, dormant, and expirable." (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 @@ the thread are to be displayed." (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 @@ If NO-DISPLAY, don't generate a summary buffer." (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 @@ If NO-DISPLAY, don't generate a summary buffer." (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 @@ If NO-DISPLAY, don't generate a summary buffer." (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 @@ If NO-DISPLAY, don't generate a summary buffer." (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 @@ If NO-DISPLAY, don't generate a summary buffer." ((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 @@ If NO-DISPLAY, don't generate a summary buffer." (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 @@ If NO-DISPLAY, don't generate a summary buffer." ;; 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 @@ If NO-DISPLAY, don't generate a summary buffer." (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 @@ If NO-DISPLAY, don't generate a summary buffer." (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 @@ If NO-DISPLAY, don't generate a summary buffer." (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 @@ If NO-DISPLAY, don't generate a summary buffer." (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 @@ If NO-DISPLAY, don't generate a summary buffer." 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 @@ If NO-DISPLAY, don't generate a summary buffer." (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 @@ If NO-DISPLAY, don't generate a summary buffer." (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 @@ If NO-DISPLAY, don't generate a summary buffer." (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 @@ If NO-DISPLAY, don't generate a summary buffer." (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 @@ If NO-DISPLAY, don't generate a summary buffer." 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 @@ If NO-DISPLAY, don't generate a summary buffer." (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 @@ If NO-DISPLAY, don't generate a summary buffer." (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 @@ If NO-DISPLAY, don't generate a summary buffer." (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 @@ If NO-DISPLAY, don't generate a summary buffer." (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 NO-DISPLAY, don't generate a summary buffer." (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 NO-DISPLAY, don't generate a summary buffer." ;; 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 @@ If NO-DISPLAY, don't generate a summary buffer." "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 @@ Unscored articles will be counted as having a score of zero." (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 @@ or a straight list of headers." (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 @@ or a straight list of headers." (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 @@ or a straight list of headers." (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 @@ or a straight list of headers." (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 @@ or a straight list of headers." (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 @@ If READ-ALL is non-nil, all articles in the group are selected." (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 @@ If READ-ALL is non-nil, all articles in the group are selected." 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 @@ If READ-ALL is non-nil, all articles in the group are selected." (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 @@ If READ-ALL is non-nil, all articles in the group are selected." (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 @@ The resulting hash table is returned, or nil if no Xrefs were found." (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 @@ The resulting hash table is returned, or nil if no Xrefs were found." (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 @@ The resulting hash table is returned, or nil if no Xrefs were found." (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 @@ The resulting hash table is returned, or nil if no Xrefs were found." (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 @@ The resulting hash table is returned, or nil if no Xrefs were found." (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 @@ The resulting hash table is returned, or nil if no Xrefs were found." ;; 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 @@ The resulting hash table is returned, or nil if no Xrefs were found." (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 @@ The resulting hash table is returned, or nil if no Xrefs were found." (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 @@ list of headers that match SEQUENCE (see `nntp-retrieve-headers')." (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 @@ This is meant to be called in `gnus-article-internal-prepare-hook'." (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 @@ This is meant to be called in `gnus-article-internal-prepare-hook'." (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 @@ This is meant to be called in `gnus-article-internal-prepare-hook'." ;;; 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 @@ If EXCLUDE-GROUP, do not go to this group." (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 EXCLUDE-GROUP, do not go to this group." (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 @@ displayed, no centering will be performed." ;; 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 @@ displayed, no centering will be performed." (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 @@ displayed, no centering will be performed." ;; 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 @@ With arg, turn line truncation on iff arg is positive." "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 @@ The prefix argument ALL means to select all articles." (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 @@ gnus-exit-group-hook is called with no arguments if that value is non-nil." (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-exit-group-hook is called with no arguments if that value is non-nil." (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-exit-group-hook is called with no arguments if that value is non-nil." (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 @@ gnus-exit-group-hook is called with no arguments if that value is non-nil." (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-exit-group-hook is called with no arguments if that value is non-nil." (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 @@ which existed when entering the ephemeral is reset." (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 @@ If prefix argument NO-ARTICLE is non-nil, no article is selected 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 @@ previous group instead." (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 @@ previous group instead." (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 @@ If prefix argument NO-ARTICLE is non-nil, no article is selected initially." ;; 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 @@ Returns the article selected or nil if there are no unread articles." (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 @@ returned." (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 @@ If FORCE, also allow jumping to articles not currently shown." ;; 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 @@ If FORCE, also allow jumping to articles not currently shown." (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 @@ If FORCE, also allow jumping to articles not currently shown." "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 @@ Given a prefix, will force an `article' buffer configuration." (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 UNREAD, only unread articles are selected. 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 @@ If BACKWARD, the previous article is selected instead of the next." (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 @@ article." (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 @@ Argument LINES specifies lines to be scrolled down. 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 @@ If at the beginning of the article, go to the next article." "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 @@ Argument LINES specifies lines to be scrolled up (or down if negative)." (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 @@ Return nil if there are no unread articles." "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 @@ Return nil if there are no articles." (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 @@ Return nil if there are no articles." (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 @@ If ALL-HEADERS is non-nil, no header lines are hidden." (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 @@ NUMBER articles will be popped off." (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 @@ NUMBER articles will be popped off." "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 @@ If not given a prefix, use the process marked articles instead." "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 @@ articles that are younger than AGE days." (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 @@ If REVERSE (the prefix), limit the summary buffer to articles that are 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 @@ Returns how many articles were removed." (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 @@ Returns how many articles were removed." (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 @@ Returns how many articles were removed." (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 @@ Returns how many articles were removed." (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 @@ If ALL, mark even excluded ticked and dormants as read." '<) (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 @@ If ALL, mark even excluded ticked and dormants as read." ;; 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 @@ If ALL, mark even excluded ticked and dormants as read." (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 @@ If ALL, mark even excluded ticked and dormants as read." (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 @@ fetch-old-headers verbiage, and so on." (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 @@ fetch-old-headers verbiage, and so on." (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 @@ fetch-old-headers verbiage, and so on." 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 @@ The difference between N and the number of articles fetched is returned." (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 @@ Return how many articles were fetched." (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 @@ or `gnus-select-method', no matter what backend the article comes from." (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 @@ or `gnus-select-method', no matter what backend the article comes from." ;; 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 @@ Obeys the standard process/prefix convention." "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 @@ If BACKWARD, search backward instead." (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 @@ article. If BACKWARD (the prefix) is non-nil, search backward instead." 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 @@ article. If BACKWARD (the prefix) is non-nil, search backward instead." (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 @@ article. If BACKWARD (the prefix) is non-nil, search backward instead." (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 @@ article. If BACKWARD (the prefix) is non-nil, search backward instead." (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. +(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 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 +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 @@ article massaging functions being run." 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 negative number, turn header display off." 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 @@ If ARG is a negative number, hide the unwanted header lines." (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 @@ If ARG is a positive number, turn MIME processing on." 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 @@ forward." (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 @@ and `request-accept' functions." (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 @@ and `request-accept' functions." ((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 @@ and `request-accept' functions." (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 @@ and `request-accept' functions." (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 @@ latter case, they will be copied into the relevant groups." (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 @@ latter case, they will be copied into the relevant groups." (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 @@ latter case, they will be copied into the relevant groups." (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 @@ This will be the case if the article has both been mailed and posted." (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 @@ This will be the case if the article has both been mailed and posted." ;; 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 @@ This will be the case if the article has both been mailed and posted." ;; 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 will be the case if the article has both been mailed and posted." 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 negative, delete backwards. 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 @@ groups." (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 @@ groups." ;;; 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 @@ groups." (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 @@ groups." 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 negative, tick articles." 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 @@ If N is negative, mark backward instead. If UNMARK is non-nil, remove 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 @@ number of articles marked is returned." (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 @@ the actual number of articles marked is returned." 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 @@ the actual number of articles marked is returned." (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 @@ the actual number of articles marked is returned." (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 @@ the actual number of articles marked is returned." 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 @@ the actual number of articles marked is returned." (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 @@ the actual number of articles marked is returned." (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 @@ If N is negative, mark backwards instead. Mark with MARK, ?r by default. 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 @@ returned." (= 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 @@ returned." (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)) + (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)) + ;; 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 @@ marked." (= 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 @@ marked." (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 @@ marked." (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)) + (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))) - (setq gnus-newsgroup-reads - (delq (assq article gnus-newsgroup-reads) - gnus-newsgroup-reads)))) + ;; 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 @@ even ticked and dormant ones." (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 @@ even ticked and dormant ones." (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 @@ even ticked and dormant ones." (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 @@ Note that this function will only catch up the unread article 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 @@ The number of articles marked as read is returned." (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 @@ The number of articles marked as read is returned." "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 @@ If ALL is non-nil, also mark ticked and dormant articles as read." (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 prefix argument ALL is non-nil, all articles are marked as read." 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 @@ with that article." (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 @@ is non-nil or the Subject: of both articles are the same." (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 @@ is non-nil or the Subject: of both articles are the same." (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 @@ is non-nil or the Subject: of both articles are the same." "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 @@ If ARG is positive number, turn showing conversation threads on." (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 @@ If ARG is positive number, turn showing conversation threads on." "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 @@ Returns nil if no thread was there to be shown." (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 @@ Returns nil if no thread was there to be shown." "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 @@ done. 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 @@ If SILENT, don't output messages." 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 @@ If N is negative, go up instead. 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 @@ If N is negative, go up instead. 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 @@ taken." 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 @@ Argument REVERSE means reverse order." (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 @@ If N is nil and any articles have been marked with the process mark, 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 a negative number, pipe the N previous articles. 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 a negative number, save the N previous articles. 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 a negative number, save the N previous articles. 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 a negative number, save the N previous articles. 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 a negative number, save the N previous articles. 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 a negative number, save the N previous articles. 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 @@ save those articles instead." (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 @@ save those articles instead." (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 @@ save those articles instead." (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 @@ save those articles instead." (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 @@ save those articles instead." (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 @@ save those articles instead." (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) diff --git a/lisp/gnus/gnus-topic.el b/lisp/gnus/gnus-topic.el index 413a43f53a6..26b91f8072f 100644 --- a/lisp/gnus/gnus-topic.el +++ b/lisp/gnus/gnus-topic.el @@ -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 @@ with some simple extensions. (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 @@ with some simple extensions. (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 @@ with some simple extensions. (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 @@ with some simple extensions. (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 @@ with some simple extensions. 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 @@ with some simple extensions. (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 @@ with some simple extensions. ;;; 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 @@ If LOWEST is non-nil, list all newsgroups of level LOWEST or higher." (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 LOWEST is non-nil, list all newsgroups of level LOWEST or higher." (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 @@ articles in the topic and its subtopics." (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 @@ articles in the topic and its subtopics." (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 @@ articles in the topic and its subtopics." (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 @@ articles in the topic and its subtopics." (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 @@ articles in the topic and its subtopics." '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 @@ articles in the topic and its subtopics." (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 @@ articles in the topic and its subtopics." (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 @@ articles in the topic and its subtopics." "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 @@ articles in the topic and its subtopics." "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 @@ articles in the topic and its subtopics." "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 @@ articles in the topic and its subtopics." (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 @@ articles in the topic and its subtopics." ;; 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 COPYP, copy the groups instead." (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 @@ If COPYP, copy the groups instead." (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 @@ If COPYP, copy the groups instead." (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 @@ If FORCE, always re-read the active file." (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." diff --git a/lisp/gnus/gnus-undo.el b/lisp/gnus/gnus-undo.el index b34070a3373..624b34a9916 100644 --- a/lisp/gnus/gnus-undo.el +++ b/lisp/gnus/gnus-undo.el @@ -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) + +(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 nil - "Minor mode for undoing in Gnus buffers.") +(defcustom gnus-undo-mode nil + "Minor mode for undoing in Gnus buffers." + :type 'boolean + :group 'gnus-undo) -(defvar gnus-undo-mode-hook nil - "Hook called in all `gnus-undo-mode' buffers.") +(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 @@ FORMS may use backtick quote syntax." ;; 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) diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index ee863a01cc3..8885fbd8719 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -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 @@ Cache the result as a text property stored in DATE." "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 @@ jabbering all the time." 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 @@ If N, return the Nth ancestor instead." (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 @@ Timezone package is used." (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 @@ Timezone package is used." (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 @@ Timezone package is used." (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 @@ Bind `print-quoted' to t while printing." ;; 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 @@ Bind `print-quoted' to t while printing." (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 @@ with potentially long computations." (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 @@ with potentially long computations." (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 diff --git a/lisp/gnus/gnus-uu.el b/lisp/gnus/gnus-uu.el index 48c502d251d..abea681013a 100644 --- a/lisp/gnus/gnus-uu.el +++ b/lisp/gnus/gnus-uu.el @@ -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 @@ details." (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 @@ details." ("\\.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 @@ so I simply dropped them." :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 @@ didn't work, and overwrite existing files. Otherwise, ask each time." (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 @@ didn't work, and overwrite existing files. Otherwise, ask each time." ;"^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 @@ didn't work, and overwrite existing files. Otherwise, ask each time." "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 @@ didn't work, and overwrite existing files. Otherwise, ask each time." (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 @@ didn't work, and overwrite existing files. Otherwise, ask each time." (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 @@ didn't work, and overwrite existing files. Otherwise, ask each time." (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 @@ didn't work, and overwrite existing files. Otherwise, ask each time." (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 @@ didn't work, and overwrite existing files. Otherwise, ask each time." (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 @@ didn't work, and overwrite existing files. Otherwise, ask each time." (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 @@ didn't work, and overwrite existing files. Otherwise, ask each time." (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 @@ didn't work, and overwrite existing files. Otherwise, ask each time." (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 @@ didn't work, and overwrite existing files. Otherwise, ask each time." (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 @@ didn't work, and overwrite existing files. Otherwise, ask each time." (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 @@ didn't work, and overwrite existing files. Otherwise, ask each time." (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 @@ didn't work, and overwrite existing files. Otherwise, ask each time." (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 @@ didn't work, and overwrite existing files. Otherwise, ask each time." (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 @@ didn't work, and overwrite existing files. Otherwise, ask each time." (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 @@ didn't work, and overwrite existing files. Otherwise, ask each time." (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 @@ didn't work, and overwrite existing files. Otherwise, ask each time." ;; 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 @@ didn't work, and overwrite existing files. Otherwise, ask each time." (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 @@ didn't work, and overwrite existing files. Otherwise, ask each time." (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) - (goto-char (point-min)) - (when (looking-at vernum) - (replace-match vernum t t) - (setq beg (length vernum))) + (setq case-fold-search nil) - (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]+/\\([0-9]+\\)" nil t) + (replace-match "\\1[0-9]+/\\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]+[ \t]*of[ \t]*\\([0-9]+\\)" + nil t) + (replace-match "\\1[0-9]+ of \\2") - (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 beg) - (while (re-search-forward "[ \t]+" nil t) - (replace-match "[ \t]*" t t)) + (goto-char 1) + (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 @@ didn't work, and overwrite existing files. Otherwise, ask each time." (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 @@ didn't work, and overwrite existing files. Otherwise, ask each time." (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 @@ didn't work, and overwrite existing files. Otherwise, ask each time." (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 @@ didn't work, and overwrite existing files. Otherwise, ask each time." (not (memq 'end process-state)))) (setq article (pop articles)) - (push article article-series) - - (unless articles - (if (eq state 'first) - (setq state 'first-and-last) - (setq state 'last))) + (when (vectorp (gnus-summary-article-header article)) + (push article article-series) - (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) + (unless articles + (if (eq state 'first) + (setq state 'first-and-last) + (setq state 'last))) - ;; 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) - - ;; 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))) - - ;; 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)) - - ;; 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))) + (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) - ;; 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)))) + ;; 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) + + ;; 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))) + + ;; 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)) + + ;; 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))))) result-files)) @@ -1355,11 +1350,18 @@ didn't work, and overwrite existing files. Otherwise, ask each time." (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 @@ didn't work, and overwrite existing files. Otherwise, ask each time." (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 @@ didn't work, and overwrite existing files. Otherwise, ask each time." ;; 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 @@ didn't work, and overwrite existing files. Otherwise, ask each time." (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 @@ didn't work, and overwrite existing files. Otherwise, ask each time." (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 @@ didn't work, and overwrite existing files. Otherwise, ask each time." (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 @@ The user will be asked for a file name." ;; 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 @@ If no file has been included, the user will be asked for a file." (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 @@ If no file has been included, the user will be asked for a file." (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 @@ If no file has been included, the user will be asked for a file." (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 @@ If no file has been included, the user will be asked for a file." (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 @@ If no file has been included, the user will be asked for a file." (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) diff --git a/lisp/gnus/gnus-vm.el b/lisp/gnus/gnus-vm.el index 8e83dbea95a..bbefaaca5f9 100644 --- a/lisp/gnus/gnus-vm.el +++ b/lisp/gnus/gnus-vm.el @@ -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 @@ save those articles instead." (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 diff --git a/lisp/gnus/gnus-win.el b/lisp/gnus/gnus-win.el index 59a80e984f1..ea0d65ddd11 100644 --- a/lisp/gnus/gnus-win.el +++ b/lisp/gnus/gnus-win.el @@ -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 @@ See the Gnus manual for an explanation of the syntax used.") (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 @@ See the Gnus manual for an explanation of the syntax used.") "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 @@ See the Gnus manual for an explanation of the syntax used.") (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 @@ See the Gnus manual for an explanation of the syntax used.") ;; 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 @@ See the Gnus manual for an explanation of the syntax used.") (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 @@ should have point." (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 @@ should have point." (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) diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index e1368c61d72..a59c3873890 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -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 @@ is restarted, and sometimes reloaded." :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 @@ be set in `.emacs' instead." (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 @@ be set in `.emacs' instead." (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 @@ be set in `.emacs' instead." "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 @@ be set in `.emacs' instead." (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 @@ be set in `.emacs' instead." (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 @@ All other Gnus path variables are initialized from this variable." (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 @@ used to 899, you would say something along these lines: (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 @@ used to 899, you would say something along these lines: 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 @@ see the manual for details." ,(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 @@ that case, just return a fully prefixed name of the group -- \"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 @@ in the documentation of `gnus-select-method'." "/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 @@ articles. This is not a good idea." (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 @@ required." (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 @@ slower." ("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 @@ It is called with three parameters -- GROUP, LEVEL and OLDLEVEL." 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 @@ and `grouplens-menu'." '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 @@ face." 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 @@ want." :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 @@ want." ;; 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 @@ want." (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 @@ want." (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 @@ want." (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 @@ gnus-newsrc-hashtb should be kept so that both hold the same information.") ("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 @@ gnus-newsrc-hashtb should be kept so that both hold the same information.") 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-newsrc-hashtb should be kept so that both hold the same information.") 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-newsrc-hashtb should be kept so that both hold the same information.") 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-newsrc-hashtb should be kept so that both hold the same information.") 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-newsrc-hashtb should be kept so that both hold the same information.") ("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-newsrc-hashtb should be kept so that both hold the same information.") 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-newsrc-hashtb should be kept so that both hold the same information.") ("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 @@ with some simple extensions. %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 @@ This restriction may disappear in later versions of Gnus." (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 @@ This restriction may disappear in later versions of Gnus." "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 @@ This restriction may disappear in later versions of Gnus." ;;; 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 @@ STRINGS will be evaluated in normal `or' order." (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 @@ If ARG, insert string at point." (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 @@ If ARG, insert string at point." (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 @@ that that variable is buffer-local to the summary buffers." "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 @@ that that variable is buffer-local to the summary buffers." (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 @@ that that variable is buffer-local to the summary buffers." (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 @@ that that variable is buffer-local to the summary buffers." (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 @@ You should probably use `gnus-find-method-for-group' instead." (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 @@ You should probably use `gnus-find-method-for-group' instead." "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 @@ If SYMBOL, return the value of that symbol in the group parameters." (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 @@ If SCORE is nil, add 1 to the score of GROUP." "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 @@ Disallow illegal group names." (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 @@ Allow completion over sensible values." (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 @@ Allow completion over sensible values." ;;;###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)) diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index f539a86ed41..7204669fb86 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -1,7 +1,7 @@ ;;; message.el --- composing mail and news messages -;; 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. @@ -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 @@ Otherwise, most addresses look like `angles', but they look like :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 @@ Don't touch this variable unless you really know what you're doing. 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 @@ header, remove it from this list." (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 @@ included. Organization, Lines and X-Mailer are optional." :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 @@ any confusion." :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 @@ any confusion." :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 @@ nil means let mailer mail back a message to report errors." :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 @@ If t, use `message-user-organization-file'." :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 @@ If nil, message won't auto-save." :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 @@ The headers should be delimited by a line whose contents match the 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 @@ might set this variable to '(\"-f\" \"you@some.where\")." (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 @@ the signature is inserted." :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 @@ Used by `message-yank-original' via `message-yank-cite'." :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 @@ If stringp, use this; if non-nil, use no host name (user name only)." (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 @@ articles." ;; 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 prefix.") 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 @@ Defaults to `text-mode-abbrev-table'.") (defface message-header-other-face '((((class color) (background dark)) - (:foreground "red4")) + (:foreground "#b00000")) (((class color) (background light)) (:foreground "steel blue")) @@ -720,7 +755,7 @@ Defaults to `text-mode-abbrev-table'.") (defface message-separator-face '((((class color) (background dark)) - (:foreground "blue4")) + (:foreground "blue3")) (((class color) (background light)) (:foreground "brown")) @@ -763,14 +798,21 @@ Defaults to `text-mode-abbrev-table'.") (,(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 @@ The cdr of ech entry is a function for applying the face to a region.") :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 @@ The cdr of ech entry is a function for applying the face to a region.") "\\(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 @@ The cdr of ech entry is a function for applying the face to a region.") (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 @@ The cdr of ech entry is a function for applying the face to a region.") (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 @@ The cdr of ech entry is a function for applying the face to a region.") "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 REGEXP, HEADER is a regular expression. 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 @@ Return the number of headers removed." (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 @@ Return the number of headers removed." (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 @@ Return the number of headers removed." ["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-w message-insert-signature (insert `message-signature-file' file). 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 @@ C-c C-r message-caesar-buffer-body (rot13 the message body)." ;; 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 @@ C-c C-r message-caesar-buffer-body (rot13 the message body)." (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 @@ C-c C-r message-caesar-buffer-body (rot13 the message body)." (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 @@ With the prefix argument FORCE, insert the header anyway." ;;; 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 @@ With the prefix argument FORCE, insert the header anyway." (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 @@ message-elide-elipsis) will be inserted where the text was killed." (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, rather than giving an automatic name." (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 @@ prefix, and don't delete any headers." (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 @@ The text will also be indented the normal way." (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 @@ The text will also be indented the normal way." (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 @@ or error messages, and inform user. 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 @@ the user from the mailer." ;; (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 @@ the user from the mailer." 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 @@ the user from the mailer." ;; 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 @@ the user from the mailer." (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 @@ to find out how to use this." (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 @@ to find out how to use this." (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 @@ to find out how to use this." (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 @@ to find out how to use this." (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 @@ to find out how to use this." (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 @@ to find out how to use this." ;; 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))) + (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))))) + ;; 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 @@ to find out how to use this." (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 @@ to find out how to use this." (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 @@ give as trustworthy answer as possible." (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 @@ Headers already prepared in the buffer are not modified." (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 @@ Headers already prepared in the buffer are not modified." (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 @@ Headers already prepared in the buffer are not modified." (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 @@ Headers already prepared in the buffer are not modified." (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 @@ Headers already prepared in the buffer are not modified." (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 @@ Headers already prepared in the buffer are not modified." (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 already prepared in the buffer are not modified." 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 @@ Headers already prepared in the buffer are not modified." (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 @@ Headers already prepared in the buffer are not modified." (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 @@ Headers already prepared in the buffer are not modified." (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 @@ Headers already prepared in the buffer are not modified." (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 @@ Headers already prepared in the buffer are not modified." (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 @@ Headers already prepared in the buffer are not modified." (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 @@ Headers already prepared in the buffer are not modified." 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 @@ Headers already prepared in the buffer are not modified." (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 @@ Headers already prepared in the buffer are not modified." 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 @@ If TO-NEWSGROUPS, use that as the new Newsgroups line." (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 @@ responses here are directed to other newsgroups.")) (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 @@ responses here are directed to other newsgroups.")) 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 @@ header line with the old Message-ID." (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 @@ Optional NEWS will use news to forward instead of mail." (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 @@ you." (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 @@ you." (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 @@ you." (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 @@ you." (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 @@ Do a `tab-to-tab-stop' if not in those headers." (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 @@ Do a `tab-to-tab-stop' if not in those headers." (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 varstr." (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) diff --git a/lisp/gnus/messcompat.el b/lisp/gnus/messcompat.el index 19371fe9354..870992476e7 100644 --- a/lisp/gnus/messcompat.el +++ b/lisp/gnus/messcompat.el @@ -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 @@ nil means let mailer mail back a message to report errors.") "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 t, the `message-signature-file' file will be inserted instead. 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 @@ these lines.") (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 diff --git a/lisp/gnus/nnbabyl.el b/lisp/gnus/nnbabyl.el index 8c37024e9ae..def1e0c9403 100644 --- a/lisp/gnus/nnbabyl.el +++ b/lisp/gnus/nnbabyl.el @@ -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) diff --git a/lisp/gnus/nndir.el b/lisp/gnus/nndir.el index 89d4954c26b..a3b5eaef20d 100644 --- a/lisp/gnus/nndir.el +++ b/lisp/gnus/nndir.el @@ -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) diff --git a/lisp/gnus/nndoc.el b/lisp/gnus/nndoc.el index e0816e8dce8..0da245a7cab 100644 --- a/lisp/gnus/nndoc.el +++ b/lisp/gnus/nndoc.el @@ -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 @@ One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward', (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 @@ One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward', (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 @@ One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward', (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 @@ One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward', (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 @@ One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward', (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 @@ One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward', "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 @@ One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward', (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 @@ One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward', (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 @@ One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward', (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 @@ One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward', (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 @@ One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward', (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 @@ One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward', (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 @@ One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward', (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 @@ One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward', (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 @@ as the last checked definition, if t or `first', add as the 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)) diff --git a/lisp/gnus/nndraft.el b/lisp/gnus/nndraft.el index 5f2cb9afbe5..c6f23c41026 100644 --- a/lisp/gnus/nndraft.el +++ b/lisp/gnus/nndraft.el @@ -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)) +(eval-when-compile + (require 'cl) + ;; This is just to shut up the byte-compiler. + (fset 'nndraft-request-group 'ignore)) -(nnoo-declare nndraft) +(nnoo-declare nndraft + nnmh) -(eval-and-compile - (autoload 'mail-send-and-exit "sendmail")) - -(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 diff --git a/lisp/gnus/nneething.el b/lisp/gnus/nneething.el index b04d5b36294..7da54665884 100644 --- a/lisp/gnus/nneething.el +++ b/lisp/gnus/nneething.el @@ -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 @@ If this variable is nil, no files will be excluded.") (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 @@ If this variable is nil, no files will be excluded.") (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 @@ If this variable is nil, no files will be excluded.") (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 @@ If this variable is nil, no files will be excluded.") (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 @@ If this variable is nil, no files will be excluded.") (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))) diff --git a/lisp/gnus/nnfolder.el b/lisp/gnus/nnfolder.el index c7f9a720ff2..fb14056af93 100644 --- a/lisp/gnus/nnfolder.el +++ b/lisp/gnus/nnfolder.el @@ -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 @@ time saver for large mailboxes.") (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 @@ time saver for large mailboxes.") (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 @@ time saver for large mailboxes.") (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 @@ time saver for large mailboxes.") (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 @@ time saver for large mailboxes.") (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 @@ time saver for large mailboxes.") (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 @@ time saver for large mailboxes.") (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 @@ time saver for large mailboxes.") (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 @@ time saver for large mailboxes.") (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 @@ time saver for large mailboxes.") (unless (looking-at message-unix-mail-delimiter) (insert "From nobody " (current-time-string) "\n") (goto-char (point-min))) - ;; Quote all "From " lines in the article. (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. (let (case-fold-search) (while (re-search-forward "^From " nil t) (beginning-of-line) @@ -594,16 +624,19 @@ time saver for large mailboxes.") (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 @@ time saver for large mailboxes.") (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 @@ time saver for large mailboxes.") (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 @@ time saver for large mailboxes.") (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." diff --git a/lisp/gnus/nngateway.el b/lisp/gnus/nngateway.el index 5888d48b272..c580ac55309 100644 --- a/lisp/gnus/nngateway.el +++ b/lisp/gnus/nngateway.el @@ -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 @@ parameter -- the gateway address.") (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 @@ parameter -- the gateway address.") (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) diff --git a/lisp/gnus/nnheader.el b/lisp/gnus/nnheader.el index 448fb8252e1..395a2085e00 100644 --- a/lisp/gnus/nnheader.el +++ b/lisp/gnus/nnheader.el @@ -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 @@ on your system, you could say something like: (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 @@ on your system, you could say something like: (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 @@ on your system, you could say something like: (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 @@ on your system, you could say something like: (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 @@ the line could be found." (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 @@ the line could be found." (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 @@ If FILE is t, return the buffer contents as a string." (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 @@ If FILE is t, return the buffer contents as a string." "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 @@ The first string in ARGS can be a format string." (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 @@ without formatting." (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 @@ If FILE, find the \".../etc/PACKAGE\" file instead." (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 @@ find-file-hooks, etc. (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 @@ find-file-hooks, etc. (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 @@ find-file-hooks, etc. (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)) diff --git a/lisp/gnus/nnkiboze.el b/lisp/gnus/nnkiboze.el index 971d74a8f2e..c47a10d3911 100644 --- a/lisp/gnus/nnkiboze.el +++ b/lisp/gnus/nnkiboze.el @@ -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 @@ Finds out what articles are to be part of the nnkiboze groups." (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 @@ Finds out what articles are to be part of the nnkiboze groups." (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 @@ Finds out what articles are to be part of the nnkiboze groups." (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 @@ Finds out what articles are to be part of the nnkiboze groups." 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 @@ Finds out what articles are to be part of the nnkiboze groups." (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 @@ Finds out what articles are to be part of the nnkiboze groups." ;; 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) diff --git a/lisp/gnus/nnmail.el b/lisp/gnus/nnmail.el index a3ed26c45c0..056600b8255 100644 --- a/lisp/gnus/nnmail.el +++ b/lisp/gnus/nnmail.el @@ -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 @@ Eg.: (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 @@ used as incoming mailboxes. 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 @@ several files - eg. \".spool[0-9]*\"." :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 @@ to be moved to." (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 @@ that) from the headers before splitting and saving the messages." 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 @@ messages will be shown to indicate the current status." "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 @@ Example: (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 @@ parameter. It should return nil, `warn' or `delete'." (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 @@ parameter. It should return nil, `warn' or `delete'." (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 @@ parameter. It should return nil, `warn' or `delete'." (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 @@ parameter. It should return nil, `warn' or `delete'." (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 @@ parameter. It should return nil, `warn' or `delete'." "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 @@ parameter. It should return nil, `warn' or `delete'." (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 @@ parameter. It should return nil, `warn' or `delete'." "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 @@ parameter. It should return nil, `warn' or `delete'." (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 @@ parameter. It should return nil, `warn' or `delete'." (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 @@ parameter. It should return nil, `warn' or `delete'." 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 @@ parameter. It should return nil, `warn' or `delete'." (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 @@ parameter. It should return nil, `warn' or `delete'." (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 @@ nn*-request-list should have been called before calling this function." 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 @@ return nil if FILE is a spool file or the procmail group for which it 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 @@ is a spool. If not using procmail, return GROUP." (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 @@ is a spool. If not using procmail, return GROUP." (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 @@ is a spool. If not using procmail, return GROUP." (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 @@ FUNC will be called with the buffer narrowed to each mail." (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 @@ FUNC will be called with the group name to determine the article number." (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 @@ FUNC will be called with the group name to determine the article number." (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 @@ FUNC will be called with the group name to determine the article number." (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 @@ FUNC will be called with the group name to determine the article number." (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 @@ Return the number of characters in the body." (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 @@ Return the number of characters in the body." ;;; 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 @@ See the documentation for the variable `nnmail-split-fancy' for documentation." (defun nnmail-split-it (split) ;; Return a list of groups matching SPLIT. - (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)) - - ;; 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) ':) - (nnmail-split-it (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)))) - - ;; 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))))) + (let (cached-pair) + (cond + ;; nil split + ((null split) + nil) + + ;; 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))) + + ;; 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) ':) + (nnmail-split-it (save-excursion (eval (cdr 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)))))) (defun nnmail-expand-newtext (newtext) (let ((len (length newtext)) @@ -1299,14 +1357,14 @@ See the documentation for the variable `nnmail-split-fancy' for documentation." (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 @@ See the documentation for the variable `nnmail-split-fancy' for documentation." 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 @@ See the documentation for the variable `nnmail-split-fancy' for documentation." ;; 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 @@ See the documentation for the variable `nnmail-split-fancy' for documentation." (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 @@ See the documentation for the variable `nnmail-split-fancy' for documentation." (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 @@ See the documentation for the variable `nnmail-split-fancy' for documentation." (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 @@ If ARGS, PROMPT is used as an argument to `format'." (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 @@ If ARGS, PROMPT is used as an argument to `format'." ", ")) (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 @@ If ARGS, PROMPT is used as an argument to `format'." (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) diff --git a/lisp/gnus/nnmbox.el b/lisp/gnus/nnmbox.el index a5c46769e3c..1f05d1d16b5 100644 --- a/lisp/gnus/nnmbox.el +++ b/lisp/gnus/nnmbox.el @@ -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) diff --git a/lisp/gnus/nnmh.el b/lisp/gnus/nnmh.el index bf4363de717..30069a154c2 100644 --- a/lisp/gnus/nnmh.el +++ b/lisp/gnus/nnmh.el @@ -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) diff --git a/lisp/gnus/nnml.el b/lisp/gnus/nnml.el index 6819086fa6c..59b911f0537 100644 --- a/lisp/gnus/nnml.el +++ b/lisp/gnus/nnml.el @@ -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 @@ all. This may very well take some time.") (defvoo nnml-generate-active-function 'nnml-generate-active-info) +(defvar nnml-nov-buffer-file-name nil) + ;;; Interface functions. @@ -98,9 +100,8 @@ all. This may very well take some time.") (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 @@ all. This may very well take some time.") (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 @@ all. This may very well take some time.") (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 @@ all. This may very well take some time.") (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 @@ all. This may very well take some time.") (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 @@ all. This may very well take some time.") (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 @@ all. This may very well take some time.") ;; 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 @@ all. This may very well take some time.") (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 @@ all. This may very well take some time.") (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 @@ all. This may very well take some time.") "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 @@ all. This may very well take some time.") (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 @@ all. This may very well take some time.") (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 @@ all. This may very well take some time.") (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) diff --git a/lisp/gnus/nnoo.el b/lisp/gnus/nnoo.el index d2f271f5c55..9c27786bf68 100644 --- a/lisp/gnus/nnoo.el +++ b/lisp/gnus/nnoo.el @@ -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))) diff --git a/lisp/gnus/nnsoup.el b/lisp/gnus/nnsoup.el index 31335352e21..e7641509a84 100644 --- a/lisp/gnus/nnsoup.el +++ b/lisp/gnus/nnsoup.el @@ -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 @@ The SOUP packet file name will be inserted at the %s.") (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 @@ The SOUP packet file name will be inserted at the %s.") (defvoo nnsoup-current-group nil) (defvoo nnsoup-group-alist-touched nil) (defvoo nnsoup-article-alist nil) - ;;; Interface functions. @@ -413,7 +417,7 @@ The SOUP packet file name will be inserted at the %s.") (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 @@ The SOUP packet file name will be inserted at the %s.") 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 @@ The SOUP packet file name will be inserted at the %s.") "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 @@ The SOUP packet file name will be inserted at the %s.") (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 @@ The SOUP packet file name will be inserted at the %s.") ;; 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 @@ The SOUP packet file name will be inserted at the %s.") (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 @@ The SOUP packet file name will be inserted at the %s.") (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 @@ The SOUP packet file name will be inserted at the %s.") (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))) diff --git a/lisp/gnus/nnspool.el b/lisp/gnus/nnspool.el index 4e2280f0eef..da39914f5d4 100644 --- a/lisp/gnus/nnspool.el +++ b/lisp/gnus/nnspool.el @@ -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 @@ there.") (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 @@ there.") (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 @@ there.") (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 @@ there.") (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 @@ there.") (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 @@ there.") (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) diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el index 0812be9917d..a653c5d65ec 100644 --- a/lisp/gnus/nntp.el +++ b/lisp/gnus/nntp.el @@ -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 @@ the NNTP server available there (see nntp-rlogin-parameters) and `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 @@ via telnet.") (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 @@ by one.") 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 @@ server there that you can connect to. See also `nntp-open-connection-function'" +(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 @@ server there that you can connect to. See also `nntp-open-connection-function'" (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 @@ server there that you can connect to. See also `nntp-open-connection-function'" (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 @@ server there that you can connect to. See also `nntp-open-connection-function'" (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 @@ server there that you can connect to. See also `nntp-open-connection-function'" ;; 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 @@ server there that you can connect to. See also `nntp-open-connection-function'" (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 @@ server there that you can connect to. See also `nntp-open-connection-function'" (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 @@ server there that you can connect to. See also `nntp-open-connection-function'" (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)) - (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]") + (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 - (goto-char (point-max)) - (forward-line -1) - (not (looking-at "^\\.\r?\n"))) - (nntp-accept-response))) + (set-buffer buf) + (goto-char last-point) + ;; Count replies. + (while (nntp-next-result-arrived-p) + (setq last-point (point)) + (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 @@ server there that you can connect to. See also `nntp-open-connection-function'" (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 @@ server there that you can connect to. See also `nntp-open-connection-function'" (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 @@ server there that you can connect to. See also `nntp-open-connection-function'" (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 @@ server there that you can connect to. See also `nntp-open-connection-function'" (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 @@ server there that you can connect to. See also `nntp-open-connection-function'" (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 @@ server there that you can connect to. See also `nntp-open-connection-function'" (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 @@ server there that you can connect to. See also `nntp-open-connection-function'" (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 @@ It will make innd servers spawn an nnrpd process to allow actual article reading." (nntp-send-command "^.*\r?\n" "MODE READER")) -(defun nntp-send-nosy-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" - (read-string (format "NNTP (%s) user name: " nntp-address))) - (nntp-send-command - "^.*\r?\n" "AUTHINFO PASS" - (nnmail-read-passwd "NNTP (%s) password: " nntp-address))) - -(defun nntp-send-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" (user-login-name)) - (nntp-send-command - "^.*\r?\n" "AUTHINFO PASS" - (nnmail-read-passwd (format "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. + +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 @@ This function is supposed to be called from `nntp-server-opened-hook'." (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 @@ This function is supposed to be called from `nntp-server-opened-hook'." "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 @@ This function is supposed to be called from `nntp-server-opened-hook'." (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 @@ This function is supposed to be called from `nntp-server-opened-hook'." (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 @@ This function is supposed to be called from `nntp-server-opened-hook'." (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 @@ This function is supposed to be called from `nntp-server-opened-hook'." (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 @@ This function is supposed to be called from `nntp-server-opened-hook'." (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 @@ This function is supposed to be called from `nntp-server-opened-hook'." (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 diff --git a/lisp/gnus/nnvirtual.el b/lisp/gnus/nnvirtual.el index aece7417cbc..243717f5baf 100644 --- a/lisp/gnus/nnvirtual.el +++ b/lisp/gnus/nnvirtual.el @@ -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 @@ to virtual article number.") (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 @@ to virtual article number.") (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 @@ to virtual article number.") "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 @@ to virtual article number.") (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 @@ If UPDATE-P is not nil, call gnus-group-update-group on the components." (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) diff --git a/lisp/gnus/nnweb.el b/lisp/gnus/nnweb.el index 2134577dcb8..c9d866a3a35 100644 --- a/lisp/gnus/nnweb.el +++ b/lisp/gnus/nnweb.el @@ -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" . "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" . "score") + ("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)) diff --git a/lisp/gnus/pop3.el b/lisp/gnus/pop3.el index ce1390f02e7..0b2243a1bf8 100644 --- a/lisp/gnus/pop3.el +++ b/lisp/gnus/pop3.el @@ -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 @@ Used for APOP authentication.") (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 @@ Returns the process associated with the connection." (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,18 +265,27 @@ Return the response string if optional second argument is non-nil." (defun pop3-pass (process) "Send authentication information to the server." + (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." (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 ((hash (pop3-md5 (concat pop3-timestamp pass)))) + (pop3-send-command process (format "APOP %s %s" user hash)) (let ((response (pop3-read-response process t))) (if (not (and response (string-match "+OK" response))) (pop3-quit process))))) )) +;; TRANSACTION STATE + (defvar pop3-md5-program "md5" "*Program to encode its input in MD5.") @@ -283,22 +300,6 @@ Return the response string if optional second argument is non-nil." ;; Don't return the newline that follows them! (buffer-substring (point-min) (+ (point-min) 32)))) -(defun pop3-apop (process user) - "Send alternate 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 - (let ((hash (pop3-md5 (concat pop3-timestamp pass)))) - (pop3-send-command process (format "APOP %s %s" user hash)) - (let ((response (pop3-read-response process t))) - (if (not (and response (string-match "+OK" response))) - (pop3-quit process))))) - )) - -;; TRANSACTION STATE - (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 @@ This function currently does nothing.") (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... diff --git a/lisp/gnus/score-mode.el b/lisp/gnus/score-mode.el index fdb8d71b010..24c31f67242 100644 --- a/lisp/gnus/score-mode.el +++ b/lisp/gnus/score-mode.el @@ -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 @@ This mode is an extended emacs-lisp mode. (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 @@ This mode is an extended emacs-lisp mode. (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 () |