diff --exclude=*.elc --exclude=*~ --exclude=*-[0-9] --exclude=gnus --exclude=readme --context --recursive pub/dgnus/lisp/ChangeLog dgnus/lisp/ChangeLog *** pub/dgnus/lisp/ChangeLog Fri Apr 21 05:55:05 1995 --- dgnus/lisp/ChangeLog Sat Apr 22 08:06:43 1995 *************** *** 1,3 **** --- 1,68 ---- + Sat Apr 22 07:27:25 1995 Lars Magne Ingebrigtsen + + * gnus.el: Pushed all score code out to a separate file. + + * gnus-score.el: New file. + + * gnus.el (gnus-newsrc-alist): Name change from gnus-newsrc-assoc. + + Sat Apr 22 04:54:11 1995 Lars Magne Ingebrigtsen + + * gnus.el: Many patches from Hallvard B Furuseth on XEmacs and + kill-buffer matters. + + * gnus-uu.el (gnus-uu-digest-and-forward): Make a better name and + kill the temp buffer. + + * gnus.el (gnus-split-methods): Doc fix. + (gnus-summary-copy-article): Activate non-active newsgroups. + (gnus-summary-insert-pseudos): View pseudos non-separately. + (gnus-view-pseudos-separately): New variable. + + Fri Apr 21 11:00:53 1995 Lars Magne Ingebrigtsen + + * gnus.el (gnus-start-news-server): Arguments in incorrect order + for substring. + (gnus-summary-refer-article): Always open the server before asking + for articles. + (gnus-simplify-subject-fuzzy): Installed Sudish' and Hallvard's + version. + + Fri Apr 21 09:26:06 1995 Lars Magne Ingebrigtsen + + * gnus.el (gnus-group-set-current-level): Changed meaning of + prefix. + (gnus-level-default-unsubscribed): Missing value. + (gnus-simplify-subject-fuzzy): substring instead of + buffer-substring. + + * nnml.el (nnml-request-expire-articles): Would sometimes bomb, + for reasons unknown. + + * nnmh.el (nnmh-request-list): Don't list empty groups. + + * gnus.el (gnus-mail-forward-using-mail): Use emacs-lisp mode + map. + + * gnus.el: 0.56 is released. + + Sun Apr 16 00:34:51 1995 Christian Limpach + + * gnus.el (gnus-article-prepare): fixed moving to bookmark when + displaying article + + Fri Apr 21 05:56:51 1995 Lars Magne Ingebrigtsen + + * gnus.el (gnus-score-check-syntax): Add file names to error + message. + (gnus-browse-foreign-server): Numbers would be one off. + + * nntp.el (nntp-request-group): Just use the GROUP command. + + Fri Apr 21 05:56:34 1995 Lars Magne Ingebrigtsen + + * gnus.el: 0.55 is released. + Fri Apr 21 02:50:11 1995 Lars Magne Ingebrigtsen * gnus.el (gnus-start-news-server): Set nnmh-directory in the diff --exclude=*.elc --exclude=*~ --exclude=*-[0-9] --exclude=gnus --exclude=readme --context --recursive pub/dgnus/lisp/gnus-kill.el dgnus/lisp/gnus-kill.el *** pub/dgnus/lisp/gnus-kill.el Fri Apr 21 05:54:58 1995 --- dgnus/lisp/gnus-kill.el Sat Apr 22 07:54:02 1995 *************** *** 28,34 **** (require 'gnus) (defvar gnus-kill-file-mode-hook nil ! "A hook for Gnus kill file mode.") (defvar gnus-winconf-kill-file nil) --- 28,37 ---- (require 'gnus) (defvar gnus-kill-file-mode-hook nil ! "*A hook for Gnus kill file mode.") ! ! (defvar gnus-kill-expiry-days 7 ! "*Number of days before expiring unused kill file entries.") (defvar gnus-winconf-kill-file nil) *************** *** 416,422 **** (if (zerop (gnus-execute field (car kill-list) command nil (not all))) (if (> (gnus-days-between date (cdr kill-list)) ! gnus-score-expiry-days) (setq regexp nil)) (setcdr kill-list date)) (while (setq kill (car kill-list)) --- 419,425 ---- (if (zerop (gnus-execute field (car kill-list) command nil (not all))) (if (> (gnus-days-between date (cdr kill-list)) ! gnus-kill-expiry-days) (setq regexp nil)) (setcdr kill-list date)) (while (setq kill (car kill-list)) *************** *** 427,433 **** (if (zerop (gnus-execute field (car kill) command nil (not all))) (if (> (gnus-days-between date kdate) ! gnus-score-expiry-days) ;; Time limit has been exceeded, so we ;; remove the match. (if prev --- 430,436 ---- (if (zerop (gnus-execute field (car kill) command nil (not all))) (if (> (gnus-days-between date kdate) ! gnus-kill-expiry-days) ;; Time limit has been exceeded, so we ;; remove the match. (if prev diff --exclude=*.elc --exclude=*~ --exclude=*-[0-9] --exclude=gnus --exclude=readme --context --recursive pub/dgnus/lisp/gnus-message.el dgnus/lisp/gnus-message.el *** pub/dgnus/lisp/gnus-message.el Sat Apr 22 08:15:46 1995 --- dgnus/lisp/gnus-message.el Sat Apr 22 08:27:07 1995 *************** *** 0 **** --- 1,1197 ---- + ;;; gnus-message --- mail and post interface for Gnus + ;; Copyright (C) 1995 Free Software Foundation, Inc. + + ;; Author: Masanobu UMEDA + ;; Lars Magne Ingebrigtsen + ;; Keywords: news + + ;; This file is part of GNU Emacs. + + ;; GNU Emacs is free software; you can redistribute it and/or modify + ;; it under the terms of the GNU General Public License as published by + ;; the Free Software Foundation; either version 2, or (at your option) + ;; any later version. + + ;; GNU Emacs is distributed in the hope that it will be useful, + ;; but WITHOUT ANY WARRANTY; without even the implied warranty of + ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;; GNU General Public License for more details. + + ;; You should have received a copy of the GNU General Public License + ;; along with GNU Emacs; see the file COPYING. If not, write to + ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + ;;; Commentary: + + ;;; Code: + + (require 'gnus) + (require 'sendmail) + + + ;;; + ;;; Gnus Posting Functions + ;;; + + (defvar gnus-organization-file "/usr/lib/news/organization" + "*Local news organization file.") + + (defvar gnus-post-news-buffer "*post-news*") + (defvar gnus-winconf-post-news nil) + + ;;; Post news commands of Gnus group mode and summary mode + + (defun gnus-group-post-news () + "Post an article." + (interactive) + (gnus-set-global-variables) + ;; Save window configuration. + (setq gnus-winconf-post-news (current-window-configuration)) + (let ((gnus-newsgroup-name nil)) + (unwind-protect + (if gnus-split-window + (progn + (pop-to-buffer gnus-article-buffer) + (widen) + (split-window-vertically) + (gnus-post-news 'post)) + (progn + (pop-to-buffer gnus-article-buffer) + (widen) + (delete-other-windows) + (gnus-post-news 'post))) + (or (and (eq (current-buffer) (get-buffer gnus-post-news-buffer)) + (not (zerop (buffer-size)))) + ;; Restore last window configuration. + (and gnus-winconf-post-news + (set-window-configuration gnus-winconf-post-news))))) + ;; We don't want to return to summary buffer nor article buffer later. + (setq gnus-winconf-post-news nil) + (if (get-buffer gnus-summary-buffer) + (bury-buffer gnus-summary-buffer)) + (if (get-buffer gnus-article-buffer) + (bury-buffer gnus-article-buffer))) + + (defun gnus-summary-post-news () + "Post an article." + (interactive) + (gnus-set-global-variables) + ;; Save window configuration. + (setq gnus-winconf-post-news (current-window-configuration)) + (unwind-protect + (gnus-post-news 'post gnus-newsgroup-name) + (or (and (eq (current-buffer) (get-buffer gnus-post-news-buffer)) + (not (zerop (buffer-size)))) + ;; Restore last window configuration. + (and gnus-winconf-post-news + (set-window-configuration gnus-winconf-post-news)))) + ;; We don't want to return to article buffer later. + (if (get-buffer gnus-article-buffer) + (bury-buffer gnus-article-buffer))) + + (defun gnus-summary-followup (yank) + "Compose a followup to an article. + If prefix argument YANK is non-nil, original article is yanked automatically." + (interactive "P") + (gnus-set-global-variables) + (save-window-excursion + (gnus-summary-select-article t)) + (let ((headers gnus-current-headers) + (gnus-newsgroup-name gnus-newsgroup-name)) + ;; Check Followup-To: poster. + (set-buffer gnus-article-buffer) + (if (and gnus-use-followup-to + (string-equal "poster" (gnus-fetch-field "followup-to")) + (or (not (eq gnus-use-followup-to t)) + (not (gnus-y-or-n-p + "Do you want to ignore `Followup-To: poster'? ")))) + ;; Mail to the poster. Gnus is now RFC1036 compliant. + (gnus-summary-reply yank) + ;; Save window configuration. + (setq gnus-winconf-post-news (current-window-configuration)) + (unwind-protect + (gnus-post-news nil gnus-newsgroup-name + headers gnus-article-buffer yank) + (or (and (eq (current-buffer) (get-buffer gnus-post-news-buffer)) + (not (zerop (buffer-size)))) + ;; Restore last window configuration. + (and gnus-winconf-post-news + (set-window-configuration gnus-winconf-post-news)))) + ;; We don't want to return to article buffer later. + (bury-buffer gnus-article-buffer))) + (gnus-article-hide-headers-if-wanted)) + + (defun gnus-summary-followup-with-original () + "Compose a followup to an article and include the original article." + (interactive) + (gnus-summary-followup t)) + + ;; Suggested by Daniel Quinlan . + (defun gnus-summary-followup-and-reply (yank) + "Compose a followup and do an auto mail to author." + (interactive "P") + (let ((gnus-auto-mail-to-author t)) + (gnus-summary-followup yank))) + + (defun gnus-summary-followup-and-reply-with-original () + "Compose a followup, include the original, and do an auto mail to author." + (interactive) + (gnus-summary-followup-and-reply t)) + + (defun gnus-summary-cancel-article () + "Cancel an article you posted." + (interactive) + (gnus-set-global-variables) + (gnus-summary-select-article t) + (gnus-eval-in-buffer-window gnus-article-buffer (gnus-cancel-news)) + (gnus-article-hide-headers-if-wanted)) + + (defun gnus-summary-supersede-article () + "Compose an article that will supersede a previous article. + 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) + (if (not + (string-equal + (downcase (mail-strip-quoted-names + (header-from gnus-current-headers))) + (downcase (mail-strip-quoted-names (gnus-inews-user-name))))) + (error "This article is not yours.")) + (gnus-summary-select-article t) + (save-excursion + (set-buffer gnus-article-buffer) + (let ((buffer-read-only nil)) + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (if (not (re-search-backward "^Message-ID: " nil t)) + (error "No Message-ID in this article")))) + (if (gnus-post-news 'post gnus-newsgroup-name) + (progn + (erase-buffer) + (insert-buffer gnus-article-buffer) + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (if (not (re-search-backward "^Message-ID: " nil t)) + (error "No Message-ID in this article") + (replace-match "Supersedes: " t t)) + (search-forward "\n\n") + (forward-line -1) + (insert mail-header-separator)))) + + + ;;;###autoload + (fset 'sendnews 'gnus-post-news) + + ;;;###autoload + (fset 'postnews 'gnus-post-news) + + (defun gnus-post-news (post &optional group header article-buffer yank) + "Begin editing a new USENET news article to be posted. + Type \\[describe-mode] in the buffer to get a list of commands." + (interactive (list t)) + (if (or (not gnus-novice-user) + gnus-expert-user + (not (eq 'post + (nth 1 (assoc + (format "%s" (car (gnus-find-method-for-group + gnus-newsgroup-name))) + gnus-valid-select-methods)))) + (assq 'to-address (nth 5 (nth 2 (gnus-gethash gnus-newsgroup-name + gnus-newsrc-hashtb)))) + (gnus-y-or-n-p "Are you sure you want to post to all of USENET? ")) + (let ((sumart (if (not post) + (save-excursion + (set-buffer gnus-summary-buffer) + (cons (current-buffer) gnus-current-article)))) + (from (and header (header-from header))) + subject follow-to real-group) + (and gnus-interactive-post + (not gnus-expert-user) + post (not group) + (progn + (setq group + (completing-read "Group: " gnus-active-hashtb)) + (setq subject (read-string "Subject: ")))) + (setq mail-reply-buffer article-buffer) + + (let ((gnus-newsgroup-name (or group gnus-newsgroup-name ""))) + (setq real-group (and group (gnus-group-real-name group))) + (setq gnus-post-news-buffer + (gnus-request-post-buffer + post real-group subject header article-buffer + (nth 2 (and group (gnus-gethash group gnus-newsrc-hashtb))) + (or (cdr (assq 'to-group + (nth 5 (nth 2 (gnus-gethash + gnus-newsgroup-name + gnus-newsrc-hashtb))))) + (if (and (boundp 'gnus-followup-to-function) + gnus-followup-to-function) + (setq follow-to + (save-excursion + (set-buffer article-buffer) + (funcall gnus-followup-to-function group))))) + (eq gnus-use-followup-to t))) + (if post + (progn + (gnus-configure-windows '(1 0 0)) + (switch-to-buffer gnus-post-news-buffer)) + (gnus-configure-windows '(0 1 0)) + (if (not yank) + (progn + (switch-to-buffer article-buffer) + (pop-to-buffer gnus-post-news-buffer)) + (switch-to-buffer gnus-post-news-buffer))) + (gnus-overload-functions) + (make-local-variable 'gnus-article-reply) + (make-local-variable 'gnus-article-check-size) + (setq gnus-article-reply sumart) + ;; Handle `gnus-auto-mail-to-author'. + ;; Suggested by Daniel Quinlan . + (let ((to (if (eq gnus-auto-mail-to-author 'ask) + (and (y-or-n-p "Also send mail to author? ") from) + (and gnus-auto-mail-to-author from)))) + (if to + (progn + (if (mail-fetch-field "To") + (progn + (beginning-of-line) + (insert "Cc: " to "\n")) + (mail-position-on-field "To") + (insert to))))) + ;; Handle author copy using BCC field. + (if (and gnus-mail-self-blind + (not (mail-fetch-field "bcc"))) + (progn + (mail-position-on-field "Bcc") + (insert (if (stringp gnus-mail-self-blind) + gnus-mail-self-blind + (user-login-name))))) + ;; Handle author copy using FCC field. + (if gnus-author-copy + (progn + (mail-position-on-field "Fcc") + (insert gnus-author-copy))) + (goto-char (point-min)) + (if post + (cond ((not group) + (re-search-forward "^Newsgroup:" nil t) + (end-of-line)) + ((not subject) + (re-search-forward "^Subject:" nil t) + (end-of-line)) + (t + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "$")) + (forward-line 1))) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "$")) + (forward-line 1) + (and yank (save-excursion (news-reply-yank-original nil))) + (if gnus-post-prepare-function + (funcall gnus-post-prepare-function group)))))) + (setq gnus-article-check-size (cons (buffer-size) (gnus-article-checksum))) + (message "") + t) + + (defun gnus-inews-news (&optional use-group-method) + "Send a news message. + If given a prefix, and the group is a foreign group, this function + will attempt to use the foreign server to post the article." + (interactive "P") + ;; Check whether the article is a good Net Citizen. + (if (and gnus-article-check-size (not (gnus-inews-check-post))) + ;; Aber nein! + () + ;; Looks ok, so we do the nasty. + (let* ((case-fold-search nil) + (server-running (gnus-server-opened gnus-select-method)) + (reply gnus-article-reply)) + (save-excursion + ;; Connect to default NNTP server if necessary. + ;; Suggested by yuki@flab.fujitsu.junet. + (gnus-start-news-server) ;Use default server. + ;; NNTP server must be opened before current buffer is modified. + (widen) + (goto-char (point-min)) + (run-hooks 'news-inews-hook) + (save-restriction + (narrow-to-region + (point-min) + (progn + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "$")))) + + ;; Correct newsgroups field: change sequence of spaces to comma and + ;; eliminate spaces around commas. Eliminate imbedded line breaks. + (goto-char (point-min)) + (if (search-forward-regexp "^Newsgroups: +" nil t) + (save-restriction + (narrow-to-region + (point) + (if (re-search-forward "^[^ \t]" nil 'end) + (match-beginning 0) + (point-max))) + (goto-char (point-min)) + (replace-regexp "\n[ \t]+" " ") ;No line breaks (too confusing) + (goto-char (point-min)) + (replace-regexp "[ \t\n]*,[ \t\n]*\\|[ \t]+" ","))) + + ;; Added by Per Abrahamsen . + ;; Help save the the world! + (or + gnus-expert-user + (let ((newsgroups (mail-fetch-field "newsgroups")) + (followup-to (mail-fetch-field "followup-to")) + groups to) + (if (and (string-match "," newsgroups) (not followup-to)) + (progn + (while (string-match "," newsgroups) + (setq groups + (cons (list (substring newsgroups + 0 (match-beginning 0))) + groups)) + (setq newsgroups (substring newsgroups (match-end 0)))) + (setq groups (nreverse (cons (list newsgroups) groups))) + + (setq to + (completing-read "Followups to: (default all groups) " + groups)) + (if (> (length to) 0) + (progn + (goto-char (point-min)) + (insert "Followup-To: " to "\n"))))))) + + ;; Cleanup Followup-To. + (goto-char (point-min)) + (if (search-forward-regexp "^Followup-To: +" nil t) + (save-restriction + (narrow-to-region + (point) + (if (re-search-forward "^[^ \t]" nil 'end) + (match-beginning 0) + (point-max))) + (goto-char (point-min)) + (replace-regexp "\n[ \t]+" " ") ;No line breaks (too confusing) + (goto-char (point-min)) + (replace-regexp "[ \t\n]*,[ \t\n]*\\|[ \t]+" ","))) + + ;; Mail the message too if To:, Bcc:. or Cc: exists. + (if (or (mail-fetch-field "to" nil t) + (mail-fetch-field "bcc" nil t) + (mail-fetch-field "cc" nil t)) + (if gnus-mail-send-method + (save-excursion + (save-restriction + (widen) + (message "Sending via mail...") + + (if gnus-mail-courtesy-message + (progn + ;; Insert "courtesy" mail message. + (goto-char 1) + (re-search-forward + (concat "^" (regexp-quote + mail-header-separator) "$")) + (forward-line 1) + (insert gnus-mail-courtesy-message) + (funcall gnus-mail-send-method) + (goto-char 1) + (search-forward gnus-mail-courtesy-message) + (replace-match "" t t)) + (funcall gnus-mail-send-method)) + + (message "Sending via mail... done") + + (goto-char 1) + (narrow-to-region + 1 (re-search-forward + (concat "^" (regexp-quote + mail-header-separator) "$"))) + (goto-char 1) + (delete-matching-lines "BCC:.*"))) + (ding) + (message "No mailer defined. To: and/or Cc: fields ignored.") + (sit-for 1)))) + + ;; Send to NNTP server. + (message "Posting to USENET...") + (if (gnus-inews-article use-group-method) + (progn + (message "Posting to USENET... done") + (if (gnus-buffer-exists-p (car-safe reply)) + (progn + (save-excursion + (set-buffer gnus-summary-buffer) + (gnus-summary-mark-article-as-replied + (cdr reply)))))) + ;; We cannot signal an error. + (ding) (message "Article rejected: %s" + (gnus-status-message gnus-select-method))) + (set-buffer-modified-p nil)) + ;; If NNTP server is opened by gnus-inews-news, close it by myself. + (or server-running + (gnus-close-server (gnus-find-method-for-group gnus-newsgroup-name))) + (and (fboundp 'bury-buffer) (bury-buffer)) + ;; Restore last window configuration. + (and gnus-winconf-post-news + (set-window-configuration gnus-winconf-post-news)) + (setq gnus-winconf-post-news nil)))) + + (defun gnus-inews-check-post () + "Check whether the post looks ok." + (or + (not gnus-check-before-posting) + (and + ;; We narrow to the headers and check them first. + (save-excursion + (save-restriction + (goto-char (point-min)) + (narrow-to-region + (point) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "$"))) + (goto-char (point-min)) + (and + ;; Check for commands in Subject. + (save-excursion + (if (string-match "^cmsg " (mail-fetch-field "subject")) + (gnus-y-or-n-p + "The control code \"cmsg \" is in the subject. Really post? ") + t)) + ;; Check for multiple identical headers. + (save-excursion + (let (found) + (while (and (not found) (re-search-forward "^[^ \t:]+: " nil t)) + (save-excursion + (or (re-search-forward + (concat "^" (setq found + (buffer-substring + (match-beginning 0) + (- (match-end 0) 2)))) + nil t) + (setq found nil)))) + (if found + (gnus-y-or-n-p + (format "Multiple %s headers. Really post? " found)) + t))) + ;; Check for version and sendsys. + (save-excursion + (if (re-search-forward "^Sendsys:\\|^Version:" nil t) + (gnus-yes-or-no-p + (format "The article contains a %s command. Really post? " + (buffer-substring (match-beginning 0) + (1- (match-end 0))))) + t)) + ;; Check the Message-Id header. + (save-excursion + (let* ((case-fold-search t) + (message-id (mail-fetch-field "message-id"))) + (or (not message-id) + (and (string-match "@" message-id) + (string-match "@[^\\.]*\\." message-id)) + (gnus-yes-or-no-p + (format "The Message-ID looks strange: \"%s\". Really post? " + message-id))))) + ;; Check the From header. + (save-excursion + (let* ((case-fold-search t) + (from (mail-fetch-field "from"))) + (or (not from) + (and (string-match "@" from) + (string-match "@[^\\.]*\\." from)) + (gnus-yes-or-no-p + (format "The From looks strange: \"%s\". Really post? " + from)))))))) + ;; Check for long lines. + (save-excursion + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "$")) + (while (and + (progn + (end-of-line) + (< (current-column) 80)) + (zerop (forward-line 1)))) + (or (bolp) + (gnus-yes-or-no-p + (format + "You have lines longer than 79 characters. Really post? ")))) + ;; Check for control characters. + (save-excursion + (if (re-search-forward "[\000-\007\013\015-\037\200-\237]" nil t) + (gnus-y-or-n-p + "The article contains control characters. Really post? ") + t)) + ;; Check excessive size. + (if (> (buffer-size) 60000) + (gnus-y-or-n-p (format "The article is %d octets long. Really post? " + (buffer-size))) + t) + ;; Use the (size . checksum) variable to see whether the + ;; article is empty or has only quoted text. + (if (and (= (buffer-size) (car gnus-article-check-size)) + (= (gnus-article-checksum) (cdr gnus-article-check-size))) + (gnus-yes-or-no-p + "It looks like there's no new text in your article. Really post? ") + t)))) + + (defun gnus-article-checksum () + (let ((sum 0)) + (save-excursion + (while (not (eobp)) + (setq sum (logxor sum (following-char))) + (forward-char 1))) + sum)) + + (defun gnus-cancel-news () + "Cancel an article you posted." + (interactive) + (if (or gnus-expert-user + (gnus-yes-or-no-p "Do you really want to cancel this article? ")) + (let ((from nil) + (newsgroups nil) + (message-id nil) + (distribution nil)) + (save-excursion + ;; Get header info. from original article. + (save-restriction + (gnus-article-show-all-headers) + (goto-char (point-min)) + (search-forward "\n\n" nil 'move) + (narrow-to-region (point-min) (point)) + (setq from (mail-fetch-field "from")) + (setq newsgroups (mail-fetch-field "newsgroups")) + (setq message-id (mail-fetch-field "message-id")) + (setq distribution (mail-fetch-field "distribution"))) + ;; Verify if the article is absolutely user's by comparing + ;; user id with value of its From: field. + (if (not + (string-equal + (downcase (mail-strip-quoted-names from)) + (downcase (mail-strip-quoted-names (gnus-inews-user-name))))) + (progn + (ding) (message "This article is not yours.")) + ;; Make control article. + (set-buffer (get-buffer-create " *Gnus-canceling*")) + (buffer-disable-undo (current-buffer)) + (erase-buffer) + (insert "Newsgroups: " newsgroups "\n" + "Subject: cancel " message-id "\n" + "Control: cancel " message-id "\n" + mail-header-separator "\n" + "This is a cancel message from " from ".\n") + ;; Send the control article to NNTP server. + (message "Canceling your article...") + (if (gnus-inews-article) + (message "Canceling your article... done") + (ding) + (message "Cancel failed; %s" + (gnus-status-message gnus-newsgroup-name))) + ;; Kill the article buffer. + (kill-buffer (current-buffer))))))) + + + ;;; Lowlevel inews interface + + (defun gnus-inews-article (&optional use-group-method) + "Post an article in current buffer using NNTP protocol." + (let ((artbuf (current-buffer)) + (tmpbuf (get-buffer-create " *Gnus-posting*"))) + (widen) + (goto-char (point-max)) + ;; require a newline at the end for inews to append .signature to + (or (= (preceding-char) ?\n) + (insert ?\n)) + ;; Prepare article headers. All message body such as signature + ;; must be inserted before Lines: field is prepared. + (save-restriction + (goto-char (point-min)) + (narrow-to-region + (point-min) + (save-excursion + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "$")) + (match-beginning 0))) + (gnus-inews-insert-headers) + (run-hooks gnus-inews-article-header-hook) + (widen)) + (save-excursion + (set-buffer tmpbuf) + (buffer-disable-undo (current-buffer)) + (erase-buffer) + (insert-buffer-substring artbuf) + ;; Remove the header separator. + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "$")) + (replace-match "" t t) + ;; This hook may insert a signature. + (run-hooks 'gnus-prepare-article-hook) + ;; Run final inews hooks. This hook may do FCC. + ;; The article must be saved before being posted because + ;; `gnus-request-post' modifies the buffer. + (run-hooks 'gnus-inews-article-hook) + ;; Post an article to NNTP server. + ;; Return NIL if post failed. + (prog1 + (gnus-request-post + (if use-group-method + (gnus-find-method-for-group gnus-newsgroup-name) + gnus-select-method) use-group-method) + (kill-buffer (current-buffer)))))) + + (defun gnus-inews-insert-headers () + "Prepare article headers. + Headers already prepared in the buffer are not modified. + Headers in `gnus-required-headers' will be generated." + (let ((Date (gnus-inews-date)) + (Message-ID (gnus-inews-message-id)) + (Organization (gnus-inews-organization)) + (From (gnus-inews-user-name)) + (Path (gnus-inews-path)) + (Subject nil) + (Newsgroups nil) + (Distribution nil) + (Lines (gnus-inews-lines)) + (X-Newsreader gnus-version) + (headers gnus-required-headers) + (case-fold-search t) + header value elem) + ;; First we remove any old Message-IDs. This might be slightly + ;; fascist, but if the user really wants to generate Message-IDs + ;; by herself, she should remove it from the `gnus-required-list'. + (goto-char (point-min)) + (and (memq 'Message-ID headers) + (re-search-forward "^Message-ID:" nil t) + (delete-region (progn (beginning-of-line) (point)) + (progn (forward-line 1) (point)))) + ;; Remove NNTP-posting-host. + (goto-char (point-min)) + (and (re-search-forward "^nntp-posting-host:" nil t) + (delete-region (progn (beginning-of-line) (point)) + (progn (forward-line 1) (point)))) + ;; Insert new Sender if the From is strange. + (let ((from (mail-fetch-field "from"))) + (if (and from (not (string= (downcase from) (downcase From)))) + (progn + (goto-char (point-min)) + (and (re-search-forward "^Sender:" nil t) + (delete-region (progn (beginning-of-line) (point)) + (progn (forward-line 1) (point)))) + (insert "Sender: " From "\n")))) + ;; If there are References, and no "Re: ", then the thread has + ;; changed name. See Son-of-1036. + (if (and (mail-fetch-field "references") + (get-buffer gnus-article-buffer)) + (let ((psubject (gnus-simplify-subject-re + (mail-fetch-field "subject"))) + subject) + (save-excursion + (set-buffer gnus-article-buffer) + (save-restriction + (gnus-narrow-to-headers) + (if (setq subject (mail-fetch-field "subject")) + (progn + (and gnus-summary-gather-subject-limit + (numberp gnus-summary-gather-subject-limit) + (> (length subject) gnus-summary-gather-subject-limit) + (setq subject + (substring subject 0 + gnus-summary-gather-subject-limit))) + (setq subject (gnus-simplify-subject-re subject)))))) + (or (and psubject subject (string= subject psubject)) + (progn + (string-match "@" Message-ID) + (setq Message-ID + (concat (substring Message-ID 0 (match-beginning 0)) + "_-_" + (substring Message-ID (match-beginning 0)))))))) + ;; Go through all the required headers and see if they are in the + ;; articles already. If they are not, or are empty, they are + ;; inserted automatically - except for Subject, Newsgroups and + ;; Distribution. + (while headers + (goto-char (point-min)) + (setq elem (car headers)) + (if (consp elem) + (setq header (car elem)) + (setq header elem)) + (if (or (not (re-search-forward + (concat "^" (downcase (symbol-name header)) ":") nil t)) + (progn + (if (= (following-char) ? ) (forward-char 1) (insert " ")) + (looking-at "[ \t]*$"))) + (progn + (setq value + (or (if (consp elem) + ;; The element is a cons. Either the cdr is + ;; a string to be inserted verbatim, or it + ;; is a function, and we insert the value + ;; returned from this function. + (or (and (stringp (cdr elem)) (cdr elem)) + (and (fboundp (cdr elem)) (funcall (cdr elem)))) + ;; The element is a symbol. We insert the + ;; value of this symbol, if any. + (and (boundp header) (symbol-value header))) + ;; We couldn't generate a value for this header, + ;; so we just ask the user. + (read-from-minibuffer + (format "Empty header for %s; enter value: " header)))) + (if (bolp) + (save-excursion + (goto-char (point-max)) + (insert (symbol-name header) ": " value "\n")) + (replace-match value t t)))) + (setq headers (cdr headers))))) + + (defun gnus-inews-insert-signature () + "Insert a signature file. + If `gnus-signature-function' is bound and returns a string, this + string is used instead of the variable `gnus-signature-file'. + In either case, if the string is a file name, this file is + inserted. If the string is not a file name, the string itself is + inserted. + If you never want any signature inserted, set both those variables to + nil." + (save-excursion + (let ((signature + (or (and gnus-signature-function + (fboundp gnus-signature-function) + (funcall gnus-signature-function gnus-newsgroup-name)) + gnus-signature-file)) + b) + (if (and signature + (or (file-exists-p signature) + (string-match " " signature) + (not (string-match + "^/[^/]+/" (expand-file-name signature))))) + (progn + (goto-char (point-max)) + ;; Delete any previous signatures. + (if (and mail-signature (search-backward "\n-- \n" nil t)) + (delete-region (1+ (point)) (point-max))) + (insert "\n-- \n") + (and (< 4 (setq b (count-lines + (point) + (progn + (if (file-exists-p signature) + (insert-file-contents signature) + (insert signature)) + (goto-char (point-max)) + (or (bolp) (insert "\n")) + (point))))) + (not gnus-expert-user) + (not + (gnus-y-or-n-p + (format + "Your .sig is %d lines; it should be max 4. Really post? " + b))) + (if (file-exists-p signature) + (error (format "Edit %s." signature)) + (error "Trim your signature.")))))))) + + (defun gnus-inews-do-fcc () + "Process FCC: fields in current article buffer. + Unless the first character of the field is `|', the article is saved + to the specified file using the function specified by the variable + gnus-author-copy-saver. The default function rmail-output saves in + Unix mailbox format. + If the first character is `|', the contents of the article is send to + a program specified by the rest of the value." + (let ((fcc-list nil) + (fcc-file nil) + (case-fold-search t)) ;Should ignore case. + (save-excursion + (save-restriction + (goto-char (point-min)) + (search-forward "\n\n") + (narrow-to-region (point-min) (point)) + (goto-char (point-min)) + (while (re-search-forward "^FCC:[ \t]*" nil t) + (setq fcc-list + (cons (buffer-substring + (point) + (progn + (end-of-line) + (skip-chars-backward " \t") + (point))) + fcc-list)) + (delete-region (match-beginning 0) + (progn (forward-line 1) (point)))) + ;; Process FCC operations. + (widen) + (while fcc-list + (setq fcc-file (car fcc-list)) + (setq fcc-list (cdr fcc-list)) + (cond ((string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" fcc-file) + (let ((program (substring fcc-file + (match-beginning 1) (match-end 1)))) + ;; Suggested by yuki@flab.fujitsu.junet. + ;; Send article to named program. + (call-process-region (point-min) (point-max) shell-file-name + nil nil nil "-c" program))) + (t + ;; Suggested by hyoko@flab.fujitsu.junet. + ;; Save article in Unix mail format by default. + (if (and gnus-author-copy-saver + (not (eq gnus-author-copy-saver 'rmail-output))) + (funcall gnus-author-copy-saver fcc-file) + (if (and (file-readable-p fcc-file) (rmail-file-p fcc-file)) + (gnus-output-to-rmail fcc-file) + (rmail-output fcc-file 1 t t)))))))))) + + (defun gnus-inews-path () + "Return uucp path." + (let ((login-name (gnus-inews-login-name))) + (cond ((null gnus-use-generic-path) + (concat (nth 1 gnus-select-method) "!" login-name)) + ((stringp gnus-use-generic-path) + ;; Support GENERICPATH. Suggested by vixie@decwrl.dec.com. + (concat gnus-use-generic-path "!" login-name)) + (t login-name)))) + + (defun gnus-inews-user-name () + "Return user's network address as \"NAME@DOMAIN (FULL-NAME)\"." + (let ((full-name (gnus-inews-full-name))) + (or gnus-user-from-line + (concat (if (or gnus-user-login-name gnus-use-generic-from + gnus-local-domain (getenv "DOMAINNAME")) + (concat (gnus-inews-login-name) "@" + (gnus-inews-domain-name gnus-use-generic-from)) + user-mail-address) + ;; User's full name. + (cond ((string-equal full-name "") "") + ((string-equal full-name "&") ;Unix hack. + (concat " (" (user-login-name) ")")) + (t + (concat " (" full-name ")"))))))) + + (defun gnus-inews-login-name () + "Return login name." + (or gnus-user-login-name (getenv "LOGNAME") (user-login-name))) + + (defun gnus-inews-full-name () + "Return full user name." + (or gnus-user-full-name (getenv "NAME") (user-full-name))) + + (defun gnus-inews-domain-name (&optional genericfrom) + "Return user's domain name. + If optional argument GENERICFROM is a string, use it as the domain + name; if it is non-nil, strip off local host name from the domain name. + If the function `system-name' returns full internet name and the + domain is undefined, the domain name is got from it." + (if (or genericfrom gnus-local-domain (getenv "DOMAINNAME")) + (let* ((system-name (system-name)) + (domain + (or (if (stringp genericfrom) genericfrom) + (getenv "DOMAINNAME") + gnus-local-domain + ;; Function `system-name' may return full internet name. + ;; Suggested by Mike DeCorte . + (if (string-match "\\." system-name) + (substring system-name (match-end 0))) + (read-string "Domain name (no host): "))) + (host (or (if (string-match "\\." system-name) + (substring system-name 0 (match-beginning 0))) + system-name))) + (if (string-equal "." (substring domain 0 1)) + (setq domain (substring domain 1))) + ;; Support GENERICFROM as same as standard Bnews system. + ;; Suggested by ohm@kaba.junet and vixie@decwrl.dec.com. + (cond ((null genericfrom) + (concat host "." domain)) + ;;((stringp genericfrom) genericfrom) + (t domain))) + (if (string-match "\\." (system-name)) + (system-name) + (substring user-mail-address + (1+ (string-match "@" user-mail-address)))))) + + (defun gnus-inews-full-address () + (let ((domain (gnus-inews-domain-name)) + (system (system-name)) + (case-fold-search t)) + (if (string-match "\\." system) system + (if (string-match (concat "^" (regexp-quote system)) domain) domain + (concat system "." domain))))) + + (defun gnus-inews-message-id () + "Generate unique Message-ID for user." + ;; Message-ID should not contain a slash and should be terminated by + ;; a number. I don't know the reason why it is so. + (concat "<" (gnus-inews-unique-id) "@" (gnus-inews-full-address) ">")) + + (defun gnus-inews-unique-id () + "Generate unique ID from user name and current time." + (concat (downcase (gnus-inews-login-name)) + (mapconcat + (lambda (num) (gnus-number-base-x num 3 31)) + (current-time) ""))) + + (defun gnus-inews-date () + "Current time string." + (timezone-make-date-arpa-standard + (current-time-string) (current-time-zone))) + + (defun gnus-inews-organization () + "Return user's organization. + The ORGANIZATION environment variable is used if defined. + If not, the variable `gnus-local-organization' is used instead. + If it is a function, the function will be called with the current + newsgroup name as the argument. + If this is a file name, the contents of this file will be used as the + organization." + (let* ((organization + (or (getenv "ORGANIZATION") + (if gnus-local-organization + (if (and (symbolp gnus-local-organization) + (fboundp gnus-local-organization)) + (funcall gnus-local-organization gnus-newsgroup-name) + gnus-local-organization)) + gnus-organization-file + "~/.organization"))) + (and (stringp organization) + (> (length organization) 0) + (or (file-exists-p organization) + (string-match " " organization) + (not (string-match "^/[^/]+/" (expand-file-name organization)))) + (save-excursion + (set-buffer (get-buffer-create " *Gnus organization*")) + (buffer-disable-undo (current-buffer)) + (erase-buffer) + (if (file-exists-p organization) + (insert-file-contents organization) + (insert organization)) + (goto-char (point-min)) + (while (re-search-forward " *\n *" nil t) + (replace-match " " t t)) + (buffer-substring (point-min) (point-max)))))) + + (defun gnus-inews-lines () + "Count the number of lines and return numeric string." + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (search-forward "\n\n" nil 'move) + (int-to-string (count-lines (point) (point-max)))))) + + + ;;; + ;;; Gnus Mail Functions + ;;; + + ;;; Mail reply commands of Gnus summary mode + + (defun gnus-summary-reply (yank) + "Reply mail to news author. + If prefix argument YANK is non-nil, original article is yanked automatically. + Customize the variable gnus-mail-reply-method to use another mailer." + (interactive "P") + ;; Bug fix by jbw@bigbird.bu.edu (Joe Wells) + ;; Stripping headers should be specified with mail-yank-ignored-headers. + (gnus-set-global-variables) + (setq gnus-winconf-post-news (current-window-configuration)) + (gnus-summary-select-article t) + (let ((gnus-newsgroup-name gnus-newsgroup-name)) + (bury-buffer gnus-article-buffer) + (funcall gnus-mail-reply-method yank)) + (gnus-article-hide-headers-if-wanted)) + + (defun gnus-summary-reply-with-original () + "Reply mail to news author with original article. + Customize the variable gnus-mail-reply-method to use another mailer." + (interactive) + (gnus-summary-reply t)) + + (defun gnus-summary-mail-forward () + "Forward the current message to another user. + Customize the variable gnus-mail-forward-method to use another mailer." + (interactive) + (gnus-summary-select-article t) + (setq gnus-winconf-post-news (current-window-configuration)) + (if gnus-split-window + (widen) + (switch-to-buffer gnus-article-buffer) + (widen) + (delete-other-windows) + (bury-buffer gnus-article-buffer)) + (let ((gnus-newsgroup-name gnus-newsgroup-name)) + (funcall gnus-mail-forward-method)) + (gnus-article-hide-headers-if-wanted)) + + (defun gnus-summary-mail-other-window () + "Compose mail in other window. + Customize the variable `gnus-mail-other-window-method' to use another + mailer." + (interactive) + (setq gnus-winconf-post-news (current-window-configuration)) + (let ((gnus-newsgroup-name gnus-newsgroup-name)) + (funcall gnus-mail-other-window-method))) + + (defun gnus-mail-reply-using-mail (&optional yank to-address) + (save-excursion + (set-buffer gnus-summary-buffer) + (let ((info (nth 2 (gnus-gethash gnus-newsgroup-name gnus-newsrc-hashtb))) + (group (gnus-group-real-name gnus-newsgroup-name)) + (cur (cons (current-buffer) (cdr gnus-article-current))) + from subject date to reply-to message-of + references message-id sender follow-to cc) + (set-buffer (get-buffer-create "*mail*")) + (mail-mode) + (make-local-variable 'gnus-article-reply) + (setq gnus-article-reply cur) + (use-local-map (copy-keymap mail-mode-map)) + (local-set-key "\C-c\C-c" 'gnus-mail-send-and-exit) + (if (and (buffer-modified-p) + (> (buffer-size) 0) + (not (gnus-y-or-n-p + "Unsent article being composed; erase it? "))) + () + (erase-buffer) + (save-excursion + (set-buffer gnus-article-buffer) + (let ((buffer-read-only nil)) + (goto-char (point-min)) + (narrow-to-region (point-min) + (progn (search-forward "\n\n") (point))) + (add-text-properties (point-min) (point-max) '(invisible nil))) + (if (and (boundp 'gnus-reply-to-function) + gnus-reply-to-function) + (save-excursion + (save-restriction + (gnus-narrow-to-headers) + (setq follow-to (funcall gnus-reply-to-function group))))) + (setq from (mail-fetch-field "from")) + (setq date (mail-fetch-field "date")) + (and from + (let ((stop-pos + (string-match " *at \\| *@ \\| *(\\| *<" from))) + (setq message-of + (concat (if stop-pos (substring from 0 stop-pos) from) + "'s message of " date)))) + (setq sender (mail-fetch-field "sender")) + (setq subject (or (mail-fetch-field "subject") + "Re: none")) + (or (string-match "^[Rr][Ee]:" subject) + (setq subject (concat "Re: " subject))) + (setq cc (mail-fetch-field "cc")) + (setq reply-to (mail-fetch-field "reply-to")) + (setq references (mail-fetch-field "references")) + (setq message-id (mail-fetch-field "message-id")) + (widen)) + (setq news-reply-yank-from from) + (setq news-reply-yank-message-id message-id) + (mail-setup (or to-address + (if (and follow-to (not (stringp follow-to))) "" + (or follow-to reply-to from sender ""))) + subject message-of nil gnus-article-buffer nil) + (if (and follow-to (listp follow-to)) + (progn + (goto-char (point-min)) + (while follow-to + (insert (car (car follow-to)) ": " (cdr (car follow-to)) "\n") + (setq follow-to (cdr follow-to))))) + ;; Fold long references line to follow RFC1036. + (mail-position-on-field "References") + (let ((begin (- (point) (length "References: "))) + (fill-column 78) + (fill-prefix "\t")) + (if references (insert references)) + (if (and references message-id) (insert " ")) + (if message-id (insert message-id)) + ;; The region must end with a newline to fill the region + ;; without inserting extra newline. + (fill-region-as-paragraph begin (1+ (point)))) + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "$")) + (forward-line 1) + (if yank + (let ((last (point))) + (save-excursion + (mail-yank-original nil)) + (run-hooks 'news-reply-header-hook) + (goto-char last)))) + (let ((mail (current-buffer))) + (if yank + (progn + (gnus-configure-windows '(0 1 0)) + (switch-to-buffer mail)) + (gnus-configure-windows '(0 0 1)) + (switch-to-buffer-other-window mail)))))) + + (defun gnus-mail-yank-original () + (interactive) + (save-excursion + (mail-yank-original nil)) + (run-hooks 'news-reply-header-hook)) + + (defun gnus-mail-send-and-exit () + (interactive) + (let ((cbuf (current-buffer))) + (mail-send-and-exit nil) + (if (get-buffer gnus-group-buffer) + (progn + (save-excursion + (set-buffer cbuf) + (let ((reply gnus-article-reply)) + (if (gnus-buffer-exists-p (car-safe reply)) + (progn + (set-buffer (car reply)) + (and (cdr reply) + (gnus-summary-mark-article-as-replied + (cdr reply))))))) + (and gnus-winconf-post-news + (set-window-configuration gnus-winconf-post-news)) + (setq gnus-winconf-post-news nil))))) + + (defun gnus-mail-forward-using-mail () + "Forward the current message to another user using mail." + ;; This is almost a carbon copy of rmail-forward in rmail.el. + (let ((forward-buffer (current-buffer)) + (subject + (concat "[" (if (memq 'mail (assoc (symbol-name + (car (gnus-find-method-for-group + gnus-newsgroup-name))) + gnus-valid-select-methods)) + (gnus-fetch-field "From") + gnus-newsgroup-name) + "] " (or (gnus-fetch-field "Subject") ""))) + beg) + ;; If only one window, use it for the mail buffer. + ;; Otherwise, use another window for the mail buffer + ;; so that the Rmail buffer remains visible + ;; and sending the mail will get back to it. + (if (if (one-window-p t) + (mail nil nil subject) + (mail-other-window nil nil subject)) + (save-excursion + (use-local-map (copy-keymap (current-local-map))) + (local-set-key "\C-c\C-c" 'gnus-mail-send-and-exit) + (setq beg (goto-char (point-max))) + (insert "------- Start of forwarded message -------\n") + (insert-buffer forward-buffer) + (goto-char (point-max)) + (insert "------- End of forwarded message -------\n") + ;; Suggested by Sudish Joseph . + (goto-char beg) + (while (setq beg (next-single-property-change (point) 'invisible)) + (goto-char beg) + (delete-region beg (or (next-single-property-change + (point) 'invisible) + (point-max)))) + ;; You have a chance to arrange the message. + (run-hooks 'gnus-mail-forward-hook))))) + + (defun gnus-mail-other-window-using-mail () + "Compose mail other window using mail." + (mail-other-window nil nil nil nil nil (get-buffer gnus-article-buffer)) + (use-local-map (copy-keymap (current-local-map))) + (local-set-key "\C-c\C-c" 'gnus-mail-send-and-exit)) + + (provide 'gnus-message) + + ;;; gnus-message.el ends here \ No newline at end of file diff --exclude=*.elc --exclude=*~ --exclude=*-[0-9] --exclude=gnus --exclude=readme --context --recursive pub/dgnus/lisp/gnus-score.el dgnus/lisp/gnus-score.el *** pub/dgnus/lisp/gnus-score.el Sat Apr 22 07:49:24 1995 --- dgnus/lisp/gnus-score.el Sat Apr 22 09:08:46 1995 *************** *** 0 **** --- 1,1268 ---- + ;;; gnus-score --- scoring code for Gnus + ;; Copyright (C) 1995 Free Software Foundation, Inc. + + ;; Author: Lars Magne Ingebrigtsen + ;; Per Abrahamsen + ;; Keywords: news + + ;; This file is part of GNU Emacs. + + ;; GNU Emacs is free software; you can redistribute it and/or modify + ;; it under the terms of the GNU General Public License as published by + ;; the Free Software Foundation; either version 2, or (at your option) + ;; any later version. + + ;; GNU Emacs is distributed in the hope that it will be useful, + ;; but WITHOUT ANY WARRANTY; without even the implied warranty of + ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;; GNU General Public License for more details. + + ;; You should have received a copy of the GNU General Public License + ;; along with GNU Emacs; see the file COPYING. If not, write to + ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + ;;; Commentary: + + ;;; Code: + + (require 'gnus) + + (defvar gnus-score-expiry-days 7 + "*Number of days before unused score file entries are expired.") + + (defvar gnus-score-interactive-default-score 1000 + "*Scoring commands will raise/lower the score with this number as the default.") + + (defvar gnus-orphan-score nil + "*All orphans get this score added. Set in the score file.") + + + + ;; Internal variables. + + (defvar gnus-current-score-file nil) + + (defvar gnus-score-alist nil + "Alist containing score information. + The keys can be symbols or strings. The following symbols are defined. + + touched: If this alist has been modified. + mark: Automatically mark articles below this. + expunge: Automatically expunge articles below this. + files: List of other SCORE files to load when loading this one. + eval: Sexp to be evaluated when the score file is loaded. + + String entries have the form (HEADER (MATCH TYPE SCORE DATE) ...) + where HEADER is the header being scored, MATCH is the string we are + looking for, TYPE is a flag indicating whether it should use regexp or + substring matching, SCORE is the score to add and DATE is the date + of the last succesful match.") + + (defvar gnus-score-cache nil) + (defvar gnus-scores-articles nil) + (defvar gnus-scores-exclude-files nil) + (defvar gnus-header-index nil) + (defvar gnus-score-index nil) + + (defvar gnus-winconf-edit-score nil) + + (autoload 'gnus-uu-ctl-map "gnus-uu" nil nil 'keymap) + + ;;; Summary mode score maps. + + (defvar gnus-summary-score-map nil) + (defvar gnus-summary-increase-map nil) + (defvar gnus-summary-inc-subject-map nil) + (defvar gnus-summary-inc-author-map nil) + (defvar gnus-summary-inc-body-map nil) + (defvar gnus-summary-inc-id-map nil) + (defvar gnus-summary-inc-xref-map nil) + (defvar gnus-summary-inc-thread-map nil) + (defvar gnus-summary-inc-fol-map nil) + (defvar gnus-summary-lower-map nil) + (defvar gnus-summary-low-subject-map nil) + (defvar gnus-summary-low-author-map nil) + (defvar gnus-summary-low-body-map nil) + (defvar gnus-summary-low-id-map nil) + (defvar gnus-summary-low-xref-map nil) + (defvar gnus-summary-low-thread-map nil) + (defvar gnus-summary-low-fol-map nil) + + (define-prefix-command 'gnus-summary-score-map) + (define-key gnus-summary-various-map "S" 'gnus-summary-score-map) + (define-key gnus-summary-score-map "s" 'gnus-summary-set-score) + (define-key gnus-summary-score-map "c" 'gnus-score-change-score-file) + (define-key gnus-summary-score-map "m" 'gnus-score-set-mark-below) + (define-key gnus-summary-score-map "x" 'gnus-score-set-expunge-below) + (define-key gnus-summary-score-map "e" 'gnus-score-edit-alist) + (define-key gnus-summary-score-map "f" 'gnus-score-edit-file) + + + (define-prefix-command 'gnus-summary-increase-map) + (define-key gnus-summary-mode-map "I" gnus-summary-increase-map) + + (define-key gnus-summary-increase-map "i" 'gnus-summary-raise-same-subject-and-select) + (define-key gnus-summary-increase-map "I" 'gnus-summary-raise-same-subject) + (define-key gnus-summary-increase-map "\C-i" 'gnus-summary-raise-score) + + (define-prefix-command 'gnus-summary-inc-subject-map) + (define-key gnus-summary-increase-map "s" gnus-summary-inc-subject-map) + (define-key gnus-summary-increase-map "S" 'gnus-summary-temporarily-raise-by-subject) + (define-key gnus-summary-inc-subject-map "s" 'gnus-summary-temporarily-raise-by-subject) + (define-key gnus-summary-inc-subject-map "S" 'gnus-summary-raise-by-subject) + (define-key gnus-summary-inc-subject-map "t" 'gnus-summary-temporarily-raise-by-subject) + (define-key gnus-summary-inc-subject-map "p" 'gnus-summary-raise-by-subject) + + (define-prefix-command 'gnus-summary-inc-author-map) + (define-key gnus-summary-increase-map "a" 'gnus-summary-inc-author-map) + (define-key gnus-summary-increase-map "A" 'gnus-summary-temporarily-raise-by-author) + (define-key gnus-summary-inc-author-map "a" 'gnus-summary-temporarily-raise-by-author) + (define-key gnus-summary-inc-author-map "A" 'gnus-summary-raise-by-author) + (define-key gnus-summary-inc-author-map "t" 'gnus-summary-temporarily-raise-by-author) + (define-key gnus-summary-inc-author-map "p" 'gnus-summary-raise-by-author) + + (define-prefix-command 'gnus-summary-inc-body-map) + (define-key gnus-summary-increase-map "b" 'gnus-summary-inc-body-map) + (define-key gnus-summary-increase-map "B" 'gnus-summary-temporarily-raise-by-body) + (define-key gnus-summary-inc-body-map "b" 'gnus-summary-temporarily-raise-by-body) + (define-key gnus-summary-inc-body-map "B" 'gnus-summary-raise-by-body) + (define-key gnus-summary-inc-body-map "t" 'gnus-summary-temporarily-raise-by-body) + (define-key gnus-summary-inc-body-map "p" 'gnus-summary-raise-by-body) + + (define-prefix-command 'gnus-summary-inc-id-map) + (define-key gnus-summary-increase-map "i" 'gnus-summary-inc-id-map) + (define-key gnus-summary-increase-map "I" 'gnus-summary-temporarily-raise-by-id) + (define-key gnus-summary-inc-id-map "i" 'gnus-summary-temporarily-raise-by-id) + (define-key gnus-summary-inc-id-map "I" 'gnus-summary-raise-by-id) + (define-key gnus-summary-inc-id-map "t" 'gnus-summary-temporarily-raise-by-id) + (define-key gnus-summary-inc-id-map "p" 'gnus-summary-raise-by-id) + + (define-prefix-command 'gnus-summary-inc-thread-map) + (define-key gnus-summary-increase-map "t" 'gnus-summary-inc-thread-map) + (define-key gnus-summary-increase-map "T" 'gnus-summary-temporarily-raise-by-thread) + (define-key gnus-summary-inc-thread-map "t" 'gnus-summary-temporarily-raise-by-thread) + (define-key gnus-summary-inc-thread-map "T" 'gnus-summary-raise-by-thread) + (define-key gnus-summary-inc-thread-map "t" 'gnus-summary-temporarily-raise-by-thread) + (define-key gnus-summary-inc-thread-map "p" 'gnus-summary-raise-by-thread) + + (define-prefix-command 'gnus-summary-inc-xref-map) + (define-key gnus-summary-increase-map "x" 'gnus-summary-inc-xref-map) + (define-key gnus-summary-increase-map "X" 'gnus-summary-temporarily-raise-by-xref) + (define-key gnus-summary-inc-xref-map "x" 'gnus-summary-temporarily-raise-by-xref) + (define-key gnus-summary-inc-xref-map "X" 'gnus-summary-raise-by-xref) + (define-key gnus-summary-inc-xref-map "t" 'gnus-summary-temporarily-raise-by-xref) + (define-key gnus-summary-inc-xref-map "p" 'gnus-summary-raise-by-xref) + + (define-prefix-command 'gnus-summary-inc-fol-map) + (define-key gnus-summary-increase-map "f" 'gnus-summary-inc-fol-map) + (define-key gnus-summary-increase-map "F" 'gnus-summary-raise-followups-to-author) + (define-key gnus-summary-inc-fol-map "f" 'gnus-summary-raise-followups-to-author) + (define-key gnus-summary-inc-fol-map "F" 'gnus-summary-raise-followups-to-author) + (define-key gnus-summary-inc-fol-map "t" 'gnus-summary-raise-followups-to-author) + (define-key gnus-summary-inc-fol-map "p" 'gnus-summary-raise-followups-to-author) + + + (define-prefix-command 'gnus-summary-lower-map) + (define-key gnus-summary-mode-map "L" 'gnus-summary-lower-map) + + (define-key gnus-summary-lower-map "l" 'gnus-summary-lower-same-subject-and-select) + (define-key gnus-summary-lower-map "L" 'gnus-summary-lower-same-subject) + (define-key gnus-summary-lower-map "\C-l" 'gnus-summary-lower-score) + + (define-prefix-command 'gnus-summary-low-subject-map) + (define-key gnus-summary-lower-map "s" 'gnus-summary-low-subject-map) + (define-key gnus-summary-lower-map "S" 'gnus-summary-temporarily-lower-by-subject) + (define-key gnus-summary-low-subject-map "s" 'gnus-summary-temporarily-lower-by-subject) + (define-key gnus-summary-low-subject-map "S" 'gnus-summary-lower-by-subject) + (define-key gnus-summary-low-subject-map "t" 'gnus-summary-temporarily-lower-by-subject) + (define-key gnus-summary-low-subject-map "p" 'gnus-summary-lower-by-subject) + + (define-prefix-command 'gnus-summary-low-body-map) + (define-key gnus-summary-lower-map "b" 'gnus-summary-low-body-map) + (define-key gnus-summary-lower-map "B" 'gnus-summary-temporarily-lower-by-body) + (define-key gnus-summary-low-body-map "b" 'gnus-summary-temporarily-lower-by-body) + (define-key gnus-summary-low-body-map "B" 'gnus-summary-lower-by-body) + (define-key gnus-summary-low-body-map "t" 'gnus-summary-temporarily-lower-by-body) + (define-key gnus-summary-low-body-map "p" 'gnus-summary-lower-by-body) + + (define-prefix-command 'gnus-summary-low-author-map) + (define-key gnus-summary-lower-map "a" 'gnus-summary-low-author-map) + (define-key gnus-summary-lower-map "A" 'gnus-summary-temporarily-lower-by-author) + (define-key gnus-summary-low-author-map "a" 'gnus-summary-temporarily-lower-by-author) + (define-key gnus-summary-low-author-map "A" 'gnus-summary-lower-by-author) + (define-key gnus-summary-low-author-map "t" 'gnus-summary-temporarily-lower-by-author) + (define-key gnus-summary-low-author-map "p" 'gnus-summary-lower-by-author) + + (define-prefix-command 'gnus-summary-low-id-map) + (define-key gnus-summary-lower-map "i" 'gnus-summary-low-id-map) + (define-key gnus-summary-lower-map "I" 'gnus-summary-temporarily-lower-by-id) + (define-key gnus-summary-low-id-map "i" 'gnus-summary-temporarily-lower-by-id) + (define-key gnus-summary-low-id-map "I" 'gnus-summary-lower-by-id) + (define-key gnus-summary-low-id-map "t" 'gnus-summary-temporarily-lower-by-id) + (define-key gnus-summary-low-id-map "p" 'gnus-summary-lower-by-id) + + (define-prefix-command 'gnus-summary-low-thread-map) + (define-key gnus-summary-lower-map "t" 'gnus-summary-low-thread-map) + (define-key gnus-summary-lower-map "T" 'gnus-summary-temporarily-lower-by-thread) + (define-key gnus-summary-low-thread-map "t" 'gnus-summary-temporarily-lower-by-thread) + (define-key gnus-summary-low-thread-map "T" 'gnus-summary-lower-by-thread) + (define-key gnus-summary-low-thread-map "t" 'gnus-summary-temporarily-lower-by-thread) + (define-key gnus-summary-low-thread-map "p" 'gnus-summary-lower-by-thread) + + (define-prefix-command 'gnus-summary-low-xref-map) + (define-key gnus-summary-lower-map "x" 'gnus-summary-low-xref-map) + (define-key gnus-summary-lower-map "X" 'gnus-summary-temporarily-lower-by-xref) + (define-key gnus-summary-low-xref-map "x" 'gnus-summary-temporarily-lower-by-xref) + (define-key gnus-summary-low-xref-map "X" 'gnus-summary-lower-by-xref) + (define-key gnus-summary-low-xref-map "t" 'gnus-summary-temporarily-lower-by-xref) + (define-key gnus-summary-low-xref-map "p" 'gnus-summary-lower-by-xref) + + (define-prefix-command 'gnus-summary-low-fol-map) + (define-key gnus-summary-lower-map "f" 'gnus-summary-low-fol-map) + (define-key gnus-summary-lower-map "F" 'gnus-summary-lower-followups-to-author) + (define-key gnus-summary-low-fol-map "f" 'gnus-summary-lower-followups-to-author) + (define-key gnus-summary-low-fol-map "F" 'gnus-summary-lower-followups-to-author) + (define-key gnus-summary-low-fol-map "t" 'gnus-summary-lower-followups-to-author) + (define-key gnus-summary-low-fol-map "p" 'gnus-summary-lower-followups-to-author) + + + ;; Summary score file commands + + ;; Much modification of the kill (ahem, score) code and lots of the + ;; functions are written by Per Abrahamsen . + + (defun gnus-summary-header (header) + ;; Return HEADER for current articles, or error. + (let ((article (gnus-summary-article-number))) + (if article + (aref (gnus-get-header-by-number article) + (nth 1 (assoc header gnus-header-index))) + (error "No article on current line")))) + + (defun gnus-summary-score-entry (header match type score date &optional prompt) + "Enter score file entry. + HEADER is the header being scored. + MATCH is the string we are looking for. + TYPE is a flag indicating if it is a regexp or substring. + SCORE is the score to add. + DATE is the expire date." + (interactive + (list (completing-read "Header: " + gnus-header-index + (lambda (x) (fboundp (nth 2 x))) + t) + (read-string "Match: ") + (y-or-n-p "Use regexp match? ") + (prefix-numeric-value current-prefix-arg) + (if (y-or-n-p "Expire kill? ") + (current-time-string) + nil))) + (let ((score (gnus-score-default score)) + (header (downcase header))) + (and prompt (setq match (read-string + (format "Match %s on %s, %s: " + (if date "temp" "permanent") + header + (if (< score 0) "lower" "raise")) + match))) + (and (>= (nth 1 (assoc header gnus-header-index)) 0) + (gnus-summary-score-effect header match type score)) + (and (= score gnus-score-interactive-default-score) + (setq score nil)) + (let ((new (cond (type + (list match score (and date (gnus-day-number date)) type)) + (date + (list match score (gnus-day-number date))) + (score + (list match score)) + (t + (list match)))) + (old (gnus-score-get header))) + (gnus-score-set + header + (if old (cons new old) (list new)))) + (gnus-score-set 'touched '(t)))) + + (defun gnus-summary-score-effect (header match type score) + "Simulate the effect of a score file entry. + HEADER is the header being scored. + MATCH is the string we are looking for. + TYPE is a flag indicating if it is a regexp or substring. + SCORE is the score to add." + (interactive (list (completing-read "Header: " + gnus-header-index + (lambda (x) (fboundp (nth 2 x))) + t) + (read-string "Match: ") + (y-or-n-p "Use regexp match? ") + (prefix-numeric-value current-prefix-arg))) + (save-excursion + (or (and (stringp match) (> (length match) 0)) + (error "No match")) + (goto-char (point-min)) + (let ((regexp (if type + match + (concat "\\`.*" (regexp-quote match) ".*\\'")))) + (while (not (eobp)) + (let ((content (gnus-summary-header header)) + (case-fold-search t)) + (and content + (if (string-match regexp content) + (gnus-summary-raise-score score)))) + (beginning-of-line 2))))) + + (defun gnus-summary-score-crossposting (score date) + ;; Enter score file entry for current crossposting. + ;; SCORE is the score to add. + ;; DATE is the expire date. + (let ((xref (gnus-summary-header "xref")) + (start 0) + group) + (or xref (error "This article is not crossposted")) + (while (string-match " \\([^ \t]+\\):" xref start) + (setq start (match-end 0)) + (if (not (string= + (setq group + (substring xref (match-beginning 1) (match-end 1))) + gnus-newsgroup-name)) + (gnus-summary-score-entry + "xref" (concat " " group ":") nil score date t))))) + + (defun gnus-summary-temporarily-lower-by-subject (level) + "Temporarily lower score by LEVEL for current subject. + See `gnus-score-expiry-days'." + (interactive "P") + (gnus-summary-score-entry + "subject" (gnus-simplify-subject-re (gnus-summary-header "subject")) + nil (- (gnus-score-default level)) + (current-time-string) t)) + + (defun gnus-summary-temporarily-lower-by-author (level) + "Temporarily lower score by LEVEL for current author. + See `gnus-score-expiry-days'." + (interactive "P") + (gnus-summary-score-entry + "from" (gnus-summary-header "from") nil (- (gnus-score-default level)) + (current-time-string) t)) + + (defun gnus-summary-temporarily-lower-by-body (level) + "Temporarily lower score by LEVEL for a match on the body of the article. + See `gnus-score-expiry-days'." + (interactive "P") + (gnus-summary-score-entry + "body" "" nil (- (gnus-score-default level)) (current-time-string) t)) + + (defun gnus-summary-temporarily-lower-by-id (level) + "Temporarily lower score by LEVEL for current message-id. + See `gnus-score-expiry-days'." + (interactive "P") + (gnus-summary-score-entry + "message-id" (gnus-summary-header "message-id") + nil (- (gnus-score-default level)) + (current-time-string))) + + (defun gnus-summary-temporarily-lower-by-xref (level) + "Temporarily lower score by LEVEL for current xref. + See `gnus-score-expiry-days'." + (interactive "P") + (gnus-summary-score-crossposting + (- (gnus-score-default level)) (current-time-string))) + + (defun gnus-summary-temporarily-lower-by-thread (level) + "Temporarily lower score by LEVEL for current thread. + See `gnus-score-expiry-days'." + (interactive "P") + (gnus-summary-score-entry + "references" (gnus-summary-header "message-id") + nil (- (gnus-score-default level)) (current-time-string))) + + (defun gnus-summary-lower-by-subject (level) + "Lower score by LEVEL for current subject." + (interactive "P") + (gnus-summary-score-entry + "subject" (gnus-simplify-subject-re (gnus-summary-header "subject")) + nil (- (gnus-score-default level)) + nil t)) + + (defun gnus-summary-lower-by-author (level) + "Lower score by LEVEL for current author." + (interactive "P") + (gnus-summary-score-entry + "from" (gnus-summary-header "from") nil + (- (gnus-score-default level)) nil t)) + + (defun gnus-summary-lower-by-body (level) + "Lower score by LEVEL for a match on the body of the article." + (interactive "P") + (gnus-summary-score-entry + "body" "" nil (- (gnus-score-default level)) nil t)) + + (defun gnus-summary-lower-by-id (level) + "Lower score by LEVEL for current message-id." + (interactive "P") + (gnus-summary-score-entry + "message-id" (gnus-summary-header "message-id") nil + (- (gnus-score-default level)) nil)) + + (defun gnus-summary-lower-by-xref (level) + "Lower score by LEVEL for current xref." + (interactive "P") + (gnus-summary-score-crossposting (- (gnus-score-default level)) nil)) + + (defun gnus-summary-lower-followups-to-author (level) + "Lower score by LEVEL for all followups to the current author." + (interactive "P") + (gnus-summary-raise-followups-to-author + (- (gnus-score-default level)))) + + (defun gnus-summary-temporarily-raise-by-subject (level) + "Temporarily raise score by LEVEL for current subject. + See `gnus-score-expiry-days'." + (interactive "P") + (gnus-summary-score-entry + "subject" (gnus-simplify-subject-re (gnus-summary-header "subject")) + nil level (current-time-string) t)) + + (defun gnus-summary-temporarily-raise-by-author (level) + "Temporarily raise score by LEVEL for current author. + See `gnus-score-expiry-days'." + (interactive "P") + (gnus-summary-score-entry + "from" (gnus-summary-header "from") nil level (current-time-string) t)) + + (defun gnus-summary-temporarily-raise-by-body (level) + "Temporarily raise score by LEVEL for a match on the body of the article. + See `gnus-score-expiry-days'." + (interactive "P") + (gnus-summary-score-entry "body" "" nil level (current-time-string) t)) + + (defun gnus-summary-temporarily-raise-by-id (level) + "Temporarily raise score by LEVEL for current message-id. + See `gnus-score-expiry-days'." + (interactive "P") + (gnus-summary-score-entry + "message-id" (gnus-summary-header "message-id") + nil level (current-time-string))) + + (defun gnus-summary-temporarily-raise-by-xref (level) + "Temporarily raise score by LEVEL for current xref. + See `gnus-score-expiry-days'." + (interactive "P") + (gnus-summary-score-crossposting level (current-time-string))) + + (defun gnus-summary-temporarily-raise-by-thread (level) + "Temporarily raise score by LEVEL for current thread. + See `gnus-score-expiry-days'." + (interactive "P") + (gnus-summary-score-entry + "references" (gnus-summary-header "message-id") + nil level (current-time-string))) + + (defun gnus-summary-raise-by-subject (level) + "Raise score by LEVEL for current subject." + (interactive "P") + (gnus-summary-score-entry + "subject" (gnus-simplify-subject-re (gnus-summary-header "subject")) + nil level nil t)) + + (defun gnus-summary-raise-by-author (level) + "Raise score by LEVEL for current author." + (interactive "P") + (gnus-summary-score-entry + "from" (gnus-summary-header "from") nil level nil t)) + + (defun gnus-summary-raise-by-body (level) + "Raise score by LEVEL for a match on the body of the article." + (interactive "P") + (gnus-summary-score-entry "body" "" nil level nil t)) + + (defun gnus-summary-raise-by-id (level) + "Raise score by LEVEL for current message-id." + (interactive "P") + (gnus-summary-score-entry + "message-id" (gnus-summary-header "message-id") nil level nil)) + + (defun gnus-summary-raise-by-xref (level) + "Raise score by LEVEL for current xref." + (interactive "P") + (gnus-summary-score-crossposting level nil)) + + (defun gnus-summary-raise-followups-to-author (level) + "Raise score by LEVEL for all followups to the current author." + (interactive "P") + (let ((article (gnus-summary-article-number))) + (if article (setq gnus-current-headers (gnus-get-header-by-number article)) + (error "No article on current line"))) + (gnus-kill-file-raise-followups-to-author + (gnus-score-default level))) + + + + ;;; + ;;; Gnus Score Files + ;;; + + ;; All score code written by Per Abrahamsen . + + ;; Added by Per Abrahamsen . + (defun gnus-score-set-mark-below (score) + "Automatically mark articles with score below SCORE as read." + (interactive + (list (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg)) + (string-to-int (read-string "Mark below: "))))) + (setq score (or score gnus-summary-default-score 0)) + (gnus-score-set 'mark (list score)) + (gnus-score-set 'touched '(t)) + (setq gnus-summary-mark-below score) + (gnus-summary-update-lines)) + + (defun gnus-score-set-expunge-below (score) + "Automatically expunge articles with score below SCORE." + (interactive + (list (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg)) + (string-to-int (read-string "Expunge below: "))))) + (setq score (or score gnus-summary-default-score 0)) + (gnus-score-set 'expunge (list score)) + (gnus-score-set 'touched '(t))) + + (defun gnus-score-default (level) + (if level (prefix-numeric-value level) + gnus-score-interactive-default-score)) + + (defun gnus-score-set (symbol value &optional alist) + ;; Set SYMBOL to VALUE in ALIST. + (let* ((alist + (or alist + gnus-score-alist + (progn + (gnus-score-load (gnus-score-file-name gnus-newsgroup-name)) + gnus-score-alist))) + (entry (assoc symbol alist))) + (cond ((gnus-score-get 'read-only alist) + ;; This is a read-only score file, so we do nothing. + ) + (entry + (setcdr entry value)) + ((null alist) + (error "Empty alist")) + (t + (setcdr alist + (cons (cons symbol value) (cdr alist))))))) + + (defun gnus-score-get (symbol &optional alist) + ;; Get SYMBOL's definition in ALIST. + (cdr (assoc symbol + (or alist + gnus-score-alist + (progn + (gnus-score-load + (gnus-score-file-name gnus-newsgroup-name)) + gnus-score-alist))))) + + (defun gnus-score-change-score-file (file) + "Change current score alist." + (interactive + (list (completing-read "Score file: " gnus-score-cache))) + (setq gnus-current-score-file file) + (gnus-score-load-file file) + (gnus-set-mode-line 'summary)) + + (defun gnus-score-edit-alist (file) + "Edit the current score alist." + (interactive (list gnus-current-score-file)) + (and (buffer-name gnus-summary-buffer) (gnus-score-save)) + (setq gnus-winconf-edit-score (current-window-configuration)) + (gnus-configure-windows 'article) + (pop-to-buffer (find-file-noselect file)) + (message (substitute-command-keys + "\\\\[gnus-score-edit-done] to save edits")) + (gnus-score-mode)) + + (defun gnus-score-edit-file (file) + "Edit a score file." + (interactive + (list (read-file-name "Edit score file: " gnus-kill-files-directory))) + (and (buffer-name gnus-summary-buffer) (gnus-score-save)) + (setq gnus-winconf-edit-score (current-window-configuration)) + (gnus-configure-windows 'article) + (pop-to-buffer (find-file-noselect file)) + (message (substitute-command-keys + "\\\\[gnus-score-edit-done] to save edits")) + (gnus-score-mode)) + + (defun gnus-score-load-file (file) + ;; Load score file FILE. Returns a list a retrieved score-alists. + (setq gnus-kill-files-directory (or gnus-kill-files-directory "~/News/")) + (let* ((file (expand-file-name + (or (and (string-match + (concat "^" (expand-file-name + gnus-kill-files-directory)) + (expand-file-name file)) + file) + (concat gnus-kill-files-directory file)))) + (cached (assoc file gnus-score-cache)) + (global (member file gnus-internal-global-score-files)) + lists alist) + (if cached + ;; The score file was already loaded. + (setq alist (cdr cached)) + ;; We load the score file. + (setq gnus-score-alist nil) + (setq alist (gnus-score-load-score-alist file)) + ;; We add '(touched) to the alist to signify that it hasn't been + ;; touched (yet). + (or (assq 'touched alist) (setq alist (cons (list 'touched nil) alist))) + ;; If it is a global score file, we make it read-only. + (and global + (not (assq 'read-only alist)) + (setq alist (cons (list 'read-only t) alist))) + ;; Update cache. + (setq gnus-score-cache + (cons (cons file alist) gnus-score-cache))) + ;; If there are actual scores in the alist, we add it to the + ;; return value of this function. + (if (memq t (mapcar (lambda (e) (stringp (car e))) alist)) + (setq lists (list alist))) + ;; Treat the other possible atoms in the score alist. + (let ((mark (car (gnus-score-get 'mark alist))) + (expunge (car (gnus-score-get 'expunge alist))) + (mark-and-expunge + (car (gnus-score-get 'mark-and-expunge alist))) + (read-only (gnus-score-get 'read-only alist)) + (files (gnus-score-get 'files alist)) + (exclude-files (gnus-score-get 'exclude-files alist)) + (orphan (gnus-score-get 'orphan alist)) + (eval (gnus-score-get 'eval 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)) + files)))) + (and eval (not global) (eval eval)) + (setq gnus-scores-exclude-files exclude-files) + (if orphan (setq gnus-orphan-score (car orphan))) + (setq gnus-summary-mark-below + (or mark mark-and-expunge gnus-summary-mark-below)) + (setq gnus-summary-expunge-below + (or expunge mark-and-expunge gnus-summary-expunge-below))) + (setq gnus-current-score-file file) + (setq gnus-score-alist alist) + lists)) + + (defun gnus-score-load (file) + ;; Load score FILE. + (let ((cache (assoc file gnus-score-cache))) + (if cache + (setq gnus-score-alist (cdr cache)) + (setq gnus-score-alist nil) + (gnus-score-load-score-alist file) + (or gnus-score-alist + (setq gnus-score-alist (copy-alist '((touched nil))))) + (setq gnus-score-cache + (cons (cons file gnus-score-alist) gnus-score-cache))))) + + (defun gnus-score-remove-from-cache (file) + (setq gnus-score-cache + (delq (assoc file gnus-score-cache) gnus-score-cache))) + + (defun gnus-score-load-score-alist (file) + (let (alist) + (if (file-readable-p file) + (progn + (save-excursion + (gnus-set-work-buffer) + (insert-file-contents file) + (goto-char (point-min)) + ;; Only do the loading if the score file isn't empty. + (if (save-excursion (re-search-forward "[()0-9a-zA-Z]" nil t)) + (setq alist + (condition-case () + (read (current-buffer)) + (error + (progn + (message "Problem with score file %s" file) + (ding) + (sit-for 2) + nil)))))) + (if (eq (car alist) 'setq) + (setq gnus-score-alist (gnus-score-transform-old-to-new alist)) + (setq gnus-score-alist alist)) + (setq gnus-score-alist + (gnus-score-check-syntax gnus-score-alist file))) + (setq gnus-score-alist nil)))) + + (defun gnus-score-check-syntax (alist file) + (cond + ((null alist) + nil) + ((not (consp alist)) + (message "Score file is not a list: %s" file) + (ding) + nil) + (t + (let ((a alist) + err) + (while (and a (not err)) + (cond ((not (listp (car a))) + (message "Illegal score element %s in %s" (car a) file) + (setq err t)) + ((and (stringp (car (car a))) + (not (listp (nth 1 (car a))))) + (message "Illegal header match %s in %s" (nth 1 (car a)) file) + (setq err t)) + (t + (setq a (cdr a))))) + (if err + (progn + (ding) + nil) + alist))))) + + (defun gnus-score-transform-old-to-new (alist) + (let* ((alist (nth 2 alist)) + out entry) + (if (eq (car alist) 'quote) + (setq alist (nth 1 alist))) + (while alist + (setq entry (car alist)) + (if (stringp (car entry)) + (let ((scor (cdr entry))) + (setq out (cons entry out)) + (while scor + (setcar scor + (list (car (car scor)) (nth 2 (car scor)) + (and (nth 3 (car scor)) + (gnus-day-number (nth 3 (car scor)))) + (if (nth 1 (car scor)) 'r 's))) + (setq scor (cdr scor)))) + (setq out (cons (if (not (listp (cdr entry))) + (list (car entry) (cdr entry)) + entry) + out))) + (setq alist (cdr alist))) + (cons (list 'touched t) (nreverse out)))) + + (defun gnus-score-save () + ;; Save all SCORE information. + (let ((cache gnus-score-cache)) + (save-excursion + (setq gnus-score-alist nil) + (set-buffer (get-buffer-create "*Score*")) + (buffer-disable-undo (current-buffer)) + (let (entry score file) + (while cache + (setq entry (car cache) + cache (cdr cache) + file (car entry) + score (cdr entry)) + (if (or (not (equal (gnus-score-get 'touched score) '(t))) + (gnus-score-get 'read-only score) + (not (file-writable-p file))) + () + (setq score (delq (assq 'touched score) score)) + (erase-buffer) + (let (emacs-lisp-mode-hook) + (pp score (current-buffer))) + (gnus-make-directory (file-name-directory file)) + (write-region (point-min) (point-max) file nil 'silent)))) + (kill-buffer (current-buffer))))) + + (defun gnus-score-headers (score-files) + ;; Score `gnus-newsgroup-headers'. + (let (scores) + ;; PLM: probably this is not the best place to clear orphan-score + (setq gnus-orphan-score nil) + ;; Load the SCORE files. + (while score-files + (if (stringp (car score-files)) + ;; It is a string, which means that it's a score file name, + ;; so we load the score file and add the score alist to + ;; the list of alists. + (setq scores (nconc (gnus-score-load-file (car score-files)) scores)) + ;; It is an alist, so we just add it to the list directly. + (setq scores (nconc (car score-files) scores))) + (setq score-files (cdr score-files))) + ;; Prune the score files that are to be excluded, if any. + (if (not gnus-scores-exclude-files) + () + (let ((s scores) + c) + (while s + (and (setq c (rassq (car s) gnus-score-cache)) + (member (car c) gnus-scores-exclude-files) + (setq scores (delq (car s) scores))) + (setq s (cdr s))))) + (if (not (and gnus-summary-default-score + scores + (> (length gnus-newsgroup-headers) + (length gnus-newsgroup-scored)))) + () + (let* ((entries gnus-header-index) + (now (gnus-day-number (current-time-string))) + (expire (- now gnus-score-expiry-days)) + (headers gnus-newsgroup-headers) + entry header) + (message "Scoring...") + ;; Create articles, an alist of the form `(HEADER . SCORE)'. + (while headers + (setq header (car headers) + headers (cdr headers)) + ;; WARNING: The assq makes the function O(N*S) while it could + ;; be written as O(N+S), where N is (length gnus-newsgroup-headers) + ;; and S is (length gnus-newsgroup-scored). + (or (assq (header-number header) gnus-newsgroup-scored) + (setq gnus-scores-articles ;Total of 2 * N cons-cells used. + (cons (cons header (or gnus-summary-default-score 0)) + gnus-scores-articles)))) + + (save-excursion + (set-buffer (get-buffer-create "*Headers*")) + (buffer-disable-undo (current-buffer)) + ;; score orphans + (if gnus-orphan-score + (progn + (setq gnus-score-index + (nth 1 (assoc "references" gnus-header-index))) + (gnus-score-orphans gnus-orphan-score))) + ;; Run each header through the score process. + (while entries + (setq entry (car entries) + header (nth 0 entry) + entries (cdr entries)) + (setq gnus-score-index (nth 1 (assoc header gnus-header-index))) + (if (< 0 (apply 'max (mapcar + (lambda (score) + (length (gnus-score-get header score))) + scores))) + (funcall (nth 2 entry) scores header now expire))) + ;; Remove the buffer. + (kill-buffer (current-buffer))) + + ;; Add articles to `gnus-newsgroup-scored'. + (while gnus-scores-articles + (or (= gnus-summary-default-score (cdr (car gnus-scores-articles))) + (setq gnus-newsgroup-scored + (cons (cons (header-number + (car (car gnus-scores-articles))) + (cdr (car gnus-scores-articles))) + gnus-newsgroup-scored))) + (setq gnus-scores-articles (cdr gnus-scores-articles))) + + (message "Scoring...done"))))) + + + (defun gnus-get-new-thread-ids (articles) + (let ((index (nth 1 (assoc "message-id" gnus-header-index))) + (refind gnus-score-index) + id-list art this tref) + (while articles + (setq art (car articles) + this (aref (car art) index) + tref (aref (car art) refind) + articles (cdr articles)) + (if (string-equal tref "") ;no references line + (setq id-list (cons this id-list)))) + id-list)) + + ;; Orphan functions written by plm@atcmp.nl (Peter Mutsaers). + (defun gnus-score-orphans (score) + (let ((new-thread-ids (gnus-get-new-thread-ids gnus-scores-articles)) + (index (nth 1 (assoc "references" gnus-header-index))) + alike articles art arts this last this-id) + + (setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<) + articles gnus-scores-articles) + + ;;more or less the same as in gnus-score-string + (erase-buffer) + (while articles + (setq art (car articles) + this (aref (car art) gnus-score-index) + articles (cdr articles)) + ;;completely skip if this is empty (not a child, so not an orphan) + (if (not (string= this "")) + (if (equal last this) + ;; O(N*H) cons-cells used here, where H is the number of + ;; headers. + (setq alike (cons art alike)) + (if last + (progn + ;; Insert the line, with a text property on the + ;; terminating newline refering to the articles with + ;; this line. + (insert last ?\n) + (put-text-property (1- (point)) (point) 'articles alike))) + (setq alike (list art) + last this)))) + (and last ; Bwadr, duplicate code. + (progn + (insert last ?\n) + (put-text-property (1- (point)) (point) 'articles alike))) + + ;; PLM: now delete those lines that contain an entry from new-thread-ids + (while new-thread-ids + (setq this-id (car new-thread-ids) + new-thread-ids (cdr new-thread-ids)) + (goto-char (point-min)) + (while (search-forward this-id nil t) + ;; found a match. remove this line + (beginning-of-line) + (kill-line 1))) + + ;; now for each line: update its articles with score by moving to + ;; every end-of-line in the buffer and read the articles property + (goto-char (point-min)) + (while (eq 0 (progn + (end-of-line) + (setq arts (get-text-property (point) 'articles)) + (while arts + (setq art (car arts) + arts (cdr arts)) + (setcdr art (+ score (cdr art)))) + (forward-line)))))) + + + (defun gnus-score-integer (scores header now expire) + (let ((gnus-score-index (nth 1 (assoc header gnus-header-index))) + alike last this art entries alist articles) + + ;; Find matches. + (while scores + (setq alist (car scores) + scores (cdr scores) + entries (assoc header alist)) + (while (cdr entries) ;First entry is the header index. + (let* ((rest (cdr entries)) + (kill (car rest)) + (match (nth 0 kill)) + (type (or (nth 3 kill) '>)) + (score (or (nth 1 kill) gnus-score-interactive-default-score)) + (date (nth 2 kill)) + (found nil) + (match-func (if (or (eq type '>) (eq type '<) (eq type '<=) + (eq type '>=) (eq type '=)) + type + (error "Illegal match type: %s" type))) + (articles gnus-scores-articles) + arts art) + ;; Instead of doing all the clever stuff that + ;; `gnus-score-string' does to minimize searches and stuff, + ;; I will assume that people generally will put so few + ;; matches on numbers that any cleverness will take more + ;; time than one would gain. + (while articles + (and (funcall match-func match + (or (aref (car (car articles)) gnus-score-index) 0)) + (progn + (setq found t) + (setcdr (car articles) (+ score (cdr (car articles)))))) + (setq articles (cdr articles))) + ;; Update expire date + (cond ((null date)) ;Permanent entry. + (found ;Match, update date. + (gnus-score-set 'touched '(t) alist) + (setcar (nthcdr 2 kill) now)) + ((< date expire) ;Old entry, remove. + (gnus-score-set 'touched '(t) alist) + (setcdr entries (cdr rest)) + (setq rest entries))) + (setq entries rest)))))) + + (defun gnus-score-date (scores header now expire) + (let ((gnus-score-index (nth 1 (assoc header gnus-header-index))) + alike last this art entries alist articles) + + ;; Find matches. + (while scores + (setq alist (car scores) + scores (cdr scores) + entries (assoc header alist)) + (while (cdr entries) ;First entry is the header index. + (let* ((rest (cdr entries)) + (kill (car rest)) + (match (timezone-make-date-sortable (nth 0 kill))) + (type (or (nth 3 kill) 'before)) + (score (or (nth 1 kill) gnus-score-interactive-default-score)) + (date (nth 2 kill)) + (found nil) + (match-func + (cond ((eq type 'after) 'string<) + ((eq type 'before) 'gnus-string>) + ((eq type 'at) 'string=) + (t (error "Illegal match type: %s" type)))) + (articles gnus-scores-articles) + arts art l) + ;; Instead of doing all the clever stuff that + ;; `gnus-score-string' does to minimize searches and stuff, + ;; I will assume that people generally will put so few + ;; matches on numbers that any cleverness will take more + ;; time than one would gain. + (while articles + (and + (setq l (aref (car (car articles)) gnus-score-index)) + (funcall match-func match (timezone-make-date-sortable l)) + (progn + (setq found t) + (setcdr (car articles) (+ score (cdr (car articles)))))) + (setq articles (cdr articles))) + ;; Update expire date + (cond ((null date)) ;Permanent entry. + (found ;Match, update date. + (gnus-score-set 'touched '(t) alist) + (setcar (nthcdr 2 kill) now)) + ((< date expire) ;Old entry, remove. + (gnus-score-set 'touched '(t) alist) + (setcdr entries (cdr rest)) + (setq rest entries))) + (setq entries rest)))))) + + (defun gnus-score-body (scores header now expire) + (save-excursion + (set-buffer nntp-server-buffer) + (save-restriction + (let* ((buffer-read-only nil) + (articles gnus-scores-articles) + (all-scores scores) + (request-func (cond ((string= "head" (downcase header)) + 'gnus-request-head) + ((string= "body" (downcase header)) + 'gnus-request-body) + (t 'gnus-request-article))) + alike last this art entries alist ofunc article) + ;; Not all backends support partial fetching. In that case, + ;; we just fetch the entire article. + (or (gnus-check-backend-function request-func gnus-newsgroup-name) + (progn + (setq ofunc request-func) + (setq request-func 'gnus-request-article))) + (while articles + (setq article (header-number (car (car articles)))) + (message "Scoring on article %s..." article) + (if (not (funcall request-func article gnus-newsgroup-name)) + () + (widen) + (goto-char (point-min)) + ;; If just parts of the article is to be searched, but the + ;; backend didn't support partial fetching, we just narrow + ;; to the relevant parts. + (if ofunc + (if (eq ofunc 'gnus-request-head) + (narrow-to-region + (point) + (or (search-forward "\n\n" nil t) (point-max))) + (narrow-to-region + (or (search-forward "\n\n" nil t) (point)) + (point-max)))) + (setq scores all-scores) + ;; Find matches. + (while scores + (setq alist (car scores) + scores (cdr scores) + entries (assoc header alist)) + (while (cdr entries) ;First entry is the header index. + (let* ((rest (cdr entries)) + (kill (car rest)) + (match (nth 0 kill)) + (type (or (nth 3 kill) 's)) + (score (or (nth 1 kill) + gnus-score-interactive-default-score)) + (date (nth 2 kill)) + (found nil) + (case-fold-search + (not (or (eq type 'R) (eq type 'S) + (eq type 'Regexp) (eq type 'String)))) + (search-func + (cond ((or (eq type 'r) (eq type 'R) + (eq type 'regexp) (eq type 'Regexp)) + 're-search-forward) + ((or (eq type 's) (eq type 'S) + (eq type 'string) (eq type 'String)) + 'search-forward) + (t + (error "Illegal match type: %s" type)))) + arts art) + (goto-char (point-min)) + (if (funcall search-func match nil t) + ;; Found a match, update scores. + (progn + (setcdr (car articles) (+ score (cdr (car articles)))) + (setq found t))) + ;; Update expire date + (cond ((null date)) ;Permanent entry. + (found ;Match, update date. + (gnus-score-set 'touched '(t) alist) + (setcar (nthcdr 2 kill) now)) + ((< date expire) ;Old entry, remove. + (gnus-score-set 'touched '(t) alist) + (setcdr entries (cdr rest)) + (setq rest entries))) + (setq entries rest))))) + (setq articles (cdr articles))))))) + + (defun gnus-score-string (scores header now expire) + ;; Score ARTICLES according to HEADER in SCORES. + ;; Update matches entries to NOW and remove unmatched entried older + ;; than EXPIRE. + + ;; 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. + alike last this art entries alist articles) + + ;; Sorting the articles costs os O(N*log N) but will allow us to + ;; only match with each unique header. Thus the actual matching + ;; will be O(M*U) where M is the number of strings to match with, + ;; and U is the number of unique headers. It is assumed (but + ;; untested) this will be a net win because of the large constant + ;; factor involved with string matching. + (setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<) + articles gnus-scores-articles) + + (erase-buffer) + (while articles + (setq art (car articles) + this (aref (car art) gnus-score-index) + articles (cdr articles)) + (if (equal last this) + ;; O(N*H) cons-cells used here, where H is the number of + ;; headers. + (setq alike (cons art alike)) + (if last + (progn + ;; Insert the line, with a text property on the + ;; terminating newline refering to the articles with + ;; this line. + (insert last ?\n) + (put-text-property (1- (point)) (point) 'articles alike))) + (setq alike (list art) + last this))) + (and last ; Bwadr, duplicate code. + (progn + (insert last ?\n) + (put-text-property (1- (point)) (point) 'articles alike))) + + ;; Find matches. + (while scores + (setq alist (car scores) + scores (cdr scores) + entries (assoc header alist)) + (while (cdr entries) ;First entry is the header index. + (let* ((rest (cdr entries)) + (kill (car rest)) + (match (nth 0 kill)) + (type (or (nth 3 kill) 's)) + (score (or (nth 1 kill) gnus-score-interactive-default-score)) + (date (nth 2 kill)) + (found nil) + (case-fold-search + (not (or (eq type 'R) (eq type 'S) + (eq type 'Regexp) (eq type 'String)))) + (search-func (cond ((or (eq type 'r) (eq type 'R) + (eq type 'regexp) (eq type 'Regexp)) + 're-search-forward) + ((or (eq type 's) (eq type 'S) + (eq type 'string) (eq type 'String)) + 'search-forward) + (t + (error "Illegal match type: %s" type)))) + arts art) + (goto-char (point-min)) + (while (funcall search-func match nil t) + (end-of-line 1) + (setq found t + arts (get-text-property (point) 'articles)) + ;; Found a match, update scores. + (while arts + (setq art (car arts) + arts (cdr arts)) + (setcdr art (+ score (cdr art))))) + ;; Update expire date + (cond ((null date)) ;Permanent entry. + (found ;Match, update date. + (gnus-score-set 'touched '(t) alist) + (setcar (nthcdr 2 kill) now)) + ((< date expire) ;Old entry, remove. + (gnus-score-set 'touched '(t) alist) + (setcdr entries (cdr rest)) + (setq rest entries))) + (setq entries rest)))))) + + (defun gnus-score-string< (a1 a2) + ;; Compare headers in articles A2 and A2. + ;; The header index used is the free variable `gnus-score-index'. + (string-lessp (aref (car a1) gnus-score-index) + (aref (car a2) gnus-score-index))) + + (defun gnus-score-build-cons (article) + ;; Build a `gnus-newsgroup-scored' type cons from ARTICLE. + (cons (header-number (car article)) (cdr article))) + + (defconst gnus-header-index + ;; Name to index alist. + '(("number" 0 gnus-score-integer) + ("subject" 1 gnus-score-string) + ("from" 2 gnus-score-string) + ("date" 3 gnus-score-date) + ("message-id" 4 gnus-score-string) + ("references" 5 gnus-score-string) + ("chars" 6 gnus-score-integer) + ("lines" 7 gnus-score-integer) + ("xref" 8 gnus-score-string) + ("head" -1 gnus-score-body) + ("body" -1 gnus-score-body) + ("all" -1 gnus-score-body))) + + (defun gnus-current-score-file-nondirectory (&optional score-file) + (let ((score-file (or score-file gnus-current-score-file))) + (if score-file + (gnus-short-group-name (file-name-nondirectory score-file)) + "none"))) + + ;;; + ;;; Score mode. + ;;; + + (defvar gnus-score-mode-map nil) + (defvar gnus-score-mode-hook nil) + + (if gnus-score-mode-map + () + (setq gnus-score-mode-map (copy-keymap emacs-lisp-mode-map)) + (define-key gnus-score-mode-map "\C-c\C-c" 'gnus-score-edit-done) + (define-key gnus-score-mode-map "\C-c\C-d" 'gnus-score-edit-insert-date)) + + (defun gnus-score-mode () + "Mode for editing score files. + This mode is an extended emacs-lisp mode. + + \\{gnus-score-mode-map}" + (interactive) + (kill-all-local-variables) + (use-local-map gnus-score-mode-map) + (set-syntax-table emacs-lisp-mode-syntax-table) + (setq major-mode 'gnus-score-mode) + (setq mode-name "Score") + (lisp-mode-variables nil) + (run-hooks 'emacs-lisp-mode-hook 'gnus-score-mode-hook)) + + (defun gnus-score-edit-insert-date () + "Insert date in numerical format." + (interactive) + (insert (int-to-string (gnus-day-number (current-time-string))))) + + (defun gnus-score-edit-done () + "Save the score file and return to the summary buffer." + (interactive) + (let ((bufnam (buffer-file-name (current-buffer)))) + (save-buffer) + (kill-buffer (current-buffer)) + (and gnus-winconf-edit-score + (set-window-configuration gnus-winconf-edit-score)) + (gnus-score-remove-from-cache bufnam) + (gnus-score-load-file bufnam))) + + (provide 'gnus-score) + + ;;; gnus-score.el ends here \ No newline at end of file diff --exclude=*.elc --exclude=*~ --exclude=*-[0-9] --exclude=gnus --exclude=readme --context --recursive pub/dgnus/lisp/gnus-uu.el dgnus/lisp/gnus-uu.el *** pub/dgnus/lisp/gnus-uu.el Fri Apr 21 05:54:58 1995 --- dgnus/lisp/gnus-uu.el Sat Apr 22 08:26:29 1995 *************** *** 27,32 **** --- 27,33 ---- ;;; Code: (require 'gnus) + (require 'gnus-message) ;; Default viewing action rules *************** *** 366,379 **** (interactive "P") (gnus-uu-initialize) (let ((gnus-uu-save-in-digest t) ! (file (concat gnus-uu-work-dir (make-temp-name "forward")))) (gnus-uu-decode-save n file) ! (switch-to-buffer (get-buffer-create "*gnus-uu-forward*")) (erase-buffer) (delete-other-windows) (insert-file file) (goto-char (point-min)) ! (funcall gnus-mail-forward-method))) ;; Process marking. --- 367,394 ---- (interactive "P") (gnus-uu-initialize) (let ((gnus-uu-save-in-digest t) ! (file (concat gnus-uu-work-dir (make-temp-name "forward"))) ! buf) ! (setq gnus-winconf-post-news (current-window-configuration)) (gnus-uu-decode-save n file) ! (gnus-uu-add-file file) ! (setq buf (switch-to-buffer (get-buffer-create " *gnus-uu-forward*"))) ! (gnus-add-current-to-buffer-list) (erase-buffer) (delete-other-windows) (insert-file file) (goto-char (point-min)) ! (and (re-search-forward "^Subject: ") ! (progn ! (delete-region (point) (gnus-point-at-eol)) ! (insert "Digested Articles"))) ! (goto-char (point-min)) ! (and (re-search-forward "^From: ") ! (progn ! (delete-region (point) (gnus-point-at-eol)) ! (insert "Various"))) ! (funcall gnus-mail-forward-method) ! (kill-buffer buf))) ;; Process marking. *************** *** 693,702 **** (setq name (cdr (assq 'name (car files)))) (and (setq action (gnus-uu-get-action name)) ! (setcar files (cons (cons 'execute (if (string-match "%" action) ! (format action name) ! (concat action " " name))) ! (car files)))) (setq files (cdr files))) ofiles)) --- 708,718 ---- (setq name (cdr (assq 'name (car files)))) (and (setq action (gnus-uu-get-action name)) ! (setcar files (nconc (list (cons 'action action) ! (cons 'execute (if (string-match "%" action) ! (format action name) ! (concat action " " name)))) ! (car files)))) (setq files (cdr files))) ofiles)) *************** *** 955,960 **** --- 971,977 ---- nntp-server-buffer) (setq gnus-last-article gnus-current-article) (setq gnus-current-article article) + (setq gnus-article-current (cons gnus-newsgroup-name article)) (if (stringp nntp-server-buffer) (setq article-buffer nntp-server-buffer) (setq article-buffer (buffer-name nntp-server-buffer)))) diff --exclude=*.elc --exclude=*~ --exclude=*-[0-9] --exclude=gnus --exclude=readme --context --recursive pub/dgnus/lisp/gnus.el dgnus/lisp/gnus.el *** pub/dgnus/lisp/gnus.el Fri Apr 21 05:55:01 1995 --- dgnus/lisp/gnus.el Sat Apr 22 09:08:48 1995 *************** *** 26,32 **** ;; Although (ding) Gnus looks suspiciously like GNUS, it isn't quite ;; the same beast. Most internal structures have been changed. If you ;; have written packages that depend on any of the hash tables, ! ;; `gnus-newsrc-assoc', `gnus-killed-assoc', marked lists, the .newsrc ;; buffer, or internal knowledge of the `nntp-header-' macros, or ;; dependence on the buffers having a certain format, your code will ;; fail. --- 26,32 ---- ;; Although (ding) Gnus looks suspiciously like GNUS, it isn't quite ;; the same beast. Most internal structures have been changed. If you ;; have written packages that depend on any of the hash tables, ! ;; `gnus-newsrc-alist', `gnus-killed-assoc', marked lists, the .newsrc ;; buffer, or internal knowledge of the `nntp-header-' macros, or ;; dependence on the buffers having a certain format, your code will ;; fail. *************** *** 40,45 **** --- 40,87 ---- (require 'nnheader) + ;; Site dependent variables. These variables should be defined in + ;; paths.el. + + (defvar gnus-default-nntp-server nil + "Specify a default NNTP server. + This variable should be defined in paths.el, and should never be set + by the user. + If you want to change servers, you should use `gnus-select-method'. + See the documentation to that variable.") + + (defconst gnus-backup-default-subscribed-newsgroups + '("news.announce.newusers" "news.groups.questions" "gnu.emacs.gnus") + "Default default new newsgroups the first time Gnus is run. + Should be set in paths.el, and shouldn't be touched by the user.") + + (defvar gnus-local-domain nil + "Local domain name without a host name. + The DOMAINNAME environment variable is used instead if it is defined. + If the `system-name' function returns the full Internet name, there is + no need to set this variable.") + + (defvar gnus-local-organization nil + "String with a description of what organization (if any) the user belongs to. + The ORGANIZATION environment variable is used instead if it is defined. + If this variable contains a function, this function will be called + with the current newsgroup name as the argument. The function should + return a string. + In any case, if the string (either in the variable, in the environment + variable, or returned by the function) is a file name, the contents of + this file will be used as the organization.") + + (defvar gnus-use-generic-from nil + "If nil, the full host name will be the system name prepended to the domain name. + If this is a string, the full host name will be this string. + If this is non-nil, non-string, the domain name will be used as the + full host name.") + + (defvar gnus-use-generic-path nil + "If nil, use the NNTP server name in the Path header. + If stringp, use this; if non-nil, use no host name (user name only).") + + ;; Customization variables (defvar gnus-select-method *************** *** 259,268 **** "*Name of the directory where kill files will be stored (default \"~/News\"). Initialized from the SAVEDIR environment variable.") ! (defvar gnus-score-expiry-days 7 ! "*Number of days before unused score file entries are expired.") ! ! (defvar gnus-default-article-saver (function gnus-summary-save-in-rmail) "*A function to save articles in your favorite format. The function must be interactively callable (in other words, it must be an Emacs command). --- 301,307 ---- "*Name of the directory where kill files will be stored (default \"~/News\"). Initialized from the SAVEDIR environment variable.") ! (defvar gnus-default-article-saver 'gnus-summary-save-in-rmail "*A function to save articles in your favorite format. The function must be interactively callable (in other words, it must be an Emacs command). *************** *** 299,306 **** the file \"gnus-stuff\", and articles related to VM in \"vm-stuff\", you could set this variable to something like: ! '(("^Subject:.*gnus\\|^Newsgroups:.*gnus" "gnus-stuff") ! ("^Subject:.*vm\\|^Xref:.*vm" "vm-stuff"))") (defvar gnus-score-file-suffix "SCORE" "*Suffix of the score files.") --- 338,348 ---- the file \"gnus-stuff\", and articles related to VM in \"vm-stuff\", you could set this variable to something like: ! '((\"^Subject:.*gnus\\|^Newsgroups:.*gnus\" \"gnus-stuff\") ! (\"^Subject:.*vm\\|^Xref:.*vm\" \"vm-stuff\"))") ! ! (defvar gnus-save-score nil ! "*If non-nil, save group scoring info.") (defvar gnus-score-file-suffix "SCORE" "*Suffix of the score files.") *************** *** 442,448 **** (defvar gnus-level-default-subscribed 3 "*New subscribed groups will be subscribed at this level.") ! (defvar gnus-level-default-unsubscribed "*New unsubscribed groups will be unsubscribed at this level.") (defvar gnus-activate-foreign-newsgroups nil --- 484,490 ---- (defvar gnus-level-default-subscribed 3 "*New subscribed groups will be subscribed at this level.") ! (defvar gnus-level-default-unsubscribed 6 "*New unsubscribed groups will be unsubscribed at this level.") (defvar gnus-activate-foreign-newsgroups nil *************** *** 497,522 **** `mail-extract-address-components', which works much better, but is slower.") - (defvar gnus-score-interactive-default-score 1000 - "*Scoring commands will raise/lower the score with this number as the default.") - - (defvar gnus-save-score nil - "*If non-nil, save group scoring info.") - - (defvar gnus-global-score-files nil - "*List of global score files and directories. - Set this variable if you want to use people's score files. One entry - for each score file or each score file directory. Gnus will decide - by itself what score files are applicable to which group. - - Say you want to use the single score file - \"/ftp.ifi.uio.no@ftp:/pub/larsi/ding/score/soc.motss.SCORE\" and all - score files in the \"/ftp.some-where:/pub/score\" directory. - - (setq gnus-global-score-files - '(\"/ftp.ifi.uio.no:/pub/larsi/ding/score/soc.motss.SCORE\" - \"/ftp.some-where:/pub/score\"))") - (defvar gnus-summary-default-score 0 "*Default article score level. If this variable is nil, scoring will be disabled.") --- 539,544 ---- *************** *** 810,815 **** --- 832,842 ---- If `not-confirm', pseudos will be viewed automatically, and the user will not be asked to confirm the command.") + (defvar gnus-view-pseudos-separately t + "*If non-nil, one pseudo-article will be created for each file to be viewed. + If nil, all files that use the same viewing command will be given as a + list of parameters to that command.") + (defvar gnus-group-line-format "%M%S%5y: %(%g%)\n" "*Format of group lines. It works along the same lines as a normal formatting string, *************** *** 970,978 **** This variable is local to each summary buffer and usually set by the score file.") - (defvar gnus-orphan-score nil - "*All orphans get this score added. Set in the score file.") - (defvar gnus-thread-sort-functions '(gnus-thread-sort-by-number) "*List of functions used for sorting threads in the summary buffer. By default, threads are sorted by article number. --- 997,1002 ---- *************** *** 1177,1226 **** The hook is intended to mark an article as read (or unread) automatically when it is selected.") - ;; Site dependent variables. These variables should be defined in - ;; paths.el. - - (defvar gnus-default-nntp-server nil - "*Specify a default NNTP server. - This variable should be defined in paths.el, and should never be set - by the user. - If you want to change servers, you should use `gnus-select-method'. - See the documentation to that variable.") - - (defconst gnus-backup-default-subscribed-newsgroups - '("news.announce.newusers" "news.groups.questions" "gnu.emacs.gnus") - "Default default new newsgroups the first time Gnus is run. - Should be set in paths.el, and shouldn't be touched by the user.") - - (defvar gnus-local-domain nil - "*Local domain name without a host name. - The DOMAINNAME environment variable is used instead if it is defined. - If the `system-name' function returns the full Internet name, there is - no need to set this variable.") - - (defvar gnus-local-organization nil - "*String with a description of what organization (if any) the user belongs to. - The ORGANIZATION environment variable is used instead if it is defined. - If this variable contains a function, this function will be called - with the current newsgroup name as the argument. The function should - return a string. - In any case, if the string (either in the variable, in the environment - variable, or returned by the function) is a file name, the contents of - this file will be used as the organization.") - - (defvar gnus-use-generic-from nil - "*If nil, the full host name will be the system name prepended to the domain name. - If this is a string, the full host name will be this string. - If this is non-nil, non-string, the domain name will be used as the - full host name.") - - (defvar gnus-use-generic-path nil - "*If nil, use the NNTP server name in the Path header. - If stringp, use this; if non-nil, use no host name (user name only).") - ;; Internal variables ;; Avoid highlighting in kill files. (defvar gnus-summary-inhibit-highlight nil) (defvar gnus-newsgroup-selected-overlay nil) --- 1201,1212 ---- The hook is intended to mark an article as read (or unread) automatically when it is selected.") ;; Internal variables + (defvar gnus-internal-global-score-files nil) + (defvar gnus-score-file-list nil) + ;; Avoid highlighting in kill files. (defvar gnus-summary-inhibit-highlight nil) (defvar gnus-newsgroup-selected-overlay nil) *************** *** 1232,1265 **** (defvar gnus-article-reply nil) (defvar gnus-override-method nil) (defvar gnus-article-check-size nil) - (defvar gnus-score-file-list nil) - (defvar gnus-internal-global-score-files nil) - (defvar gnus-current-score-file nil) (defvar gnus-current-move-group nil) - (defvar gnus-score-alist nil - "Alist containing score information. - The keys can be symbols or strings. The following symbols are defined. - - touched: If this alist has been modified. - mark: Automatically mark articles below this. - expunge: Automatically expunge articles below this. - files: List of other SCORE files to load when loading this one. - eval: Sexp to be evaluated when the score file is loaded. - - String entries have the form (HEADER (MATCH TYPE SCORE DATE) ...) - where HEADER is the header being scored, MATCH is the string we are - looking for, TYPE is a flag indicating whether it should use regexp or - substring matching, SCORE is the score to add and DATE is the date - of the last succesful match.") - - (defvar gnus-score-cache nil) - (defvar gnus-scores-articles nil) - (defvar gnus-scores-exclude-files nil) - (defvar gnus-header-index nil) - (defvar gnus-score-index nil) - (defvar gnus-newsgroup-dependencies nil) (defconst gnus-group-edit-buffer "*Gnus edit newsgroup*") --- 1218,1226 ---- *************** *** 1342,1348 **** (defconst gnus-maintainer "Lars Magne Ingebrigtsen " "The mail address of the Gnus maintainer.") ! (defconst gnus-version "(ding) Gnus v0.55" "Version number for this version of Gnus.") (defvar gnus-info-nodes --- 1303,1309 ---- (defconst gnus-maintainer "Lars Magne Ingebrigtsen " "The mail address of the Gnus maintainer.") ! (defconst gnus-version "(ding) Gnus v0.57" "Version number for this version of Gnus.") (defvar gnus-info-nodes *************** *** 1370,1376 **** (defvar gnus-variable-list '(gnus-newsrc-options gnus-newsrc-options-n gnus-newsrc-last-checked-date ! gnus-newsrc-assoc gnus-server-alist gnus-killed-list gnus-zombie-list) "Gnus variables saved in the quick startup file.") --- 1331,1337 ---- (defvar gnus-variable-list '(gnus-newsrc-options gnus-newsrc-options-n gnus-newsrc-last-checked-date ! gnus-newsrc-alist gnus-server-alist gnus-killed-list gnus-zombie-list) "Gnus variables saved in the quick startup file.") *************** *** 1389,1400 **** (defvar gnus-newsrc-last-checked-date nil "Date Gnus last asked server for new newsgroups.") ! (defvar gnus-newsrc-assoc nil "Assoc list of read articles. gnus-newsrc-hashtb should be kept so that both hold the same information.") (defvar gnus-newsrc-hashtb nil ! "Hashtable of gnus-newsrc-assoc.") (defvar gnus-killed-list nil "List of killed newsgroups.") --- 1350,1361 ---- (defvar gnus-newsrc-last-checked-date nil "Date Gnus last asked server for new newsgroups.") ! (defvar gnus-newsrc-alist nil "Assoc list of read articles. gnus-newsrc-hashtb should be kept so that both hold the same information.") (defvar gnus-newsrc-hashtb nil ! "Hashtable of gnus-newsrc-alist.") (defvar gnus-killed-list nil "List of killed newsgroups.") *************** *** 1492,1498 **** ;; Save window configuration. (defvar gnus-winconf-edit-group nil) - (defvar gnus-winconf-edit-score nil) ;; Format specs (defvar gnus-summary-line-format-spec nil) --- 1453,1458 ---- *************** *** 1595,1600 **** --- 1555,1584 ---- (autoload 'pp "pp") (autoload 'pp-to-string "pp") (autoload 'mail-extract-address-components "mail-extr") + + (autoload 'gnus-summary-increase-map "gnus-score" nil nil 'keymap) + (autoload 'gnus-summary-lower-map "gnus-score" nil nil 'keymap) + (autoload 'gnus-summary-score-map "gnus-score" nil nil 'keymap) + (autoload 'gnus-score-save "gnus-score") + (autoload 'gnus-score-headers "gnus-score") + + (autoload 'gnus-group-post-news "gnus-message") + (autoload 'gnus-summary-post-news "gnus-message") + (autoload 'gnus-summary-followup "gnus-message") + (autoload 'gnus-summary-followup-with-original "gnus-message") + (autoload 'gnus-summary-followup-and-reply "gnus-message") + (autoload 'gnus-summary-followup-and-reply-with-original "gnus-message") + (autoload 'gnus-summary-cancel-article "gnus-message") + (autoload 'gnus-summary-supersede-article "gnus-message") + (autoload 'gnus-post-news "gnus-message") + (autoload 'gnus-inews-news "gnus-message") + (autoload 'gnus-cancel-news "gnus-message") + (autoload 'gnus-summary-reply "gnus-message") + (autoload 'gnus-summary-reply-with-original "gnus-message") + (autoload 'gnus-summary-mail-forward "gnus-message") + (autoload 'gnus-summary-mail-other-window "gnus-message") + (autoload 'gnus-mail-reply-using-mail "gnus-message") + ) *************** *** 1606,1627 **** (defalias 'gnus-group-position-cursor 'gnus-goto-colon) ;; Cruft to make Gnus work under GNU XEmacs. ! (defvar gnus-xemacs nil "Non-nil if Gnus is running under GNU XEmacs.") ! (if (not (string-match "XEmacs\\|Lucid" emacs-version)) ! () ! (setq gnus-xemacs t) ! (eval ! '((or (memq 'underline (list-faces)) ! (make-face 'underline)) ! (or (face-differs-from-default-p 'underline) ! (set-face-underline-p 'underline t)) ! ! (defun set-text-properties (start end props &optional buffer) ! (if props ! (put-text-property start end (car props) (cadr props) buffer) ! (remove-text-properties start end ())))))) (defmacro gnus-eval-in-buffer-window (buffer &rest forms) --- 1590,1610 ---- (defalias 'gnus-group-position-cursor 'gnus-goto-colon) ;; Cruft to make Gnus work under GNU XEmacs. ! (defconst gnus-xemacs (not (not (string-match "XEmacs\\|Lucid" emacs-version))) "Non-nil if Gnus is running under GNU XEmacs.") ! (if gnus-xemacs ! (progn ! (or (memq 'underline (funcall 'list-faces)) ! (make-face 'underline)) ! (or (face-differs-from-default-p 'underline) ! (set-face-underline-p 'underline t)) ! (or (fboundp 'set-text-properties) ! (defun set-text-properties (start end props &optional buffer) ! (if props ! (put-text-property start end (car props) ! (funcall (intern "cadr") props) buffer) ! (remove-text-properties start end ())))))) (defmacro gnus-eval-in-buffer-window (buffer &rest forms) *************** *** 1665,1670 **** --- 1648,1662 ---- (defsubst gnus-goto-char (point) (and point (goto-char point))) + (defmacro gnus-buffer-exists-p (buffer) + (` (and (, buffer) + (funcall (if (stringp (, buffer)) 'get-buffer 'buffer-name) + (, buffer))))) + + (defmacro gnus-kill-buffer (buffer) + (` (if (gnus-buffer-exists-p (, buffer)) + (kill-buffer (, buffer))))) + (defsubst gnus-point-at-bol () "Return point at the beginning of line." (let ((p (point))) *************** *** 1877,1883 **** (defun gnus-set-work-buffer () (if (get-buffer gnus-work-buffer) (progn ! (set-buffer (get-buffer gnus-work-buffer)) (gnus-add-current-to-buffer-list) (erase-buffer)) (set-buffer (get-buffer-create gnus-work-buffer)) --- 1869,1875 ---- (defun gnus-set-work-buffer () (if (get-buffer gnus-work-buffer) (progn ! (set-buffer gnus-work-buffer) (gnus-add-current-to-buffer-list) (erase-buffer)) (set-buffer (get-buffer-create gnus-work-buffer)) *************** *** 2013,2019 **** (defun gnus-subscribe-alphabetically (newgroup) "Subscribe new NEWSGROUP and insert it in alphabetical order." ;; Basic ideas by mike-w@cs.aukuni.ac.nz (Mike Williams) ! (let ((groups (cdr gnus-newsrc-assoc)) before) (while (and (not before) groups) (if (string< newgroup (car (car groups))) --- 2005,2011 ---- (defun gnus-subscribe-alphabetically (newgroup) "Subscribe new NEWSGROUP and insert it in alphabetical order." ;; Basic ideas by mike-w@cs.aukuni.ac.nz (Mike Williams) ! (let ((groups (cdr gnus-newsrc-alist)) before) (while (and (not before) groups) (if (string< newgroup (car (car groups))) *************** *** 2127,2139 **** (while (re-search-forward "[ \t\n]*([^()]*)[ \t\n]*\\'" nil t) (replace-match "" t t) (goto-char (point-min))) ! (while (re-search-forward "[ \t]+" nil t) (replace-match " " t t)) ! (goto-char (point-max)) ! (forward-char -1) ! (if (= (following-char) ? ) ! (substring (point-min) (point)) ! (substring (point-min) (point-max)))))) (defun gnus-add-current-to-buffer-list () (setq gnus-buffer-list (cons (current-buffer) gnus-buffer-list))) --- 2119,2130 ---- (while (re-search-forward "[ \t\n]*([^()]*)[ \t\n]*\\'" nil t) (replace-match "" t t) (goto-char (point-min))) ! (while (re-search-forward "[ \t]+" nil 'move) (replace-match " " t t)) ! ;; the 'move above makes sure we are at (point-max) ! (and (= (preceding-char) ? ) ! (delete-char -1)) ! (buffer-string)))) (defun gnus-add-current-to-buffer-list () (setq gnus-buffer-list (cons (current-buffer) gnus-buffer-list))) *************** *** 2187,2193 **** ;; Clear other internal variables. (setq gnus-list-of-killed-groups nil gnus-have-read-active-file nil ! gnus-newsrc-assoc nil gnus-newsrc-hashtb nil gnus-killed-list nil gnus-zombie-list nil --- 2178,2184 ---- ;; Clear other internal variables. (setq gnus-list-of-killed-groups nil gnus-have-read-active-file nil ! gnus-newsrc-alist nil gnus-newsrc-hashtb nil gnus-killed-list nil gnus-zombie-list nil *************** *** 2196,2207 **** gnus-moderated-list nil gnus-description-hashtb nil gnus-newsgroup-headers nil - gnus-score-cache nil gnus-newsgroup-headers-hashtb-by-number nil gnus-newsgroup-name nil - gnus-internal-global-score-files nil gnus-server-alist nil gnus-current-select-method nil) ;; Kill the startup file. (and gnus-current-startup-file (get-file-buffer gnus-current-startup-file) --- 2187,2200 ---- gnus-moderated-list nil gnus-description-hashtb nil gnus-newsgroup-headers nil gnus-newsgroup-headers-hashtb-by-number nil gnus-newsgroup-name nil gnus-server-alist nil + gnus-internal-global-score-files nil gnus-current-select-method nil) + ;; Reset any score variables. + (and (boundp 'gnus-score-cache) + (set 'gnus-score-cache nil)) ;; Kill the startup file. (and gnus-current-startup-file (get-file-buffer gnus-current-startup-file) *************** *** 2210,2222 **** ;; Kill global KILL file buffer. (if (get-file-buffer (gnus-newsgroup-kill-file nil)) (kill-buffer (get-file-buffer (gnus-newsgroup-kill-file nil)))) ! (and (buffer-name nntp-server-buffer) ! (kill-buffer nntp-server-buffer)) ;; Kill Gnus buffers. (while gnus-buffer-list ! (if (and (get-buffer (car gnus-buffer-list)) ! (buffer-name (get-buffer (car gnus-buffer-list)))) ! (kill-buffer (car gnus-buffer-list))) (setq gnus-buffer-list (cdr gnus-buffer-list)))) (defun gnus-configure-windows (action &optional force) --- 2203,2212 ---- ;; Kill global KILL file buffer. (if (get-file-buffer (gnus-newsgroup-kill-file nil)) (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 (car gnus-buffer-list)) (setq gnus-buffer-list (cdr gnus-buffer-list)))) (defun gnus-configure-windows (action &optional force) *************** *** 2325,2333 **** (switch-to-buffer gnus-group-buffer t) (delete-other-windows) (split-window-horizontally) ! (cond ((or (eq action 'newsgoups) (eq action 'summary)) ! (if (and (get-buffer gnus-summary-buffer) ! (buffer-name gnus-summary-buffer)) (switch-to-buffer-other-window gnus-summary-buffer))) ((eq action 'article) (switch-to-buffer gnus-summary-buffer t) --- 2315,2322 ---- (switch-to-buffer gnus-group-buffer t) (delete-other-windows) (split-window-horizontally) ! (cond ((memq action '(newsgoups summary)) ! (if (gnus-buffer-exists-p gnus-summary-buffer) (switch-to-buffer-other-window gnus-summary-buffer))) ((eq action 'article) (switch-to-buffer gnus-summary-buffer t) *************** *** 2909,2915 **** did-connect) (unwind-protect (progn ! (switch-to-buffer (get-buffer-create gnus-group-buffer)) (gnus-add-current-to-buffer-list) (gnus-group-mode) (or dont-connect --- 2898,2904 ---- did-connect) (unwind-protect (progn ! (switch-to-buffer gnus-group-buffer) (gnus-add-current-to-buffer-list) (gnus-group-mode) (or dont-connect *************** *** 2964,2970 **** (defun gnus-group-setup-buffer () (or (get-buffer gnus-group-buffer) (progn ! (switch-to-buffer (get-buffer-create gnus-group-buffer)) (gnus-add-current-to-buffer-list) (gnus-group-mode)))) --- 2953,2959 ---- (defun gnus-group-setup-buffer () (or (get-buffer gnus-group-buffer) (progn ! (switch-to-buffer gnus-group-buffer) (gnus-add-current-to-buffer-list) (gnus-group-mode)))) *************** *** 2972,2978 **** "List newsgroups with level LEVEL or lower that have unread alticles. Default is all subscribed groups. If argument UNREAD is non-nil, groups with no unread articles are also listed." ! (interactive "P") (setq level (or level gnus-group-default-list-level gnus-level-subscribed)) (gnus-group-setup-buffer) ;May call from out of group buffer (let ((case-fold-search nil) --- 2961,2968 ---- "List newsgroups with level LEVEL or lower that have unread alticles. Default is all subscribed groups. If argument UNREAD is non-nil, groups with no unread articles are also listed." ! (interactive (list (and current-prefix-arg ! (prefix-numeric-value current-prefix-arg)))) (setq level (or level gnus-group-default-list-level gnus-level-subscribed)) (gnus-group-setup-buffer) ;May call from out of group buffer (let ((case-fold-search nil) *************** *** 3010,3016 **** If REGEXP, only list groups matching REGEXP." (set-buffer gnus-group-buffer) (let ((buffer-read-only nil) ! (newsrc (cdr gnus-newsrc-assoc)) (lowest (or lowest 1)) info clevel unread group) (erase-buffer) --- 3000,3006 ---- If REGEXP, only list groups matching REGEXP." (set-buffer gnus-group-buffer) (let ((buffer-read-only nil) ! (newsrc (cdr gnus-newsrc-alist)) (lowest (or lowest 1)) info clevel unread group) (erase-buffer) *************** *** 3566,3572 **** (if group (setq info (nth 2 (gnus-gethash group gnus-newsrc-hashtb))) (error "No group on current line")) (setq gnus-winconf-edit-group (current-window-configuration)) ! (pop-to-buffer (get-buffer-create gnus-group-edit-buffer)) (gnus-add-current-to-buffer-list) (emacs-lisp-mode) ;; Suggested by Hallvard B Furuseth . --- 3556,3562 ---- (if group (setq info (nth 2 (gnus-gethash group gnus-newsrc-hashtb))) (error "No group on current line")) (setq gnus-winconf-edit-group (current-window-configuration)) ! (pop-to-buffer gnus-group-edit-buffer) (gnus-add-current-to-buffer-list) (emacs-lisp-mode) ;; Suggested by Hallvard B Furuseth . *************** *** 3696,3703 **** (defun gnus-group-sort-groups () "Sort the group buffer using `gnus-group-sort-function'." (interactive) ! (setq gnus-newsrc-assoc ! (sort (cdr gnus-newsrc-assoc) gnus-group-sort-function)) (gnus-make-hashtable-from-newsrc-alist) (gnus-get-unread-articles (1+ gnus-level-subscribed)) (gnus-group-list-groups nil)) --- 3686,3693 ---- (defun gnus-group-sort-groups () "Sort the group buffer using `gnus-group-sort-function'." (interactive) ! (setq gnus-newsrc-alist ! (sort (cdr gnus-newsrc-alist) gnus-group-sort-function)) (gnus-make-hashtable-from-newsrc-alist) (gnus-get-unread-articles (1+ gnus-level-subscribed)) (gnus-group-list-groups nil)) *************** *** 3784,3821 **** "Expire all expirable articles in all newsgroups." (interactive) (message "Expiring...") ! (let ((newsrc (cdr gnus-newsrc-assoc))) (while newsrc (gnus-group-expire-articles (car (car newsrc))) (setq newsrc (cdr newsrc)))) (message "Expiring...done")) ! (defun gnus-group-set-current-level (n) ! "Set the level of the current group to the numeric prefix." ! (interactive "P") ! (setq n (or n (string-to-int ! (completing-read ! "Level: " ! (mapcar (lambda (n) (list (char-to-string n))) "123456789") ! nil t)))) ! (let ((group (gnus-group-group-name))) ! (if (not group) (error "No newsgroup on current line.") ! (if (and (numberp n) (>= n 1) (<= n 9)) ! (progn ! (message "Changed level of %s from %d to %d" ! group (gnus-group-group-level) n) ! (gnus-group-change-level group n (gnus-group-group-level)) ! (gnus-group-update-group-line)) ! (error "Illegal level: %s" n)))) ! (forward-line 1) ! (gnus-group-position-cursor)) (defun gnus-group-unsubscribe-current-group (arg) "Toggle subscribe from/to unsubscribe current group." (interactive "P") (let ((group (gnus-group-group-name))) (or group (error "No newsgroup on current line")) ! (or arg (setq arg (if (<= (gnus-group-group-level) 5) 6 3))) (gnus-group-unsubscribe-group group arg) (gnus-group-next-group 1))) --- 3774,3810 ---- "Expire all expirable articles in all newsgroups." (interactive) (message "Expiring...") ! (let ((newsrc (cdr gnus-newsrc-alist))) (while newsrc (gnus-group-expire-articles (car (car newsrc))) (setq newsrc (cdr newsrc)))) (message "Expiring...done")) ! (defun gnus-group-set-current-level (n level) ! "Set the level of the next N groups to LEVEL." ! (interactive "P\nnLevel: ") ! (let (group) ! (while (and (< n 0) ! (setq group (gnus-group-group-name))) ! (and (setq group (gnus-group-group-name)) ! (message "Changed level of %s from %d to %d" ! group (gnus-group-group-level) level) ! (gnus-group-change-level group level ! (gnus-group-group-level)) ! (gnus-group-update-group-line)) ! (forward-line 1) ! (setq n (1- n)))) ! (gnus-group-position-cursor) ! n) (defun gnus-group-unsubscribe-current-group (arg) "Toggle subscribe from/to unsubscribe current group." (interactive "P") (let ((group (gnus-group-group-name))) (or group (error "No newsgroup on current line")) ! (or arg (setq arg (if (<= (gnus-group-group-level) gnus-level-subscribed) ! (1+ gnus-level-subscribed) ! gnus-level-default-unsubscribed))) (gnus-group-unsubscribe-group group arg) (gnus-group-next-group 1))) *************** *** 3829,3835 **** (cond (newsrc ;; Toggle subscription flag. (gnus-group-change-level ! newsrc (if level level (if (< (nth 1 (nth 2 newsrc)) 6) 6 4))) (gnus-group-update-group group)) ((and (stringp group) (or (not gnus-have-read-active-file) --- 3818,3827 ---- (cond (newsrc ;; Toggle subscription flag. (gnus-group-change-level ! newsrc (if level level (if (<= (nth 1 (nth 2 newsrc)) ! gnus-level-subscribed) ! (1+ gnus-level-subscribed) ! gnus-level-default-subscribed))) (gnus-group-update-group group)) ((and (stringp group) (or (not gnus-have-read-active-file) *************** *** 3837,3847 **** ;; Add new newsgroup. (gnus-group-change-level group ! (if level level 3) ! (or (and (member group gnus-zombie-list) 8) 9) (or (and (gnus-group-group-name) (gnus-gethash (gnus-group-group-name) gnus-newsrc-hashtb)) ! (gnus-gethash (car (car gnus-newsrc-assoc)) gnus-newsrc-hashtb))) (gnus-group-update-group group)) (t (error "No such newsgroup: %s" group))) --- 3829,3841 ---- ;; Add new newsgroup. (gnus-group-change-level group ! (if level level gnus-level-default-subscribed) ! (or (and (member group gnus-zombie-list) ! gnus-level-zombie) ! gnus-level-killed) (or (and (gnus-group-group-name) (gnus-gethash (gnus-group-group-name) gnus-newsrc-hashtb)) ! (gnus-gethash (car (car gnus-newsrc-alist)) gnus-newsrc-hashtb))) (gnus-group-update-group group)) (t (error "No such newsgroup: %s" group))) *************** *** 3868,3874 **** (interactive) (setq gnus-killed-list (nconc gnus-zombie-list gnus-killed-list)) (setq gnus-zombie-list nil) ! (funcall gnus-group-prepare-function 5 nil nil) (goto-char (point-min)) (gnus-group-position-cursor)) --- 3862,3868 ---- (interactive) (setq gnus-killed-list (nconc gnus-zombie-list gnus-killed-list)) (setq gnus-zombie-list nil) ! (funcall gnus-group-prepare-function gnus-level-subscribed nil nil) (goto-char (point-min)) (gnus-group-position-cursor)) *************** *** 3914,3920 **** (setq gnus-list-of-killed-groups (cons (cons (car entry) (nth 2 entry)) gnus-list-of-killed-groups))) ! (gnus-group-change-level (if entry entry group) 9 (if entry nil level))) (if (eobp) (forward-line -1)) (gnus-group-position-cursor) --- 3908,3915 ---- (setq gnus-list-of-killed-groups (cons (cons (car entry) (nth 2 entry)) gnus-list-of-killed-groups))) ! (gnus-group-change-level ! (if entry entry group) gnus-level-killed (if entry nil level))) (if (eobp) (forward-line -1)) (gnus-group-position-cursor) *************** *** 3939,3947 **** (while (and (not (setq prev (gnus-group-group-name))) (zerop (forward-line -1)))) (if (not prev) ! (setq prev (car (car gnus-newsrc-assoc)))) (gnus-group-change-level ! info (nth 2 info) 9 (gnus-gethash prev gnus-newsrc-hashtb) t) (gnus-group-insert-group-line-info (nth 1 info)) --- 3934,3942 ---- (while (and (not (setq prev (gnus-group-group-name))) (zerop (forward-line -1)))) (if (not prev) ! (setq prev (car (car gnus-newsrc-alist)))) (gnus-group-change-level ! info (nth 2 info) gnus-level-killed (gnus-gethash prev gnus-newsrc-hashtb) t) (gnus-group-insert-group-line-info (nth 1 info)) *************** *** 3963,3969 **** (interactive) (if (not gnus-killed-list) (message "No killed groups") ! (funcall gnus-group-prepare-function 9 t 9) (goto-char (point-min))) (gnus-group-position-cursor)) --- 3958,3964 ---- (interactive) (if (not gnus-killed-list) (message "No killed groups") ! (funcall gnus-group-prepare-function gnus-level-killed t gnus-level-killed) (goto-char (point-min))) (gnus-group-position-cursor)) *************** *** 3972,3978 **** (interactive) (if (not gnus-zombie-list) (message "No zombie groups") ! (funcall gnus-group-prepare-function 8 t 8) (goto-char (point-min))) (gnus-group-position-cursor)) --- 3967,3973 ---- (interactive) (if (not gnus-zombie-list) (message "No zombie groups") ! (funcall gnus-group-prepare-function gnus-level-zombie t gnus-level-zombie) (goto-char (point-min))) (gnus-group-position-cursor)) *************** *** 4101,4107 **** (message "No groups matched \"%s\"." regexp) ;; Print out all the groups. (save-excursion ! (pop-to-buffer (get-buffer-create "*Gnus Help*")) (buffer-disable-undo (current-buffer)) (erase-buffer) (setq groups (sort groups 'string<)) --- 4096,4102 ---- (message "No groups matched \"%s\"." regexp) ;; Print out all the groups. (save-excursion ! (pop-to-buffer "*Gnus Help*") (buffer-disable-undo (current-buffer)) (erase-buffer) (setq groups (sort groups 'string<)) *************** *** 4204,4219 **** (run-hooks 'gnus-suspend-gnus-hook) ;; Kill Gnus buffers except for group mode buffer. (let ((group-buf (get-buffer gnus-group-buffer))) ! (while gnus-buffer-list ! (and (not (eq (get-buffer (car gnus-buffer-list)) group-buf)) ! (not (eq (get-buffer (car gnus-buffer-list)) gnus-dribble-buffer)) ! (get-buffer (car gnus-buffer-list)) ! (buffer-name (get-buffer (car gnus-buffer-list))) ! (kill-buffer (car gnus-buffer-list))) ! (setq gnus-buffer-list (cdr gnus-buffer-list))) ! (setq gnus-buffer-list (list group-buf)) ! (bury-buffer group-buf) ! (delete-windows-on group-buf t))) (defun gnus-group-clear-dribble () "Clear all information from the dribble buffer." --- 4199,4216 ---- (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 ! (let ((gnus-buffer-list ! (delq group-buf (delq gnus-dribble-buffer ! (append gnus-buffer-list nil))))) ! (while gnus-buffer-list ! (gnus-kill-buffer (car gnus-buffer-list)) ! (setq gnus-buffer-list (cdr gnus-buffer-list)))) ! (if group-buf ! (progn ! (setq gnus-buffer-list (list group-buf)) ! (bury-buffer group-buf) ! (delete-windows-on group-buf t))))) (defun gnus-group-clear-dribble () "Clear all information from the dribble buffer." *************** *** 4278,4288 **** and the second element is the address." (interactive (list (list (intern (completing-read ! "Select method: " gnus-valid-select-methods nil t "nntp")) ;; Suggested by mapjph@bath.ac.uk. (completing-read ! "Server name: " (mapcar (lambda (server) (list server)) gnus-secondary-servers))))) (gnus-browse-foreign-server method)) --- 4275,4285 ---- and the second element is the address." (interactive (list (list (intern (completing-read ! "Which backend: " gnus-valid-select-methods nil t "nntp")) ;; Suggested by mapjph@bath.ac.uk. (completing-read ! "Address: " (mapcar (lambda (server) (list server)) gnus-secondary-servers))))) (gnus-browse-foreign-server method)) *************** *** 4351,4357 **** (goto-char (match-end 1)) (setq groups (cons (cons (buffer-substring (match-beginning 1) (match-end 1)) ! (- (read cur) (read cur))) groups))))) (setq groups (sort groups (lambda (l1 l2) --- 4348,4354 ---- (goto-char (match-end 1)) (setq groups (cons (cons (buffer-substring (match-beginning 1) (match-end 1)) ! (max 0 (- (1+ (read cur)) (read cur)))) groups))))) (setq groups (sort groups (lambda (l1 l2) *************** *** 4436,4442 **** (list t group gnus-level-default-subscribed nil nil gnus-browse-current-method) gnus-level-default-subscribed gnus-level-killed ! (gnus-gethash (car (nth 1 gnus-newsrc-assoc)) gnus-newsrc-hashtb) t) (insert ? )) (gnus-group-change-level --- 4433,4439 ---- (list t group gnus-level-default-subscribed nil nil gnus-browse-current-method) gnus-level-default-subscribed gnus-level-killed ! (gnus-gethash (car (nth 1 gnus-newsrc-alist)) gnus-newsrc-hashtb) t) (insert ? )) (gnus-group-change-level *************** *** 4476,4501 **** (defvar gnus-summary-various-map nil) (defvar gnus-summary-interest-map nil) (defvar gnus-summary-process-map nil) - (defvar gnus-summary-score-map nil) (defvar gnus-summary-sort-map nil) (defvar gnus-summary-mgroup-map nil) (defvar gnus-summary-vsave-map nil) ! (defvar gnus-summary-increase-map nil) ! (defvar gnus-summary-inc-subject-map nil) ! (defvar gnus-summary-inc-author-map nil) ! (defvar gnus-summary-inc-body-map nil) ! (defvar gnus-summary-inc-id-map nil) ! (defvar gnus-summary-inc-xref-map nil) ! (defvar gnus-summary-inc-thread-map nil) ! (defvar gnus-summary-inc-fol-map nil) ! (defvar gnus-summary-lower-map nil) ! (defvar gnus-summary-low-subject-map nil) ! (defvar gnus-summary-low-author-map nil) ! (defvar gnus-summary-low-body-map nil) ! (defvar gnus-summary-low-id-map nil) ! (defvar gnus-summary-low-xref-map nil) ! (defvar gnus-summary-low-thread-map nil) ! (defvar gnus-summary-low-fol-map nil) (put 'gnus-summary-mode 'mode-class 'special) (if gnus-summary-mode-map --- 4473,4482 ---- (defvar gnus-summary-various-map nil) (defvar gnus-summary-interest-map nil) (defvar gnus-summary-process-map nil) (defvar gnus-summary-sort-map nil) (defvar gnus-summary-mgroup-map nil) (defvar gnus-summary-vsave-map nil) ! (put 'gnus-summary-mode 'mode-class 'special) (if gnus-summary-mode-map *************** *** 4791,4804 **** (define-key gnus-summary-vsave-map "h" 'gnus-summary-save-article-folder) (define-key gnus-summary-vsave-map "p" 'gnus-summary-pipe-output) - (define-prefix-command 'gnus-summary-score-map) (define-key gnus-summary-various-map "S" 'gnus-summary-score-map) - (define-key gnus-summary-score-map "s" 'gnus-summary-set-score) - (define-key gnus-summary-score-map "c" 'gnus-score-change-score-file) - (define-key gnus-summary-score-map "m" 'gnus-score-set-mark-below) - (define-key gnus-summary-score-map "x" 'gnus-score-set-expunge-below) - (define-key gnus-summary-score-map "e" 'gnus-score-edit-alist) - (define-key gnus-summary-score-map "f" 'gnus-score-edit-file) (define-prefix-command 'gnus-summary-sort-map) (define-key gnus-summary-various-map "s" 'gnus-summary-sort-map) --- 4772,4778 ---- *************** *** 4817,4946 **** (define-key gnus-summary-mgroup-map "w" 'gnus-summary-edit-article) (define-key gnus-summary-mgroup-map "c" 'gnus-summary-copy-article) - - (define-prefix-command 'gnus-summary-increase-map) (define-key gnus-summary-mode-map "I" 'gnus-summary-increase-map) - (define-key gnus-summary-increase-map "i" 'gnus-summary-raise-same-subject-and-select) - (define-key gnus-summary-increase-map "I" 'gnus-summary-raise-same-subject) - (define-key gnus-summary-increase-map "\C-i" 'gnus-summary-raise-score) - - (define-prefix-command 'gnus-summary-inc-subject-map) - (define-key gnus-summary-increase-map "s" 'gnus-summary-inc-subject-map) - (define-key gnus-summary-increase-map "S" 'gnus-summary-temporarily-raise-by-subject) - (define-key gnus-summary-inc-subject-map "s" 'gnus-summary-temporarily-raise-by-subject) - (define-key gnus-summary-inc-subject-map "S" 'gnus-summary-raise-by-subject) - (define-key gnus-summary-inc-subject-map "t" 'gnus-summary-temporarily-raise-by-subject) - (define-key gnus-summary-inc-subject-map "p" 'gnus-summary-raise-by-subject) - - (define-prefix-command 'gnus-summary-inc-author-map) - (define-key gnus-summary-increase-map "a" 'gnus-summary-inc-author-map) - (define-key gnus-summary-increase-map "A" 'gnus-summary-temporarily-raise-by-author) - (define-key gnus-summary-inc-author-map "a" 'gnus-summary-temporarily-raise-by-author) - (define-key gnus-summary-inc-author-map "A" 'gnus-summary-raise-by-author) - (define-key gnus-summary-inc-author-map "t" 'gnus-summary-temporarily-raise-by-author) - (define-key gnus-summary-inc-author-map "p" 'gnus-summary-raise-by-author) - - (define-prefix-command 'gnus-summary-inc-body-map) - (define-key gnus-summary-increase-map "b" 'gnus-summary-inc-body-map) - (define-key gnus-summary-increase-map "B" 'gnus-summary-temporarily-raise-by-body) - (define-key gnus-summary-inc-body-map "b" 'gnus-summary-temporarily-raise-by-body) - (define-key gnus-summary-inc-body-map "B" 'gnus-summary-raise-by-body) - (define-key gnus-summary-inc-body-map "t" 'gnus-summary-temporarily-raise-by-body) - (define-key gnus-summary-inc-body-map "p" 'gnus-summary-raise-by-body) - - (define-prefix-command 'gnus-summary-inc-id-map) - (define-key gnus-summary-increase-map "i" 'gnus-summary-inc-id-map) - (define-key gnus-summary-increase-map "I" 'gnus-summary-temporarily-raise-by-id) - (define-key gnus-summary-inc-id-map "i" 'gnus-summary-temporarily-raise-by-id) - (define-key gnus-summary-inc-id-map "I" 'gnus-summary-raise-by-id) - (define-key gnus-summary-inc-id-map "t" 'gnus-summary-temporarily-raise-by-id) - (define-key gnus-summary-inc-id-map "p" 'gnus-summary-raise-by-id) - - (define-prefix-command 'gnus-summary-inc-thread-map) - (define-key gnus-summary-increase-map "t" 'gnus-summary-inc-thread-map) - (define-key gnus-summary-increase-map "T" 'gnus-summary-temporarily-raise-by-thread) - (define-key gnus-summary-inc-thread-map "t" 'gnus-summary-temporarily-raise-by-thread) - (define-key gnus-summary-inc-thread-map "T" 'gnus-summary-raise-by-thread) - (define-key gnus-summary-inc-thread-map "t" 'gnus-summary-temporarily-raise-by-thread) - (define-key gnus-summary-inc-thread-map "p" 'gnus-summary-raise-by-thread) - - (define-prefix-command 'gnus-summary-inc-xref-map) - (define-key gnus-summary-increase-map "x" 'gnus-summary-inc-xref-map) - (define-key gnus-summary-increase-map "X" 'gnus-summary-temporarily-raise-by-xref) - (define-key gnus-summary-inc-xref-map "x" 'gnus-summary-temporarily-raise-by-xref) - (define-key gnus-summary-inc-xref-map "X" 'gnus-summary-raise-by-xref) - (define-key gnus-summary-inc-xref-map "t" 'gnus-summary-temporarily-raise-by-xref) - (define-key gnus-summary-inc-xref-map "p" 'gnus-summary-raise-by-xref) - - (define-prefix-command 'gnus-summary-inc-fol-map) - (define-key gnus-summary-increase-map "f" 'gnus-summary-inc-fol-map) - (define-key gnus-summary-increase-map "F" 'gnus-summary-raise-followups-to-author) - (define-key gnus-summary-inc-fol-map "f" 'gnus-summary-raise-followups-to-author) - (define-key gnus-summary-inc-fol-map "F" 'gnus-summary-raise-followups-to-author) - (define-key gnus-summary-inc-fol-map "t" 'gnus-summary-raise-followups-to-author) - (define-key gnus-summary-inc-fol-map "p" 'gnus-summary-raise-followups-to-author) - - (define-prefix-command 'gnus-summary-lower-map) (define-key gnus-summary-mode-map "L" 'gnus-summary-lower-map) - (define-key gnus-summary-lower-map "l" 'gnus-summary-lower-same-subject-and-select) - (define-key gnus-summary-lower-map "L" 'gnus-summary-lower-same-subject) - (define-key gnus-summary-lower-map "\C-l" 'gnus-summary-lower-score) - - (define-prefix-command 'gnus-summary-low-subject-map) - (define-key gnus-summary-lower-map "s" 'gnus-summary-low-subject-map) - (define-key gnus-summary-lower-map "S" 'gnus-summary-temporarily-lower-by-subject) - (define-key gnus-summary-low-subject-map "s" 'gnus-summary-temporarily-lower-by-subject) - (define-key gnus-summary-low-subject-map "S" 'gnus-summary-lower-by-subject) - (define-key gnus-summary-low-subject-map "t" 'gnus-summary-temporarily-lower-by-subject) - (define-key gnus-summary-low-subject-map "p" 'gnus-summary-lower-by-subject) - - (define-prefix-command 'gnus-summary-low-body-map) - (define-key gnus-summary-lower-map "b" 'gnus-summary-low-body-map) - (define-key gnus-summary-lower-map "B" 'gnus-summary-temporarily-lower-by-body) - (define-key gnus-summary-low-body-map "b" 'gnus-summary-temporarily-lower-by-body) - (define-key gnus-summary-low-body-map "B" 'gnus-summary-lower-by-body) - (define-key gnus-summary-low-body-map "t" 'gnus-summary-temporarily-lower-by-body) - (define-key gnus-summary-low-body-map "p" 'gnus-summary-lower-by-body) - - (define-prefix-command 'gnus-summary-low-author-map) - (define-key gnus-summary-lower-map "a" 'gnus-summary-low-author-map) - (define-key gnus-summary-lower-map "A" 'gnus-summary-temporarily-lower-by-author) - (define-key gnus-summary-low-author-map "a" 'gnus-summary-temporarily-lower-by-author) - (define-key gnus-summary-low-author-map "A" 'gnus-summary-lower-by-author) - (define-key gnus-summary-low-author-map "t" 'gnus-summary-temporarily-lower-by-author) - (define-key gnus-summary-low-author-map "p" 'gnus-summary-lower-by-author) - - (define-prefix-command 'gnus-summary-low-id-map) - (define-key gnus-summary-lower-map "i" 'gnus-summary-low-id-map) - (define-key gnus-summary-lower-map "I" 'gnus-summary-temporarily-lower-by-id) - (define-key gnus-summary-low-id-map "i" 'gnus-summary-temporarily-lower-by-id) - (define-key gnus-summary-low-id-map "I" 'gnus-summary-lower-by-id) - (define-key gnus-summary-low-id-map "t" 'gnus-summary-temporarily-lower-by-id) - (define-key gnus-summary-low-id-map "p" 'gnus-summary-lower-by-id) - - (define-prefix-command 'gnus-summary-low-thread-map) - (define-key gnus-summary-lower-map "t" 'gnus-summary-low-thread-map) - (define-key gnus-summary-lower-map "T" 'gnus-summary-temporarily-lower-by-thread) - (define-key gnus-summary-low-thread-map "t" 'gnus-summary-temporarily-lower-by-thread) - (define-key gnus-summary-low-thread-map "T" 'gnus-summary-lower-by-thread) - (define-key gnus-summary-low-thread-map "t" 'gnus-summary-temporarily-lower-by-thread) - (define-key gnus-summary-low-thread-map "p" 'gnus-summary-lower-by-thread) - - (define-prefix-command 'gnus-summary-low-xref-map) - (define-key gnus-summary-lower-map "x" 'gnus-summary-low-xref-map) - (define-key gnus-summary-lower-map "X" 'gnus-summary-temporarily-lower-by-xref) - (define-key gnus-summary-low-xref-map "x" 'gnus-summary-temporarily-lower-by-xref) - (define-key gnus-summary-low-xref-map "X" 'gnus-summary-lower-by-xref) - (define-key gnus-summary-low-xref-map "t" 'gnus-summary-temporarily-lower-by-xref) - (define-key gnus-summary-low-xref-map "p" 'gnus-summary-lower-by-xref) - - (define-prefix-command 'gnus-summary-low-fol-map) - (define-key gnus-summary-lower-map "f" 'gnus-summary-low-fol-map) - (define-key gnus-summary-lower-map "F" 'gnus-summary-lower-followups-to-author) - (define-key gnus-summary-low-fol-map "f" 'gnus-summary-lower-followups-to-author) - (define-key gnus-summary-low-fol-map "F" 'gnus-summary-lower-followups-to-author) - (define-key gnus-summary-low-fol-map "t" 'gnus-summary-lower-followups-to-author) - (define-key gnus-summary-low-fol-map "p" 'gnus-summary-lower-followups-to-author) ) --- 4791,4798 ---- *************** *** 5141,5147 **** ;; You can change the subjects in this hook. (run-hooks 'gnus-select-group-hook) ;; Do score processing. ! (gnus-score-headers) ;; Update the format specifiers. (gnus-update-format-specifications) ;; Generate the summary buffer. --- 4993,4999 ---- ;; You can change the subjects in this hook. (run-hooks 'gnus-select-group-hook) ;; Do score processing. ! (gnus-possibly-score-headers) ;; Update the format specifiers. (gnus-update-format-specifications) ;; Generate the summary buffer. *************** *** 5158,5167 **** ;; This newsgroup is empty. (gnus-summary-catchup-and-exit nil t) ;Without confirmations. (message "No unread news") ! (and kill-buffer ! (get-buffer kill-buffer) ! (buffer-name (get-buffer kill-buffer)) ! (kill-buffer kill-buffer))) (save-excursion (if kill-buffer (let ((gnus-summary-buffer kill-buffer)) --- 5010,5016 ---- ;; This newsgroup is empty. (gnus-summary-catchup-and-exit nil t) ;Without confirmations. (message "No unread news") ! (gnus-kill-buffer kill-buffer)) (save-excursion (if kill-buffer (let ((gnus-summary-buffer kill-buffer)) *************** *** 5182,5191 **** (pop-to-buffer gnus-summary-buffer) (gnus-set-mode-line 'summary) (gnus-summary-position-cursor) ! (if (and kill-buffer ! (get-buffer kill-buffer) ! (buffer-name (get-buffer kill-buffer))) ! (kill-buffer kill-buffer)))) ;; Cannot select newsgroup GROUP. (message "Couldn't select newsgroup") (and (eq major-mode 'gnus-summary-mode) --- 5031,5037 ---- (pop-to-buffer gnus-summary-buffer) (gnus-set-mode-line 'summary) (gnus-summary-position-cursor) ! (gnus-kill-buffer kill-buffer))) ;; Cannot select newsgroup GROUP. (message "Couldn't select newsgroup") (and (eq major-mode 'gnus-summary-mode) *************** *** 6698,6704 **** (headers gnus-newsgroup-headers)) (gnus-close-group group) (run-hooks 'gnus-exit-group-hook) ! (gnus-score-save) (gnus-update-read-articles group gnus-newsgroup-unreads gnus-newsgroup-unselected gnus-newsgroup-marked --- 6544,6551 ---- (headers gnus-newsgroup-headers)) (gnus-close-group group) (run-hooks 'gnus-exit-group-hook) ! (and (fboundp 'gnus-score-save) ! (funcall 'gnus-score-save)) (gnus-update-read-articles group gnus-newsgroup-unreads gnus-newsgroup-unselected gnus-newsgroup-marked *************** *** 6734,6747 **** (gnus-summary-clear-local-variables) (gnus-configure-windows 'newsgroups t) ;; Return to group mode buffer. ! (and (get-buffer buf) ! (eq mode 'gnus-summary-mode) ! (kill-buffer buf)) (if (get-buffer gnus-article-buffer) (bury-buffer gnus-article-buffer)) (setq gnus-current-select-method gnus-select-method) (pop-to-buffer gnus-group-buffer) ! (if (and quit-buffer (buffer-name quit-buffer)) (progn (switch-to-buffer quit-buffer) (gnus-set-global-variables) --- 6581,6593 ---- (gnus-summary-clear-local-variables) (gnus-configure-windows 'newsgroups t) ;; Return to group mode buffer. ! (if (eq mode 'gnus-summary-mode) ! (gnus-kill-buffer buf)) (if (get-buffer gnus-article-buffer) (bury-buffer gnus-article-buffer)) (setq gnus-current-select-method gnus-select-method) (pop-to-buffer gnus-group-buffer) ! (if (gnus-buffer-exists-p quit-buffer) (progn (switch-to-buffer quit-buffer) (gnus-set-global-variables) *************** *** 6771,6777 **** (pop-to-buffer gnus-group-buffer) (gnus-group-jump-to-group group) (gnus-group-next-group 1) ! (if (and quit-buffer (buffer-name quit-buffer)) (progn (switch-to-buffer quit-buffer) (gnus-configure-windows 'summary))))))) --- 6617,6623 ---- (pop-to-buffer gnus-group-buffer) (gnus-group-jump-to-group group) (gnus-group-next-group 1) ! (if (gnus-buffer-exists-p quit-buffer) (progn (switch-to-buffer quit-buffer) (gnus-configure-windows 'summary))))))) *************** *** 7254,7259 **** --- 7100,7107 ---- (if header (gnus-summary-goto-article (header-number header)) (let ((gnus-override-method gnus-refer-article-method)) + (or (gnus-server-opened gnus-refer-article-method) + (gnus-open-server gnus-refer-article-method)) (if (gnus-article-prepare message-id nil (gnus-read-header message-id)) (progn *************** *** 7516,7521 **** --- 7364,7370 ---- (if (or (string= to-newsgroup "") (string= to-newsgroup prefix)) (setq to-newsgroup (or gnus-current-move-group ""))) (or (gnus-gethash to-newsgroup gnus-active-hashtb) + (gnus-activate-newsgroup to-newsgroup) (error "No such group: %s" to-newsgroup)) (setq gnus-current-move-group to-newsgroup))) (or (gnus-check-backend-function 'request-accept-article *************** *** 7641,7646 **** --- 7490,7496 ---- (if (or (string= to-newsgroup "") (string= to-newsgroup prefix)) (setq to-newsgroup (or gnus-current-move-group ""))) (or (gnus-gethash to-newsgroup gnus-active-hashtb) + (gnus-activate-newsgroup to-newsgroup) (error "No such group: %s" to-newsgroup)) (setq gnus-current-move-group to-newsgroup))) (or (gnus-check-backend-function 'request-accept-article *************** *** 8970,8975 **** --- 8820,8845 ---- (or gnus-newsgroup-headers-hashtb-by-number (gnus-make-headers-hashtable-by-number)) (gnus-summary-position-cursor) + ;; If all commands are to be bunched up on one line, we collect + ;; them here. + (if gnus-view-pseudos-separately + () + (let ((ps (setq pslist (sort pslist 'gnus-pseudos<))) + files action) + (while ps + (setq action (cdr (assq 'action (car ps)))) + (while (and ps (cdr ps) + (string= (or action "1") + (or (cdr (assq 'action (car (cdr ps)))) "2"))) + (setq files (cons (cdr (assq 'name (car (cdr ps)))) files)) + (setcdr ps (cdr (cdr ps)))) + (if (not files) + () + (setcdr (assq 'command (car ps)) + (apply (if (string-match "%s" action) + 'format 'concat) + action (mapconcat (lambda (f) f) files " ")))) + (setq ps (cdr ps))))) (if gnus-view-pseudos (while pslist (and (assq 'execute (car pslist)) *************** *** 8997,9002 **** --- 8867,8877 ---- (setq gnus-reffed-article-number (1- gnus-reffed-article-number)) (setq pslist (cdr pslist))))))) + (defun gnus-pseudos< (p1 p2) + (let ((c1 (cdr (assq 'action p1))) + (c2 (cdr (assq 'action p2)))) + (and c1 c2 (string< c1 c2)))) + (defun gnus-request-pseudo-article (props) (cond ((assq 'execute props) (gnus-execute-command (cdr (assq 'execute props))))) *************** *** 9026,9310 **** (file-name-nondirectory file)))) (copy-file file to)) - ;; Summary score file commands - - ;; Much modification of the kill (ahem, score) code and lots of the - ;; functions are written by Per Abrahamsen . - - (defun gnus-summary-header (header) - ;; Return HEADER for current articles, or error. - (let ((article (gnus-summary-article-number))) - (if article - (aref (gnus-get-header-by-number article) - (nth 1 (assoc header gnus-header-index))) - (error "No article on current line")))) - - (defun gnus-summary-score-entry (header match type score date &optional prompt) - "Enter score file entry. - HEADER is the header being scored. - MATCH is the string we are looking for. - TYPE is a flag indicating if it is a regexp or substring. - SCORE is the score to add. - DATE is the expire date." - (interactive - (list (completing-read "Header: " - gnus-header-index - (lambda (x) (fboundp (nth 2 x))) - t) - (read-string "Match: ") - (y-or-n-p "Use regexp match? ") - (prefix-numeric-value current-prefix-arg) - (if (y-or-n-p "Expire kill? ") - (current-time-string) - nil))) - (let ((score (gnus-score-default score)) - (header (downcase header))) - (and prompt (setq match (read-string - (format "Match %s on %s, %s: " - (if date "temp" "permanent") - header - (if (< score 0) "lower" "raise")) - match))) - (and (>= (nth 1 (assoc header gnus-header-index)) 0) - (gnus-summary-score-effect header match type score)) - (and (= score gnus-score-interactive-default-score) - (setq score nil)) - (let ((new (cond (type - (list match score (and date (gnus-day-number date)) type)) - (date - (list match score (gnus-day-number date))) - (score - (list match score)) - (t - (list match)))) - (old (gnus-score-get header))) - (gnus-score-set - header - (if old (cons new old) (list new)))) - (gnus-score-set 'touched '(t)))) - - (defun gnus-summary-score-effect (header match type score) - "Simulate the effect of a score file entry. - HEADER is the header being scored. - MATCH is the string we are looking for. - TYPE is a flag indicating if it is a regexp or substring. - SCORE is the score to add." - (interactive (list (completing-read "Header: " - gnus-header-index - (lambda (x) (fboundp (nth 2 x))) - t) - (read-string "Match: ") - (y-or-n-p "Use regexp match? ") - (prefix-numeric-value current-prefix-arg))) - (save-excursion - (or (and (stringp match) (> (length match) 0)) - (error "No match")) - (goto-char (point-min)) - (let ((regexp (if type - match - (concat "\\`.*" (regexp-quote match) ".*\\'")))) - (while (not (eobp)) - (let ((content (gnus-summary-header header)) - (case-fold-search t)) - (and content - (if (string-match regexp content) - (gnus-summary-raise-score score)))) - (beginning-of-line 2))))) - - (defun gnus-summary-score-crossposting (score date) - ;; Enter score file entry for current crossposting. - ;; SCORE is the score to add. - ;; DATE is the expire date. - (let ((xref (gnus-summary-header "xref")) - (start 0) - group) - (or xref (error "This article is not crossposted")) - (while (string-match " \\([^ \t]+\\):" xref start) - (setq start (match-end 0)) - (if (not (string= - (setq group - (substring xref (match-beginning 1) (match-end 1))) - gnus-newsgroup-name)) - (gnus-summary-score-entry - "xref" (concat " " group ":") nil score date t))))) - - (defun gnus-summary-temporarily-lower-by-subject (level) - "Temporarily lower score by LEVEL for current subject. - See `gnus-score-expiry-days'." - (interactive "P") - (gnus-summary-score-entry - "subject" (gnus-simplify-subject-re (gnus-summary-header "subject")) - nil (- (gnus-score-default level)) - (current-time-string) t)) - - (defun gnus-summary-temporarily-lower-by-author (level) - "Temporarily lower score by LEVEL for current author. - See `gnus-score-expiry-days'." - (interactive "P") - (gnus-summary-score-entry - "from" (gnus-summary-header "from") nil (- (gnus-score-default level)) - (current-time-string) t)) - - (defun gnus-summary-temporarily-lower-by-body (level) - "Temporarily lower score by LEVEL for a match on the body of the article. - See `gnus-score-expiry-days'." - (interactive "P") - (gnus-summary-score-entry - "body" "" nil (- (gnus-score-default level)) (current-time-string) t)) - - (defun gnus-summary-temporarily-lower-by-id (level) - "Temporarily lower score by LEVEL for current message-id. - See `gnus-score-expiry-days'." - (interactive "P") - (gnus-summary-score-entry - "message-id" (gnus-summary-header "message-id") - nil (- (gnus-score-default level)) - (current-time-string))) - - (defun gnus-summary-temporarily-lower-by-xref (level) - "Temporarily lower score by LEVEL for current xref. - See `gnus-score-expiry-days'." - (interactive "P") - (gnus-summary-score-crossposting - (- (gnus-score-default level)) (current-time-string))) - - (defun gnus-summary-temporarily-lower-by-thread (level) - "Temporarily lower score by LEVEL for current thread. - See `gnus-score-expiry-days'." - (interactive "P") - (gnus-summary-score-entry - "references" (gnus-summary-header "message-id") - nil (- (gnus-score-default level)) (current-time-string))) - - (defun gnus-summary-lower-by-subject (level) - "Lower score by LEVEL for current subject." - (interactive "P") - (gnus-summary-score-entry - "subject" (gnus-simplify-subject-re (gnus-summary-header "subject")) - nil (- (gnus-score-default level)) - nil t)) - - (defun gnus-summary-lower-by-author (level) - "Lower score by LEVEL for current author." - (interactive "P") - (gnus-summary-score-entry - "from" (gnus-summary-header "from") nil - (- (gnus-score-default level)) nil t)) - - (defun gnus-summary-lower-by-body (level) - "Lower score by LEVEL for a match on the body of the article." - (interactive "P") - (gnus-summary-score-entry - "body" "" nil (- (gnus-score-default level)) nil t)) - - (defun gnus-summary-lower-by-id (level) - "Lower score by LEVEL for current message-id." - (interactive "P") - (gnus-summary-score-entry - "message-id" (gnus-summary-header "message-id") nil - (- (gnus-score-default level)) nil)) - - (defun gnus-summary-lower-by-xref (level) - "Lower score by LEVEL for current xref." - (interactive "P") - (gnus-summary-score-crossposting (- (gnus-score-default level)) nil)) - - (defun gnus-summary-lower-followups-to-author (level) - "Lower score by LEVEL for all followups to the current author." - (interactive "P") - (gnus-summary-raise-followups-to-author - (- (gnus-score-default level)))) - - (defun gnus-summary-temporarily-raise-by-subject (level) - "Temporarily raise score by LEVEL for current subject. - See `gnus-score-expiry-days'." - (interactive "P") - (gnus-summary-score-entry - "subject" (gnus-simplify-subject-re (gnus-summary-header "subject")) - nil level (current-time-string) t)) - - (defun gnus-summary-temporarily-raise-by-author (level) - "Temporarily raise score by LEVEL for current author. - See `gnus-score-expiry-days'." - (interactive "P") - (gnus-summary-score-entry - "from" (gnus-summary-header "from") nil level (current-time-string) t)) - - (defun gnus-summary-temporarily-raise-by-body (level) - "Temporarily raise score by LEVEL for a match on the body of the article. - See `gnus-score-expiry-days'." - (interactive "P") - (gnus-summary-score-entry "body" "" nil level (current-time-string) t)) - - (defun gnus-summary-temporarily-raise-by-id (level) - "Temporarily raise score by LEVEL for current message-id. - See `gnus-score-expiry-days'." - (interactive "P") - (gnus-summary-score-entry - "message-id" (gnus-summary-header "message-id") - nil level (current-time-string))) - - (defun gnus-summary-temporarily-raise-by-xref (level) - "Temporarily raise score by LEVEL for current xref. - See `gnus-score-expiry-days'." - (interactive "P") - (gnus-summary-score-crossposting level (current-time-string))) - - (defun gnus-summary-temporarily-raise-by-thread (level) - "Temporarily raise score by LEVEL for current thread. - See `gnus-score-expiry-days'." - (interactive "P") - (gnus-summary-score-entry - "references" (gnus-summary-header "message-id") - nil level (current-time-string))) - - (defun gnus-summary-raise-by-subject (level) - "Raise score by LEVEL for current subject." - (interactive "P") - (gnus-summary-score-entry - "subject" (gnus-simplify-subject-re (gnus-summary-header "subject")) - nil level nil t)) - - (defun gnus-summary-raise-by-author (level) - "Raise score by LEVEL for current author." - (interactive "P") - (gnus-summary-score-entry - "from" (gnus-summary-header "from") nil level nil t)) - - (defun gnus-summary-raise-by-body (level) - "Raise score by LEVEL for a match on the body of the article." - (interactive "P") - (gnus-summary-score-entry "body" "" nil level nil t)) - - (defun gnus-summary-raise-by-id (level) - "Raise score by LEVEL for current message-id." - (interactive "P") - (gnus-summary-score-entry - "message-id" (gnus-summary-header "message-id") nil level nil)) - - (defun gnus-summary-raise-by-xref (level) - "Raise score by LEVEL for current xref." - (interactive "P") - (gnus-summary-score-crossposting level nil)) - - (defun gnus-summary-raise-followups-to-author (level) - "Raise score by LEVEL for all followups to the current author." - (interactive "P") - (let ((article (gnus-summary-article-number))) - (if article (setq gnus-current-headers (gnus-get-header-by-number article)) - (error "No article on current line"))) - (gnus-kill-file-raise-followups-to-author - (gnus-score-default level))) - ;; Summary kill commands. (defun gnus-summary-edit-global-kill (article) ! "Edit the global score file." (interactive (list (gnus-summary-article-number))) (gnus-group-edit-global-kill article)) (defun gnus-summary-edit-local-kill () ! "Edit a local score file applied to the current newsgroup." (interactive) (setq gnus-current-headers (gnus-gethash --- 8901,8915 ---- (file-name-nondirectory file)))) (copy-file file to)) ;; Summary kill commands. (defun gnus-summary-edit-global-kill (article) ! "Edit the \"global\" kill file." (interactive (list (gnus-summary-article-number))) (gnus-group-edit-global-kill article)) (defun gnus-summary-edit-local-kill () ! "Edit a local kill file applied to the current newsgroup." (interactive) (setq gnus-current-headers (gnus-gethash *************** *** 9555,9566 **** (gnus-configure-windows 'article) (goto-char 1) (set-window-start ! (get-buffer-window gnus-article-buffer) (point-min)) ! (if bookmark ! (progn ! (message "Moved to bookmark") ! (search-forward "\n\n" nil t) ! (forward-line bookmark))) t))))))) (defun gnus-article-show-all-headers () --- 9160,9173 ---- (gnus-configure-windows 'article) (goto-char 1) (set-window-start ! (get-buffer-window gnus-article-buffer) ! (cond (bookmark ! (message "Moved to bookmark") ! (search-forward "\n\n" nil t) ! (forward-line bookmark) ! (point)) ! (t ! (point-min)))) t))))))) (defun gnus-article-show-all-headers () *************** *** 10111,10117 **** ;; Start Gnus. (gnus) ;; Apply kills to specified newsgroups in command line arguments. ! (setq newsrc (cdr gnus-newsrc-assoc)) (while newsrc (setq group (car (car newsrc))) (setq entry (gnus-gethash group gnus-newsrc-hashtb)) --- 9718,9724 ---- ;; Start Gnus. (gnus) ;; Apply kills to specified newsgroups in command line arguments. ! (setq newsrc (cdr gnus-newsrc-alist)) (while newsrc (setq group (car (car newsrc))) (setq entry (gnus-gethash group gnus-newsrc-hashtb)) *************** *** 10170,12337 **** ;;; ! ;;; Gnus Score Files ;;; ! ;; All score code written by Per Abrahamsen . ! ;; Added by Per Abrahamsen . ! (defun gnus-score-set-mark-below (score) ! "Automatically mark articles with score below SCORE as read." ! (interactive ! (list (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg)) ! (string-to-int (read-string "Mark below: "))))) ! (setq score (or score gnus-summary-default-score 0)) ! (gnus-score-set 'mark (list score)) ! (gnus-score-set 'touched '(t)) ! (setq gnus-summary-mark-below score) ! (gnus-summary-update-lines)) ! (defun gnus-score-set-expunge-below (score) ! "Automatically expunge articles with score below SCORE." ! (interactive ! (list (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg)) ! (string-to-int (read-string "Expunge below: "))))) ! (setq score (or score gnus-summary-default-score 0)) ! (gnus-score-set 'expunge (list score)) ! (gnus-score-set 'touched '(t))) ! ! (defun gnus-score-default (level) ! (if level (prefix-numeric-value level) ! gnus-score-interactive-default-score)) ! ! (defun gnus-score-set (symbol value &optional alist) ! ;; Set SYMBOL to VALUE in ALIST. ! (let* ((alist ! (or alist ! gnus-score-alist ! (progn ! (gnus-score-load (gnus-score-file-name gnus-newsgroup-name)) ! gnus-score-alist))) ! (entry (assoc symbol alist))) ! (cond ((gnus-score-get 'read-only alist) ! ;; This is a read-only score file, so we do nothing. ! ) ! (entry ! (setcdr entry value)) ! ((null alist) ! (error "Empty alist")) ! (t ! (setcdr alist ! (cons (cons symbol value) (cdr alist))))))) ! (defun gnus-score-get (symbol &optional alist) ! ;; Get SYMBOL's definition in ALIST. ! (cdr (assoc symbol ! (or alist ! gnus-score-alist (progn ! (gnus-score-load ! (gnus-score-file-name gnus-newsgroup-name)) ! gnus-score-alist))))) ! (defun gnus-score-change-score-file (file) ! "Change current score alist." ! (interactive ! (list (completing-read "Score file: " gnus-score-cache))) ! (setq gnus-current-score-file file) ! (gnus-score-load-file file) ! (gnus-set-mode-line 'summary)) ! ! (defun gnus-score-edit-alist (file) ! "Edit the current score alist." ! (interactive (list gnus-current-score-file)) ! (and (buffer-name gnus-summary-buffer) (gnus-score-save)) ! (setq gnus-winconf-edit-score (current-window-configuration)) ! (gnus-configure-windows 'article) ! (pop-to-buffer (find-file-noselect file)) ! (message (substitute-command-keys ! "\\\\[gnus-score-edit-done] to save edits")) ! (gnus-score-mode)) ! ! (defun gnus-score-edit-file (file) ! "Edit a score file." ! (interactive ! (list (read-file-name "Edit score file: " gnus-kill-files-directory))) ! (and (buffer-name gnus-summary-buffer) (gnus-score-save)) ! (setq gnus-winconf-edit-score (current-window-configuration)) ! (gnus-configure-windows 'article) ! (pop-to-buffer (find-file-noselect file)) ! (message (substitute-command-keys ! "\\\\[gnus-score-edit-done] to save edits")) ! (gnus-score-mode)) ! ! (defun gnus-score-load-file (file) ! ;; Load score file FILE. Returns a list a retrieved score-alists. ! (setq gnus-kill-files-directory (or gnus-kill-files-directory "~/News/")) ! (let* ((file (expand-file-name ! (or (and (string-match ! (concat "^" (expand-file-name ! gnus-kill-files-directory)) ! (expand-file-name file)) ! file) ! (concat gnus-kill-files-directory file)))) ! (cached (assoc file gnus-score-cache)) ! (global (member file gnus-internal-global-score-files)) ! lists alist) ! (if cached ! ;; The score file was already loaded. ! (setq alist (cdr cached)) ! ;; We load the score file. ! (setq gnus-score-alist nil) ! (setq alist (gnus-score-load-score-alist file)) ! ;; We add '(touched) to the alist to signify that it hasn't been ! ;; touched (yet). ! (or (assq 'touched alist) (setq alist (cons (list 'touched nil) alist))) ! ;; If it is a global score file, we make it read-only. ! (and global ! (not (assq 'read-only alist)) ! (setq alist (cons (list 'read-only t) alist))) ! ;; Update cache. ! (setq gnus-score-cache ! (cons (cons file alist) gnus-score-cache))) ! ;; If there are actual scores in the alist, we add it to the ! ;; return value of this function. ! (if (memq t (mapcar (lambda (e) (stringp (car e))) alist)) ! (setq lists (list alist))) ! ;; Treat the other possible atoms in the score alist. ! (let ((mark (car (gnus-score-get 'mark alist))) ! (expunge (car (gnus-score-get 'expunge alist))) ! (mark-and-expunge ! (car (gnus-score-get 'mark-and-expunge alist))) ! (read-only (gnus-score-get 'read-only alist)) ! (files (gnus-score-get 'files alist)) ! (exclude-files (gnus-score-get 'exclude-files alist)) ! (orphan (gnus-score-get 'orphan alist)) ! (eval (gnus-score-get 'eval 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)) ! files)))) ! (and eval (not global) (eval eval)) ! (setq gnus-scores-exclude-files exclude-files) ! (if orphan (setq gnus-orphan-score (car orphan))) ! (setq gnus-summary-mark-below ! (or mark mark-and-expunge gnus-summary-mark-below)) ! (setq gnus-summary-expunge-below ! (or expunge mark-and-expunge gnus-summary-expunge-below))) ! (setq gnus-current-score-file file) ! (setq gnus-score-alist alist) ! lists)) ! ! (defun gnus-score-load (file) ! ;; Load score FILE. ! (let ((cache (assoc file gnus-score-cache))) ! (if cache ! (setq gnus-score-alist (cdr cache)) ! (setq gnus-score-alist nil) ! (gnus-score-load-score-alist file) ! (or gnus-score-alist ! (setq gnus-score-alist (copy-alist '((touched nil))))) ! (setq gnus-score-cache ! (cons (cons file gnus-score-alist) gnus-score-cache))))) ! ! (defun gnus-score-remove-from-cache (file) ! (setq gnus-score-cache ! (delq (assoc file gnus-score-cache) gnus-score-cache))) ! ! (defun gnus-score-load-score-alist (file) ! (let (alist) ! (if (file-readable-p file) ! (progn ! (save-excursion ! (gnus-set-work-buffer) ! (insert-file-contents file) ! (goto-char (point-min)) ! ;; Only do the loading if the score file isn't empty. ! (if (save-excursion (re-search-forward "[()0-9a-zA-Z]" nil t)) ! (setq alist ! (condition-case () ! (read (current-buffer)) ! (error ! (progn ! (message "Problem with score file %s" file) ! (ding) ! (sit-for 2) ! nil)))))) ! (if (eq (car alist) 'setq) ! (setq gnus-score-alist (gnus-score-transform-old-to-new alist)) ! (setq gnus-score-alist alist)) ! (setq gnus-score-alist ! (gnus-score-check-syntax gnus-score-alist))) ! (setq gnus-score-alist nil)))) ! ! (defun gnus-score-check-syntax (alist) ! (cond ! ((null alist) ! nil) ! ((not (consp alist)) ! (message "Score file is not a list: %s" alist) ! (ding) ! nil) ! (t ! (let ((a alist) ! err) ! (while (and a (not err)) ! (cond ((not (listp (car a))) ! (message "Illegal score element: %s" (car a)) ! (setq err t)) ! ((and (stringp (car (car a))) ! (not (listp (nth 1 (car a))))) ! (message "Illegal header match: %s" (nth 1 (car a))) ! (setq err t)) ! (t ! (setq a (cdr a))))) ! (if err ! (progn ! (ding) ! nil) ! alist))))) ! ! (defun gnus-score-transform-old-to-new (alist) ! (let* ((alist (nth 2 alist)) ! out entry) ! (if (eq (car alist) 'quote) ! (setq alist (nth 1 alist))) ! (while alist ! (setq entry (car alist)) ! (if (stringp (car entry)) ! (let ((scor (cdr entry))) ! (setq out (cons entry out)) ! (while scor ! (setcar scor ! (list (car (car scor)) (nth 2 (car scor)) ! (and (nth 3 (car scor)) ! (gnus-day-number (nth 3 (car scor)))) ! (if (nth 1 (car scor)) 'r 's))) ! (setq scor (cdr scor)))) ! (setq out (cons (if (not (listp (cdr entry))) ! (list (car entry) (cdr entry)) ! entry) ! out))) ! (setq alist (cdr alist))) ! (cons (list 'touched t) (nreverse out)))) ! ! (defun gnus-score-save () ! ;; Save all SCORE information. ! (let ((cache gnus-score-cache)) ! (save-excursion ! (setq gnus-score-alist nil) ! (set-buffer (get-buffer-create "*Score*")) ! (buffer-disable-undo (current-buffer)) ! (let (entry score file) ! (while cache ! (setq entry (car cache) ! cache (cdr cache) ! file (car entry) ! score (cdr entry)) ! (if (or (not (equal (gnus-score-get 'touched score) '(t))) ! (gnus-score-get 'read-only score) ! (not (file-writable-p file))) ! () ! (setq score (delq (assq 'touched score) score)) ! (erase-buffer) ! (let (emacs-lisp-mode-hook) ! (pp score (current-buffer))) ! (gnus-make-directory (file-name-directory file)) ! (write-region (point-min) (point-max) file nil 'silent)))) ! (kill-buffer (current-buffer))))) ! ! (defun gnus-score-headers () ! ;; Score `gnus-newsgroup-headers'. ! (let ((func gnus-score-find-score-files-function) ! score-files scores) ! (and func (not (listp func)) ! (setq func (list func))) ! ;; Go through all the functions for finding score files (or actual ! ;; scores) and add them to a list. ! (while func ! (and (symbolp (car func)) ! (fboundp (car func)) ! (setq score-files ! (nconc score-files (funcall (car func) gnus-newsgroup-name)))) ! (setq func (cdr func))) ! ;; PLM: probably this is not the best place to clear orphan-score ! (setq gnus-orphan-score nil) ! ;; Load the SCORE files. ! (while score-files ! (if (stringp (car score-files)) ! ;; It is a string, which means that it's a score file name, ! ;; so we load the score file and add the score alist to ! ;; the list of alists. ! (setq scores (nconc (gnus-score-load-file (car score-files)) scores)) ! ;; It is an alist, so we just add it to the list directly. ! (setq scores (nconc (car score-files) scores))) ! (setq score-files (cdr score-files))) ! ;; Prune the score files that are to be excluded, if any. ! (if (not gnus-scores-exclude-files) ! () ! (let ((s scores) ! c) ! (while s ! (and (setq c (rassq (car s) gnus-score-cache)) ! (member (car c) gnus-scores-exclude-files) ! (setq scores (delq (car s) scores))) ! (setq s (cdr s))))) ! (if (not (and gnus-summary-default-score ! scores ! (> (length gnus-newsgroup-headers) ! (length gnus-newsgroup-scored)))) ! () ! (let* ((entries gnus-header-index) ! (now (gnus-day-number (current-time-string))) ! (expire (- now gnus-score-expiry-days)) ! (headers gnus-newsgroup-headers) ! entry header) ! (message "Scoring...") ! ;; Create articles, an alist of the form `(HEADER . SCORE)'. ! (while headers ! (setq header (car headers) ! headers (cdr headers)) ! ;; WARNING: The assq makes the function O(N*S) while it could ! ;; be written as O(N+S), where N is (length gnus-newsgroup-headers) ! ;; and S is (length gnus-newsgroup-scored). ! (or (assq (header-number header) gnus-newsgroup-scored) ! (setq gnus-scores-articles ;Total of 2 * N cons-cells used. ! (cons (cons header (or gnus-summary-default-score 0)) ! gnus-scores-articles)))) ! ! (save-excursion ! (set-buffer (get-buffer-create "*Headers*")) ! (buffer-disable-undo (current-buffer)) ! ;; score orphans ! (if gnus-orphan-score ! (progn ! (setq gnus-score-index ! (nth 1 (assoc "references" gnus-header-index))) ! (gnus-score-orphans gnus-orphan-score))) ! ;; Run each header through the score process. ! (while entries ! (setq entry (car entries) ! header (nth 0 entry) ! entries (cdr entries)) ! (setq gnus-score-index (nth 1 (assoc header gnus-header-index))) ! (if (< 0 (apply 'max (mapcar ! (lambda (score) ! (length (gnus-score-get header score))) ! scores))) ! (funcall (nth 2 entry) scores header now expire))) ! ;; Remove the buffer. ! (kill-buffer (current-buffer))) ! ! ;; Add articles to `gnus-newsgroup-scored'. ! (while gnus-scores-articles ! (or (= gnus-summary-default-score (cdr (car gnus-scores-articles))) ! (setq gnus-newsgroup-scored ! (cons (cons (header-number ! (car (car gnus-scores-articles))) ! (cdr (car gnus-scores-articles))) ! gnus-newsgroup-scored))) ! (setq gnus-scores-articles (cdr gnus-scores-articles))) ! ! (message "Scoring...done"))))) ! ! ! (defun gnus-get-new-thread-ids (articles) ! (let ((index (nth 1 (assoc "message-id" gnus-header-index))) ! (refind gnus-score-index) ! id-list art this tref) ! (while articles ! (setq art (car articles) ! this (aref (car art) index) ! tref (aref (car art) refind) ! articles (cdr articles)) ! (if (string-equal tref "") ;no references line ! (setq id-list (cons this id-list)))) ! id-list)) ! ! ;; Orphan functions written by plm@atcmp.nl (Peter Mutsaers). ! (defun gnus-score-orphans (score) ! (let ((new-thread-ids (gnus-get-new-thread-ids gnus-scores-articles)) ! (index (nth 1 (assoc "references" gnus-header-index))) ! alike articles art arts this last this-id) ! ! (setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<) ! articles gnus-scores-articles) ! ! ;;more or less the same as in gnus-score-string ! (erase-buffer) ! (while articles ! (setq art (car articles) ! this (aref (car art) gnus-score-index) ! articles (cdr articles)) ! ;;completely skip if this is empty (not a child, so not an orphan) ! (if (not (string= this "")) ! (if (equal last this) ! ;; O(N*H) cons-cells used here, where H is the number of ! ;; headers. ! (setq alike (cons art alike)) ! (if last ! (progn ! ;; Insert the line, with a text property on the ! ;; terminating newline refering to the articles with ! ;; this line. ! (insert last ?\n) ! (put-text-property (1- (point)) (point) 'articles alike))) ! (setq alike (list art) ! last this)))) ! (and last ; Bwadr, duplicate code. ! (progn ! (insert last ?\n) ! (put-text-property (1- (point)) (point) 'articles alike))) ! ! ;; PLM: now delete those lines that contain an entry from new-thread-ids ! (while new-thread-ids ! (setq this-id (car new-thread-ids) ! new-thread-ids (cdr new-thread-ids)) ! (goto-char (point-min)) ! (while (search-forward this-id nil t) ! ;; found a match. remove this line ! (beginning-of-line) ! (kill-line 1))) ! ! ;; now for each line: update its articles with score by moving to ! ;; every end-of-line in the buffer and read the articles property ! (goto-char (point-min)) ! (while (eq 0 (progn ! (end-of-line) ! (setq arts (get-text-property (point) 'articles)) ! (while arts ! (setq art (car arts) ! arts (cdr arts)) ! (setcdr art (+ score (cdr art)))) ! (forward-line)))))) ! ! ! (defun gnus-score-integer (scores header now expire) ! (let ((gnus-score-index (nth 1 (assoc header gnus-header-index))) ! alike last this art entries alist articles) ! ! ;; Find matches. ! (while scores ! (setq alist (car scores) ! scores (cdr scores) ! entries (assoc header alist)) ! (while (cdr entries) ;First entry is the header index. ! (let* ((rest (cdr entries)) ! (kill (car rest)) ! (match (nth 0 kill)) ! (type (or (nth 3 kill) '>)) ! (score (or (nth 1 kill) gnus-score-interactive-default-score)) ! (date (nth 2 kill)) ! (found nil) ! (match-func (if (or (eq type '>) (eq type '<) (eq type '<=) ! (eq type '>=) (eq type '=)) ! type ! (error "Illegal match type: %s" type))) ! (articles gnus-scores-articles) ! arts art) ! ;; Instead of doing all the clever stuff that ! ;; `gnus-score-string' does to minimize searches and stuff, ! ;; I will assume that people generally will put so few ! ;; matches on numbers that any cleverness will take more ! ;; time than one would gain. ! (while articles ! (and (funcall match-func match ! (or (aref (car (car articles)) gnus-score-index) 0)) ! (progn ! (setq found t) ! (setcdr (car articles) (+ score (cdr (car articles)))))) ! (setq articles (cdr articles))) ! ;; Update expire date ! (cond ((null date)) ;Permanent entry. ! (found ;Match, update date. ! (gnus-score-set 'touched '(t) alist) ! (setcar (nthcdr 2 kill) now)) ! ((< date expire) ;Old entry, remove. ! (gnus-score-set 'touched '(t) alist) ! (setcdr entries (cdr rest)) ! (setq rest entries))) ! (setq entries rest)))))) ! ! (defun gnus-score-date (scores header now expire) ! (let ((gnus-score-index (nth 1 (assoc header gnus-header-index))) ! alike last this art entries alist articles) ! ! ;; Find matches. ! (while scores ! (setq alist (car scores) ! scores (cdr scores) ! entries (assoc header alist)) ! (while (cdr entries) ;First entry is the header index. ! (let* ((rest (cdr entries)) ! (kill (car rest)) ! (match (timezone-make-date-sortable (nth 0 kill))) ! (type (or (nth 3 kill) 'before)) ! (score (or (nth 1 kill) gnus-score-interactive-default-score)) ! (date (nth 2 kill)) ! (found nil) ! (match-func ! (cond ((eq type 'after) 'string<) ! ((eq type 'before) 'gnus-string>) ! ((eq type 'at) 'string=) ! (t (error "Illegal match type: %s" type)))) ! (articles gnus-scores-articles) ! arts art l) ! ;; Instead of doing all the clever stuff that ! ;; `gnus-score-string' does to minimize searches and stuff, ! ;; I will assume that people generally will put so few ! ;; matches on numbers that any cleverness will take more ! ;; time than one would gain. ! (while articles ! (and ! (setq l (aref (car (car articles)) gnus-score-index)) ! (funcall match-func match (timezone-make-date-sortable l)) ! (progn ! (setq found t) ! (setcdr (car articles) (+ score (cdr (car articles)))))) ! (setq articles (cdr articles))) ! ;; Update expire date ! (cond ((null date)) ;Permanent entry. ! (found ;Match, update date. ! (gnus-score-set 'touched '(t) alist) ! (setcar (nthcdr 2 kill) now)) ! ((< date expire) ;Old entry, remove. ! (gnus-score-set 'touched '(t) alist) ! (setcdr entries (cdr rest)) ! (setq rest entries))) ! (setq entries rest)))))) ! ! (defun gnus-score-body (scores header now expire) ! (save-excursion ! (set-buffer nntp-server-buffer) ! (save-restriction ! (let* ((buffer-read-only nil) ! (articles gnus-scores-articles) ! (all-scores scores) ! (request-func (cond ((string= "head" (downcase header)) ! 'gnus-request-head) ! ((string= "body" (downcase header)) ! 'gnus-request-body) ! (t 'gnus-request-article))) ! alike last this art entries alist ofunc article) ! ;; Not all backends support partial fetching. In that case, ! ;; we just fetch the entire article. ! (or (gnus-check-backend-function request-func gnus-newsgroup-name) ! (progn ! (setq ofunc request-func) ! (setq request-func 'gnus-request-article))) ! (while articles ! (setq article (header-number (car (car articles)))) ! (message "Scoring on article %s..." article) ! (if (not (funcall request-func article gnus-newsgroup-name)) ! () ! (widen) ! (goto-char (point-min)) ! ;; If just parts of the article is to be searched, but the ! ;; backend didn't support partial fetching, we just narrow ! ;; to the relevant parts. ! (if ofunc ! (if (eq ofunc 'gnus-request-head) ! (narrow-to-region ! (point) ! (or (search-forward "\n\n" nil t) (point-max))) ! (narrow-to-region ! (or (search-forward "\n\n" nil t) (point)) ! (point-max)))) ! (setq scores all-scores) ! ;; Find matches. ! (while scores ! (setq alist (car scores) ! scores (cdr scores) ! entries (assoc header alist)) ! (while (cdr entries) ;First entry is the header index. ! (let* ((rest (cdr entries)) ! (kill (car rest)) ! (match (nth 0 kill)) ! (type (or (nth 3 kill) 's)) ! (score (or (nth 1 kill) ! gnus-score-interactive-default-score)) ! (date (nth 2 kill)) ! (found nil) ! (case-fold-search ! (not (or (eq type 'R) (eq type 'S) ! (eq type 'Regexp) (eq type 'String)))) ! (search-func ! (cond ((or (eq type 'r) (eq type 'R) ! (eq type 'regexp) (eq type 'Regexp)) ! 're-search-forward) ! ((or (eq type 's) (eq type 'S) ! (eq type 'string) (eq type 'String)) ! 'search-forward) ! (t ! (error "Illegal match type: %s" type)))) ! arts art) ! (goto-char (point-min)) ! (if (funcall search-func match nil t) ! ;; Found a match, update scores. ! (progn ! (setcdr (car articles) (+ score (cdr (car articles)))) ! (setq found t))) ! ;; Update expire date ! (cond ((null date)) ;Permanent entry. ! (found ;Match, update date. ! (gnus-score-set 'touched '(t) alist) ! (setcar (nthcdr 2 kill) now)) ! ((< date expire) ;Old entry, remove. ! (gnus-score-set 'touched '(t) alist) ! (setcdr entries (cdr rest)) ! (setq rest entries))) ! (setq entries rest))))) ! (setq articles (cdr articles))))))) ! ! (defun gnus-score-string (scores header now expire) ! ;; Score ARTICLES according to HEADER in SCORES. ! ;; Update matches entries to NOW and remove unmatched entried older ! ;; than EXPIRE. ! ! ;; 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. ! alike last this art entries alist articles) ! ! ;; Sorting the articles costs os O(N*log N) but will allow us to ! ;; only match with each unique header. Thus the actual matching ! ;; will be O(M*U) where M is the number of strings to match with, ! ;; and U is the number of unique headers. It is assumed (but ! ;; untested) this will be a net win because of the large constant ! ;; factor involved with string matching. ! (setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<) ! articles gnus-scores-articles) ! ! (erase-buffer) ! (while articles ! (setq art (car articles) ! this (aref (car art) gnus-score-index) ! articles (cdr articles)) ! (if (equal last this) ! ;; O(N*H) cons-cells used here, where H is the number of ! ;; headers. ! (setq alike (cons art alike)) ! (if last ! (progn ! ;; Insert the line, with a text property on the ! ;; terminating newline refering to the articles with ! ;; this line. ! (insert last ?\n) ! (put-text-property (1- (point)) (point) 'articles alike))) ! (setq alike (list art) ! last this))) ! (and last ; Bwadr, duplicate code. ! (progn ! (insert last ?\n) ! (put-text-property (1- (point)) (point) 'articles alike))) ! ! ;; Find matches. ! (while scores ! (setq alist (car scores) ! scores (cdr scores) ! entries (assoc header alist)) ! (while (cdr entries) ;First entry is the header index. ! (let* ((rest (cdr entries)) ! (kill (car rest)) ! (match (nth 0 kill)) ! (type (or (nth 3 kill) 's)) ! (score (or (nth 1 kill) gnus-score-interactive-default-score)) ! (date (nth 2 kill)) ! (found nil) ! (case-fold-search ! (not (or (eq type 'R) (eq type 'S) ! (eq type 'Regexp) (eq type 'String)))) ! (search-func (cond ((or (eq type 'r) (eq type 'R) ! (eq type 'regexp) (eq type 'Regexp)) ! 're-search-forward) ! ((or (eq type 's) (eq type 'S) ! (eq type 'string) (eq type 'String)) ! 'search-forward) ! (t ! (error "Illegal match type: %s" type)))) ! arts art) ! (goto-char (point-min)) ! (while (funcall search-func match nil t) ! (end-of-line 1) ! (setq found t ! arts (get-text-property (point) 'articles)) ! ;; Found a match, update scores. ! (while arts ! (setq art (car arts) ! arts (cdr arts)) ! (setcdr art (+ score (cdr art))))) ! ;; Update expire date ! (cond ((null date)) ;Permanent entry. ! (found ;Match, update date. ! (gnus-score-set 'touched '(t) alist) ! (setcar (nthcdr 2 kill) now)) ! ((< date expire) ;Old entry, remove. ! (gnus-score-set 'touched '(t) alist) ! (setcdr entries (cdr rest)) ! (setq rest entries))) ! (setq entries rest)))))) ! ! (defun gnus-score-string< (a1 a2) ! ;; Compare headers in articles A2 and A2. ! ;; The header index used is the free variable `gnus-score-index'. ! (string-lessp (aref (car a1) gnus-score-index) ! (aref (car a2) gnus-score-index))) ! ! (defun gnus-score-build-cons (article) ! ;; Build a `gnus-newsgroup-scored' type cons from ARTICLE. ! (cons (header-number (car article)) (cdr article))) ! ! (defconst gnus-header-index ! ;; Name to index alist. ! '(("number" 0 gnus-score-integer) ! ("subject" 1 gnus-score-string) ! ("from" 2 gnus-score-string) ! ("date" 3 gnus-score-date) ! ("message-id" 4 gnus-score-string) ! ("references" 5 gnus-score-string) ! ("chars" 6 gnus-score-integer) ! ("lines" 7 gnus-score-integer) ! ("xref" 8 gnus-score-string) ! ("head" -1 gnus-score-body) ! ("body" -1 gnus-score-body) ! ("all" -1 gnus-score-body))) ! ! (defun gnus-score-file-name (newsgroup) ! "Return the name of a score file for NEWSGROUP." ! (cond ((or (null newsgroup) ! (string-equal newsgroup "")) ! ;; The global score file is placed at top of the directory. ! (expand-file-name gnus-score-file-suffix ! (or gnus-kill-files-directory "~/News"))) ! ((gnus-use-long-file-name 'not-score) ! ;; Append ".SCORE" to newsgroup name. ! (expand-file-name (concat newsgroup "." gnus-score-file-suffix) ! (or gnus-kill-files-directory "~/News"))) ! (t ! ;; Place "SCORE" under the hierarchical directory. ! (expand-file-name (concat (gnus-newsgroup-directory-form newsgroup) ! "/" gnus-score-file-suffix) ! (or gnus-kill-files-directory "~/News"))))) ! ! (defun gnus-score-score-files (group) ! "Return a list of all possible score files." ! (and gnus-global-score-files ! (or gnus-internal-global-score-files ! (gnus-score-search-global-directories gnus-global-score-files))) ! (setq gnus-kill-files-directory ! (file-name-as-directory ! (or gnus-kill-files-directory "~/News/"))) ! (if (not (file-readable-p gnus-kill-files-directory)) ! (setq gnus-score-file-list nil) ! (if (gnus-use-long-file-name 'not-score) ! (if (or (not gnus-score-file-list) ! (gnus-file-newer-than gnus-kill-files-directory ! (car gnus-score-file-list))) ! (setq gnus-score-file-list ! (cons (nth 5 (file-attributes gnus-kill-files-directory)) ! (nreverse ! (directory-files ! gnus-kill-files-directory t ! (concat gnus-score-file-suffix "$")))))) ! (let ((dir (expand-file-name ! (concat gnus-kill-files-directory ! (gnus-replace-chars-in-string group ?. ?/)))) ! (mdir (length (expand-file-name gnus-kill-files-directory))) ! files) ! (if (file-exists-p (concat dir "/" gnus-score-file-suffix)) ! (setq files (list (concat dir "/" gnus-score-file-suffix)))) ! (while (>= (1+ (length dir)) mdir) ! (and (file-exists-p (concat dir "/all/" gnus-score-file-suffix)) ! (setq files (cons (concat dir "/all/" gnus-score-file-suffix) ! files))) ! (string-match "/[^/]*$" dir) ! (setq dir (substring dir 0 (match-beginning 0)))) ! (setq gnus-score-file-list ! (cons nil (nreverse files))))) ! (cdr gnus-score-file-list))) ! ! (defun gnus-score-find-single (group) ! "Return list containing the score file for GROUP." ! (list (gnus-score-file-name group))) ! ! (defun gnus-score-find-hierarchical (group) ! "Return list of score files for GROUP. ! This includes the score file for the group and all its parents." ! (let ((all (copy-sequence '(nil))) ! (start 0)) ! (while (string-match "\\." group (1+ start)) ! (setq start (match-beginning 0)) ! (setq all (cons (substring group 0 start) all))) ! (setq all (cons group all)) ! (mapcar 'gnus-score-file-name (nreverse all)))) ! ! (defun gnus-score-find-bnews (group) ! "Return a list of score files for GROUP. ! The score files are those files in the ~/News directory which matches ! GROUP using BNews sys file syntax." ! (let* ((sfiles (append (gnus-score-score-files group) ! gnus-internal-global-score-files)) ! (kill-dir (file-name-as-directory ! (expand-file-name gnus-kill-files-directory))) ! (klen (length kill-dir)) ! ofiles not-match regexp) ! (save-excursion ! (set-buffer (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. ! (while sfiles ! (erase-buffer) ! (insert (car sfiles)) ! (goto-char 1) ! ;; First remove the suffix itself. ! (re-search-forward (concat "." gnus-score-file-suffix "$")) ! (replace-match "" t t) ! (goto-char 1) ! (if (looking-at (regexp-quote kill-dir)) ! ;; If the file name was just "SCORE", `klen' is one character ! ;; too much. ! (delete-char (min (1- (point-max)) klen)) ! (goto-char (point-max)) ! (search-backward "/") ! (delete-region (1+ (point)) (point-min))) ! ;; Translate "all" to ".*". ! (while (search-forward "all" nil t) ! (replace-match ".*" t t)) ! (goto-char 1) ! ;; Deal with "not."s. ! (if (looking-at "not.") ! (progn ! (setq not-match t) ! (setq regexp (buffer-substring 5 (point-max)))) ! (setq regexp (buffer-substring 1 (point-max))) ! (setq not-match nil)) ! ;; Finally - if this resulting regexp matches the group name, ! ;; we add this score file to the list of score files ! ;; applicable to this group. ! (if (or (and not-match ! (not (string-match regexp group))) ! (and (not not-match) ! (string-match regexp group))) ! (setq ofiles (cons (car sfiles) ofiles))) ! (setq sfiles (cdr sfiles))) ! (kill-buffer (current-buffer)) ! ;; Slight kludge here - the last score file returned should be ! ;; the local score file, whether it exists or not. This is so ! ;; that any score commands the user enters will go to the right ! ;; file, and not end up in some global score file. ! (let ((localscore ! (expand-file-name ! (if (gnus-use-long-file-name 'not-score) ! (concat gnus-kill-files-directory group "." ! gnus-score-file-suffix) ! (concat gnus-kill-files-directory ! (gnus-replace-chars-in-string group ?. ?/) ! "/" gnus-score-file-suffix))))) ! (and (member localscore ofiles) ! (delete localscore ofiles)) ! (setq ofiles (cons localscore ofiles))) ! (nreverse ofiles)))) ! ! (defun gnus-score-search-global-directories (files) ! "Scan all global score directories for score files." ! ;; Set the variable `gnus-internal-global-score-files' to all ! ;; available global score files. ! (interactive (list gnus-global-score-files)) ! (let (out) ! (while files ! (if (string-match "/$" (car files)) ! (setq out (nconc (directory-files ! (car files) t ! (concat gnus-score-file-suffix "$")))) ! (setq out (cons (car files) out))) ! (setq files (cdr files))) ! (setq gnus-internal-global-score-files out))) ! ! (defun gnus-current-score-file-nondirectory (&optional score-file) ! (let ((score-file (or score-file gnus-current-score-file))) ! (if score-file ! (gnus-short-group-name (file-name-nondirectory score-file)) ! "none"))) ! ! ;;; ! ;;; Score mode. ! ;;; ! ! (defvar gnus-score-mode-map nil) ! (defvar gnus-score-mode-hook nil) ! ! (if gnus-score-mode-map ! () ! (setq gnus-score-mode-map (copy-keymap emacs-lisp-mode-map)) ! (define-key gnus-score-mode-map "\C-c\C-c" 'gnus-score-edit-done) ! (define-key gnus-score-mode-map "\C-c\C-d" 'gnus-score-edit-insert-date)) ! ! (defun gnus-score-mode () ! "Mode for editing score files. ! This mode is an extended emacs-lisp mode. ! ! \\{gnus-score-mode-map}" ! (interactive) ! (kill-all-local-variables) ! (use-local-map gnus-score-mode-map) ! (set-syntax-table emacs-lisp-mode-syntax-table) ! (setq major-mode 'gnus-score-mode) ! (setq mode-name "Score") ! (lisp-mode-variables nil) ! (run-hooks 'emacs-lisp-mode-hook 'gnus-score-mode-hook)) ! ! (defun gnus-score-edit-insert-date () ! "Insert date in numerical format." ! (interactive) ! (insert (int-to-string (gnus-day-number (current-time-string))))) ! ! (defun gnus-score-edit-done () ! "Save the score file and return to the summary buffer." ! (interactive) ! (let ((bufnam (buffer-file-name (current-buffer)))) ! (save-buffer) ! (kill-buffer (current-buffer)) ! (and gnus-winconf-edit-score ! (set-window-configuration gnus-winconf-edit-score)) ! (gnus-score-remove-from-cache bufnam) ! (gnus-score-load-file bufnam))) ! ! ! ;;; ! ;;; Gnus Posting Functions ! ;;; ! ! (defvar gnus-organization-file "/usr/lib/news/organization" ! "*Local news organization file.") ! ! (defvar gnus-post-news-buffer "*post-news*") ! (defvar gnus-winconf-post-news nil) ! ! ;;; Post news commands of Gnus group mode and summary mode ! ! (defun gnus-group-post-news () ! "Post an article." ! (interactive) ! (gnus-set-global-variables) ! ;; Save window configuration. ! (setq gnus-winconf-post-news (current-window-configuration)) ! (let ((gnus-newsgroup-name nil)) ! (unwind-protect ! (if gnus-split-window ! (progn ! (pop-to-buffer gnus-article-buffer) ! (widen) ! (split-window-vertically) ! (gnus-post-news 'post)) ! (progn ! (pop-to-buffer gnus-article-buffer) ! (widen) ! (delete-other-windows) ! (gnus-post-news 'post))) ! (or (and (eq (current-buffer) (get-buffer gnus-post-news-buffer)) ! (not (zerop (buffer-size)))) ! ;; Restore last window configuration. ! (and gnus-winconf-post-news ! (set-window-configuration gnus-winconf-post-news))))) ! ;; We don't want to return to summary buffer nor article buffer later. ! (setq gnus-winconf-post-news nil) ! (if (get-buffer gnus-summary-buffer) ! (bury-buffer gnus-summary-buffer)) ! (if (get-buffer gnus-article-buffer) ! (bury-buffer gnus-article-buffer))) ! ! (defun gnus-summary-post-news () ! "Post an article." ! (interactive) ! (gnus-set-global-variables) ! ;; Save window configuration. ! (setq gnus-winconf-post-news (current-window-configuration)) ! (unwind-protect ! (gnus-post-news 'post gnus-newsgroup-name) ! (or (and (eq (current-buffer) (get-buffer gnus-post-news-buffer)) ! (not (zerop (buffer-size)))) ! ;; Restore last window configuration. ! (and gnus-winconf-post-news ! (set-window-configuration gnus-winconf-post-news)))) ! ;; We don't want to return to article buffer later. ! (if (get-buffer gnus-article-buffer) ! (bury-buffer gnus-article-buffer))) ! ! (defun gnus-summary-followup (yank) ! "Compose a followup to an article. ! If prefix argument YANK is non-nil, original article is yanked automatically." ! (interactive "P") ! (gnus-set-global-variables) ! (save-window-excursion ! (gnus-summary-select-article t)) ! (let ((headers gnus-current-headers) ! (gnus-newsgroup-name gnus-newsgroup-name)) ! ;; Check Followup-To: poster. ! (set-buffer gnus-article-buffer) ! (if (and gnus-use-followup-to ! (string-equal "poster" (gnus-fetch-field "followup-to")) ! (or (not (eq gnus-use-followup-to t)) ! (not (gnus-y-or-n-p ! "Do you want to ignore `Followup-To: poster'? ")))) ! ;; Mail to the poster. Gnus is now RFC1036 compliant. ! (gnus-summary-reply yank) ! ;; Save window configuration. ! (setq gnus-winconf-post-news (current-window-configuration)) ! (unwind-protect ! (gnus-post-news nil gnus-newsgroup-name ! headers gnus-article-buffer yank) ! (or (and (eq (current-buffer) (get-buffer gnus-post-news-buffer)) ! (not (zerop (buffer-size)))) ! ;; Restore last window configuration. ! (and gnus-winconf-post-news ! (set-window-configuration gnus-winconf-post-news)))) ! ;; We don't want to return to article buffer later. ! (bury-buffer gnus-article-buffer))) ! (gnus-article-hide-headers-if-wanted)) ! ! (defun gnus-summary-followup-with-original () ! "Compose a followup to an article and include the original article." ! (interactive) ! (gnus-summary-followup t)) ! ! ;; Suggested by Daniel Quinlan . ! (defun gnus-summary-followup-and-reply (yank) ! "Compose a followup and do an auto mail to author." ! (interactive "P") ! (let ((gnus-auto-mail-to-author t)) ! (gnus-summary-followup yank))) ! ! (defun gnus-summary-followup-and-reply-with-original () ! "Compose a followup, include the original, and do an auto mail to author." ! (interactive) ! (gnus-summary-followup-and-reply t)) ! ! (defun gnus-summary-cancel-article () ! "Cancel an article you posted." ! (interactive) ! (gnus-set-global-variables) ! (gnus-summary-select-article t) ! (gnus-eval-in-buffer-window gnus-article-buffer (gnus-cancel-news)) ! (gnus-article-hide-headers-if-wanted)) ! ! (defun gnus-summary-supersede-article () ! "Compose an article that will supersede a previous article. ! 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) ! (if (not ! (string-equal ! (downcase (mail-strip-quoted-names ! (header-from gnus-current-headers))) ! (downcase (mail-strip-quoted-names (gnus-inews-user-name))))) ! (error "This article is not yours.")) ! (gnus-summary-select-article t) ! (save-excursion ! (set-buffer gnus-article-buffer) ! (let ((buffer-read-only nil)) ! (goto-char (point-min)) ! (search-forward "\n\n" nil t) ! (if (not (re-search-backward "^Message-ID: " nil t)) ! (error "No Message-ID in this article")))) ! (if (gnus-post-news 'post gnus-newsgroup-name) ! (progn ! (erase-buffer) ! (insert-buffer gnus-article-buffer) ! (goto-char (point-min)) ! (search-forward "\n\n" nil t) ! (if (not (re-search-backward "^Message-ID: " nil t)) ! (error "No Message-ID in this article") ! (replace-match "Supersedes: " t t)) ! (search-forward "\n\n") ! (forward-line -1) ! (insert mail-header-separator)))) ! ! ! ;;;###autoload ! (fset 'sendnews 'gnus-post-news) ! ! ;;;###autoload ! (fset 'postnews 'gnus-post-news) ! ! (defun gnus-post-news (post &optional group header article-buffer yank) ! "Begin editing a new USENET news article to be posted. ! Type \\[describe-mode] in the buffer to get a list of commands." ! (interactive (list t)) ! (if (or (not gnus-novice-user) ! gnus-expert-user ! (not (eq 'post ! (nth 1 (assoc ! (format "%s" (car (gnus-find-method-for-group ! gnus-newsgroup-name))) ! gnus-valid-select-methods)))) ! (assq 'to-address (nth 5 (nth 2 (gnus-gethash gnus-newsgroup-name ! gnus-newsrc-hashtb)))) ! (gnus-y-or-n-p "Are you sure you want to post to all of USENET? ")) ! (let ((sumart (if (not post) ! (save-excursion ! (set-buffer gnus-summary-buffer) ! (cons (current-buffer) gnus-current-article)))) ! (from (and header (header-from header))) ! subject follow-to real-group) ! (and gnus-interactive-post ! (not gnus-expert-user) ! post (not group) ! (progn ! (setq group ! (completing-read "Group: " gnus-active-hashtb)) ! (setq subject (read-string "Subject: ")))) ! (setq mail-reply-buffer article-buffer) ! ! (let ((gnus-newsgroup-name (or group gnus-newsgroup-name ""))) ! (setq real-group (and group (gnus-group-real-name group))) ! (setq gnus-post-news-buffer ! (gnus-request-post-buffer ! post real-group subject header article-buffer ! (nth 2 (and group (gnus-gethash group gnus-newsrc-hashtb))) ! (or (cdr (assq 'to-group ! (nth 5 (nth 2 (gnus-gethash ! gnus-newsgroup-name ! gnus-newsrc-hashtb))))) ! (if (and (boundp 'gnus-followup-to-function) ! gnus-followup-to-function) ! (setq follow-to ! (save-excursion ! (set-buffer article-buffer) ! (funcall gnus-followup-to-function group))))) ! (eq gnus-use-followup-to t))) ! (if post ! (progn ! (gnus-configure-windows '(1 0 0)) ! (switch-to-buffer gnus-post-news-buffer)) ! (gnus-configure-windows '(0 1 0)) ! (if (not yank) ! (progn ! (switch-to-buffer article-buffer) ! (pop-to-buffer gnus-post-news-buffer)) ! (switch-to-buffer gnus-post-news-buffer))) ! (gnus-overload-functions) ! (make-local-variable 'gnus-article-reply) ! (make-local-variable 'gnus-article-check-size) ! (setq gnus-article-reply sumart) ! ;; Handle `gnus-auto-mail-to-author'. ! ;; Suggested by Daniel Quinlan . ! (let ((to (if (eq gnus-auto-mail-to-author 'ask) ! (and (y-or-n-p "Also send mail to author? ") from) ! (and gnus-auto-mail-to-author from)))) ! (if to ! (progn ! (if (mail-fetch-field "To") ! (progn ! (beginning-of-line) ! (insert "Cc: " to "\n")) ! (mail-position-on-field "To") ! (insert to))))) ! ;; Handle author copy using BCC field. ! (if (and gnus-mail-self-blind ! (not (mail-fetch-field "bcc"))) ! (progn ! (mail-position-on-field "Bcc") ! (insert (if (stringp gnus-mail-self-blind) ! gnus-mail-self-blind ! (user-login-name))))) ! ;; Handle author copy using FCC field. ! (if gnus-author-copy ! (progn ! (mail-position-on-field "Fcc") ! (insert gnus-author-copy))) ! (goto-char (point-min)) ! (if post ! (cond ((not group) ! (re-search-forward "^Newsgroup:" nil t) ! (end-of-line)) ! ((not subject) ! (re-search-forward "^Subject:" nil t) ! (end-of-line)) ! (t ! (re-search-forward ! (concat "^" (regexp-quote mail-header-separator) "$")) ! (forward-line 1))) ! (re-search-forward ! (concat "^" (regexp-quote mail-header-separator) "$")) ! (forward-line 1) ! (and yank (save-excursion (news-reply-yank-original nil))) ! (if gnus-post-prepare-function ! (funcall gnus-post-prepare-function group)))))) ! (setq gnus-article-check-size (cons (buffer-size) (gnus-article-checksum))) ! (message "") ! t) ! ! (defun gnus-inews-news (&optional use-group-method) ! "Send a news message. ! If given a prefix, and the group is a foreign group, this function ! will attempt to use the foreign server to post the article." ! (interactive "P") ! ;; Check whether the article is a good Net Citizen. ! (if (and gnus-article-check-size (not (gnus-inews-check-post))) ! ;; Aber nein! ! () ! ;; Looks ok, so we do the nasty. ! (let* ((case-fold-search nil) ! (server-running (gnus-server-opened gnus-select-method)) ! (reply gnus-article-reply)) ! (save-excursion ! ;; Connect to default NNTP server if necessary. ! ;; Suggested by yuki@flab.fujitsu.junet. ! (gnus-start-news-server) ;Use default server. ! ;; NNTP server must be opened before current buffer is modified. ! (widen) ! (goto-char (point-min)) ! (run-hooks 'news-inews-hook) ! (save-restriction ! (narrow-to-region ! (point-min) ! (progn ! (goto-char (point-min)) ! (re-search-forward ! (concat "^" (regexp-quote mail-header-separator) "$")))) ! ! ;; Correct newsgroups field: change sequence of spaces to comma and ! ;; eliminate spaces around commas. Eliminate imbedded line breaks. ! (goto-char (point-min)) ! (if (search-forward-regexp "^Newsgroups: +" nil t) ! (save-restriction ! (narrow-to-region ! (point) ! (if (re-search-forward "^[^ \t]" nil 'end) ! (match-beginning 0) ! (point-max))) ! (goto-char (point-min)) ! (replace-regexp "\n[ \t]+" " ") ;No line breaks (too confusing) ! (goto-char (point-min)) ! (replace-regexp "[ \t\n]*,[ \t\n]*\\|[ \t]+" ","))) ! ! ;; Added by Per Abrahamsen . ! ;; Help save the the world! ! (or ! gnus-expert-user ! (let ((newsgroups (mail-fetch-field "newsgroups")) ! (followup-to (mail-fetch-field "followup-to")) ! groups to) ! (if (and (string-match "," newsgroups) (not followup-to)) ! (progn ! (while (string-match "," newsgroups) ! (setq groups ! (cons (list (substring newsgroups ! 0 (match-beginning 0))) ! groups)) ! (setq newsgroups (substring newsgroups (match-end 0)))) ! (setq groups (nreverse (cons (list newsgroups) groups))) ! ! (setq to ! (completing-read "Followups to: (default all groups) " ! groups)) ! (if (> (length to) 0) ! (progn ! (goto-char (point-min)) ! (insert "Followup-To: " to "\n"))))))) ! ! ;; Cleanup Followup-To. ! (goto-char (point-min)) ! (if (search-forward-regexp "^Followup-To: +" nil t) ! (save-restriction ! (narrow-to-region ! (point) ! (if (re-search-forward "^[^ \t]" nil 'end) ! (match-beginning 0) ! (point-max))) ! (goto-char (point-min)) ! (replace-regexp "\n[ \t]+" " ") ;No line breaks (too confusing) ! (goto-char (point-min)) ! (replace-regexp "[ \t\n]*,[ \t\n]*\\|[ \t]+" ","))) ! ! ;; Mail the message too if To:, Bcc:. or Cc: exists. ! (if (or (mail-fetch-field "to" nil t) ! (mail-fetch-field "bcc" nil t) ! (mail-fetch-field "cc" nil t)) ! (if gnus-mail-send-method ! (save-excursion ! (save-restriction ! (widen) ! (message "Sending via mail...") ! ! (if gnus-mail-courtesy-message ! (progn ! ;; Insert "courtesy" mail message. ! (goto-char 1) ! (re-search-forward ! (concat "^" (regexp-quote ! mail-header-separator) "$")) ! (forward-line 1) ! (insert gnus-mail-courtesy-message) ! (funcall gnus-mail-send-method) ! (goto-char 1) ! (search-forward gnus-mail-courtesy-message) ! (replace-match "" t t)) ! (funcall gnus-mail-send-method)) ! ! (message "Sending via mail... done") ! ! (goto-char 1) ! (narrow-to-region ! 1 (re-search-forward ! (concat "^" (regexp-quote ! mail-header-separator) "$"))) ! (goto-char 1) ! (delete-matching-lines "BCC:.*"))) ! (ding) ! (message "No mailer defined. To: and/or Cc: fields ignored.") ! (sit-for 1)))) ! ! ;; Send to NNTP server. ! (message "Posting to USENET...") ! (if (gnus-inews-article use-group-method) ! (progn ! (message "Posting to USENET... done") ! (if (and reply ! (get-buffer (car reply)) ! (buffer-name (car reply))) ! (progn ! (save-excursion ! (set-buffer gnus-summary-buffer) ! (gnus-summary-mark-article-as-replied ! (cdr reply)))))) ! ;; We cannot signal an error. ! (ding) (message "Article rejected: %s" ! (gnus-status-message gnus-select-method))) ! (set-buffer-modified-p nil)) ! ;; If NNTP server is opened by gnus-inews-news, close it by myself. ! (or server-running ! (gnus-close-server (gnus-find-method-for-group gnus-newsgroup-name))) ! (and (fboundp 'bury-buffer) (bury-buffer)) ! ;; Restore last window configuration. ! (and gnus-winconf-post-news ! (set-window-configuration gnus-winconf-post-news)) ! (setq gnus-winconf-post-news nil)))) ! ! (defun gnus-inews-check-post () ! "Check whether the post looks ok." ! (or ! (not gnus-check-before-posting) ! (and ! ;; We narrow to the headers and check them first. ! (save-excursion ! (save-restriction ! (goto-char (point-min)) ! (narrow-to-region ! (point) ! (re-search-forward ! (concat "^" (regexp-quote mail-header-separator) "$"))) ! (goto-char (point-min)) ! (and ! ;; Check for commands in Subject. ! (save-excursion ! (if (string-match "^cmsg " (mail-fetch-field "subject")) ! (gnus-y-or-n-p ! "The control code \"cmsg \" is in the subject. Really post? ") ! t)) ! ;; Check for multiple identical headers. ! (save-excursion ! (let (found) ! (while (and (not found) (re-search-forward "^[^ \t:]+: " nil t)) ! (save-excursion ! (or (re-search-forward ! (concat "^" (setq found ! (buffer-substring ! (match-beginning 0) ! (- (match-end 0) 2)))) ! nil t) ! (setq found nil)))) ! (if found ! (gnus-y-or-n-p ! (format "Multiple %s headers. Really post? " found)) ! t))) ! ;; Check for version and sendsys. ! (save-excursion ! (if (re-search-forward "^Sendsys:\\|^Version:" nil t) ! (gnus-yes-or-no-p ! (format "The article contains a %s command. Really post? " ! (buffer-substring (match-beginning 0) ! (1- (match-end 0))))) ! t)) ! ;; Check the Message-Id header. ! (save-excursion ! (let* ((case-fold-search t) ! (message-id (mail-fetch-field "message-id"))) ! (or (not message-id) ! (and (string-match "@" message-id) ! (string-match "@[^\\.]*\\." message-id)) ! (gnus-yes-or-no-p ! (format "The Message-ID looks strange: \"%s\". Really post? " ! message-id))))) ! ;; Check the From header. ! (save-excursion ! (let* ((case-fold-search t) ! (from (mail-fetch-field "from"))) ! (or (not from) ! (and (string-match "@" from) ! (string-match "@[^\\.]*\\." from)) ! (gnus-yes-or-no-p ! (format "The From looks strange: \"%s\". Really post? " ! from)))))))) ! ;; Check for long lines. ! (save-excursion ! (goto-char (point-min)) ! (re-search-forward ! (concat "^" (regexp-quote mail-header-separator) "$")) ! (while (and ! (progn ! (end-of-line) ! (< (current-column) 80)) ! (zerop (forward-line 1)))) ! (or (bolp) ! (gnus-yes-or-no-p ! (format ! "You have lines longer than 79 characters. Really post? ")))) ! ;; Check for control characters. ! (save-excursion ! (if (re-search-forward "[\000-\007\013\015-\037\200-\237]" nil t) ! (gnus-y-or-n-p ! "The article contains control characters. Really post? ") ! t)) ! ;; Check excessive size. ! (if (> (buffer-size) 60000) ! (gnus-y-or-n-p (format "The article is %d octets long. Really post? " ! (buffer-size))) ! t) ! ;; Use the (size . checksum) variable to see whether the ! ;; article is empty or has only quoted text. ! (if (and (= (buffer-size) (car gnus-article-check-size)) ! (= (gnus-article-checksum) (cdr gnus-article-check-size))) ! (gnus-yes-or-no-p ! "It looks like there's no new text in your article. Really post? ") ! t)))) ! ! (defun gnus-article-checksum () ! (let ((sum 0)) ! (save-excursion ! (while (not (eobp)) ! (setq sum (logxor sum (following-char))) ! (forward-char 1))) ! sum)) ! ! (defun gnus-cancel-news () ! "Cancel an article you posted." ! (interactive) ! (if (or gnus-expert-user ! (gnus-yes-or-no-p "Do you really want to cancel this article? ")) ! (let ((from nil) ! (newsgroups nil) ! (message-id nil) ! (distribution nil)) ! (save-excursion ! ;; Get header info. from original article. ! (save-restriction ! (gnus-article-show-all-headers) ! (goto-char (point-min)) ! (search-forward "\n\n" nil 'move) ! (narrow-to-region (point-min) (point)) ! (setq from (mail-fetch-field "from")) ! (setq newsgroups (mail-fetch-field "newsgroups")) ! (setq message-id (mail-fetch-field "message-id")) ! (setq distribution (mail-fetch-field "distribution"))) ! ;; Verify if the article is absolutely user's by comparing ! ;; user id with value of its From: field. ! (if (not ! (string-equal ! (downcase (mail-strip-quoted-names from)) ! (downcase (mail-strip-quoted-names (gnus-inews-user-name))))) ! (progn ! (ding) (message "This article is not yours.")) ! ;; Make control article. ! (set-buffer (get-buffer-create " *Gnus-canceling*")) ! (buffer-disable-undo (current-buffer)) ! (erase-buffer) ! (insert "Newsgroups: " newsgroups "\n" ! "Subject: cancel " message-id "\n" ! "Control: cancel " message-id "\n" ! mail-header-separator "\n" ! "This is a cancel message from " from ".\n") ! ;; Send the control article to NNTP server. ! (message "Canceling your article...") ! (if (gnus-inews-article) ! (message "Canceling your article... done") ! (ding) ! (message "Cancel failed; %s" ! (gnus-status-message gnus-newsgroup-name))) ! ;; Kill the article buffer. ! (kill-buffer (current-buffer))))))) ! ! ! ;;; Lowlevel inews interface ! ! (defun gnus-inews-article (&optional use-group-method) ! "Post an article in current buffer using NNTP protocol." ! (let ((artbuf (current-buffer)) ! (tmpbuf (get-buffer-create " *Gnus-posting*"))) ! (widen) ! (goto-char (point-max)) ! ;; require a newline at the end for inews to append .signature to ! (or (= (preceding-char) ?\n) ! (insert ?\n)) ! ;; Prepare article headers. All message body such as signature ! ;; must be inserted before Lines: field is prepared. ! (save-restriction ! (goto-char (point-min)) ! (narrow-to-region ! (point-min) ! (save-excursion ! (re-search-forward ! (concat "^" (regexp-quote mail-header-separator) "$")) ! (match-beginning 0))) ! (gnus-inews-insert-headers) ! (run-hooks gnus-inews-article-header-hook) ! (widen)) ! (save-excursion ! (set-buffer tmpbuf) ! (buffer-disable-undo (current-buffer)) ! (erase-buffer) ! (insert-buffer-substring artbuf) ! ;; Remove the header separator. ! (goto-char (point-min)) ! (re-search-forward ! (concat "^" (regexp-quote mail-header-separator) "$")) ! (replace-match "" t t) ! ;; This hook may insert a signature. ! (run-hooks 'gnus-prepare-article-hook) ! ;; Run final inews hooks. This hook may do FCC. ! ;; The article must be saved before being posted because ! ;; `gnus-request-post' modifies the buffer. ! (run-hooks 'gnus-inews-article-hook) ! ;; Post an article to NNTP server. ! ;; Return NIL if post failed. ! (prog1 ! (gnus-request-post ! (if use-group-method ! (gnus-find-method-for-group gnus-newsgroup-name) ! gnus-select-method) use-group-method) ! (kill-buffer (current-buffer)))))) ! ! (defun gnus-inews-insert-headers () ! "Prepare article headers. ! Headers already prepared in the buffer are not modified. ! Headers in `gnus-required-headers' will be generated." ! (let ((Date (gnus-inews-date)) ! (Message-ID (gnus-inews-message-id)) ! (Organization (gnus-inews-organization)) ! (From (gnus-inews-user-name)) ! (Path (gnus-inews-path)) ! (Subject nil) ! (Newsgroups nil) ! (Distribution nil) ! (Lines (gnus-inews-lines)) ! (X-Newsreader gnus-version) ! (headers gnus-required-headers) ! (case-fold-search t) ! header value elem) ! ;; First we remove any old Message-IDs. This might be slightly ! ;; fascist, but if the user really wants to generate Message-IDs ! ;; by herself, she should remove it from the `gnus-required-list'. ! (goto-char (point-min)) ! (and (memq 'Message-ID headers) ! (re-search-forward "^Message-ID:" nil t) ! (delete-region (progn (beginning-of-line) (point)) ! (progn (forward-line 1) (point)))) ! ;; Remove NNTP-posting-host. ! (goto-char (point-min)) ! (and (re-search-forward "^nntp-posting-host:" nil t) ! (delete-region (progn (beginning-of-line) (point)) ! (progn (forward-line 1) (point)))) ! ;; Insert new Sender if the From is strange. ! (let ((from (mail-fetch-field "from"))) ! (if (and from (not (string= (downcase from) (downcase From)))) ! (progn ! (goto-char (point-min)) ! (and (re-search-forward "^Sender:" nil t) ! (delete-region (progn (beginning-of-line) (point)) ! (progn (forward-line 1) (point)))) ! (insert "Sender: " From "\n")))) ! ;; If there are References, and no "Re: ", then the thread has ! ;; changed name. See Son-of-1036. ! (if (and (mail-fetch-field "references") ! (get-buffer gnus-article-buffer)) ! (let ((psubject (gnus-simplify-subject-re ! (mail-fetch-field "subject"))) ! subject) ! (save-excursion ! (set-buffer (get-buffer gnus-article-buffer)) ! (save-restriction ! (gnus-narrow-to-headers) ! (if (setq subject (mail-fetch-field "subject")) ! (progn ! (and gnus-summary-gather-subject-limit ! (numberp gnus-summary-gather-subject-limit) ! (> (length subject) gnus-summary-gather-subject-limit) ! (setq subject ! (substring subject 0 ! gnus-summary-gather-subject-limit))) ! (setq subject (gnus-simplify-subject-re subject)))))) ! (or (and psubject subject (string= subject psubject)) ! (progn ! (string-match "@" Message-ID) ! (setq Message-ID ! (concat (substring Message-ID 0 (match-beginning 0)) ! "_-_" ! (substring Message-ID (match-beginning 0)))))))) ! ;; Go through all the required headers and see if they are in the ! ;; articles already. If they are not, or are empty, they are ! ;; inserted automatically - except for Subject, Newsgroups and ! ;; Distribution. ! (while headers ! (goto-char (point-min)) ! (setq elem (car headers)) ! (if (consp elem) ! (setq header (car elem)) ! (setq header elem)) ! (if (or (not (re-search-forward ! (concat "^" (downcase (symbol-name header)) ":") nil t)) ! (progn ! (if (= (following-char) ? ) (forward-char 1) (insert " ")) ! (looking-at "[ \t]*$"))) ! (progn ! (setq value ! (or (if (consp elem) ! ;; The element is a cons. Either the cdr is ! ;; a string to be inserted verbatim, or it ! ;; is a function, and we insert the value ! ;; returned from this function. ! (or (and (stringp (cdr elem)) (cdr elem)) ! (and (fboundp (cdr elem)) (funcall (cdr elem)))) ! ;; The element is a symbol. We insert the ! ;; value of this symbol, if any. ! (and (boundp header) (symbol-value header))) ! ;; We couldn't generate a value for this header, ! ;; so we just ask the user. ! (read-from-minibuffer ! (format "Empty header for %s; enter value: " header)))) ! (if (bolp) ! (save-excursion ! (goto-char (point-max)) ! (insert (symbol-name header) ": " value "\n")) ! (replace-match value t t)))) ! (setq headers (cdr headers))))) ! ! (defun gnus-inews-insert-signature () ! "Insert a signature file. ! If `gnus-signature-function' is bound and returns a string, this ! string is used instead of the variable `gnus-signature-file'. ! In either case, if the string is a file name, this file is ! inserted. If the string is not a file name, the string itself is ! inserted. ! If you never want any signature inserted, set both those variables to ! nil." ! (save-excursion ! (let ((signature ! (or (and gnus-signature-function ! (fboundp gnus-signature-function) ! (funcall gnus-signature-function gnus-newsgroup-name)) ! gnus-signature-file)) ! b) ! (if (and signature ! (or (file-exists-p signature) ! (string-match " " signature) ! (not (string-match ! "^/[^/]+/" (expand-file-name signature))))) ! (progn ! (goto-char (point-max)) ! ;; Delete any previous signatures. ! (if (and mail-signature (search-backward "\n-- \n" nil t)) ! (delete-region (1+ (point)) (point-max))) ! (insert "\n-- \n") ! (and (< 4 (setq b (count-lines ! (point) ! (progn ! (if (file-exists-p signature) ! (insert-file-contents signature) ! (insert signature)) ! (goto-char (point-max)) ! (or (bolp) (insert "\n")) ! (point))))) ! (not gnus-expert-user) ! (not ! (gnus-y-or-n-p ! (format ! "Your .sig is %d lines; it should be max 4. Really post? " ! b))) ! (if (file-exists-p signature) ! (error (format "Edit %s." signature)) ! (error "Trim your signature.")))))))) ! ! (defun gnus-inews-do-fcc () ! "Process FCC: fields in current article buffer. ! Unless the first character of the field is `|', the article is saved ! to the specified file using the function specified by the variable ! gnus-author-copy-saver. The default function rmail-output saves in ! Unix mailbox format. ! If the first character is `|', the contents of the article is send to ! a program specified by the rest of the value." ! (let ((fcc-list nil) ! (fcc-file nil) ! (case-fold-search t)) ;Should ignore case. ! (save-excursion ! (save-restriction ! (goto-char (point-min)) ! (search-forward "\n\n") ! (narrow-to-region (point-min) (point)) ! (goto-char (point-min)) ! (while (re-search-forward "^FCC:[ \t]*" nil t) ! (setq fcc-list ! (cons (buffer-substring ! (point) ! (progn ! (end-of-line) ! (skip-chars-backward " \t") ! (point))) ! fcc-list)) ! (delete-region (match-beginning 0) ! (progn (forward-line 1) (point)))) ! ;; Process FCC operations. ! (widen) ! (while fcc-list ! (setq fcc-file (car fcc-list)) ! (setq fcc-list (cdr fcc-list)) ! (cond ((string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" fcc-file) ! (let ((program (substring fcc-file ! (match-beginning 1) (match-end 1)))) ! ;; Suggested by yuki@flab.fujitsu.junet. ! ;; Send article to named program. ! (call-process-region (point-min) (point-max) shell-file-name ! nil nil nil "-c" program))) ! (t ! ;; Suggested by hyoko@flab.fujitsu.junet. ! ;; Save article in Unix mail format by default. ! (if (and gnus-author-copy-saver ! (not (eq gnus-author-copy-saver 'rmail-output))) ! (funcall gnus-author-copy-saver fcc-file) ! (if (and (file-readable-p fcc-file) (rmail-file-p fcc-file)) ! (gnus-output-to-rmail fcc-file) ! (rmail-output fcc-file 1 t t)))))))))) ! ! (defun gnus-inews-path () ! "Return uucp path." ! (let ((login-name (gnus-inews-login-name))) ! (cond ((null gnus-use-generic-path) ! (concat (nth 1 gnus-select-method) "!" login-name)) ! ((stringp gnus-use-generic-path) ! ;; Support GENERICPATH. Suggested by vixie@decwrl.dec.com. ! (concat gnus-use-generic-path "!" login-name)) ! (t login-name)))) ! ! (defun gnus-inews-user-name () ! "Return user's network address as \"NAME@DOMAIN (FULL-NAME)\"." ! (let ((full-name (gnus-inews-full-name))) ! (or gnus-user-from-line ! (concat (if (or gnus-user-login-name gnus-use-generic-from ! gnus-local-domain (getenv "DOMAINNAME")) ! (concat (gnus-inews-login-name) "@" ! (gnus-inews-domain-name gnus-use-generic-from)) ! user-mail-address) ! ;; User's full name. ! (cond ((string-equal full-name "") "") ! ((string-equal full-name "&") ;Unix hack. ! (concat " (" (user-login-name) ")")) ! (t ! (concat " (" full-name ")"))))))) ! ! (defun gnus-inews-login-name () ! "Return login name." ! (or gnus-user-login-name (getenv "LOGNAME") (user-login-name))) ! ! (defun gnus-inews-full-name () ! "Return full user name." ! (or gnus-user-full-name (getenv "NAME") (user-full-name))) ! ! (defun gnus-inews-domain-name (&optional genericfrom) ! "Return user's domain name. ! If optional argument GENERICFROM is a string, use it as the domain ! name; if it is non-nil, strip off local host name from the domain name. ! If the function `system-name' returns full internet name and the ! domain is undefined, the domain name is got from it." ! (if (or genericfrom gnus-local-domain (getenv "DOMAINNAME")) ! (let* ((system-name (system-name)) ! (domain ! (or (if (stringp genericfrom) genericfrom) ! (getenv "DOMAINNAME") ! gnus-local-domain ! ;; Function `system-name' may return full internet name. ! ;; Suggested by Mike DeCorte . ! (if (string-match "\\." system-name) ! (substring system-name (match-end 0))) ! (read-string "Domain name (no host): "))) ! (host (or (if (string-match "\\." system-name) ! (substring system-name 0 (match-beginning 0))) ! system-name))) ! (if (string-equal "." (substring domain 0 1)) ! (setq domain (substring domain 1))) ! ;; Support GENERICFROM as same as standard Bnews system. ! ;; Suggested by ohm@kaba.junet and vixie@decwrl.dec.com. ! (cond ((null genericfrom) ! (concat host "." domain)) ! ;;((stringp genericfrom) genericfrom) ! (t domain))) ! (if (string-match "\\." (system-name)) ! (system-name) ! (substring user-mail-address ! (1+ (string-match "@" user-mail-address)))))) ! ! (defun gnus-inews-full-address () ! (let ((domain (gnus-inews-domain-name)) ! (system (system-name)) ! (case-fold-search t)) ! (if (string-match "\\." system) system ! (if (string-match (concat "^" (regexp-quote system)) domain) domain ! (concat system "." domain))))) ! ! (defun gnus-inews-message-id () ! "Generate unique Message-ID for user." ! ;; Message-ID should not contain a slash and should be terminated by ! ;; a number. I don't know the reason why it is so. ! (concat "<" (gnus-inews-unique-id) "@" (gnus-inews-full-address) ">")) ! ! (defun gnus-inews-unique-id () ! "Generate unique ID from user name and current time." ! (concat (downcase (gnus-inews-login-name)) ! (mapconcat ! (lambda (num) (gnus-number-base-x num 3 31)) ! (current-time) ""))) ! ! (defun gnus-inews-date () ! "Current time string." ! (timezone-make-date-arpa-standard ! (current-time-string) (current-time-zone))) ! ! (defun gnus-inews-organization () ! "Return user's organization. ! The ORGANIZATION environment variable is used if defined. ! If not, the variable `gnus-local-organization' is used instead. ! If it is a function, the function will be called with the current ! newsgroup name as the argument. ! If this is a file name, the contents of this file will be used as the ! organization." ! (let* ((organization ! (or (getenv "ORGANIZATION") ! (if gnus-local-organization ! (if (and (symbolp gnus-local-organization) ! (fboundp gnus-local-organization)) ! (funcall gnus-local-organization gnus-newsgroup-name) ! gnus-local-organization)) ! gnus-organization-file ! "~/.organization"))) ! (and (stringp organization) ! (> (length organization) 0) ! (or (file-exists-p organization) ! (string-match " " organization) ! (not (string-match "^/[^/]+/" (expand-file-name organization)))) ! (save-excursion ! (set-buffer (get-buffer-create " *Gnus organization*")) ! (buffer-disable-undo (current-buffer)) ! (erase-buffer) ! (if (file-exists-p organization) ! (insert-file-contents organization) ! (insert organization)) ! (goto-char (point-min)) ! (while (re-search-forward " *\n *" nil t) ! (replace-match " " t t)) ! (buffer-substring (point-min) (point-max)))))) ! ! (defun gnus-inews-lines () ! "Count the number of lines and return numeric string." ! (save-excursion ! (save-restriction ! (widen) ! (goto-char (point-min)) ! (search-forward "\n\n" nil 'move) ! (int-to-string (count-lines (point) (point-max)))))) ! ! ! ;;; ! ;;; Gnus Mail Functions ! ;;; ! ! ;;; Mail reply commands of Gnus summary mode ! ! (defun gnus-summary-reply (yank) ! "Reply mail to news author. ! If prefix argument YANK is non-nil, original article is yanked automatically. ! Customize the variable gnus-mail-reply-method to use another mailer." ! (interactive "P") ! ;; Bug fix by jbw@bigbird.bu.edu (Joe Wells) ! ;; Stripping headers should be specified with mail-yank-ignored-headers. ! (gnus-set-global-variables) ! (setq gnus-winconf-post-news (current-window-configuration)) ! (gnus-summary-select-article t) ! (let ((gnus-newsgroup-name gnus-newsgroup-name)) ! (bury-buffer gnus-article-buffer) ! (funcall gnus-mail-reply-method yank)) ! (gnus-article-hide-headers-if-wanted)) ! ! (defun gnus-summary-reply-with-original () ! "Reply mail to news author with original article. ! Customize the variable gnus-mail-reply-method to use another mailer." ! (interactive) ! (gnus-summary-reply t)) ! ! (defun gnus-summary-mail-forward () ! "Forward the current message to another user. ! Customize the variable gnus-mail-forward-method to use another mailer." ! (interactive) ! (gnus-summary-select-article t) ! (setq gnus-winconf-post-news (current-window-configuration)) ! (or gnus-split-window ! (switch-to-buffer gnus-article-buffer)) ! (widen) ! (or gnus-split-window (delete-other-windows)) ! (or gnus-split-window (bury-buffer gnus-article-buffer)) ! (let ((gnus-newsgroup-name gnus-newsgroup-name)) ! (funcall gnus-mail-forward-method)) ! (gnus-article-hide-headers-if-wanted)) ! ! (defun gnus-summary-mail-other-window () ! "Compose mail in other window. ! Customize the variable `gnus-mail-other-window-method' to use another ! mailer." ! (interactive) ! (setq gnus-winconf-post-news (current-window-configuration)) ! (let ((gnus-newsgroup-name gnus-newsgroup-name)) ! (funcall gnus-mail-other-window-method))) ! ! (defun gnus-mail-reply-using-mail (&optional yank to-address) ! (save-excursion ! (set-buffer gnus-summary-buffer) ! (let ((info (nth 2 (gnus-gethash gnus-newsgroup-name gnus-newsrc-hashtb))) ! (group (gnus-group-real-name gnus-newsgroup-name)) ! (cur (cons (current-buffer) (cdr gnus-article-current))) ! from subject date to reply-to message-of ! references message-id sender follow-to cc) ! (set-buffer (get-buffer-create "*mail*")) ! (mail-mode) ! (make-local-variable 'gnus-article-reply) ! (setq gnus-article-reply cur) ! (use-local-map (copy-keymap mail-mode-map)) ! (local-set-key "\C-c\C-c" 'gnus-mail-send-and-exit) ! (if (and (buffer-modified-p) ! (> (buffer-size) 0) ! (not (gnus-y-or-n-p ! "Unsent article being composed; erase it? "))) ! () ! (erase-buffer) ! (save-excursion ! (set-buffer gnus-article-buffer) ! (let ((buffer-read-only nil)) ! (goto-char (point-min)) ! (narrow-to-region (point-min) ! (progn (search-forward "\n\n") (point))) ! (add-text-properties (point-min) (point-max) '(invisible nil))) ! (if (and (boundp 'gnus-reply-to-function) ! gnus-reply-to-function) ! (save-excursion ! (save-restriction ! (gnus-narrow-to-headers) ! (setq follow-to (funcall gnus-reply-to-function group))))) ! (setq from (mail-fetch-field "from")) ! (setq date (mail-fetch-field "date")) ! (and from ! (let ((stop-pos ! (string-match " *at \\| *@ \\| *(\\| *<" from))) ! (setq message-of ! (concat (if stop-pos (substring from 0 stop-pos) from) ! "'s message of " date)))) ! (setq sender (mail-fetch-field "sender")) ! (setq subject (or (mail-fetch-field "subject") ! "Re: none")) ! (or (string-match "^[Rr][Ee]:" subject) ! (setq subject (concat "Re: " subject))) ! (setq cc (mail-fetch-field "cc")) ! (setq reply-to (mail-fetch-field "reply-to")) ! (setq references (mail-fetch-field "references")) ! (setq message-id (mail-fetch-field "message-id")) ! (widen)) ! (setq news-reply-yank-from from) ! (setq news-reply-yank-message-id message-id) ! (mail-setup (or to-address ! (if (and follow-to (not (stringp follow-to))) "" ! (or follow-to reply-to from sender ""))) ! subject message-of nil gnus-article-buffer nil) ! (if (and follow-to (listp follow-to)) ! (progn ! (goto-char (point-min)) ! (while follow-to ! (insert (car (car follow-to)) ": " (cdr (car follow-to)) "\n") ! (setq follow-to (cdr follow-to))))) ! ;; Fold long references line to follow RFC1036. ! (mail-position-on-field "References") ! (let ((begin (- (point) (length "References: "))) ! (fill-column 78) ! (fill-prefix "\t")) ! (if references (insert references)) ! (if (and references message-id) (insert " ")) ! (if message-id (insert message-id)) ! ;; The region must end with a newline to fill the region ! ;; without inserting extra newline. ! (fill-region-as-paragraph begin (1+ (point)))) ! (goto-char (point-min)) ! (re-search-forward ! (concat "^" (regexp-quote mail-header-separator) "$")) ! (forward-line 1) ! (if yank ! (let ((last (point))) ! (save-excursion ! (mail-yank-original nil)) ! (run-hooks 'news-reply-header-hook) ! (goto-char last)))) ! (let ((mail (current-buffer))) ! (if yank ! (progn ! (gnus-configure-windows '(0 1 0)) ! (switch-to-buffer mail)) ! (gnus-configure-windows '(0 0 1)) ! (switch-to-buffer-other-window mail)))))) ! ! (defun gnus-mail-yank-original () ! (interactive) ! (save-excursion ! (mail-yank-original nil)) ! (run-hooks 'news-reply-header-hook)) ! ! (defun gnus-mail-send-and-exit () ! (interactive) ! (let ((cbuf (current-buffer))) ! (mail-send-and-exit nil) ! (if (get-buffer gnus-group-buffer) ! (progn ! (save-excursion ! (set-buffer cbuf) ! (let ((reply gnus-article-reply)) ! (if (and reply ! (get-buffer (car reply)) ! (buffer-name (car reply))) ! (progn ! (set-buffer (car reply)) ! (and (cdr reply) ! (gnus-summary-mark-article-as-replied ! (cdr reply))))))) ! (and gnus-winconf-post-news ! (set-window-configuration gnus-winconf-post-news)) ! (setq gnus-winconf-post-news nil))))) ! ! (defun gnus-mail-forward-using-mail () ! "Forward the current message to another user using mail." ! ;; This is almost a carbon copy of rmail-forward in rmail.el. ! (let ((forward-buffer (current-buffer)) ! (subject ! (concat "[" (if (memq 'mail (assoc (symbol-name ! (car (gnus-find-method-for-group ! gnus-newsgroup-name))) ! gnus-valid-select-methods)) ! (gnus-fetch-field "From") ! gnus-newsgroup-name) ! "] " (or (gnus-fetch-field "Subject") ""))) ! beg) ! ;; If only one window, use it for the mail buffer. ! ;; Otherwise, use another window for the mail buffer ! ;; so that the Rmail buffer remains visible ! ;; and sending the mail will get back to it. ! (if (if (one-window-p t) ! (mail nil nil subject) ! (mail-other-window nil nil subject)) ! (save-excursion ! (use-local-map (copy-keymap emacs-lisp-mode-map)) ! (local-set-key "\C-c\C-c" 'gnus-mail-send-and-exit) ! (setq beg (goto-char (point-max))) ! (insert "------- Start of forwarded message -------\n") ! (insert-buffer forward-buffer) ! (goto-char (point-max)) ! (insert "------- End of forwarded message -------\n") ! ;; Suggested by Sudish Joseph . ! (goto-char beg) ! (while (setq beg (next-single-property-change (point) 'invisible)) ! (goto-char beg) ! (delete-region beg (or (next-single-property-change ! (point) 'invisible) ! (point-max)))) ! ;; You have a chance to arrange the message. ! (run-hooks 'gnus-mail-forward-hook))))) ! ! (defun gnus-mail-other-window-using-mail () ! "Compose mail other window using mail." ! (mail-other-window nil nil nil nil nil (get-buffer gnus-article-buffer)) ! (use-local-map (copy-keymap (current-local-map))) ! (local-set-key "\C-c\C-c" 'gnus-mail-send-and-exit)) ! ! ! ;;; ! ;;; Dribble file ! ;;; ! ! (defvar gnus-dribble-ignore nil) ! ! (defun gnus-dribble-file-name () ! (concat gnus-startup-file "-dribble")) ! ! (defun gnus-dribble-open () ! (save-excursion ! (set-buffer ! (setq gnus-dribble-buffer (find-file-noselect (gnus-dribble-file-name)))) ! (buffer-disable-undo (current-buffer)) ! (bury-buffer gnus-dribble-buffer) ! (auto-save-mode t) ! (goto-char (point-max)))) ! ! (defun gnus-dribble-enter (string) ! (if (and (not gnus-dribble-ignore) ! gnus-dribble-buffer ! (buffer-name gnus-dribble-buffer)) ! (let ((obuf (current-buffer))) ! (set-buffer gnus-dribble-buffer) ! (insert string "\n") ! (set-window-point (get-buffer-window (current-buffer)) (point-max)) ! (set-buffer obuf)))) ! ! (defun gnus-dribble-read-file () ! (let ((dribble-file (gnus-dribble-file-name))) ! (save-excursion ! (set-buffer (setq gnus-dribble-buffer ! (get-buffer-create ! (file-name-nondirectory dribble-file)))) ! (gnus-add-current-to-buffer-list) ! (erase-buffer) ! (set-visited-file-name dribble-file) ! (buffer-disable-undo (current-buffer)) ! (bury-buffer (current-buffer)) ! (set-buffer-modified-p nil) ! (let ((auto (make-auto-save-file-name)) ! (gnus-dribble-ignore t)) ! (if (or (file-exists-p auto) (file-exists-p dribble-file)) ! (progn ! (if (file-newer-than-file-p auto dribble-file) ! (setq dribble-file auto)) ! (insert-file-contents dribble-file) ! (if (not (zerop (buffer-size))) ! (set-buffer-modified-p t)) ! (if (gnus-y-or-n-p ! "Auto-save file exists. Do you want to read it? ") ! (progn ! (message "Reading %s..." dribble-file) ! (eval-current-buffer) ! (message "Reading %s...done" dribble-file))))))))) ! ! (defun gnus-dribble-delete-file () ! (if (file-exists-p (gnus-dribble-file-name)) ! (delete-file (gnus-dribble-file-name))) ! (if gnus-dribble-buffer ! (save-excursion ! (set-buffer gnus-dribble-buffer) ! (let ((auto (make-auto-save-file-name))) ! (if (file-exists-p auto) ! (delete-file auto)) ! (erase-buffer) ! (set-buffer-modified-p nil))))) (defun gnus-dribble-save () (if (and gnus-dribble-buffer --- 9777,9848 ---- ;;; ! ;;; Dribble file ;;; ! (defvar gnus-dribble-ignore nil) ! (defun gnus-dribble-file-name () ! (concat gnus-startup-file "-dribble")) ! (defun gnus-dribble-open () ! (save-excursion ! (set-buffer ! (setq gnus-dribble-buffer (find-file-noselect (gnus-dribble-file-name)))) ! (buffer-disable-undo (current-buffer)) ! (bury-buffer gnus-dribble-buffer) ! (auto-save-mode t) ! (goto-char (point-max)))) ! ! (defun gnus-dribble-enter (string) ! (if (and (not gnus-dribble-ignore) ! gnus-dribble-buffer ! (buffer-name gnus-dribble-buffer)) ! (let ((obuf (current-buffer))) ! (set-buffer gnus-dribble-buffer) ! (insert string "\n") ! (set-window-point (get-buffer-window (current-buffer)) (point-max)) ! (set-buffer obuf)))) ! (defun gnus-dribble-read-file () ! (let ((dribble-file (gnus-dribble-file-name))) ! (save-excursion ! (set-buffer (setq gnus-dribble-buffer ! (get-buffer-create ! (file-name-nondirectory dribble-file)))) ! (gnus-add-current-to-buffer-list) ! (erase-buffer) ! (set-visited-file-name dribble-file) ! (buffer-disable-undo (current-buffer)) ! (bury-buffer (current-buffer)) ! (set-buffer-modified-p nil) ! (let ((auto (make-auto-save-file-name)) ! (gnus-dribble-ignore t)) ! (if (or (file-exists-p auto) (file-exists-p dribble-file)) ! (progn ! (if (file-newer-than-file-p auto dribble-file) ! (setq dribble-file auto)) ! (insert-file-contents dribble-file) ! (if (not (zerop (buffer-size))) ! (set-buffer-modified-p t)) ! (if (gnus-y-or-n-p ! "Auto-save file exists. Do you want to read it? ") (progn ! (message "Reading %s..." dribble-file) ! (eval-current-buffer) ! (message "Reading %s...done" dribble-file))))))))) ! (defun gnus-dribble-delete-file () ! (if (file-exists-p (gnus-dribble-file-name)) ! (delete-file (gnus-dribble-file-name))) ! (if gnus-dribble-buffer ! (save-excursion ! (set-buffer gnus-dribble-buffer) ! (let ((auto (make-auto-save-file-name))) ! (if (file-exists-p auto) ! (delete-file auto)) ! (erase-buffer) ! (set-buffer-modified-p nil))))) (defun gnus-dribble-save () (if (and gnus-dribble-buffer *************** *** 12342,12349 **** (defun gnus-dribble-clear () (save-excursion ! (if (and gnus-dribble-buffer ! (buffer-name (get-buffer gnus-dribble-buffer))) (progn (set-buffer gnus-dribble-buffer) (erase-buffer) --- 9853,9859 ---- (defun gnus-dribble-clear () (save-excursion ! (if (gnus-buffer-exists-p gnus-dribble-buffer) (progn (set-buffer gnus-dribble-buffer) (erase-buffer) *************** *** 12505,12517 **** (cond ((or (string= gnus-nntp-server "") (string= gnus-nntp-server "::")) (list 'nnspool (system-name))) ! ((string-match ":" gnus-nntp-server) (list 'nnmh gnus-nntp-server (list 'nnmh-directory (file-name-as-directory (expand-file-name (concat "~/" (substring ! 1 gnus-nntp-server))))))) (t (list 'nntp gnus-nntp-server))))) --- 10015,10027 ---- (cond ((or (string= gnus-nntp-server "") (string= gnus-nntp-server "::")) (list 'nnspool (system-name))) ! ((string-match "^:" gnus-nntp-server) (list 'nnmh gnus-nntp-server (list 'nnmh-directory (file-name-as-directory (expand-file-name (concat "~/" (substring ! gnus-nntp-server 1))))))) (t (list 'nntp gnus-nntp-server))))) *************** *** 12742,12748 **** ;;; ;; Newsrc related functions. ! ;; Gnus internal format of gnus-newsrc-assoc: ;; (("alt.general" 3 (1 . 1)) ;; ("alt.misc" 3 ((1 . 10) (12 . 15))) ;; ("alt.test" 7 (1 . 99) (45 57 93)) ...) --- 10252,10258 ---- ;;; ;; Newsrc related functions. ! ;; Gnus internal format of gnus-newsrc-alist: ;; (("alt.general" 3 (1 . 1)) ;; ("alt.misc" 3 ((1 . 10) (12 . 15))) ;; ("alt.test" 7 (1 . 99) (45 57 93)) ...) *************** *** 12755,12762 **** ;; (95 ("alt.general" 3 (1 . 1)) ("alt.misc" 3 ((1 . 10) (12 . 15))) ...) ;; This is the entry for "alt.misc". The first element is the number ;; of unread articles in "alt.misc". The cdr of this entry is the ! ;; element *before* "alt.misc" in gnus-newsrc-assoc, which makes is ! ;; trivial to remove or add new elements into gnus-newsrc-assoc ;; without scanning the entire list. So, to get the actual information ;; of "alt.misc", you'd say something like ;; (nth 2 (gnus-gethash "alt.misc" gnus-newsrc-hashtb)) --- 10265,10272 ---- ;; (95 ("alt.general" 3 (1 . 1)) ("alt.misc" 3 ((1 . 10) (12 . 15))) ...) ;; This is the entry for "alt.misc". The first element is the number ;; of unread articles in "alt.misc". The cdr of this entry is the ! ;; element *before* "alt.misc" in gnus-newsrc-alist, which makes is ! ;; trivial to remove or add new elements into gnus-newsrc-alist ;; without scanning the entire list. So, to get the actual information ;; of "alt.misc", you'd say something like ;; (nth 2 (gnus-gethash "alt.misc" gnus-newsrc-hashtb)) *************** *** 12776,12784 **** "Setup news information. If RAWFILE is non-nil, the .newsrc file will also be read. If LEVEL is non-nil, the news will be set up at level LEVEL." ! (let ((init (not (and gnus-newsrc-assoc gnus-active-hashtb (not rawfile))))) ;; Clear some variables to re-initialize news information. ! (if init (setq gnus-newsrc-assoc nil gnus-active-hashtb nil)) ;; Read the newsrc file and create `gnus-newsrc-hashtb'. (if init (gnus-read-newsrc-file rawfile)) --- 10286,10294 ---- "Setup news information. If RAWFILE is non-nil, the .newsrc file will also be read. If LEVEL is non-nil, the news will be set up at level LEVEL." ! (let ((init (not (and gnus-newsrc-alist gnus-active-hashtb (not rawfile))))) ;; Clear some variables to re-initialize news information. ! (if init (setq gnus-newsrc-alist nil gnus-active-hashtb nil)) ;; Read the newsrc file and create `gnus-newsrc-hashtb'. (if init (gnus-read-newsrc-file rawfile)) *************** *** 12931,12937 **** got-new)) (defun gnus-check-first-time-used () ! (if (or (> (length gnus-newsrc-assoc) 1) (file-exists-p gnus-startup-file) (file-exists-p (concat gnus-startup-file ".el")) (file-exists-p (concat gnus-startup-file ".eld"))) --- 10441,10447 ---- got-new)) (defun gnus-check-first-time-used () ! (if (or (> (length gnus-newsrc-alist) 1) (file-exists-p gnus-startup-file) (file-exists-p (concat gnus-startup-file ".el")) (file-exists-p (concat gnus-startup-file ".eld"))) *************** *** 13052,13062 **** (setq info (list group level nil)) (setq info (list group level nil nil method))))) (setq entry (cons info (if previous (cdr (cdr previous)) ! (cdr gnus-newsrc-assoc)))) ! (setcdr (if previous (cdr previous) gnus-newsrc-assoc) entry) (gnus-sethash group (cons num (if previous (cdr previous) ! gnus-newsrc-assoc)) gnus-newsrc-hashtb) (if (cdr entry) (setcdr (gnus-gethash (car (car (cdr entry))) --- 10562,10572 ---- (setq info (list group level nil)) (setq info (list group level nil nil method))))) (setq entry (cons info (if previous (cdr (cdr previous)) ! (cdr gnus-newsrc-alist)))) ! (setcdr (if previous (cdr previous) gnus-newsrc-alist) entry) (gnus-sethash group (cons num (if previous (cdr previous) ! gnus-newsrc-alist)) gnus-newsrc-hashtb) (if (cdr entry) (setcdr (gnus-gethash (car (car (cdr entry))) *************** *** 13076,13082 **** "Remove bogus newsgroups. If CONFIRM is non-nil, the user has to confirm the deletion of every newsgroup." ! (let ((newsrc (cdr gnus-newsrc-assoc)) bogus group) (message "Checking bogus newsgroups...") (or gnus-have-read-active-file (gnus-read-active-file)) --- 10586,10592 ---- "Remove bogus newsgroups. If CONFIRM is non-nil, the user has to confirm the deletion of every newsgroup." ! (let ((newsrc (cdr gnus-newsrc-alist)) bogus group) (message "Checking bogus newsgroups...") (or gnus-have-read-active-file (gnus-read-active-file)) *************** *** 13125,13134 **** (setcdr killed (delete (car killed) (cdr killed))) (setq killed (cdr killed))))) ! ;; Go though `gnus-newsrc-assoc' and compare with `gnus-active-hashtb' ;; and compute how many unread articles there are in each group. (defun gnus-get-unread-articles (&optional level) ! (let ((newsrc (cdr gnus-newsrc-assoc)) (level (or level (1+ gnus-level-subscribed))) info group active virtuals) (message "Checking new news...") --- 10635,10644 ---- (setcdr killed (delete (car killed) (cdr killed))) (setq killed (cdr killed))))) ! ;; Go though `gnus-newsrc-alist' and compare with `gnus-active-hashtb' ;; and compute how many unread articles there are in each group. (defun gnus-get-unread-articles (&optional level) ! (let ((newsrc (cdr gnus-newsrc-alist)) (level (or level (1+ gnus-level-subscribed))) info group active virtuals) (message "Checking new news...") *************** *** 13175,13185 **** ;; Create a hash table out of the newsrc alist. The `car's of the ;; alist elements are used as keys. (defun gnus-make-hashtable-from-newsrc-alist () ! (let ((alist gnus-newsrc-assoc) prev) (setq gnus-newsrc-hashtb (gnus-make-hashtable (length alist))) (setq alist ! (setq prev (setq gnus-newsrc-assoc (cons (list "dummy.group" 0 nil) alist)))) (while alist (gnus-sethash (car (car alist)) (cons nil prev) gnus-newsrc-hashtb) --- 10685,10695 ---- ;; Create a hash table out of the newsrc alist. The `car's of the ;; alist elements are used as keys. (defun gnus-make-hashtable-from-newsrc-alist () ! (let ((alist gnus-newsrc-alist) prev) (setq gnus-newsrc-hashtb (gnus-make-hashtable (length alist))) (setq alist ! (setq prev (setq gnus-newsrc-alist (cons (list "dummy.group" 0 nil) alist)))) (while alist (gnus-sethash (car (car alist)) (cons nil prev) gnus-newsrc-hashtb) *************** *** 13393,13399 **** ((and (eq gnus-read-active-file 'some) (gnus-check-backend-function 'retrieve-groups (car (car methods)))) ! (let ((newsrc (cdr gnus-newsrc-assoc)) groups) (while newsrc (and (gnus-server-equal --- 10903,10909 ---- ((and (eq gnus-read-active-file 'some) (gnus-check-backend-function 'retrieve-groups (car (car methods)))) ! (let ((newsrc (cdr gnus-newsrc-alist)) groups) (while newsrc (and (gnus-server-equal *************** *** 13553,13559 **** (and (file-newer-than-file-p newsrc-file quick-file) (file-newer-than-file-p newsrc-file (concat quick-file "d"))) ! (not gnus-newsrc-assoc)) ;; We read the .newsrc file. Note that if there if a ;; .newsrc.eld file exists, it has already been read, and ;; the `gnus-newsrc-hashtb' has been created. While reading --- 11063,11069 ---- (and (file-newer-than-file-p newsrc-file quick-file) (file-newer-than-file-p newsrc-file (concat quick-file "d"))) ! (not gnus-newsrc-alist)) ;; We read the .newsrc file. Note that if there if a ;; .newsrc.eld file exists, it has already been read, and ;; the `gnus-newsrc-hashtb' has been created. While reading *************** *** 13573,13581 **** (let ((ding-file (concat file "d"))) ;; We always, always read the .eld file. (message "Reading %s..." ding-file) ! (condition-case nil ! (load ding-file t t t) ! (error nil)) (gnus-uncompress-newsrc-assoc) (gnus-make-hashtable-from-newsrc-alist) (if (not (file-newer-than-file-p file ding-file)) --- 11083,11093 ---- (let ((ding-file (concat file "d"))) ;; We always, always read the .eld file. (message "Reading %s..." ding-file) ! (let (gnus-newsrc-assoc) ! (condition-case nil ! (load ding-file t t t) ! (error nil)) ! (and gnus-newsrc-assoc (setq gnus-newsrc-alist gnus-newsrc-assoc))) (gnus-uncompress-newsrc-assoc) (gnus-make-hashtable-from-newsrc-alist) (if (not (file-newer-than-file-p file ding-file)) *************** *** 13590,13604 **** (defun gnus-read-old-newsrc-el-file (file) (let (newsrc killed marked group g m len info) (prog1 ! (let (gnus-killed-assoc gnus-marked-assoc gnus-newsrc-assoc) (prog1 (condition-case nil (load file t t t) (error nil)) ! (setq newsrc gnus-newsrc-assoc killed gnus-killed-assoc marked gnus-marked-assoc))) ! (setq gnus-newsrc-assoc nil) (while newsrc (setq group (car newsrc)) (let ((info (nth 2 (gnus-gethash (car group) gnus-newsrc-hashtb)))) --- 11102,11117 ---- (defun gnus-read-old-newsrc-el-file (file) (let (newsrc killed marked group g m len info) (prog1 ! (let ((gnus-killed-assoc nil) ! gnus-marked-assoc gnus-newsrc-alist gnus-newsrc-assoc) (prog1 (condition-case nil (load file t t t) (error nil)) ! (setq newsrc gnus-newsrc-alist killed gnus-killed-assoc marked gnus-marked-assoc))) ! (setq gnus-newsrc-alist nil) (while newsrc (setq group (car newsrc)) (let ((info (nth 2 (gnus-gethash (car group) gnus-newsrc-hashtb)))) *************** *** 13608,13622 **** (setcar (cdr info) (if (nth 1 group) gnus-level-default-subscribed gnus-level-default-unsubscribed)) ! (setq gnus-newsrc-assoc (cons info gnus-newsrc-assoc))) ! (setq gnus-newsrc-assoc (cons (setq info (list (car group) (if (nth 1 group) gnus-level-default-subscribed gnus-level-default-unsubscribed) (cdr (cdr group)))) ! gnus-newsrc-assoc))) (if (setq m (assoc (car group) marked)) (setcdr (cdr (cdr info)) (cons (list (cons 'tick (cdr m))) nil)))) (setq newsrc (cdr newsrc))) --- 11121,11135 ---- (setcar (cdr info) (if (nth 1 group) gnus-level-default-subscribed gnus-level-default-unsubscribed)) ! (setq gnus-newsrc-alist (cons info gnus-newsrc-alist))) ! (setq gnus-newsrc-alist (cons (setq info (list (car group) (if (nth 1 group) gnus-level-default-subscribed gnus-level-default-unsubscribed) (cdr (cdr group)))) ! gnus-newsrc-alist))) (if (setq m (assoc (car group) marked)) (setcdr (cdr (cdr info)) (cons (list (cons 'tick (cdr m))) nil)))) (setq newsrc (cdr newsrc))) *************** *** 13625,13631 **** (setcar newsrc (car (car newsrc))) (setq newsrc (cdr newsrc))) (setq gnus-killed-list killed)) ! (setq gnus-newsrc-assoc (nreverse gnus-newsrc-assoc)) (gnus-make-hashtable-from-newsrc-alist))) (defun gnus-make-newsrc-file (file) --- 11138,11144 ---- (setcar newsrc (car (car newsrc))) (setq newsrc (cdr newsrc))) (setq gnus-killed-list killed)) ! (setq gnus-newsrc-alist (nreverse gnus-newsrc-alist)) (gnus-make-hashtable-from-newsrc-alist))) (defun gnus-make-newsrc-file (file) *************** *** 13637,13643 **** (defun gnus-uncompress-newsrc-assoc () ;; Uncompress all lists of marked articles in the newsrc assoc. ! (let ((newsrc gnus-newsrc-assoc) marked) (while newsrc (if (not (setq marked (nth 3 (car newsrc)))) --- 11150,11156 ---- (defun gnus-uncompress-newsrc-assoc () ;; Uncompress all lists of marked articles in the newsrc assoc. ! (let ((newsrc gnus-newsrc-alist) marked) (while newsrc (if (not (setq marked (nth 3 (car newsrc)))) *************** *** 13652,13658 **** (defun gnus-compress-newsrc-assoc () ;; Compress all lists of marked articles in the newsrc assoc. ! (let ((newsrc gnus-newsrc-assoc) marked) (while newsrc (if (not (setq marked (nth 3 (car newsrc)))) --- 11165,11171 ---- (defun gnus-compress-newsrc-assoc () ;; Compress all lists of marked articles in the newsrc assoc. ! (let ((newsrc gnus-newsrc-alist) marked) (while newsrc (if (not (setq marked (nth 3 (car newsrc)))) *************** *** 13837,13853 **** ((and (> level gnus-level-subscribed) subscribe) (setq level gnus-level-default-subscribed))) (setcar (cdr info) level)) ! (setq gnus-newsrc-assoc (cons (list newsgroup (if subscribe gnus-level-default-subscribed (if read-list gnus-level-default-subscribed (1+ gnus-level-default-subscribed))) (nreverse read-list)) ! gnus-newsrc-assoc)))))) (setq line (1+ line)) (forward-line 1)))) ! (setq gnus-newsrc-assoc (cdr gnus-newsrc-assoc)) (gnus-make-hashtable-from-newsrc-alist) nil) --- 11350,11366 ---- ((and (> level gnus-level-subscribed) subscribe) (setq level gnus-level-default-subscribed))) (setcar (cdr info) level)) ! (setq gnus-newsrc-alist (cons (list newsgroup (if subscribe gnus-level-default-subscribed (if read-list gnus-level-default-subscribed (1+ gnus-level-default-subscribed))) (nreverse read-list)) ! gnus-newsrc-alist)))))) (setq line (1+ line)) (forward-line 1)))) ! (setq gnus-newsrc-alist (cdr gnus-newsrc-alist)) (gnus-make-hashtable-from-newsrc-alist) nil) *************** *** 13881,13888 **** (defun gnus-save-newsrc-file () "Save .newsrc file." ;; Note: We cannot save .newsrc file if all newsgroups are removed ! ;; from the variable gnus-newsrc-assoc. ! (and (or gnus-newsrc-assoc gnus-killed-list) gnus-current-startup-file (let ((make-backup-files t) (version-control nil) --- 11394,11401 ---- (defun gnus-save-newsrc-file () "Save .newsrc file." ;; Note: We cannot save .newsrc file if all newsgroups are removed ! ;; from the variable gnus-newsrc-alist. ! (and (or gnus-newsrc-alist gnus-killed-list) gnus-current-startup-file (let ((make-backup-files t) (version-control nil) *************** *** 13918,13929 **** (gnus-dribble-delete-file)))))) (defun gnus-gnus-to-quick-newsrc-format () ! "Insert Gnus variables such as gnus-newsrc-assoc in lisp format." (insert ";; (ding) Gnus startup file.\n") (insert ";; Never delete this file - touch .newsrc instead to force Gnus\n") (insert ";; to read .newsrc.\n") (let ((variables gnus-variable-list) ! (gnus-newsrc-assoc (cdr gnus-newsrc-assoc)) variable) ;; insert lisp expressions. (gnus-compress-newsrc-assoc) --- 11431,11442 ---- (gnus-dribble-delete-file)))))) (defun gnus-gnus-to-quick-newsrc-format () ! "Insert Gnus variables such as gnus-newsrc-alist in lisp format." (insert ";; (ding) Gnus startup file.\n") (insert ";; Never delete this file - touch .newsrc instead to force Gnus\n") (insert ";; to read .newsrc.\n") (let ((variables gnus-variable-list) ! (gnus-newsrc-alist (cdr gnus-newsrc-alist)) variable) ;; insert lisp expressions. (gnus-compress-newsrc-assoc) *************** *** 13941,13947 **** (defun gnus-gnus-to-newsrc-format () ;; Generate and save the .newsrc file. ! (let ((newsrc (cdr gnus-newsrc-assoc)) info ranges range) (save-excursion (set-buffer (create-file-buffer gnus-startup-file)) --- 11454,11460 ---- (defun gnus-gnus-to-newsrc-format () ;; Generate and save the .newsrc file. ! (let ((newsrc (cdr gnus-newsrc-alist)) info ranges range) (save-excursion (set-buffer (create-file-buffer gnus-startup-file)) *************** *** 14307,14313 **** (or server (error "No server on current line")) (setq gnus-winconf-edit-server (current-window-configuration)) ! (pop-to-buffer (get-buffer-create gnus-server-edit-buffer)) (gnus-add-current-to-buffer-list) (emacs-lisp-mode) (use-local-map (copy-keymap (current-local-map))) --- 11820,11826 ---- (or server (error "No server on current line")) (setq gnus-winconf-edit-server (current-window-configuration)) ! (pop-to-buffer gnus-server-edit-buffer) (gnus-add-current-to-buffer-list) (emacs-lisp-mode) (use-local-map (copy-keymap (current-local-map))) *************** *** 14330,14335 **** --- 11843,12030 ---- (gnus-server-update-server (gnus-server-server-name)) (gnus-server-position-cursor)) + ;;; Gnus score functions. + + (defvar gnus-global-score-files nil + "*List of global score files and directories. + Set this variable if you want to use people's score files. One entry + for each score file or each score file directory. Gnus will decide + by itself what score files are applicable to which group. + + Say you want to use the single score file + \"/ftp.ifi.uio.no@ftp:/pub/larsi/ding/score/soc.motss.SCORE\" and all + score files in the \"/ftp.some-where:/pub/score\" directory. + + (setq gnus-global-score-files + '(\"/ftp.ifi.uio.no:/pub/larsi/ding/score/soc.motss.SCORE\" + \"/ftp.some-where:/pub/score\"))") + + (defun gnus-score-score-files (group) + "Return a list of all possible score files." + (and gnus-global-score-files + (or gnus-internal-global-score-files + (gnus-score-search-global-directories gnus-global-score-files))) + (setq gnus-kill-files-directory + (file-name-as-directory + (or gnus-kill-files-directory "~/News/"))) + (if (not (file-readable-p gnus-kill-files-directory)) + (setq gnus-score-file-list nil) + (if (gnus-use-long-file-name 'not-score) + (if (or (not gnus-score-file-list) + (gnus-file-newer-than gnus-kill-files-directory + (car gnus-score-file-list))) + (setq gnus-score-file-list + (cons (nth 5 (file-attributes gnus-kill-files-directory)) + (nreverse + (directory-files + gnus-kill-files-directory t + (concat gnus-score-file-suffix "$")))))) + (let ((dir (expand-file-name + (concat gnus-kill-files-directory + (gnus-replace-chars-in-string group ?. ?/)))) + (mdir (length (expand-file-name gnus-kill-files-directory))) + files) + (if (file-exists-p (concat dir "/" gnus-score-file-suffix)) + (setq files (list (concat dir "/" gnus-score-file-suffix)))) + (while (>= (1+ (length dir)) mdir) + (and (file-exists-p (concat dir "/all/" gnus-score-file-suffix)) + (setq files (cons (concat dir "/all/" gnus-score-file-suffix) + files))) + (string-match "/[^/]*$" dir) + (setq dir (substring dir 0 (match-beginning 0)))) + (setq gnus-score-file-list + (cons nil (nreverse files))))) + (cdr gnus-score-file-list))) + + (defun gnus-score-find-bnews (group) + "Return a list of score files for GROUP. + The score files are those files in the ~/News directory which matches + GROUP using BNews sys file syntax." + (let* ((sfiles (append (gnus-score-score-files group) + gnus-internal-global-score-files)) + (kill-dir (file-name-as-directory + (expand-file-name gnus-kill-files-directory))) + (klen (length kill-dir)) + ofiles not-match regexp) + (save-excursion + (set-buffer (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. + (while sfiles + (erase-buffer) + (insert (car sfiles)) + (goto-char 1) + ;; First remove the suffix itself. + (re-search-forward (concat "." gnus-score-file-suffix "$")) + (replace-match "" t t) + (goto-char 1) + (if (looking-at (regexp-quote kill-dir)) + ;; If the file name was just "SCORE", `klen' is one character + ;; too much. + (delete-char (min (1- (point-max)) klen)) + (goto-char (point-max)) + (search-backward "/") + (delete-region (1+ (point)) (point-min))) + ;; Translate "all" to ".*". + (while (search-forward "all" nil t) + (replace-match ".*" t t)) + (goto-char 1) + ;; Deal with "not."s. + (if (looking-at "not.") + (progn + (setq not-match t) + (setq regexp (buffer-substring 5 (point-max)))) + (setq regexp (buffer-substring 1 (point-max))) + (setq not-match nil)) + ;; Finally - if this resulting regexp matches the group name, + ;; we add this score file to the list of score files + ;; applicable to this group. + (if (or (and not-match + (not (string-match regexp group))) + (and (not not-match) + (string-match regexp group))) + (setq ofiles (cons (car sfiles) ofiles))) + (setq sfiles (cdr sfiles))) + (kill-buffer (current-buffer)) + ;; Slight kludge here - the last score file returned should be + ;; the local score file, whether it exists or not. This is so + ;; that any score commands the user enters will go to the right + ;; file, and not end up in some global score file. + (let ((localscore + (expand-file-name + (if (gnus-use-long-file-name 'not-score) + (concat gnus-kill-files-directory group "." + gnus-score-file-suffix) + (concat gnus-kill-files-directory + (gnus-replace-chars-in-string group ?. ?/) + "/" gnus-score-file-suffix))))) + (and (member localscore ofiles) + (delete localscore ofiles)) + (setq ofiles (cons localscore ofiles))) + (nreverse ofiles)))) + + (defun gnus-score-find-single (group) + "Return list containing the score file for GROUP." + (list (gnus-score-file-name group))) + + (defun gnus-score-find-hierarchical (group) + "Return list of score files for GROUP. + This includes the score file for the group and all its parents." + (let ((all (copy-sequence '(nil))) + (start 0)) + (while (string-match "\\." group (1+ start)) + (setq start (match-beginning 0)) + (setq all (cons (substring group 0 start) all))) + (setq all (cons group all)) + (mapcar 'gnus-score-file-name (nreverse all)))) + + (defun gnus-possibly-score-headers () + (let ((func gnus-score-find-score-files-function) + score-files scores) + (and func (not (listp func)) + (setq func (list func))) + ;; Go through all the functions for finding score files (or actual + ;; scores) and add them to a list. + (while func + (and (symbolp (car func)) + (fboundp (car func)) + (setq score-files + (nconc score-files (funcall (car func) gnus-newsgroup-name)))) + (setq func (cdr func))) + (if score-files (gnus-score-headers score-files)))) + + (defun gnus-score-file-name (newsgroup) + "Return the name of a score file for NEWSGROUP." + (cond ((or (null newsgroup) + (string-equal newsgroup "")) + ;; The global score file is placed at top of the directory. + (expand-file-name gnus-score-file-suffix + (or gnus-kill-files-directory "~/News"))) + ((gnus-use-long-file-name 'not-score) + ;; Append ".SCORE" to newsgroup name. + (expand-file-name (concat newsgroup "." gnus-score-file-suffix) + (or gnus-kill-files-directory "~/News"))) + (t + ;; Place "SCORE" under the hierarchical directory. + (expand-file-name (concat (gnus-newsgroup-directory-form newsgroup) + "/" gnus-score-file-suffix) + (or gnus-kill-files-directory "~/News"))))) + + (defun gnus-score-search-global-directories (files) + "Scan all global score directories for score files." + ;; Set the variable `gnus-internal-global-score-files' to all + ;; available global score files. + (interactive (list gnus-global-score-files)) + (let (out) + (while files + (if (string-match "/$" (car files)) + (setq out (nconc (directory-files + (car files) t + (concat gnus-score-file-suffix "$")))) + (setq out (cons (car files) out))) + (setq files (cdr files))) + (setq gnus-internal-global-score-files out))) (provide 'gnus) diff --exclude=*.elc --exclude=*~ --exclude=*-[0-9] --exclude=gnus --exclude=readme --context --recursive pub/dgnus/lisp/nnkiboze.el dgnus/lisp/nnkiboze.el *** pub/dgnus/lisp/nnkiboze.el Fri Apr 21 05:55:01 1995 --- dgnus/lisp/nnkiboze.el Sat Apr 22 07:27:01 1995 *************** *** 195,202 **** (gnus-read-active-file t) (gnus-expert-user t)) (gnus)) ! (let* ((gnus-newsrc-assoc (gnus-copy-sequence gnus-newsrc-assoc)) ! (newsrc gnus-newsrc-assoc)) (while newsrc (if (string-match "nnkiboze" (car (car newsrc))) (nnkiboze-generate-group (car (car newsrc)))) --- 195,202 ---- (gnus-read-active-file t) (gnus-expert-user t)) (gnus)) ! (let* ((gnus-newsrc-alist (gnus-copy-sequence gnus-newsrc-alist)) ! (newsrc gnus-newsrc-alist)) (while newsrc (if (string-match "nnkiboze" (car (car newsrc))) (nnkiboze-generate-group (car (car newsrc)))) diff --exclude=*.elc --exclude=*~ --exclude=*-[0-9] --exclude=gnus --exclude=readme --context --recursive pub/dgnus/lisp/nnmh.el dgnus/lisp/nnmh.el *** pub/dgnus/lisp/nnmh.el Fri Apr 21 05:55:01 1995 --- dgnus/lisp/nnmh.el Fri Apr 21 09:57:48 1995 *************** *** 206,222 **** (let ((files (mapcar (lambda (name) (string-to-int name)) (directory-files dir nil "^[0-9]+$" t)))) ! (save-excursion ! (set-buffer nntp-server-buffer) ! (insert ! (format ! "%s %d %d y\n" ! (progn ! (string-match (expand-file-name nnmh-directory) dir) ! (nnmail-replace-chars-in-string ! (substring dir (match-end 0)) ?/ ?.)) ! (if files (apply (function max) files) 0) ! (if files (apply (function min) files) 0)))))) t) (defun nnmh-request-newgroups (date &optional server) --- 206,224 ---- (let ((files (mapcar (lambda (name) (string-to-int name)) (directory-files dir nil "^[0-9]+$" t)))) ! (if (null files) ! () ! (save-excursion ! (set-buffer nntp-server-buffer) ! (insert ! (format ! "%s %d %d y\n" ! (progn ! (string-match (expand-file-name nnmh-directory) dir) ! (nnmail-replace-chars-in-string ! (substring dir (match-end 0)) ?/ ?.)) ! (apply (function max) files) ! (apply (function min) files))))))) t) (defun nnmh-request-newgroups (date &optional server) diff --exclude=*.elc --exclude=*~ --exclude=*-[0-9] --exclude=gnus --exclude=readme --context --recursive pub/dgnus/lisp/nnml.el dgnus/lisp/nnml.el *** pub/dgnus/lisp/nnml.el Fri Apr 21 05:55:01 1995 --- dgnus/lisp/nnml.el Fri Apr 21 09:57:47 1995 *************** *** 281,288 **** (setq rest (cons (car articles) rest)))) (setq articles (cdr articles))) (let ((active (nth 1 (assoc newsgroup nnml-group-alist)))) ! (setcar active (or (and active-articles (apply 'min active-articles)) ! 0)) (nnmail-save-active nnml-group-alist nnml-active-file)) (nnml-save-nov) rest)) --- 281,290 ---- (setq rest (cons (car articles) rest)))) (setq articles (cdr articles))) (let ((active (nth 1 (assoc newsgroup nnml-group-alist)))) ! (and active ! (setcar active (or (and active-articles ! (apply 'min active-articles)) ! 0))) (nnmail-save-active nnml-group-alist nnml-active-file)) (nnml-save-nov) rest)) diff --exclude=*.elc --exclude=*~ --exclude=*-[0-9] --exclude=gnus --exclude=readme --context --recursive pub/dgnus/lisp/nntp.el dgnus/lisp/nntp.el *** pub/dgnus/lisp/nntp.el Fri Apr 21 05:55:01 1995 --- dgnus/lisp/nntp.el Fri Apr 21 06:29:39 1995 *************** *** 409,443 **** (defun nntp-request-group (group &optional server dont-check) "Select GROUP." ! (if dont-check ! (nntp-send-command "^.*\r$" "GROUP" group) ! (cond ((eq nntp-server-list-active-group 'try) ! (or (nntp-try-list-active group) ! (nntp-send-command "^.*\r$" "GROUP" group))) ! (nntp-server-list-active-group ! (nntp-list-active-group group)) ! (t ! (nntp-send-command "^.*\r$" "GROUP" group))) ! (if nntp-server-list-active-group ! (save-excursion ! (set-buffer nntp-server-buffer) ! (goto-char (point-min)) ! (forward-line 1) ! (if (looking-at "[^ ]+[ \t]+\\([0-9]\\)[ \t]+\\([0-9]\\)") ! (let ((end (progn (goto-char (match-beginning 1)) ! (read (current-buffer)))) ! (beg (read (current-buffer)))) ! (and (> beg end) ! (setq end 0 ! beg 0)) ! (erase-buffer) ! (insert (format "211 %s %d %d %d\n" ! group (max (- (1+ end) beg) 0) ! beg end)))))) ! (save-excursion ! (set-buffer nntp-server-buffer) ! (goto-char (point-min)) ! (looking-at "[23]")))) (defun nntp-list-active-group (group &optional server) (nntp-send-command "^.*\r$" "LIST ACTIVE" group)) --- 409,419 ---- (defun nntp-request-group (group &optional server dont-check) "Select GROUP." ! (nntp-send-command "^.*\r$" "GROUP" group) ! (save-excursion ! (set-buffer nntp-server-buffer) ! (goto-char (point-min)) ! (looking-at "[23]"))) (defun nntp-list-active-group (group &optional server) (nntp-send-command "^.*\r$" "LIST ACTIVE" group)) diff --exclude=*.elc --exclude=*~ --exclude=*-[0-9] --exclude=gnus --exclude=readme --context --recursive pub/dgnus/lisp/nnvirtual.el dgnus/lisp/nnvirtual.el *** pub/dgnus/lisp/nnvirtual.el Fri Apr 21 05:55:01 1995 --- dgnus/lisp/nnvirtual.el Sat Apr 22 07:31:26 1995 *************** *** 245,251 **** (delq inf nnvirtual-group-alist))) (setq nnvirtual-current-mapping nil) (setq nnvirtual-current-group group) ! (let ((newsrc gnus-newsrc-assoc)) (setq nnvirtual-current-groups nil) (while newsrc (and (string-match regexp (car (car newsrc))) --- 245,251 ---- (delq inf nnvirtual-group-alist))) (setq nnvirtual-current-mapping nil) (setq nnvirtual-current-group group) ! (let ((newsrc gnus-newsrc-alist)) (setq nnvirtual-current-groups nil) (while newsrc (and (string-match regexp (car (car newsrc))) diff --exclude=*.elc --exclude=*~ --exclude=*-[0-9] --exclude=gnus --exclude=readme --context --recursive pub/dgnus/texi/gnus.texi dgnus/texi/gnus.texi *** pub/dgnus/texi/gnus.texi Fri Apr 21 05:55:07 1995 --- dgnus/texi/gnus.texi Sat Apr 22 09:04:51 1995 *************** *** 1125,1134 **** @item S l @kindex S l (Group) @findex gnus-group-set-current-level ! Set the level of the current group depending on the numeric ! prefix. For instance, @kbd{3 S l} will set the level of the current ! group to three (@code{gnus-group-set-current-level}). If no numeric ! prefix is given, this command will prompt the user for a level. @end table @vindex gnus-level-killed --- 1125,1133 ---- @item S l @kindex S l (Group) @findex gnus-group-set-current-level ! Set the level of the current group. If a numeric prefix is given, the ! next @var{n} groups will have their levels set. The user will be ! prompted for a level. @end table @vindex gnus-level-killed *************** *** 3113,3118 **** --- 3112,3126 ---- @end table + You may want to do spell-checking on messages that you send out. Or, if + you don't want to spell-check by hand, you could add automatic + spell-checking via the @code{ispell} package: + + @lisp + (add-hook 'news-inews-hook 'ispell-message) ;For news posts + (add-hook 'mail-send-hook 'ispell-message) ;for mail posts via sendmail + @end lisp + @node Cancelling and Superseding @section Cancelling Articles @cindex cancelling articles *************** *** 4195,4200 **** --- 4203,4214 ---- the pseudo-articles into the summary buffer, but view them immediately. If this variable is @code{not-confirm}, the user won't even be asked for a confirmation before viewing is done. + + @vindex gnus-view-pseudos-separately + If @code{gnus-view-pseudos-separately} is non-@code{nil}, one + pseudo-article will be created for each file to be viewed. If + @code{nil}, all files that use the same viewing command will be given as + a list of parameters to that command. So; there you are, reading your @emph{pseduo-articles} in your @emph{virtual newsgroup} from the @emph{virtual server}; and you think: