annotate lisp/gnus-score.el @ 13686:6e3b9c9595eb

Fixed dst-in-effect for southern hemisphere. Also made doc string clearer.
author Edward M. Reingold <reingold@emr.cs.iit.edu>
date Tue, 05 Dec 1995 22:55:22 +0000
parents 178d730efae2
children 187735b53d52
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
13401
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1 ;;; gnus-score.el --- scoring code for Gnus
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
2 ;; Copyright (C) 1995 Free Software Foundation, Inc.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
3
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
4 ;; Author: Per Abrahamsen <amanda@iesd.auc.dk>
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
5 ;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
6 ;; Keywords: news
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
7
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
8 ;; This file is part of GNU Emacs.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
9
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
10 ;; GNU Emacs is free software; you can redistribute it and/or modify
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
11 ;; it under the terms of the GNU General Public License as published by
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
12 ;; the Free Software Foundation; either version 2, or (at your option)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
13 ;; any later version.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
14
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
15 ;; GNU Emacs is distributed in the hope that it will be useful,
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
18 ;; GNU General Public License for more details.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
19
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
20 ;; You should have received a copy of the GNU General Public License
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
21 ;; along with GNU Emacs; see the file COPYING. If not, write to
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
22 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
23
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
24 ;;; Commentary:
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
25
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
26 ;;; Code:
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
27
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
28 (require 'gnus)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
29
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
30 (defvar gnus-score-expiry-days 7
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
31 "*Number of days before unused score file entries are expired.")
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
32
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
33 (defvar gnus-orphan-score nil
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
34 "*All orphans get this score added. Set in the score file.")
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
35
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
36 (defvar gnus-default-adaptive-score-alist
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
37 '((gnus-kill-file-mark)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
38 (gnus-unread-mark)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
39 (gnus-read-mark (from 3) (subject 30))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
40 (gnus-catchup-mark (subject -10))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
41 (gnus-killed-mark (from -1) (subject -20))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
42 (gnus-del-mark (from -2) (subject -15)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
43 "*Alist of marks and scores.")
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
44
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
45 (defvar gnus-score-mimic-keymap nil
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
46 "*Have the score entry functions pretend that they are a keymap.")
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
47
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
48 (defvar gnus-score-exact-adapt-limit 10
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
49 "*Number that says how long a match has to be before using substring matching.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
50 When doing adaptive scoring, one normally uses fuzzy or substring
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
51 matching. However, if the header one matches is short, the possibility
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
52 for false positives is great, so if the length of the match is less
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
53 than this variable, exact matching will be used.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
54
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
55 If this variable is nil, exact matching will always be used.")
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
56
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
57
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
58
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
59 ;; Internal variables.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
60
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
61 (defvar gnus-score-help-winconf nil)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
62 (defvar gnus-adaptive-score-alist gnus-default-adaptive-score-alist)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
63 (defvar gnus-score-trace nil)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
64 (defvar gnus-score-edit-buffer nil)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
65
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
66 (defvar gnus-score-alist nil
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
67 "Alist containing score information.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
68 The keys can be symbols or strings. The following symbols are defined.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
69
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
70 touched: If this alist has been modified.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
71 mark: Automatically mark articles below this.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
72 expunge: Automatically expunge articles below this.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
73 files: List of other score files to load when loading this one.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
74 eval: Sexp to be evaluated when the score file is loaded.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
75
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
76 String entries have the form (HEADER (MATCH TYPE SCORE DATE) ...)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
77 where HEADER is the header being scored, MATCH is the string we are
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
78 looking for, TYPE is a flag indicating whether it should use regexp or
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
79 substring matching, SCORE is the score to add and DATE is the date
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
80 of the last successful match.")
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
81
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
82 (defvar gnus-score-cache nil)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
83 (defvar gnus-scores-articles nil)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
84 (defvar gnus-header-index nil)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
85 (defvar gnus-score-index nil)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
86
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
87 (eval-and-compile
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
88 (autoload 'gnus-uu-ctl-map "gnus-uu" nil nil 'keymap)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
89 (autoload 'appt-select-lowest-window "appt.el"))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
90
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
91 ;;; Summary mode score maps.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
92
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
93 (defvar gnus-summary-score-map nil)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
94
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
95 (define-prefix-command 'gnus-summary-score-map)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
96 (define-key gnus-summary-mode-map "V" 'gnus-summary-score-map)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
97 (define-key gnus-summary-score-map "s" 'gnus-summary-set-score)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
98 (define-key gnus-summary-score-map "a" 'gnus-summary-score-entry)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
99 (define-key gnus-summary-score-map "S" 'gnus-summary-current-score)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
100 (define-key gnus-summary-score-map "c" 'gnus-score-change-score-file)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
101 (define-key gnus-summary-score-map "m" 'gnus-score-set-mark-below)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
102 (define-key gnus-summary-score-map "x" 'gnus-score-set-expunge-below)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
103 (define-key gnus-summary-score-map "e" 'gnus-score-edit-alist)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
104 (define-key gnus-summary-score-map "f" 'gnus-score-edit-file)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
105 (define-key gnus-summary-score-map "t" 'gnus-score-find-trace)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
106 (define-key gnus-summary-score-map "C" 'gnus-score-customize)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
107
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
108
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
109
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
110 ;; Summary score file commands
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
111
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
112 ;; Much modification of the kill (ahem, score) code and lots of the
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
113 ;; functions are written by Per Abrahamsen <amanda@iesd.auc.dk>.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
114
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
115 (defun gnus-summary-lower-score (&optional score)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
116 "Make a score entry based on the current article.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
117 The user will be prompted for header to score on, match type,
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
118 permanence, and the string to be used. The numerical prefix will be
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
119 used as score."
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
120 (interactive "P")
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
121 (gnus-summary-increase-score (- (gnus-score-default score))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
122
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
123 (defun gnus-summary-increase-score (&optional score)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
124 "Make a score entry based on the current article.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
125 The user will be prompted for header to score on, match type,
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
126 permanence, and the string to be used. The numerical prefix will be
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
127 used as score."
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
128 (interactive "P")
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
129 (gnus-set-global-variables)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
130 (let* ((nscore (gnus-score-default score))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
131 (prefix (if (< nscore 0) ?L ?I))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
132 (increase (> nscore 0))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
133 (char-to-header
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
134 '((?a "from" nil nil string)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
135 (?s "subject" nil nil string)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
136 (?b "body" "" nil body-string)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
137 (?h "head" "" nil body-string)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
138 (?i "message-id" nil t string)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
139 (?t "references" "message-id" t string)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
140 (?x "xref" nil nil string)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
141 (?l "lines" nil nil number)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
142 (?d "date" nil nil date)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
143 (?f "followup" nil nil string)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
144 (char-to-type
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
145 '((?s s "substring" string)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
146 (?e e "exact string" string)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
147 (?f f "fuzzy string" string)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
148 (?r r "regexp string" string)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
149 (?s s "substring" body-string)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
150 (?r s "regexp string" body-string)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
151 (?b before "before date" date)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
152 (?a at "at date" date)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
153 (?n now "this date" date)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
154 (?< < "less than number" number)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
155 (?> > "greater than number" number)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
156 (?= = "equal to number" number)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
157 (char-to-perm
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
158 (list (list ?t (current-time-string) "temporary")
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
159 '(?p perm "permanent") '(?i now "immediate")))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
160 (mimic gnus-score-mimic-keymap)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
161 hchar entry temporary tchar pchar end type)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
162 ;; First we read the header to score.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
163 (while (not hchar)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
164 (if mimic
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
165 (progn
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
166 (sit-for 1)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
167 (message "%c-" prefix))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
168 (message "%s header (%s?): " (if increase "Increase" "Lower")
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
169 (mapconcat (lambda (s) (char-to-string (car s)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
170 char-to-header "")))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
171 (setq hchar (read-char))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
172 (if (not (or (= hchar ??) (= hchar ?\C-h)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
173 ()
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
174 (setq hchar nil)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
175 (gnus-score-insert-help "Match on header" char-to-header 1)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
176
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
177 (and (get-buffer "*Score Help*")
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
178 (progn
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
179 (kill-buffer "*Score Help*")
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
180 (and gnus-score-help-winconf
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
181 (set-window-configuration gnus-score-help-winconf))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
182
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
183 (or (setq entry (assq (downcase hchar) char-to-header))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
184 (progn
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
185 (ding)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
186 (setq end t)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
187 (if mimic (message "%c %c" prefix hchar) (message ""))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
188 (if (or end (/= (downcase hchar) hchar))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
189 (progn
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
190 ;; This was a majuscle, so we end reading and set the defaults.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
191 (if mimic (message "%c %c" prefix hchar) (message ""))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
192 (setq type nil
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
193 temporary (current-time-string)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
194
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
195 ;; We continue reading - the type.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
196 (while (not tchar)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
197 (if mimic
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
198 (progn
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
199 (sit-for 1)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
200 (message "%c %c-" prefix hchar))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
201 (message "%s header '%s' with match type (%s?): "
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
202 (if increase "Increase" "Lower")
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
203 (nth 1 entry)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
204 (mapconcat (lambda (s)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
205 (if (eq (nth 4 entry)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
206 (nth 3 s))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
207 (char-to-string (car s))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
208 ""))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
209 char-to-type "")))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
210 (setq tchar (read-char))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
211 (if (not (or (= tchar ??) (= tchar ?\C-h)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
212 ()
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
213 (setq tchar nil)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
214 (gnus-score-insert-help "Match type" char-to-type 2)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
215
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
216 (and (get-buffer "*Score Help*")
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
217 (progn
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
218 (and gnus-score-help-winconf
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
219 (set-window-configuration gnus-score-help-winconf))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
220 (kill-buffer "*Score Help*")))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
221
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
222 (or (setq type (nth 1 (assq (downcase tchar) char-to-type)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
223 (progn
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
224 (ding)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
225 (if mimic (message "%c %c" prefix hchar) (message ""))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
226 (setq end t)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
227 (if (or end (/= (downcase tchar) tchar))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
228 (progn
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
229 ;; It was a majuscle, so we end reading and the the default.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
230 (if mimic (message "%c %c %c" prefix hchar tchar)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
231 (message ""))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
232 (setq temporary (current-time-string)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
233
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
234 ;; We continue reading.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
235 (while (not pchar)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
236 (if mimic
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
237 (progn
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
238 (sit-for 1)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
239 (message "%c %c %c-" prefix hchar tchar))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
240 (message "%s permanence (%s?): " (if increase "Increase" "Lower")
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
241 (mapconcat (lambda (s) (char-to-string (car s)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
242 char-to-perm "")))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
243 (setq pchar (read-char))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
244 (if (not (or (= pchar ??) (= pchar ?\C-h)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
245 ()
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
246 (setq pchar nil)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
247 (gnus-score-insert-help "Match permanence" char-to-perm 2)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
248
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
249 (and (get-buffer "*Score Help*")
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
250 (progn
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
251 (and gnus-score-help-winconf
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
252 (set-window-configuration gnus-score-help-winconf))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
253 (kill-buffer "*Score Help*")))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
254
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
255 (if mimic (message "%c %c %c" prefix hchar tchar pchar)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
256 (message ""))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
257 (if (setq temporary (nth 1 (assq pchar char-to-perm)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
258 ()
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
259 (ding)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
260 (setq end t)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
261 (if mimic
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
262 (message "%c %c %c %c" prefix hchar tchar pchar)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
263 (message "")))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
264
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
265 ;; We have all the data, so we enter this score.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
266 (if end
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
267 ()
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
268 (gnus-summary-score-entry
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
269 (nth 1 entry) ; Header
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
270 (if (string= (nth 2 entry) "") ""
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
271 (gnus-summary-header (or (nth 2 entry) (nth 1 entry)))) ; Match
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
272 type ; Type
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
273 (if (eq 's score) nil score) ; Score
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
274 (if (eq 'perm temporary) ; Temp
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
275 nil
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
276 temporary)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
277 (not (nth 3 entry))) ; Prompt
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
278 )))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
279
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
280 (defun gnus-score-insert-help (string alist idx)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
281 (setq gnus-score-help-winconf (current-window-configuration))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
282 (save-excursion
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
283 (set-buffer (get-buffer-create "*Score Help*"))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
284 (buffer-disable-undo (current-buffer))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
285 (delete-windows-on (current-buffer))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
286 (erase-buffer)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
287 (insert string ":\n\n")
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
288 (let ((max -1)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
289 (list alist)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
290 (i 0)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
291 n width pad format)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
292 ;; find the longest string to display
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
293 (while list
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
294 (setq n (length (nth idx (car list))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
295 (or (> max n)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
296 (setq max n))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
297 (setq list (cdr list)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
298 (setq max (+ max 4)) ; %c, `:', SPACE, a SPACE at end
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
299 (setq n (/ (window-width) max)) ; items per line
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
300 (setq width (/ (window-width) n)) ; width of each item
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
301 ;; insert `n' items, each in a field of width `width'
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
302 (while alist
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
303 (if (< i n)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
304 ()
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
305 (setq i 0)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
306 (delete-char -1) ; the `\n' takes a char
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
307 (insert "\n"))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
308 (setq pad (- width 3))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
309 (setq format (concat "%c: %-" (int-to-string pad) "s"))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
310 (insert (format format (car (car alist)) (nth idx (car alist))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
311 (setq alist (cdr alist))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
312 (setq i (1+ i))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
313 ;; display ourselves in a small window at the bottom
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
314 (appt-select-lowest-window)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
315 (split-window)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
316 (pop-to-buffer "*Score Help*")
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
317 (shrink-window-if-larger-than-buffer)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
318 (select-window (get-buffer-window gnus-summary-buffer))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
319
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
320 (defun gnus-summary-header (header &optional no-err)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
321 ;; Return HEADER for current articles, or error.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
322 (let ((article (gnus-summary-article-number))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
323 headers)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
324 (if article
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
325 (if (and (setq headers (gnus-get-header-by-number article))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
326 (vectorp headers))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
327 (aref headers (nth 1 (assoc header gnus-header-index)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
328 (if no-err
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
329 nil
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
330 (error "Pseudo-articles can't be scored")))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
331 (if no-err
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
332 (error "No article on current line")
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
333 nil))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
334
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
335 (defun gnus-summary-score-entry
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
336 (header match type score date &optional prompt silent)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
337 "Enter score file entry.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
338 HEADER is the header being scored.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
339 MATCH is the string we are looking for.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
340 TYPE is the match type: substring, regexp, exact, fuzzy.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
341 SCORE is the score to add.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
342 DATE is the expire date, or nil for no expire, or 'now for immediate expire.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
343 If optional argument `PROMPT' is non-nil, allow user to edit match.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
344 If optional argument `SILENT' is nil, show effect of score entry."
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
345 (interactive
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
346 (list (completing-read "Header: "
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
347 gnus-header-index
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
348 (lambda (x) (fboundp (nth 2 x)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
349 t)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
350 (read-string "Match: ")
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
351 (if (y-or-n-p "Use regexp match? ") 'r 's)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
352 (and current-prefix-arg
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
353 (prefix-numeric-value current-prefix-arg))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
354 (cond ((not (y-or-n-p "Add to score file? "))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
355 'now)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
356 ((y-or-n-p "Expire kill? ")
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
357 (current-time-string))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
358 (t nil))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
359 ;; Regexp is the default type.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
360 (if (eq type t) (setq type 'r))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
361 ;; Simplify matches...
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
362 (cond ((or (eq type 'r) (eq type 's) (eq type nil))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
363 (setq match (if match (gnus-simplify-subject-re match) "")))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
364 ((eq type 'f)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
365 (setq match (gnus-simplify-subject-fuzzy match))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
366 (let ((score (gnus-score-default score))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
367 (header (downcase header)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
368 (and prompt (setq match (read-string
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
369 (format "Match %s on %s, %s: "
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
370 (cond ((eq date 'now)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
371 "now")
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
372 ((stringp date)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
373 "temp")
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
374 (t "permanent"))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
375 header
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
376 (if (< score 0) "lower" "raise"))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
377 (if (numberp match)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
378 (int-to-string match)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
379 match))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
380 (and (>= (nth 1 (assoc header gnus-header-index)) 0)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
381 (eq (nth 2 (assoc header gnus-header-index)) 'gnus-score-string)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
382 (not silent)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
383 (gnus-summary-score-effect header match type score))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
384
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
385 ;; If this is an integer comparison, we transform from string to int.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
386 (and (eq (nth 2 (assoc header gnus-header-index)) 'gnus-score-integer)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
387 (setq match (string-to-int match)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
388
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
389 (if (eq date 'now)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
390 ()
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
391 (and (= score gnus-score-interactive-default-score)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
392 (setq score nil))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
393 (let ((new (cond
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
394 (type
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
395 (list match score (and date (gnus-day-number date)) type))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
396 (date
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
397 (list match score (gnus-day-number date)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
398 (score
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
399 (list match score))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
400 (t
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
401 (list match))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
402 (old (gnus-score-get header))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
403 elem)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
404 ;; We see whether we can collapse some score entries.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
405 ;; This isn't quite correct, because there may be more elements
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
406 ;; later on with the same key that have matching elems... Hm.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
407 (if (and old
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
408 (setq elem (assoc match old))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
409 (eq (nth 3 elem) (nth 3 new))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
410 (or (and (numberp (nth 2 elem)) (numberp (nth 2 new)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
411 (and (not (nth 2 elem)) (not (nth 2 new)))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
412 ;; Yup, we just add this new score to the old elem.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
413 (setcar (cdr elem) (+ (or (nth 1 elem)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
414 gnus-score-interactive-default-score)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
415 (or (nth 1 new)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
416 gnus-score-interactive-default-score)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
417 ;; Nope, we have to add a new elem.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
418 (gnus-score-set header (if old (cons new old) (list new)))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
419 (gnus-score-set 'touched '(t)))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
420
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
421 (defun gnus-summary-score-effect (header match type score)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
422 "Simulate the effect of a score file entry.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
423 HEADER is the header being scored.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
424 MATCH is the string we are looking for.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
425 TYPE is a flag indicating if it is a regexp or substring.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
426 SCORE is the score to add."
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
427 (interactive (list (completing-read "Header: "
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
428 gnus-header-index
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
429 (lambda (x) (fboundp (nth 2 x)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
430 t)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
431 (read-string "Match: ")
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
432 (y-or-n-p "Use regexp match? ")
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
433 (prefix-numeric-value current-prefix-arg)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
434 (save-excursion
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
435 (or (and (stringp match) (> (length match) 0))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
436 (error "No match"))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
437 (goto-char (point-min))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
438 (let ((regexp (cond ((eq type 'f)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
439 (gnus-simplify-subject-fuzzy match))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
440 (type match)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
441 (t (concat "\\`.*" (regexp-quote match) ".*\\'")))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
442 (while (not (eobp))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
443 (let ((content (gnus-summary-header header 'noerr))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
444 (case-fold-search t))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
445 (and content
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
446 (if (if (eq type 'f)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
447 (string-equal (gnus-simplify-subject-fuzzy content)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
448 regexp)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
449 (string-match regexp content))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
450 (gnus-summary-raise-score score))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
451 (beginning-of-line 2)))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
452
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
453 (defun gnus-summary-score-crossposting (score date)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
454 ;; Enter score file entry for current crossposting.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
455 ;; SCORE is the score to add.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
456 ;; DATE is the expire date.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
457 (let ((xref (gnus-summary-header "xref"))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
458 (start 0)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
459 group)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
460 (or xref (error "This article is not crossposted"))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
461 (while (string-match " \\([^ \t]+\\):" xref start)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
462 (setq start (match-end 0))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
463 (if (not (string=
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
464 (setq group
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
465 (substring xref (match-beginning 1) (match-end 1)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
466 gnus-newsgroup-name))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
467 (gnus-summary-score-entry
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
468 "xref" (concat " " group ":") nil score date t)))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
469
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
470
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
471 ;;;
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
472 ;;; Gnus Score Files
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
473 ;;;
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
474
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
475 ;; All score code written by Per Abrahamsen <abraham@iesd.auc.dk>.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
476
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
477 ;; Added by Per Abrahamsen <amanda@iesd.auc.dk>.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
478 (defun gnus-score-set-mark-below (score)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
479 "Automatically mark articles with score below SCORE as read."
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
480 (interactive
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
481 (list (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
482 (string-to-int (read-string "Mark below: ")))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
483 (setq score (or score gnus-summary-default-score 0))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
484 (gnus-score-set 'mark (list score))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
485 (gnus-score-set 'touched '(t))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
486 (setq gnus-summary-mark-below score)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
487 (gnus-summary-update-lines))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
488
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
489 (defun gnus-score-set-expunge-below (score)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
490 "Automatically expunge articles with score below SCORE."
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
491 (interactive
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
492 (list (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
493 (string-to-int (read-string "Expunge below: ")))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
494 (setq score (or score gnus-summary-default-score 0))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
495 (gnus-score-set 'expunge (list score))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
496 (gnus-score-set 'touched '(t)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
497
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
498 (defun gnus-score-set (symbol value &optional alist)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
499 ;; Set SYMBOL to VALUE in ALIST.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
500 (let* ((alist
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
501 (or alist
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
502 gnus-score-alist
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
503 (progn
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
504 (gnus-score-load (gnus-score-file-name gnus-newsgroup-name))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
505 gnus-score-alist)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
506 (entry (assoc symbol alist)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
507 (cond ((gnus-score-get 'read-only alist)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
508 ;; This is a read-only score file, so we do nothing.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
509 )
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
510 (entry
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
511 (setcdr entry value))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
512 ((null alist)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
513 (error "Empty alist"))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
514 (t
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
515 (setcdr alist
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
516 (cons (cons symbol value) (cdr alist)))))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
517
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
518 (defun gnus-score-get (symbol &optional alist)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
519 ;; Get SYMBOL's definition in ALIST.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
520 (cdr (assoc symbol
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
521 (or alist
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
522 gnus-score-alist
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
523 (progn
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
524 (gnus-score-load
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
525 (gnus-score-file-name gnus-newsgroup-name))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
526 gnus-score-alist)))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
527
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
528 (defun gnus-score-change-score-file (file)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
529 "Change current score alist."
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
530 (interactive
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
531 (list (read-file-name "Edit score file: " gnus-kill-files-directory)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
532 (gnus-score-load-file file)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
533 (gnus-set-mode-line 'summary))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
534
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
535 (defun gnus-score-edit-alist (file)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
536 "Edit the current score alist."
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
537 (interactive (list gnus-current-score-file))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
538 (let ((winconf (current-window-configuration)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
539 (and (buffer-name gnus-summary-buffer) (gnus-score-save))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
540 (setq gnus-score-edit-buffer (find-file-noselect file))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
541 (gnus-configure-windows 'edit-score)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
542 (gnus-score-mode)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
543 (make-local-variable 'gnus-prev-winconf)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
544 (setq gnus-prev-winconf winconf))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
545 (gnus-message
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
546 4 (substitute-command-keys
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
547 "\\<gnus-score-mode-map>\\[gnus-score-edit-done] to save edits")))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
548
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
549 (defun gnus-score-edit-file (file)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
550 "Edit a score file."
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
551 (interactive
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
552 (list (read-file-name "Edit score file: " gnus-kill-files-directory)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
553 (and (buffer-name gnus-summary-buffer) (gnus-score-save))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
554 (let ((winconf (current-window-configuration)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
555 (setq gnus-score-edit-buffer (find-file-noselect file))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
556 (gnus-configure-windows 'edit-score)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
557 (gnus-score-mode)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
558 (make-local-variable 'gnus-prev-winconf)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
559 (setq gnus-prev-winconf winconf))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
560 (gnus-message
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
561 4 (substitute-command-keys
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
562 "\\<gnus-score-mode-map>\\[gnus-score-edit-done] to save edits")))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
563
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
564 (defun gnus-score-load-file (file)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
565 ;; Load score file FILE. Returns a list a retrieved score-alists.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
566 (setq gnus-kill-files-directory (or gnus-kill-files-directory "~/News/"))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
567 (let* ((file (expand-file-name
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
568 (or (and (string-match
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
569 (concat "^" (expand-file-name
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
570 gnus-kill-files-directory))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
571 (expand-file-name file))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
572 file)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
573 (concat gnus-kill-files-directory file))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
574 (cached (assoc file gnus-score-cache))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
575 (global (member file gnus-internal-global-score-files))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
576 lists alist)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
577 (if cached
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
578 ;; The score file was already loaded.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
579 (setq alist (cdr cached))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
580 ;; We load the score file.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
581 (setq gnus-score-alist nil)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
582 (setq alist (gnus-score-load-score-alist file))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
583 ;; We add '(touched) to the alist to signify that it hasn't been
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
584 ;; touched (yet).
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
585 (or (assq 'touched alist) (setq alist (cons (list 'touched nil) alist)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
586 ;; If it is a global score file, we make it read-only.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
587 (and global
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
588 (not (assq 'read-only alist))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
589 (setq alist (cons (list 'read-only t) alist)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
590 ;; Update cache.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
591 (setq gnus-score-cache
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
592 (cons (cons file alist) gnus-score-cache)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
593 ;; If there are actual scores in the alist, we add it to the
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
594 ;; return value of this function.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
595 (if (memq t (mapcar (lambda (e) (stringp (car e))) alist))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
596 (setq lists (list alist)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
597 ;; Treat the other possible atoms in the score alist.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
598 (let ((mark (car (gnus-score-get 'mark alist)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
599 (expunge (car (gnus-score-get 'expunge alist)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
600 (mark-and-expunge (car (gnus-score-get 'mark-and-expunge alist)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
601 (files (gnus-score-get 'files alist))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
602 (exclude-files (gnus-score-get 'exclude-files alist))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
603 (orphan (car (gnus-score-get 'orphan alist)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
604 (adapt (gnus-score-get 'adapt alist))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
605 (local (gnus-score-get 'local alist))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
606 (eval (car (gnus-score-get 'eval alist))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
607 ;; We do not respect eval and files atoms from global score
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
608 ;; files.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
609 (and files (not global)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
610 (setq lists (apply 'append lists
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
611 (mapcar (lambda (file)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
612 (gnus-score-load-file file))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
613 files))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
614 (and eval (not global) (eval eval))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
615 ;; We then expand any exclude-file directives.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
616 (setq gnus-scores-exclude-files
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
617 (nconc
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
618 (mapcar
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
619 (lambda (sfile)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
620 (expand-file-name sfile (file-name-directory file)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
621 exclude-files) gnus-scores-exclude-files))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
622 (if (not local)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
623 ()
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
624 (save-excursion
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
625 (set-buffer gnus-summary-buffer)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
626 (while local
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
627 (and (consp (car local))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
628 (symbolp (car (car local)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
629 (progn
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
630 (make-local-variable (car (car local)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
631 (set (car (car local)) (nth 1 (car local)))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
632 (setq local (cdr local)))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
633 (if orphan (setq gnus-orphan-score orphan))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
634 (setq gnus-adaptive-score-alist
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
635 (cond ((equal adapt '(t))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
636 (setq gnus-newsgroup-adaptive t)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
637 gnus-default-adaptive-score-alist)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
638 ((equal adapt '(ignore))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
639 (setq gnus-newsgroup-adaptive nil))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
640 ((consp adapt)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
641 (setq gnus-newsgroup-adaptive t)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
642 adapt)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
643 (t
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
644 ;;(setq gnus-newsgroup-adaptive gnus-use-adaptive-scoring)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
645 gnus-default-adaptive-score-alist)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
646 (setq gnus-summary-mark-below
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
647 (or mark mark-and-expunge gnus-summary-mark-below))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
648 (setq gnus-summary-expunge-below
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
649 (or expunge mark-and-expunge gnus-summary-expunge-below)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
650 (setq gnus-current-score-file file)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
651 (setq gnus-score-alist alist)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
652 lists))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
653
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
654 (defun gnus-score-load (file)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
655 ;; Load score FILE.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
656 (let ((cache (assoc file gnus-score-cache)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
657 (if cache
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
658 (setq gnus-score-alist (cdr cache))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
659 (setq gnus-score-alist nil)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
660 (gnus-score-load-score-alist file)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
661 (or gnus-score-alist
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
662 (setq gnus-score-alist (copy-alist '((touched nil)))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
663 (setq gnus-score-cache
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
664 (cons (cons file gnus-score-alist) gnus-score-cache)))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
665
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
666 (defun gnus-score-remove-from-cache (file)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
667 (setq gnus-score-cache
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
668 (delq (assoc file gnus-score-cache) gnus-score-cache)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
669
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
670 (defun gnus-score-load-score-alist (file)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
671 (let (alist)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
672 (if (file-readable-p file)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
673 (progn
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
674 (save-excursion
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
675 (gnus-set-work-buffer)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
676 (insert-file-contents file)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
677 (goto-char (point-min))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
678 ;; Only do the loading if the score file isn't empty.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
679 (if (save-excursion (re-search-forward "[()0-9a-zA-Z]" nil t))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
680 (setq alist
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
681 (condition-case ()
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
682 (read (current-buffer))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
683 (error
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
684 (progn
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
685 (gnus-message 3 "Problem with score file %s" file)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
686 (ding)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
687 (sit-for 2)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
688 nil))))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
689 (if (eq (car alist) 'setq)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
690 (setq gnus-score-alist (gnus-score-transform-old-to-new alist))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
691 (setq gnus-score-alist alist))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
692 (setq gnus-score-alist
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
693 (gnus-score-check-syntax gnus-score-alist file)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
694 (setq gnus-score-alist nil))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
695
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
696 (defun gnus-score-check-syntax (alist file)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
697 (cond
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
698 ((null alist)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
699 nil)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
700 ((not (consp alist))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
701 (gnus-message 1 "Score file is not a list: %s" file)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
702 (ding)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
703 nil)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
704 (t
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
705 (let ((a alist)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
706 err)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
707 (while (and a (not err))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
708 (cond ((not (listp (car a)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
709 (gnus-message 3 "Illegal score element %s in %s" (car a) file)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
710 (setq err t))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
711 ((and (stringp (car (car a)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
712 (not (listp (nth 1 (car a)))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
713 (gnus-message 3 "Illegal header match %s in %s" (nth 1 (car a)) file)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
714 (setq err t))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
715 (t
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
716 (setq a (cdr a)))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
717 (if err
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
718 (progn
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
719 (ding)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
720 nil)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
721 alist)))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
722
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
723 (defun gnus-score-transform-old-to-new (alist)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
724 (let* ((alist (nth 2 alist))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
725 out entry)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
726 (if (eq (car alist) 'quote)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
727 (setq alist (nth 1 alist)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
728 (while alist
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
729 (setq entry (car alist))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
730 (if (stringp (car entry))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
731 (let ((scor (cdr entry)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
732 (setq out (cons entry out))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
733 (while scor
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
734 (setcar scor
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
735 (list (car (car scor)) (nth 2 (car scor))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
736 (and (nth 3 (car scor))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
737 (gnus-day-number (nth 3 (car scor))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
738 (if (nth 1 (car scor)) 'r 's)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
739 (setq scor (cdr scor))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
740 (setq out (cons (if (not (listp (cdr entry)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
741 (list (car entry) (cdr entry))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
742 entry)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
743 out)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
744 (setq alist (cdr alist)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
745 (cons (list 'touched t) (nreverse out))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
746
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
747 (defun gnus-score-save ()
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
748 ;; Save all score information.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
749 (let ((cache gnus-score-cache))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
750 (save-excursion
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
751 (setq gnus-score-alist nil)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
752 (set-buffer (get-buffer-create "*Score*"))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
753 (buffer-disable-undo (current-buffer))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
754 (let (entry score file)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
755 (while cache
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
756 (setq entry (car cache)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
757 cache (cdr cache)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
758 file (car entry)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
759 score (cdr entry))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
760 (if (or (not (equal (gnus-score-get 'touched score) '(t)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
761 (gnus-score-get 'read-only score)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
762 (and (file-exists-p file)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
763 (not (file-writable-p file))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
764 ()
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
765 (setq score (setcdr entry (delq (assq 'touched score) score)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
766 (erase-buffer)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
767 (let (emacs-lisp-mode-hook)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
768 (if (string-match (concat gnus-adaptive-file-suffix "$") file)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
769 ;; This is an adaptive score file, so we do not run
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
770 ;; it through `pp'. These files can get huge, and
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
771 ;; are not meant to be edited by human hands.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
772 (insert (format "%S" score))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
773 ;; This is a normal score file, so we print it very
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
774 ;; prettily.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
775 (pp score (current-buffer))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
776 (if (not (gnus-make-directory (file-name-directory file)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
777 ()
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
778 ;; If the score file is empty, we delete it.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
779 (if (zerop (buffer-size))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
780 (delete-file file)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
781 ;; There are scores, so we write the file.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
782 (and (file-writable-p file)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
783 (write-region (point-min) (point-max)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
784 file nil 'silent)))))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
785 (kill-buffer (current-buffer)))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
786
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
787 (defun gnus-score-headers (score-files &optional trace)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
788 ;; Score `gnus-newsgroup-headers'.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
789 (let (scores)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
790 ;; PLM: probably this is not the best place to clear orphan-score
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
791 (setq gnus-orphan-score nil)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
792 (setq gnus-scores-articles nil)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
793 (setq gnus-scores-exclude-files nil)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
794 ;; Load the score files.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
795 (while score-files
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
796 (if (stringp (car score-files))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
797 ;; It is a string, which means that it's a score file name,
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
798 ;; so we load the score file and add the score alist to
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
799 ;; the list of alists.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
800 (setq scores (nconc (gnus-score-load-file (car score-files)) scores))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
801 ;; It is an alist, so we just add it to the list directly.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
802 (setq scores (nconc (car score-files) scores)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
803 (setq score-files (cdr score-files)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
804 ;; Prune the score files that are to be excluded, if any.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
805 (if (not gnus-scores-exclude-files)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
806 ()
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
807 (let ((s scores)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
808 c)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
809 (while s
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
810 (and (setq c (rassq (car s) gnus-score-cache))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
811 (member (car c) gnus-scores-exclude-files)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
812 (setq scores (delq (car s) scores)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
813 (setq s (cdr s)))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
814 (if (not (and gnus-summary-default-score
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
815 scores
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
816 (> (length gnus-newsgroup-headers)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
817 (length gnus-newsgroup-scored))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
818 ()
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
819 (let* ((entries gnus-header-index)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
820 (now (gnus-day-number (current-time-string)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
821 (expire (- now gnus-score-expiry-days))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
822 (headers gnus-newsgroup-headers)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
823 (current-score-file gnus-current-score-file)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
824 entry header)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
825 (gnus-message 5 "Scoring...")
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
826 ;; Create articles, an alist of the form `(HEADER . SCORE)'.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
827 (while headers
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
828 (setq header (car headers)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
829 headers (cdr headers))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
830 ;; WARNING: The assq makes the function O(N*S) while it could
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
831 ;; be written as O(N+S), where N is (length gnus-newsgroup-headers)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
832 ;; and S is (length gnus-newsgroup-scored).
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
833 (or (assq (mail-header-number header) gnus-newsgroup-scored)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
834 (setq gnus-scores-articles ;Total of 2 * N cons-cells used.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
835 (cons (cons header (or gnus-summary-default-score 0))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
836 gnus-scores-articles))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
837
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
838 (save-excursion
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
839 (set-buffer (get-buffer-create "*Headers*"))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
840 (buffer-disable-undo (current-buffer))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
841
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
842 ;; Set the global variant of this variable.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
843 (setq gnus-current-score-file current-score-file)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
844 ;; score orphans
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
845 (if gnus-orphan-score
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
846 (progn
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
847 (setq gnus-score-index
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
848 (nth 1 (assoc "references" gnus-header-index)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
849 (gnus-score-orphans gnus-orphan-score)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
850 ;; Run each header through the score process.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
851 (while entries
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
852 (setq entry (car entries)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
853 header (nth 0 entry)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
854 entries (cdr entries))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
855 (setq gnus-score-index (nth 1 (assoc header gnus-header-index)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
856 (if (< 0 (apply 'max (mapcar
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
857 (lambda (score)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
858 (length (gnus-score-get header score)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
859 scores)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
860 (funcall (nth 2 entry) scores header now expire trace)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
861 ;; Remove the buffer.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
862 (kill-buffer (current-buffer)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
863
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
864 ;; Add articles to `gnus-newsgroup-scored'.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
865 (while gnus-scores-articles
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
866 (or (= gnus-summary-default-score (cdr (car gnus-scores-articles)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
867 (setq gnus-newsgroup-scored
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
868 (cons (cons (mail-header-number
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
869 (car (car gnus-scores-articles)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
870 (cdr (car gnus-scores-articles)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
871 gnus-newsgroup-scored)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
872 (setq gnus-scores-articles (cdr gnus-scores-articles)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
873
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
874 (gnus-message 5 "Scoring...done")))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
875
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
876
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
877 (defun gnus-get-new-thread-ids (articles)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
878 (let ((index (nth 1 (assoc "message-id" gnus-header-index)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
879 (refind gnus-score-index)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
880 id-list art this tref)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
881 (while articles
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
882 (setq art (car articles)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
883 this (aref (car art) index)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
884 tref (aref (car art) refind)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
885 articles (cdr articles))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
886 (if (string-equal tref "") ;no references line
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
887 (setq id-list (cons this id-list))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
888 id-list))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
889
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
890 ;; Orphan functions written by plm@atcmp.nl (Peter Mutsaers).
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
891 (defun gnus-score-orphans (score)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
892 (let ((new-thread-ids (gnus-get-new-thread-ids gnus-scores-articles))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
893 alike articles art arts this last this-id)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
894
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
895 (setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
896 articles gnus-scores-articles)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
897
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
898 ;;more or less the same as in gnus-score-string
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
899 (erase-buffer)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
900 (while articles
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
901 (setq art (car articles)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
902 this (aref (car art) gnus-score-index)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
903 articles (cdr articles))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
904 ;;completely skip if this is empty (not a child, so not an orphan)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
905 (if (not (string= this ""))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
906 (if (equal last this)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
907 ;; O(N*H) cons-cells used here, where H is the number of
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
908 ;; headers.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
909 (setq alike (cons art alike))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
910 (if last
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
911 (progn
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
912 ;; Insert the line, with a text property on the
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
913 ;; terminating newline refering to the articles with
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
914 ;; this line.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
915 (insert last ?\n)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
916 (put-text-property (1- (point)) (point) 'articles alike)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
917 (setq alike (list art)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
918 last this))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
919 (and last ; Bwadr, duplicate code.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
920 (progn
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
921 (insert last ?\n)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
922 (put-text-property (1- (point)) (point) 'articles alike)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
923
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
924 ;; PLM: now delete those lines that contain an entry from new-thread-ids
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
925 (while new-thread-ids
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
926 (setq this-id (car new-thread-ids)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
927 new-thread-ids (cdr new-thread-ids))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
928 (goto-char (point-min))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
929 (while (search-forward this-id nil t)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
930 ;; found a match. remove this line
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
931 (beginning-of-line)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
932 (kill-line 1)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
933
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
934 ;; now for each line: update its articles with score by moving to
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
935 ;; every end-of-line in the buffer and read the articles property
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
936 (goto-char (point-min))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
937 (while (eq 0 (progn
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
938 (end-of-line)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
939 (setq arts (get-text-property (point) 'articles))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
940 (while arts
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
941 (setq art (car arts)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
942 arts (cdr arts))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
943 (setcdr art (+ score (cdr art))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
944 (forward-line))))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
945
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
946
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
947 (defun gnus-score-integer (scores header now expire &optional trace)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
948 (let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
949 entries alist)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
950
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
951 ;; Find matches.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
952 (while scores
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
953 (setq alist (car scores)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
954 scores (cdr scores)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
955 entries (assoc header alist))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
956 (while (cdr entries) ;First entry is the header index.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
957 (let* ((rest (cdr entries))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
958 (kill (car rest))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
959 (match (nth 0 kill))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
960 (type (or (nth 3 kill) '>))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
961 (score (or (nth 1 kill) gnus-score-interactive-default-score))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
962 (date (nth 2 kill))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
963 (found nil)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
964 (match-func (if (or (eq type '>) (eq type '<) (eq type '<=)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
965 (eq type '>=) (eq type '=))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
966 type
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
967 (error "Illegal match type: %s" type)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
968 (articles gnus-scores-articles))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
969 ;; Instead of doing all the clever stuff that
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
970 ;; `gnus-score-string' does to minimize searches and stuff,
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
971 ;; I will assume that people generally will put so few
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
972 ;; matches on numbers that any cleverness will take more
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
973 ;; time than one would gain.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
974 (while articles
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
975 (and (funcall match-func
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
976 (or (aref (car (car articles)) gnus-score-index) 0)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
977 match)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
978 (progn
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
979 (and trace (setq gnus-score-trace
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
980 (cons (cons (car (car articles)) kill)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
981 gnus-score-trace)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
982 (setq found t)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
983 (setcdr (car articles) (+ score (cdr (car articles))))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
984 (setq articles (cdr articles)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
985 ;; Update expire date
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
986 (cond ((null date)) ;Permanent entry.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
987 (found ;Match, update date.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
988 (gnus-score-set 'touched '(t) alist)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
989 (setcar (nthcdr 2 kill) now))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
990 ((< date expire) ;Old entry, remove.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
991 (gnus-score-set 'touched '(t) alist)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
992 (setcdr entries (cdr rest))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
993 (setq rest entries)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
994 (setq entries rest))))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
995
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
996 (defun gnus-score-date (scores header now expire &optional trace)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
997 (let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
998 entries alist)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
999
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1000 ;; Find matches.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1001 (while scores
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1002 (setq alist (car scores)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1003 scores (cdr scores)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1004 entries (assoc header alist))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1005 (while (cdr entries) ;First entry is the header index.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1006 (let* ((rest (cdr entries))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1007 (kill (car rest))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1008 (match (timezone-make-date-sortable (nth 0 kill)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1009 (type (or (nth 3 kill) 'before))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1010 (score (or (nth 1 kill) gnus-score-interactive-default-score))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1011 (date (nth 2 kill))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1012 (found nil)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1013 (match-func
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1014 (cond ((eq type 'after) 'string<)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1015 ((eq type 'before) 'gnus-string>)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1016 ((eq type 'at) 'string=)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1017 (t (error "Illegal match type: %s" type))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1018 (articles gnus-scores-articles)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1019 l)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1020 ;; Instead of doing all the clever stuff that
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1021 ;; `gnus-score-string' does to minimize searches and stuff,
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1022 ;; I will assume that people generally will put so few
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1023 ;; matches on numbers that any cleverness will take more
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1024 ;; time than one would gain.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1025 (while articles
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1026 (and
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1027 (setq l (aref (car (car articles)) gnus-score-index))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1028 (funcall match-func match (timezone-make-date-sortable l))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1029 (progn
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1030 (and trace (setq gnus-score-trace
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1031 (cons (cons (car (car articles)) kill)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1032 gnus-score-trace)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1033 (setq found t)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1034 (setcdr (car articles) (+ score (cdr (car articles))))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1035 (setq articles (cdr articles)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1036 ;; Update expire date
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1037 (cond ((null date)) ;Permanent entry.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1038 (found ;Match, update date.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1039 (gnus-score-set 'touched '(t) alist)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1040 (setcar (nthcdr 2 kill) now))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1041 ((< date expire) ;Old entry, remove.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1042 (gnus-score-set 'touched '(t) alist)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1043 (setcdr entries (cdr rest))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1044 (setq rest entries)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1045 (setq entries rest))))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1046
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1047 (defun gnus-score-body (scores header now expire &optional trace)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1048 (save-excursion
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1049 (set-buffer nntp-server-buffer)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1050 (save-restriction
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1051 (let* ((buffer-read-only nil)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1052 (articles gnus-scores-articles)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1053 (last (mail-header-number (car (car gnus-scores-articles))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1054 (all-scores scores)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1055 (request-func (cond ((string= "head" (downcase header))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1056 'gnus-request-head)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1057 ((string= "body" (downcase header))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1058 'gnus-request-body)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1059 (t 'gnus-request-article)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1060 entries alist ofunc article)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1061 ;; Not all backends support partial fetching. In that case,
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1062 ;; we just fetch the entire article.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1063 (or (gnus-check-backend-function
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1064 (and (string-match "^gnus-" (symbol-name request-func))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1065 (intern (substring (symbol-name request-func)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1066 (match-end 0))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1067 gnus-newsgroup-name)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1068 (progn
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1069 (setq ofunc request-func)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1070 (setq request-func 'gnus-request-article)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1071 (while articles
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1072 (setq article (mail-header-number (car (car articles))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1073 (gnus-message 7 "Scoring on article %s of %s..." article last)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1074 (if (not (funcall request-func article gnus-newsgroup-name))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1075 ()
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1076 (widen)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1077 (goto-char (point-min))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1078 ;; If just parts of the article is to be searched, but the
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1079 ;; backend didn't support partial fetching, we just narrow
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1080 ;; to the relevant parts.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1081 (if ofunc
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1082 (if (eq ofunc 'gnus-request-head)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1083 (narrow-to-region
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1084 (point)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1085 (or (search-forward "\n\n" nil t) (point-max)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1086 (narrow-to-region
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1087 (or (search-forward "\n\n" nil t) (point))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1088 (point-max))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1089 (setq scores all-scores)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1090 ;; Find matches.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1091 (while scores
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1092 (setq alist (car scores)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1093 scores (cdr scores)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1094 entries (assoc header alist))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1095 (while (cdr entries) ;First entry is the header index.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1096 (let* ((rest (cdr entries))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1097 (kill (car rest))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1098 (match (nth 0 kill))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1099 (type (or (nth 3 kill) 's))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1100 (score (or (nth 1 kill)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1101 gnus-score-interactive-default-score))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1102 (date (nth 2 kill))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1103 (found nil)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1104 (case-fold-search
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1105 (not (or (eq type 'R) (eq type 'S)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1106 (eq type 'Regexp) (eq type 'String))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1107 (search-func
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1108 (cond ((or (eq type 'r) (eq type 'R)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1109 (eq type 'regexp) (eq type 'Regexp))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1110 're-search-forward)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1111 ((or (eq type 's) (eq type 'S)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1112 (eq type 'string) (eq type 'String))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1113 'search-forward)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1114 (t
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1115 (error "Illegal match type: %s" type)))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1116 (goto-char (point-min))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1117 (if (funcall search-func match nil t)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1118 ;; Found a match, update scores.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1119 (progn
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1120 (setcdr (car articles) (+ score (cdr (car articles))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1121 (setq found t)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1122 (and trace (setq gnus-score-trace
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1123 (cons (cons (car (car articles)) kill)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1124 gnus-score-trace)))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1125 ;; Update expire date
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1126 (cond ((null date)) ;Permanent entry.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1127 (found ;Match, update date.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1128 (gnus-score-set 'touched '(t) alist)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1129 (setcar (nthcdr 2 kill) now))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1130 ((< date expire) ;Old entry, remove.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1131 (gnus-score-set 'touched '(t) alist)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1132 (setcdr entries (cdr rest))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1133 (setq rest entries)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1134 (setq entries rest)))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1135 (setq articles (cdr articles)))))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1136
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1137
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1138
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1139 (defun gnus-score-followup (scores header now expire &optional trace)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1140 ;; Insert the unique article headers in the buffer.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1141 (let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1142 (current-score-file gnus-current-score-file)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1143 (all-scores scores)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1144 ;; gnus-score-index is used as a free variable.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1145 alike last this art entries alist articles)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1146
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1147 ;; Change score file to the adaptive score file. All entries that
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1148 ;; this function makes will be put into this file.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1149 (gnus-score-load-file (gnus-score-file-name
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1150 gnus-newsgroup-name gnus-adaptive-file-suffix))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1151
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1152 (setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1153 articles gnus-scores-articles)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1154
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1155 (erase-buffer)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1156 (while articles
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1157 (setq art (car articles)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1158 this (aref (car art) gnus-score-index)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1159 articles (cdr articles))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1160 (if (equal last this)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1161 (setq alike (cons art alike))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1162 (if last
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1163 (progn
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1164 (insert last ?\n)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1165 (put-text-property (1- (point)) (point) 'articles alike)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1166 (setq alike (list art)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1167 last this)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1168 (and last ; Bwadr, duplicate code.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1169 (progn
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1170 (insert last ?\n)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1171 (put-text-property (1- (point)) (point) 'articles alike)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1172
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1173 ;; Find matches.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1174 (while scores
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1175 (setq alist (car scores)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1176 scores (cdr scores)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1177 entries (assoc header alist))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1178 (while (cdr entries) ;First entry is the header index.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1179 (let* ((rest (cdr entries))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1180 (kill (car rest))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1181 (match (nth 0 kill))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1182 (type (or (nth 3 kill) 's))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1183 (score (or (nth 1 kill) gnus-score-interactive-default-score))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1184 (date (nth 2 kill))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1185 (found nil)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1186 (mt (aref (symbol-name type) 0))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1187 (case-fold-search
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1188 (not (or (= mt ?R) (= mt ?S) (= mt ?E) (= mt ?F))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1189 (dmt (downcase mt))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1190 (search-func
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1191 (cond ((= dmt ?r) 're-search-forward)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1192 ((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1193 (t (error "Illegal match type: %s" type))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1194 arts art)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1195 (goto-char (point-min))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1196 (if (= dmt ?e)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1197 (while (funcall search-func match nil t)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1198 (and (= (progn (beginning-of-line) (point))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1199 (match-beginning 0))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1200 (= (progn (end-of-line) (point))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1201 (match-end 0))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1202 (progn
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1203 (setq found (setq arts (get-text-property
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1204 (point) 'articles)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1205 ;; Found a match, update scores.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1206 (while arts
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1207 (setq art (car arts)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1208 arts (cdr arts))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1209 (gnus-score-add-followups
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1210 (car art) score all-scores)))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1211 (while (funcall search-func match nil t)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1212 (end-of-line)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1213 (setq found (setq arts (get-text-property (point) 'articles)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1214 ;; Found a match, update scores.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1215 (while arts
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1216 (setq art (car arts)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1217 arts (cdr arts))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1218 (gnus-score-add-followups (car art) score all-scores))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1219 ;; Update expire date
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1220 (cond ((null date)) ;Permanent entry.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1221 (found ;Match, update date.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1222 (gnus-score-set 'touched '(t) alist)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1223 (setcar (nthcdr 2 kill) now))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1224 ((< date expire) ;Old entry, remove.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1225 (gnus-score-set 'touched '(t) alist)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1226 (setcdr entries (cdr rest))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1227 (setq rest entries)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1228 (setq entries rest))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1229 ;; We change the score file back to the previous one.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1230 (gnus-score-load-file current-score-file)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1231
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1232 (defun gnus-score-add-followups (header score scores)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1233 (save-excursion
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1234 (set-buffer gnus-summary-buffer)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1235 (let* ((id (mail-header-id header))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1236 (scores (car scores))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1237 entry dont)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1238 ;; Don't enter a score if there already is one.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1239 (while scores
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1240 (setq entry (car scores))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1241 (and (equal "references" (car entry))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1242 (or (null (nth 3 (car (cdr entry))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1243 (eq 's (nth 3 (car (cdr entry)))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1244 (progn
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1245 (if (assoc id entry)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1246 (setq dont t))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1247 (setq scores (cdr scores)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1248 (or dont
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1249 (gnus-summary-score-entry
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1250 "references" id 's score (current-time-string) nil t)))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1251
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1252
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1253 (defun gnus-score-string (score-list header now expire &optional trace)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1254 ;; Score ARTICLES according to HEADER in SCORE-LIST.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1255 ;; Update matches entries to NOW and remove unmatched entried older
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1256 ;; than EXPIRE.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1257
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1258 ;; Insert the unique article headers in the buffer.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1259 (let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1260 ;; gnus-score-index is used as a free variable.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1261 alike last this art entries alist articles scores fuzzy)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1262
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1263 ;; Sorting the articles costs os O(N*log N) but will allow us to
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1264 ;; only match with each unique header. Thus the actual matching
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1265 ;; will be O(M*U) where M is the number of strings to match with,
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1266 ;; and U is the number of unique headers. It is assumed (but
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1267 ;; untested) this will be a net win because of the large constant
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1268 ;; factor involved with string matching.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1269 (setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1270 articles gnus-scores-articles)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1271
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1272 (erase-buffer)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1273 (while articles
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1274 (setq art (car articles)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1275 this (aref (car art) gnus-score-index)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1276 articles (cdr articles))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1277 (if (equal last this)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1278 ;; O(N*H) cons-cells used here, where H is the number of
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1279 ;; headers.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1280 (setq alike (cons art alike))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1281 (if last
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1282 (progn
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1283 ;; Insert the line, with a text property on the
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1284 ;; terminating newline refering to the articles with
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1285 ;; this line.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1286 (insert last ?\n)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1287 (put-text-property (1- (point)) (point) 'articles alike)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1288 (setq alike (list art)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1289 last this)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1290 (and last ; Bwadr, duplicate code.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1291 (progn
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1292 (insert last ?\n)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1293 (put-text-property (1- (point)) (point) 'articles alike)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1294
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1295 ;; Find ordinary matches.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1296 (setq scores score-list)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1297 (while scores
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1298 (setq alist (car scores)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1299 scores (cdr scores)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1300 entries (assoc header alist))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1301 (while (cdr entries) ;First entry is the header index.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1302 (let* ((rest (cdr entries))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1303 (kill (car rest))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1304 (match (nth 0 kill))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1305 (type (or (nth 3 kill) 's))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1306 (score (or (nth 1 kill) gnus-score-interactive-default-score))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1307 (date (nth 2 kill))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1308 (found nil)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1309 (mt (aref (symbol-name type) 0))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1310 (case-fold-search
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1311 (not (or (= mt ?R) (= mt ?S) (= mt ?E) (= mt ?F))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1312 (dmt (downcase mt))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1313 (search-func
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1314 (cond ((= dmt ?r) 're-search-forward)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1315 ((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1316 (t (error "Illegal match type: %s" type))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1317 arts art)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1318 (if (= dmt ?f)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1319 (setq fuzzy t)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1320 (goto-char (point-min))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1321 (if (= dmt ?e)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1322 (while (and (not (eobp))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1323 (funcall search-func match nil t))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1324 (and (= (progn (beginning-of-line) (point))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1325 (match-beginning 0))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1326 (= (progn (end-of-line) (point))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1327 (match-end 0))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1328 (progn
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1329 (setq found (setq arts (get-text-property
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1330 (point) 'articles)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1331 ;; Found a match, update scores.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1332 (if trace
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1333 (while arts
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1334 (setq art (car arts)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1335 arts (cdr arts))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1336 (setcdr art (+ score (cdr art)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1337 (setq gnus-score-trace
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1338 (cons (cons (mail-header-number
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1339 (car art)) kill)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1340 gnus-score-trace)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1341 (while arts
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1342 (setq art (car arts)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1343 arts (cdr arts))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1344 (setcdr art (+ score (cdr art)))))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1345 (forward-line 1))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1346 (and (string= match "") (setq match "\n"))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1347 (while (and (not (eobp))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1348 (funcall search-func match nil t))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1349 (goto-char (match-beginning 0))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1350 (end-of-line)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1351 (setq found (setq arts (get-text-property (point) 'articles)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1352 ;; Found a match, update scores.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1353 (if trace
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1354 (while arts
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1355 (setq art (car arts)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1356 arts (cdr arts))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1357 (setcdr art (+ score (cdr art)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1358 (setq gnus-score-trace
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1359 (cons (cons (mail-header-number (car art)) kill)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1360 gnus-score-trace)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1361 (while arts
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1362 (setq art (car arts)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1363 arts (cdr arts))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1364 (setcdr art (+ score (cdr art)))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1365 (forward-line 1)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1366 ;; Update expire date
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1367 (cond ((null date)) ;Permanent entry.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1368 (found ;Match, update date.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1369 (gnus-score-set 'touched '(t) alist)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1370 (setcar (nthcdr 2 kill) now))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1371 ((< date expire) ;Old entry, remove.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1372 (gnus-score-set 'touched '(t) alist)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1373 (setcdr entries (cdr rest))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1374 (setq rest entries))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1375 (setq entries rest))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1376
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1377 ;; Find fuzzy matches.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1378 (setq scores (and fuzzy score-list))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1379 (if fuzzy (gnus-simplify-buffer-fuzzy))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1380 (while scores
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1381 (setq alist (car scores)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1382 scores (cdr scores)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1383 entries (assoc header alist))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1384 (while (cdr entries) ;First entry is the header index.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1385 (let* ((rest (cdr entries))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1386 (kill (car rest))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1387 (match (nth 0 kill))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1388 (type (or (nth 3 kill) 's))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1389 (score (or (nth 1 kill) gnus-score-interactive-default-score))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1390 (date (nth 2 kill))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1391 (found nil)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1392 (mt (aref (symbol-name type) 0))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1393 (case-fold-search
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1394 (not (or (= mt ?R) (= mt ?S) (= mt ?E) (= mt ?F))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1395 (dmt (downcase mt))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1396 (search-func
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1397 (cond ((= dmt ?r) 're-search-forward)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1398 ((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1399 (t (error "Illegal match type: %s" type))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1400 arts art)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1401 (if (/= dmt ?f)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1402 ()
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1403 (goto-char (point-min))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1404 (while (and (not (eobp))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1405 (funcall search-func match nil t))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1406 (and (= (progn (beginning-of-line) (point))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1407 (match-beginning 0))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1408 (= (progn (end-of-line) (point))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1409 (match-end 0))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1410 (progn
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1411 (setq found (setq arts (get-text-property
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1412 (point) 'articles)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1413 ;; Found a match, update scores.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1414 (if trace
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1415 (while arts
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1416 (setq art (car arts)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1417 arts (cdr arts))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1418 (setcdr art (+ score (cdr art)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1419 (setq gnus-score-trace
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1420 (cons (cons (mail-header-number
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1421 (car art)) kill)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1422 gnus-score-trace)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1423 (while arts
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1424 (setq art (car arts)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1425 arts (cdr arts))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1426 (setcdr art (+ score (cdr art)))))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1427 (forward-line 1))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1428 ;; Update expire date
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1429 (cond ((null date)) ;Permanent entry.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1430 (found ;Match, update date.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1431 (gnus-score-set 'touched '(t) alist)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1432 (setcar (nthcdr 2 kill) now))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1433 ((< date expire) ;Old entry, remove.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1434 (gnus-score-set 'touched '(t) alist)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1435 (setcdr entries (cdr rest))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1436 (setq rest entries))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1437 (setq entries rest))))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1438
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1439 (defun gnus-score-string< (a1 a2)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1440 ;; Compare headers in articles A2 and A2.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1441 ;; The header index used is the free variable `gnus-score-index'.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1442 (string-lessp (aref (car a1) gnus-score-index)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1443 (aref (car a2) gnus-score-index)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1444
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1445 (defun gnus-score-build-cons (article)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1446 ;; Build a `gnus-newsgroup-scored' type cons from ARTICLE.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1447 (cons (mail-header-number (car article)) (cdr article)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1448
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1449 (defconst gnus-header-index
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1450 ;; Name to index alist.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1451 '(("number" 0 gnus-score-integer)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1452 ("subject" 1 gnus-score-string)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1453 ("from" 2 gnus-score-string)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1454 ("date" 3 gnus-score-date)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1455 ("message-id" 4 gnus-score-string)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1456 ("references" 5 gnus-score-string)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1457 ("chars" 6 gnus-score-integer)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1458 ("lines" 7 gnus-score-integer)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1459 ("xref" 8 gnus-score-string)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1460 ("head" -1 gnus-score-body)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1461 ("body" -1 gnus-score-body)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1462 ("all" -1 gnus-score-body)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1463 ("followup" 2 gnus-score-followup)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1464
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1465 (defun gnus-current-score-file-nondirectory (&optional score-file)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1466 (let ((score-file (or score-file gnus-current-score-file)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1467 (if score-file
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1468 (gnus-short-group-name (file-name-nondirectory score-file))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1469 "none")))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1470
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1471 (defun gnus-score-adaptive ()
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1472 (save-excursion
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1473 (let* ((malist (gnus-copy-sequence gnus-adaptive-score-alist))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1474 (alist malist)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1475 (date (current-time-string))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1476 elem headers match)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1477 ;; First we transform the adaptive rule alist into something
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1478 ;; that's faster to process.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1479 (while malist
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1480 (setq elem (car malist))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1481 (if (symbolp (car elem))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1482 (setcar elem (symbol-value (car elem))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1483 (setq elem (cdr elem))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1484 (while elem
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1485 (setcdr (car elem)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1486 (cons (symbol-name (car (car elem))) (cdr (car elem))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1487 (setcar (car elem)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1488 (intern
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1489 (concat "gnus-header-"
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1490 (downcase (symbol-name (car (car elem)))))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1491 (setq elem (cdr elem)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1492 (setq malist (cdr malist)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1493 ;; We change the score file to the adaptive score file.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1494 (gnus-score-load-file (gnus-score-file-name
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1495 gnus-newsgroup-name gnus-adaptive-file-suffix))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1496 ;; The we score away.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1497 (goto-char (point-min))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1498 (while (not (eobp))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1499 (setq elem (cdr (assq (gnus-summary-article-mark) alist)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1500 (if (or (not elem)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1501 (get-text-property (point) 'gnus-pseudo))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1502 ()
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1503 (setq headers (gnus-get-header-by-number
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1504 (gnus-summary-article-number)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1505 (while (and elem headers)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1506 (setq match (funcall (car (car elem)) headers))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1507 (gnus-summary-score-entry
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1508 (nth 1 (car elem)) match
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1509 (cond
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1510 ((numberp match)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1511 '=)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1512 ((equal (nth 1 (car elem)) "date")
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1513 'a)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1514 (t
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1515 ;; Whether we use substring or exact matches are controlled
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1516 ;; here.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1517 (if (or (not gnus-score-exact-adapt-limit)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1518 (< (length match) gnus-score-exact-adapt-limit))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1519 'e
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1520 (if (equal (nth 1 (car elem)) "subject")
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1521 'f 's))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1522 (nth 2 (car elem)) date nil t)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1523 (setq elem (cdr elem))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1524 (forward-line 1)))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1525
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1526 (defun gnus-score-remove-lines-adaptive (marks)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1527 (save-excursion
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1528 (let* ((malist (gnus-copy-sequence gnus-adaptive-score-alist))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1529 (alist malist)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1530 (date (current-time-string))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1531 (cur-score gnus-current-score-file)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1532 elem headers match)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1533 ;; First we transform the adaptive rule alist into something
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1534 ;; that's faster to process.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1535 (while malist
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1536 (setq elem (car malist))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1537 (if (symbolp (car elem))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1538 (setcar elem (symbol-value (car elem))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1539 (setq elem (cdr elem))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1540 (while elem
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1541 (setcdr (car elem)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1542 (cons (symbol-name (car (car elem))) (cdr (car elem))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1543 (setcar (car elem)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1544 (intern
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1545 (concat "gnus-header-"
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1546 (downcase (symbol-name (car (car elem)))))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1547 (setq elem (cdr elem)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1548 (setq malist (cdr malist)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1549 ;; The we score away.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1550 (goto-char (point-min))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1551 ;; We change the score file to the adaptive score file.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1552 (gnus-score-load-file (gnus-score-file-name
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1553 gnus-newsgroup-name gnus-adaptive-file-suffix))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1554 (while (re-search-forward marks nil t)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1555 (beginning-of-line)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1556 (setq elem (cdr (assq (gnus-summary-article-mark) alist)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1557 (if (or (not elem)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1558 (get-text-property (gnus-point-at-bol) 'gnus-pseudo))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1559 ()
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1560 (setq headers (gnus-get-header-by-number
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1561 (gnus-summary-article-number)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1562 (while elem
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1563 (setq match (funcall (car (car elem)) headers))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1564 (gnus-summary-score-entry
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1565 (nth 1 (car elem)) match
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1566 (if (or (not gnus-score-exact-adapt-limit)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1567 (< (length match) gnus-score-exact-adapt-limit))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1568 'e 's)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1569 (nth 2 (car elem)) date nil t)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1570 (setq elem (cdr elem))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1571 (delete-region (point) (progn (forward-line 1) (point))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1572 ;; Switch back to the old score file.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1573 (gnus-score-load-file cur-score))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1574
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1575 ;;;
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1576 ;;; Score mode.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1577 ;;;
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1578
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1579 (defvar gnus-score-mode-map nil)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1580 (defvar gnus-score-mode-hook nil)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1581
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1582 (if gnus-score-mode-map
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1583 ()
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1584 (setq gnus-score-mode-map (copy-keymap emacs-lisp-mode-map))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1585 (define-key gnus-score-mode-map "\C-c\C-c" 'gnus-score-edit-done)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1586 (define-key gnus-score-mode-map "\C-c\C-d" 'gnus-score-edit-insert-date))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1587
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1588 (defun gnus-score-mode ()
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1589 "Mode for editing score files.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1590 This mode is an extended emacs-lisp mode.
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1591
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1592 \\{gnus-score-mode-map}"
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1593 (interactive)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1594 (kill-all-local-variables)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1595 (use-local-map gnus-score-mode-map)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1596 (set-syntax-table emacs-lisp-mode-syntax-table)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1597 (setq major-mode 'gnus-score-mode)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1598 (setq mode-name "Score")
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1599 (lisp-mode-variables nil)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1600 (run-hooks 'emacs-lisp-mode-hook 'gnus-score-mode-hook))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1601
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1602 (defun gnus-score-edit-insert-date ()
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1603 "Insert date in numerical format."
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1604 (interactive)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1605 (insert (int-to-string (gnus-day-number (current-time-string)))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1606
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1607 (defun gnus-score-edit-done ()
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1608 "Save the score file and return to the summary buffer."
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1609 (interactive)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1610 (let ((bufnam (buffer-file-name (current-buffer)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1611 (winconf gnus-prev-winconf))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1612 (gnus-make-directory (file-name-directory (buffer-file-name)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1613 (save-buffer)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1614 (kill-buffer (current-buffer))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1615 (gnus-score-remove-from-cache bufnam)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1616 (gnus-score-load-file bufnam)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1617 (and winconf (set-window-configuration winconf))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1618
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1619 (defun gnus-score-find-trace ()
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1620 "Find all score rules applied to this article."
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1621 (interactive)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1622 (let ((gnus-newsgroup-headers
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1623 (list (gnus-get-header-by-number (gnus-summary-article-number))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1624 (gnus-newsgroup-scored nil)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1625 (buf (current-buffer))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1626 trace)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1627 (setq gnus-score-trace nil)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1628 (gnus-possibly-score-headers 'trace)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1629 (or (setq trace gnus-score-trace)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1630 (error "No score rules apply to the current article."))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1631 (pop-to-buffer "*Gnus Scores*")
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1632 (gnus-add-current-to-buffer-list)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1633 (erase-buffer)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1634 (while trace
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1635 (insert (format "%S\n" (cdr (car trace))))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1636 (setq trace (cdr trace)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1637 (goto-char (point-min))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1638 (pop-to-buffer buf)))
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1639
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1640
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1641 (provide 'gnus-score)
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1642
178d730efae2 entered into RCS
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
diff changeset
1643 ;;; gnus-score.el ends here