|
140
|
1 1;;; gnus-score.el --- scoring code for Gnus
|
|
98
|
2 ;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
|
|
0
|
3
|
|
|
4 ;; Author: Per Abrahamsen <amanda@iesd.auc.dk>
|
|
|
5 ;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
|
|
|
6 ;; Keywords: news
|
|
|
7
|
|
|
8 ;; This file is part of GNU Emacs.
|
|
|
9
|
|
|
10 ;; GNU Emacs is free software; you can redistribute it and/or modify
|
|
|
11 ;; it under the terms of the GNU General Public License as published by
|
|
|
12 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
13 ;; any later version.
|
|
|
14
|
|
|
15 ;; GNU Emacs is distributed in the hope that it will be useful,
|
|
|
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
18 ;; GNU General Public License for more details.
|
|
|
19
|
|
|
20 ;; You should have received a copy of the GNU General Public License
|
|
|
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
|
|
|
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
|
23 ;; Boston, MA 02111-1307, USA.
|
|
|
24
|
|
|
25 ;;; Commentary:
|
|
|
26
|
|
|
27 ;;; Code:
|
|
|
28
|
|
|
29 (require 'gnus)
|
|
98
|
30 (require 'gnus-sum)
|
|
|
31 (require 'gnus-range)
|
|
0
|
32
|
|
98
|
33 (defcustom gnus-global-score-files nil
|
|
|
34 "List of global score files and directories.
|
|
0
|
35 Set this variable if you want to use people's score files. One entry
|
|
|
36 for each score file or each score file directory. Gnus will decide
|
|
|
37 by itself what score files are applicable to which group.
|
|
|
38
|
|
|
39 Say you want to use the single score file
|
|
118
|
40 \"/ftp.gnus.org@ftp:/pub/larsi/ding/score/soc.motss.SCORE\" and all
|
|
0
|
41 score files in the \"/ftp.some-where:/pub/score\" directory.
|
|
|
42
|
|
|
43 (setq gnus-global-score-files
|
|
118
|
44 '(\"/ftp.gnus.org:/pub/larsi/ding/score/soc.motss.SCORE\"
|
|
98
|
45 \"/ftp.some-where:/pub/score\"))"
|
|
100
|
46 :group 'gnus-score-files
|
|
98
|
47 :type '(repeat file))
|
|
0
|
48
|
|
98
|
49 (defcustom gnus-score-file-single-match-alist nil
|
|
|
50 "Alist mapping regexps to lists of score files.
|
|
0
|
51 Each element of this alist should be of the form
|
|
|
52 (\"REGEXP\" [ \"SCORE-FILE-1\" ] [ \"SCORE-FILE-2\" ] ... )
|
|
|
53
|
|
|
54 If the name of a group is matched by REGEXP, the corresponding scorefiles
|
|
|
55 will be used for that group.
|
|
|
56 The first match found is used, subsequent matching entries are ignored (to
|
|
|
57 use multiple matches, see gnus-score-file-multiple-match-alist).
|
|
|
58
|
|
|
59 These score files are loaded in addition to any files returned by
|
|
98
|
60 gnus-score-find-score-files-function (which see)."
|
|
100
|
61 :group 'gnus-score-files
|
|
98
|
62 :type '(repeat (cons regexp (repeat file))))
|
|
0
|
63
|
|
98
|
64 (defcustom gnus-score-file-multiple-match-alist nil
|
|
|
65 "Alist mapping regexps to lists of score files.
|
|
0
|
66 Each element of this alist should be of the form
|
|
|
67 (\"REGEXP\" [ \"SCORE-FILE-1\" ] [ \"SCORE-FILE-2\" ] ... )
|
|
|
68
|
|
|
69 If the name of a group is matched by REGEXP, the corresponding scorefiles
|
|
|
70 will be used for that group.
|
|
|
71 If multiple REGEXPs match a group, the score files corresponding to each
|
|
|
72 match will be used (for only one match to be used, see
|
|
|
73 gnus-score-file-single-match-alist).
|
|
|
74
|
|
|
75 These score files are loaded in addition to any files returned by
|
|
98
|
76 gnus-score-find-score-files-function (which see)."
|
|
100
|
77 :group 'gnus-score-files
|
|
98
|
78 :type '(repeat (cons regexp (repeat file))))
|
|
0
|
79
|
|
98
|
80 (defcustom gnus-score-file-suffix "SCORE"
|
|
|
81 "Suffix of the score files."
|
|
100
|
82 :group 'gnus-score-files
|
|
98
|
83 :type 'string)
|
|
16
|
84
|
|
98
|
85 (defcustom gnus-adaptive-file-suffix "ADAPT"
|
|
|
86 "Suffix of the adaptive score files."
|
|
100
|
87 :group 'gnus-score-files
|
|
|
88 :group 'gnus-score-adapt
|
|
98
|
89 :type 'string)
|
|
|
90
|
|
|
91 (defcustom gnus-score-find-score-files-function 'gnus-score-find-bnews
|
|
|
92 "Function used to find score files.
|
|
0
|
93 The function will be called with the group name as the argument, and
|
|
|
94 should return a list of score files to apply to that group. The score
|
|
|
95 files do not actually have to exist.
|
|
|
96
|
|
|
97 Predefined values are:
|
|
|
98
|
|
|
99 gnus-score-find-single: Only apply the group's own score file.
|
|
|
100 gnus-score-find-hierarchical: Also apply score files from parent groups.
|
|
|
101 gnus-score-find-bnews: Apply score files whose names matches.
|
|
|
102
|
|
|
103 See the documentation to these functions for more information.
|
|
|
104
|
|
|
105 This variable can also be a list of functions to be called. Each
|
|
|
106 function should either return a list of score files, or a list of
|
|
98
|
107 score alists."
|
|
100
|
108 :group 'gnus-score-files
|
|
98
|
109 :type '(radio (function-item gnus-score-find-single)
|
|
|
110 (function-item gnus-score-find-hierarchical)
|
|
|
111 (function-item gnus-score-find-bnews)
|
|
|
112 (function :tag "Other")))
|
|
0
|
113
|
|
98
|
114 (defcustom gnus-score-interactive-default-score 1000
|
|
|
115 "*Scoring commands will raise/lower the score with this number as the default."
|
|
100
|
116 :group 'gnus-score-default
|
|
98
|
117 :type 'integer)
|
|
|
118
|
|
|
119 (defcustom gnus-score-expiry-days 7
|
|
0
|
120 "*Number of days before unused score file entries are expired.
|
|
98
|
121 If this variable is nil, no score file entries will be expired."
|
|
100
|
122 :group 'gnus-score-expire
|
|
98
|
123 :type '(choice (const :tag "never" nil)
|
|
|
124 number))
|
|
0
|
125
|
|
98
|
126 (defcustom gnus-update-score-entry-dates t
|
|
0
|
127 "*In non-nil, update matching score entry dates.
|
|
|
128 If this variable is nil, then score entries that provide matches
|
|
98
|
129 will be expired along with non-matching score entries."
|
|
100
|
130 :group 'gnus-score-expire
|
|
98
|
131 :type 'boolean)
|
|
|
132
|
|
|
133 (defcustom gnus-orphan-score nil
|
|
|
134 "*All orphans get this score added. Set in the score file."
|
|
100
|
135 :group 'gnus-score-default
|
|
98
|
136 :type 'integer)
|
|
|
137
|
|
|
138 (defcustom gnus-decay-scores nil
|
|
|
139 "*If non-nil, decay non-permanent scores."
|
|
100
|
140 :group 'gnus-score-decay
|
|
98
|
141 :type 'boolean)
|
|
|
142
|
|
|
143 (defcustom gnus-decay-score-function 'gnus-decay-score
|
|
|
144 "*Function called to decay a score.
|
|
|
145 It is called with one parameter -- the score to be decayed."
|
|
100
|
146 :group 'gnus-score-decay
|
|
98
|
147 :type '(radio (function-item gnus-decay-score)
|
|
|
148 (function :tag "Other")))
|
|
|
149
|
|
|
150 (defcustom gnus-score-decay-constant 3
|
|
|
151 "*Decay all \"small\" scores with this amount."
|
|
100
|
152 :group 'gnus-score-decay
|
|
98
|
153 :type 'integer)
|
|
|
154
|
|
|
155 (defcustom gnus-score-decay-scale .05
|
|
|
156 "*Decay all \"big\" scores with this factor."
|
|
100
|
157 :group 'gnus-score-decay
|
|
98
|
158 :type 'number)
|
|
|
159
|
|
|
160 (defcustom gnus-home-score-file nil
|
|
|
161 "Variable to control where interactive score entries are to go.
|
|
|
162 It can be:
|
|
|
163
|
|
|
164 * A string
|
|
|
165 This file file will be used as the home score file.
|
|
0
|
166
|
|
98
|
167 * A function
|
|
|
168 The result of this function will be used as the home score file.
|
|
|
169 The function will be passed the name of the group as its
|
|
|
170 parameter.
|
|
|
171
|
|
|
172 * A list
|
|
|
173 The elements in this list can be:
|
|
|
174
|
|
|
175 * `(regexp file-name ...)'
|
|
|
176 If the `regexp' matches the group name, the first `file-name' will
|
|
|
177 will be used as the home score file. (Multiple filenames are
|
|
|
178 allowed so that one may use gnus-score-file-single-match-alist to
|
|
|
179 set this variable.)
|
|
|
180
|
|
|
181 * A function.
|
|
|
182 If the function returns non-nil, the result will be used
|
|
108
|
183 as the home score file. The function will be passed the
|
|
98
|
184 name of the group as its parameter.
|
|
|
185
|
|
|
186 * A string. Use the string as the home score file.
|
|
0
|
187
|
|
98
|
188 The list will be traversed from the beginning towards the end looking
|
|
|
189 for matches."
|
|
100
|
190 :group 'gnus-score-files
|
|
98
|
191 :type '(choice string
|
|
|
192 (repeat (choice string
|
|
|
193 (cons regexp (repeat file))
|
|
|
194 function))
|
|
|
195 function))
|
|
|
196
|
|
|
197 (defcustom gnus-home-adapt-file nil
|
|
|
198 "Variable to control where new adaptive score entries are to go.
|
|
|
199 This variable allows the same syntax as `gnus-home-score-file'."
|
|
100
|
200 :group 'gnus-score-adapt
|
|
|
201 :group 'gnus-score-files
|
|
98
|
202 :type '(choice string
|
|
|
203 (repeat (choice string
|
|
|
204 (cons regexp (repeat file))
|
|
|
205 function))
|
|
|
206 function))
|
|
|
207
|
|
108
|
208 (defcustom gnus-default-adaptive-score-alist
|
|
0
|
209 '((gnus-kill-file-mark)
|
|
|
210 (gnus-unread-mark)
|
|
98
|
211 (gnus-read-mark (from 3) (subject 30))
|
|
0
|
212 (gnus-catchup-mark (subject -10))
|
|
|
213 (gnus-killed-mark (from -1) (subject -20))
|
|
|
214 (gnus-del-mark (from -2) (subject -15)))
|
|
98
|
215 "Alist of marks and scores."
|
|
100
|
216 :group 'gnus-score-adapt
|
|
98
|
217 :type '(repeat (cons (symbol :tag "Mark")
|
|
|
218 (repeat (list (choice :tag "Header"
|
|
|
219 (const from)
|
|
|
220 (const subject)
|
|
|
221 (symbol :tag "other"))
|
|
|
222 (integer :tag "Score"))))))
|
|
|
223
|
|
|
224 (defcustom gnus-ignored-adaptive-words nil
|
|
|
225 "List of words to be ignored when doing adaptive word scoring."
|
|
100
|
226 :group 'gnus-score-adapt
|
|
98
|
227 :type '(repeat string))
|
|
0
|
228
|
|
98
|
229 (defcustom gnus-default-ignored-adaptive-words
|
|
|
230 '("a" "i" "the" "to" "of" "and" "in" "is" "it" "for" "that" "if" "you"
|
|
|
231 "this" "be" "on" "with" "not" "have" "are" "or" "as" "from" "can"
|
|
|
232 "but" "by" "at" "an" "will" "no" "all" "was" "do" "there" "my" "one"
|
|
|
233 "so" "we" "they" "what" "would" "any" "which" "about" "get" "your"
|
|
|
234 "use" "some" "me" "then" "name" "like" "out" "when" "up" "time"
|
|
|
235 "other" "more" "only" "just" "end" "also" "know" "how" "new" "should"
|
|
|
236 "been" "than" "them" "he" "who" "make" "may" "people" "these" "now"
|
|
|
237 "their" "here" "into" "first" "could" "way" "had" "see" "work" "well"
|
|
|
238 "were" "two" "very" "where" "while" "us" "because" "good" "same"
|
|
|
239 "even" "much" "most" "many" "such" "long" "his" "over" "last" "since"
|
|
|
240 "right" "before" "our" "without" "too" "those" "why" "must" "part"
|
|
|
241 "being" "current" "back" "still" "go" "point" "value" "each" "did"
|
|
|
242 "both" "true" "off" "say" "another" "state" "might" "under" "start"
|
|
|
243 "try" "re")
|
|
|
244 "Default list of words to be ignored when doing adaptive word scoring."
|
|
100
|
245 :group 'gnus-score-adapt
|
|
98
|
246 :type '(repeat string))
|
|
0
|
247
|
|
108
|
248 (defcustom gnus-default-adaptive-word-score-alist
|
|
98
|
249 `((,gnus-read-mark . 30)
|
|
|
250 (,gnus-catchup-mark . -10)
|
|
|
251 (,gnus-killed-mark . -20)
|
|
|
252 (,gnus-del-mark . -15))
|
|
|
253 "Alist of marks and scores."
|
|
100
|
254 :group 'gnus-score-adapt
|
|
98
|
255 :type '(repeat (cons (character :tag "Mark")
|
|
|
256 (integer :tag "Score"))))
|
|
|
257
|
|
|
258 (defcustom gnus-score-mimic-keymap nil
|
|
|
259 "*Have the score entry functions pretend that they are a keymap."
|
|
100
|
260 :group 'gnus-score-default
|
|
98
|
261 :type 'boolean)
|
|
|
262
|
|
|
263 (defcustom gnus-score-exact-adapt-limit 10
|
|
0
|
264 "*Number that says how long a match has to be before using substring matching.
|
|
|
265 When doing adaptive scoring, one normally uses fuzzy or substring
|
|
|
266 matching. However, if the header one matches is short, the possibility
|
|
|
267 for false positives is great, so if the length of the match is less
|
|
|
268 than this variable, exact matching will be used.
|
|
|
269
|
|
98
|
270 If this variable is nil, exact matching will always be used."
|
|
100
|
271 :group 'gnus-score-adapt
|
|
98
|
272 :type '(choice (const nil) integer))
|
|
0
|
273
|
|
98
|
274 (defcustom gnus-score-uncacheable-files "ADAPT$"
|
|
|
275 "All score files that match this regexp will not be cached."
|
|
100
|
276 :group 'gnus-score-adapt
|
|
|
277 :group 'gnus-score-files
|
|
98
|
278 :type 'regexp)
|
|
0
|
279
|
|
98
|
280 (defcustom gnus-score-default-header nil
|
|
0
|
281 "Default header when entering new scores.
|
|
|
282
|
|
|
283 Should be one of the following symbols.
|
|
|
284
|
|
|
285 a: from
|
|
|
286 s: subject
|
|
|
287 b: body
|
|
|
288 h: head
|
|
|
289 i: message-id
|
|
|
290 t: references
|
|
|
291 x: xref
|
|
|
292 l: lines
|
|
|
293 d: date
|
|
|
294 f: followup
|
|
|
295
|
|
98
|
296 If nil, the user will be asked for a header."
|
|
100
|
297 :group 'gnus-score-default
|
|
98
|
298 :type '(choice (const :tag "from" a)
|
|
|
299 (const :tag "subject" s)
|
|
|
300 (const :tag "body" b)
|
|
|
301 (const :tag "head" h)
|
|
|
302 (const :tag "message-id" i)
|
|
|
303 (const :tag "references" t)
|
|
|
304 (const :tag "xref" x)
|
|
|
305 (const :tag "lines" l)
|
|
|
306 (const :tag "date" d)
|
|
|
307 (const :tag "followup" f)))
|
|
0
|
308
|
|
98
|
309 (defcustom gnus-score-default-type nil
|
|
0
|
310 "Default match type when entering new scores.
|
|
|
311
|
|
|
312 Should be one of the following symbols.
|
|
|
313
|
|
|
314 s: substring
|
|
|
315 e: exact string
|
|
|
316 f: fuzzy string
|
|
|
317 r: regexp string
|
|
|
318 b: before date
|
|
|
319 a: at date
|
|
|
320 n: this date
|
|
|
321 <: less than number
|
|
|
322 >: greater than number
|
|
|
323 =: equal to number
|
|
|
324
|
|
98
|
325 If nil, the user will be asked for a match type."
|
|
100
|
326 :group 'gnus-score-default
|
|
98
|
327 :type '(choice (const :tag "substring" s)
|
|
|
328 (const :tag "exact string" e)
|
|
|
329 (const :tag "fuzzy string" f)
|
|
|
330 (const :tag "regexp string" r)
|
|
|
331 (const :tag "before date" b)
|
|
|
332 (const :tag "at date" a)
|
|
|
333 (const :tag "this date" n)
|
|
|
334 (const :tag "less than number" <)
|
|
|
335 (const :tag "greater than number" >)
|
|
|
336 (const :tag "equal than number" =)))
|
|
0
|
337
|
|
98
|
338 (defcustom gnus-score-default-fold nil
|
|
|
339 "Use case folding for new score file entries iff not nil."
|
|
100
|
340 :group 'gnus-score-default
|
|
98
|
341 :type 'boolean)
|
|
0
|
342
|
|
98
|
343 (defcustom gnus-score-default-duration nil
|
|
0
|
344 "Default duration of effect when entering new scores.
|
|
|
345
|
|
|
346 Should be one of the following symbols.
|
|
|
347
|
|
|
348 t: temporary
|
|
|
349 p: permanent
|
|
|
350 i: immediate
|
|
|
351
|
|
98
|
352 If nil, the user will be asked for a duration."
|
|
100
|
353 :group 'gnus-score-default
|
|
98
|
354 :type '(choice (const :tag "temporary" t)
|
|
|
355 (const :tag "permanent" p)
|
|
120
|
356 (const :tag "immediate" i)
|
|
|
357 (const :tag "ask" nil)))
|
|
0
|
358
|
|
98
|
359 (defcustom gnus-score-after-write-file-function nil
|
|
|
360 "Function called with the name of the score file just written to disk."
|
|
100
|
361 :group 'gnus-score-files
|
|
98
|
362 :type 'function)
|
|
0
|
363
|
|
|
364
|
|
|
365
|
|
|
366 ;; Internal variables.
|
|
|
367
|
|
98
|
368 (defvar gnus-adaptive-word-syntax-table
|
|
|
369 (let ((table (copy-syntax-table (standard-syntax-table)))
|
|
|
370 (numbers '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)))
|
|
|
371 (while numbers
|
|
|
372 (modify-syntax-entry (pop numbers) " " table))
|
|
|
373 (modify-syntax-entry ?' "w" table)
|
|
|
374 table)
|
|
|
375 "Syntax table used when doing adaptive word scoring.")
|
|
|
376
|
|
|
377 (defvar gnus-scores-exclude-files nil)
|
|
0
|
378 (defvar gnus-internal-global-score-files nil)
|
|
|
379 (defvar gnus-score-file-list nil)
|
|
|
380
|
|
|
381 (defvar gnus-short-name-score-file-cache nil)
|
|
|
382
|
|
|
383 (defvar gnus-score-help-winconf nil)
|
|
|
384 (defvar gnus-adaptive-score-alist gnus-default-adaptive-score-alist)
|
|
98
|
385 (defvar gnus-adaptive-word-score-alist gnus-default-adaptive-word-score-alist)
|
|
0
|
386 (defvar gnus-score-trace nil)
|
|
|
387 (defvar gnus-score-edit-buffer nil)
|
|
|
388
|
|
|
389 (defvar gnus-score-alist nil
|
|
|
390 "Alist containing score information.
|
|
108
|
391 The keys can be symbols or strings. The following symbols are defined.
|
|
0
|
392
|
|
|
393 touched: If this alist has been modified.
|
|
|
394 mark: Automatically mark articles below this.
|
|
|
395 expunge: Automatically expunge articles below this.
|
|
|
396 files: List of other score files to load when loading this one.
|
|
|
397 eval: Sexp to be evaluated when the score file is loaded.
|
|
|
398
|
|
98
|
399 String entries have the form (HEADER (MATCH TYPE SCORE DATE) ...)
|
|
0
|
400 where HEADER is the header being scored, MATCH is the string we are
|
|
|
401 looking for, TYPE is a flag indicating whether it should use regexp or
|
|
|
402 substring matching, SCORE is the score to add and DATE is the date
|
|
|
403 of the last successful match.")
|
|
|
404
|
|
|
405 (defvar gnus-score-cache nil)
|
|
|
406 (defvar gnus-scores-articles nil)
|
|
|
407 (defvar gnus-score-index nil)
|
|
|
408
|
|
|
409
|
|
|
410 (defconst gnus-header-index
|
|
|
411 ;; Name to index alist.
|
|
|
412 '(("number" 0 gnus-score-integer)
|
|
|
413 ("subject" 1 gnus-score-string)
|
|
|
414 ("from" 2 gnus-score-string)
|
|
|
415 ("date" 3 gnus-score-date)
|
|
98
|
416 ("message-id" 4 gnus-score-string)
|
|
|
417 ("references" 5 gnus-score-string)
|
|
|
418 ("chars" 6 gnus-score-integer)
|
|
|
419 ("lines" 7 gnus-score-integer)
|
|
0
|
420 ("xref" 8 gnus-score-string)
|
|
|
421 ("head" -1 gnus-score-body)
|
|
|
422 ("body" -1 gnus-score-body)
|
|
|
423 ("all" -1 gnus-score-body)
|
|
|
424 ("followup" 2 gnus-score-followup)
|
|
|
425 ("thread" 5 gnus-score-thread)))
|
|
|
426
|
|
|
427 ;;; Summary mode score maps.
|
|
|
428
|
|
98
|
429 (gnus-define-keys (gnus-summary-score-map "V" gnus-summary-mode-map)
|
|
|
430 "s" gnus-summary-set-score
|
|
|
431 "a" gnus-summary-score-entry
|
|
|
432 "S" gnus-summary-current-score
|
|
|
433 "c" gnus-score-change-score-file
|
|
|
434 "C" gnus-score-customize
|
|
|
435 "m" gnus-score-set-mark-below
|
|
|
436 "x" gnus-score-set-expunge-below
|
|
|
437 "R" gnus-summary-rescore
|
|
|
438 "e" gnus-score-edit-current-scores
|
|
|
439 "f" gnus-score-edit-file
|
|
|
440 "F" gnus-score-flush-cache
|
|
|
441 "t" gnus-score-find-trace
|
|
|
442 "w" gnus-score-find-favourite-words)
|
|
0
|
443
|
|
|
444 ;; Summary score file commands
|
|
|
445
|
|
|
446 ;; Much modification of the kill (ahem, score) code and lots of the
|
|
|
447 ;; functions are written by Per Abrahamsen <amanda@iesd.auc.dk>.
|
|
|
448
|
|
|
449 (defun gnus-summary-lower-score (&optional score)
|
|
|
450 "Make a score entry based on the current article.
|
|
|
451 The user will be prompted for header to score on, match type,
|
|
|
452 permanence, and the string to be used. The numerical prefix will be
|
|
|
453 used as score."
|
|
|
454 (interactive "P")
|
|
|
455 (gnus-summary-increase-score (- (gnus-score-default score))))
|
|
|
456
|
|
|
457 (defun gnus-score-kill-help-buffer ()
|
|
|
458 (when (get-buffer "*Score Help*")
|
|
|
459 (kill-buffer "*Score Help*")
|
|
98
|
460 (when gnus-score-help-winconf
|
|
|
461 (set-window-configuration gnus-score-help-winconf))))
|
|
0
|
462
|
|
|
463 (defun gnus-summary-increase-score (&optional score)
|
|
|
464 "Make a score entry based on the current article.
|
|
|
465 The user will be prompted for header to score on, match type,
|
|
|
466 permanence, and the string to be used. The numerical prefix will be
|
|
|
467 used as score."
|
|
|
468 (interactive "P")
|
|
|
469 (gnus-set-global-variables)
|
|
|
470 (let* ((nscore (gnus-score-default score))
|
|
|
471 (prefix (if (< nscore 0) ?L ?I))
|
|
|
472 (increase (> nscore 0))
|
|
108
|
473 (char-to-header
|
|
0
|
474 '((?a "from" nil nil string)
|
|
|
475 (?s "subject" nil nil string)
|
|
|
476 (?b "body" "" nil body-string)
|
|
|
477 (?h "head" "" nil body-string)
|
|
|
478 (?i "message-id" nil t string)
|
|
|
479 (?t "references" "message-id" nil string)
|
|
|
480 (?x "xref" nil nil string)
|
|
|
481 (?l "lines" nil nil number)
|
|
|
482 (?d "date" nil nil date)
|
|
|
483 (?f "followup" nil nil string)
|
|
|
484 (?T "thread" nil nil string)))
|
|
|
485 (char-to-type
|
|
|
486 '((?s s "substring" string)
|
|
|
487 (?e e "exact string" string)
|
|
|
488 (?f f "fuzzy string" string)
|
|
|
489 (?r r "regexp string" string)
|
|
|
490 (?z s "substring" body-string)
|
|
98
|
491 (?p r "regexp string" body-string)
|
|
0
|
492 (?b before "before date" date)
|
|
98
|
493 (?a at "at date" date)
|
|
0
|
494 (?n now "this date" date)
|
|
|
495 (?< < "less than number" number)
|
|
98
|
496 (?> > "greater than number" number)
|
|
0
|
497 (?= = "equal to number" number)))
|
|
|
498 (char-to-perm
|
|
98
|
499 (list (list ?t (current-time-string) "temporary")
|
|
0
|
500 '(?p perm "permanent") '(?i now "immediate")))
|
|
|
501 (mimic gnus-score-mimic-keymap)
|
|
108
|
502 (hchar (and gnus-score-default-header
|
|
0
|
503 (aref (symbol-name gnus-score-default-header) 0)))
|
|
|
504 (tchar (and gnus-score-default-type
|
|
|
505 (aref (symbol-name gnus-score-default-type) 0)))
|
|
|
506 (pchar (and gnus-score-default-duration
|
|
|
507 (aref (symbol-name gnus-score-default-duration) 0)))
|
|
|
508 entry temporary type match)
|
|
108
|
509
|
|
0
|
510 (unwind-protect
|
|
|
511 (progn
|
|
|
512
|
|
|
513 ;; First we read the header to score.
|
|
|
514 (while (not hchar)
|
|
|
515 (if mimic
|
|
108
|
516 (progn
|
|
0
|
517 (sit-for 1)
|
|
|
518 (message "%c-" prefix))
|
|
|
519 (message "%s header (%s?): " (if increase "Increase" "Lower")
|
|
|
520 (mapconcat (lambda (s) (char-to-string (car s)))
|
|
|
521 char-to-header "")))
|
|
|
522 (setq hchar (read-char))
|
|
|
523 (when (or (= hchar ??) (= hchar ?\C-h))
|
|
|
524 (setq hchar nil)
|
|
|
525 (gnus-score-insert-help "Match on header" char-to-header 1)))
|
|
|
526
|
|
|
527 (gnus-score-kill-help-buffer)
|
|
|
528 (unless (setq entry (assq (downcase hchar) char-to-header))
|
|
140
|
529 (if mimic (error "%c %c" prefix hchar)
|
|
|
530 (error "Illegal header type")))
|
|
0
|
531
|
|
|
532 (when (/= (downcase hchar) hchar)
|
|
98
|
533 ;; This was a majuscule, so we end reading and set the defaults.
|
|
0
|
534 (if mimic (message "%c %c" prefix hchar) (message ""))
|
|
|
535 (setq tchar (or tchar ?s)
|
|
|
536 pchar (or pchar ?t)))
|
|
108
|
537
|
|
140
|
538 (let ((legal-types
|
|
|
539 (delq nil
|
|
|
540 (mapcar (lambda (s)
|
|
|
541 (if (eq (nth 4 entry)
|
|
|
542 (nth 3 s))
|
|
|
543 s nil))
|
|
|
544 char-to-type))))
|
|
|
545 ;; We continue reading - the type.
|
|
|
546 (while (not tchar)
|
|
|
547 (if mimic
|
|
|
548 (progn
|
|
|
549 (sit-for 1) (message "%c %c-" prefix hchar))
|
|
|
550 (message "%s header '%s' with match type (%s?): "
|
|
|
551 (if increase "Increase" "Lower")
|
|
|
552 (nth 1 entry)
|
|
|
553 (mapconcat (lambda (s) (char-to-string (car s)))
|
|
|
554 legal-types "")))
|
|
|
555 (setq tchar (read-char))
|
|
|
556 (when (or (= tchar ??) (= tchar ?\C-h))
|
|
|
557 (setq tchar nil)
|
|
|
558 (gnus-score-insert-help "Match type" legal-types 2)))
|
|
0
|
559
|
|
140
|
560 (gnus-score-kill-help-buffer)
|
|
|
561 (unless (setq type (nth 1 (assq (downcase tchar) legal-types)))
|
|
|
562 (if mimic (error "%c %c" prefix hchar)
|
|
|
563 (error "Illegal match type"))))
|
|
0
|
564
|
|
|
565 (when (/= (downcase tchar) tchar)
|
|
98
|
566 ;; It was a majuscule, so we end reading and use the default.
|
|
0
|
567 (if mimic (message "%c %c %c" prefix hchar tchar)
|
|
|
568 (message ""))
|
|
|
569 (setq pchar (or pchar ?p)))
|
|
|
570
|
|
|
571 ;; We continue reading.
|
|
|
572 (while (not pchar)
|
|
|
573 (if mimic
|
|
|
574 (progn
|
|
|
575 (sit-for 1) (message "%c %c %c-" prefix hchar tchar))
|
|
|
576 (message "%s permanence (%s?): " (if increase "Increase" "Lower")
|
|
|
577 (mapconcat (lambda (s) (char-to-string (car s)))
|
|
|
578 char-to-perm "")))
|
|
|
579 (setq pchar (read-char))
|
|
|
580 (when (or (= pchar ??) (= pchar ?\C-h))
|
|
|
581 (setq pchar nil)
|
|
|
582 (gnus-score-insert-help "Match permanence" char-to-perm 2)))
|
|
|
583
|
|
|
584 (gnus-score-kill-help-buffer)
|
|
|
585 (if mimic (message "%c %c %c" prefix hchar tchar pchar)
|
|
|
586 (message ""))
|
|
|
587 (unless (setq temporary (cadr (assq pchar char-to-perm)))
|
|
98
|
588 ;; Deal with der(r)ided superannuated paradigms.
|
|
|
589 (when (and (eq (1+ prefix) 77)
|
|
|
590 (eq (+ hchar 12) 109)
|
|
|
591 (eq tchar 114)
|
|
|
592 (eq (- pchar 4) 111))
|
|
|
593 (error "You rang?"))
|
|
108
|
594 (if mimic
|
|
0
|
595 (error "%c %c %c %c" prefix hchar tchar pchar)
|
|
140
|
596 (error "Illegal match duration"))))
|
|
0
|
597 ;; Always kill the score help buffer.
|
|
|
598 (gnus-score-kill-help-buffer))
|
|
|
599
|
|
|
600 ;; We have all the data, so we enter this score.
|
|
|
601 (setq match (if (string= (nth 2 entry) "") ""
|
|
|
602 (gnus-summary-header (or (nth 2 entry) (nth 1 entry)))))
|
|
108
|
603
|
|
0
|
604 ;; Modify the match, perhaps.
|
|
108
|
605 (cond
|
|
0
|
606 ((equal (nth 1 entry) "xref")
|
|
|
607 (when (string-match "^Xref: *" match)
|
|
|
608 (setq match (substring match (match-end 0))))
|
|
|
609 (when (string-match "^[^:]* +" match)
|
|
|
610 (setq match (substring match (match-end 0))))))
|
|
108
|
611
|
|
0
|
612 (when (memq type '(r R regexp Regexp))
|
|
|
613 (setq match (regexp-quote match)))
|
|
|
614
|
|
|
615 (gnus-summary-score-entry
|
|
|
616 (nth 1 entry) ; Header
|
|
|
617 match ; Match
|
|
|
618 type ; Type
|
|
98
|
619 (if (eq score 's) nil score) ; Score
|
|
|
620 (if (eq temporary 'perm) ; Temp
|
|
0
|
621 nil
|
|
98
|
622 temporary)
|
|
0
|
623 (not (nth 3 entry))) ; Prompt
|
|
|
624 ))
|
|
108
|
625
|
|
0
|
626 (defun gnus-score-insert-help (string alist idx)
|
|
|
627 (setq gnus-score-help-winconf (current-window-configuration))
|
|
|
628 (save-excursion
|
|
|
629 (set-buffer (get-buffer-create "*Score Help*"))
|
|
|
630 (buffer-disable-undo (current-buffer))
|
|
|
631 (delete-windows-on (current-buffer))
|
|
|
632 (erase-buffer)
|
|
|
633 (insert string ":\n\n")
|
|
|
634 (let ((max -1)
|
|
|
635 (list alist)
|
|
|
636 (i 0)
|
|
|
637 n width pad format)
|
|
|
638 ;; find the longest string to display
|
|
|
639 (while list
|
|
|
640 (setq n (length (nth idx (car list))))
|
|
98
|
641 (unless (> max n)
|
|
|
642 (setq max n))
|
|
0
|
643 (setq list (cdr list)))
|
|
|
644 (setq max (+ max 4)) ; %c, `:', SPACE, a SPACE at end
|
|
98
|
645 (setq n (/ (1- (window-width)) max)) ; items per line
|
|
0
|
646 (setq width (/ (1- (window-width)) n)) ; width of each item
|
|
108
|
647 ;; insert `n' items, each in a field of width `width'
|
|
0
|
648 (while alist
|
|
|
649 (if (< i n)
|
|
|
650 ()
|
|
|
651 (setq i 0)
|
|
|
652 (delete-char -1) ; the `\n' takes a char
|
|
|
653 (insert "\n"))
|
|
|
654 (setq pad (- width 3))
|
|
|
655 (setq format (concat "%c: %-" (int-to-string pad) "s"))
|
|
|
656 (insert (format format (caar alist) (nth idx (car alist))))
|
|
|
657 (setq alist (cdr alist))
|
|
|
658 (setq i (1+ i))))
|
|
|
659 ;; display ourselves in a small window at the bottom
|
|
|
660 (gnus-appt-select-lowest-window)
|
|
|
661 (split-window)
|
|
|
662 (pop-to-buffer "*Score Help*")
|
|
|
663 (let ((window-min-height 1))
|
|
|
664 (shrink-window-if-larger-than-buffer))
|
|
|
665 (select-window (get-buffer-window gnus-summary-buffer))))
|
|
108
|
666
|
|
0
|
667 (defun gnus-summary-header (header &optional no-err)
|
|
|
668 ;; Return HEADER for current articles, or error.
|
|
|
669 (let ((article (gnus-summary-article-number))
|
|
|
670 headers)
|
|
|
671 (if article
|
|
|
672 (if (and (setq headers (gnus-summary-article-header article))
|
|
|
673 (vectorp headers))
|
|
|
674 (aref headers (nth 1 (assoc header gnus-header-index)))
|
|
|
675 (if no-err
|
|
|
676 nil
|
|
|
677 (error "Pseudo-articles can't be scored")))
|
|
|
678 (if no-err
|
|
|
679 (error "No article on current line")
|
|
|
680 nil))))
|
|
|
681
|
|
|
682 (defun gnus-newsgroup-score-alist ()
|
|
|
683 (or
|
|
108
|
684 (let ((param-file (gnus-group-find-parameter
|
|
0
|
685 gnus-newsgroup-name 'score-file)))
|
|
|
686 (when param-file
|
|
|
687 (gnus-score-load param-file)))
|
|
|
688 (gnus-score-load
|
|
|
689 (gnus-score-file-name gnus-newsgroup-name)))
|
|
|
690 gnus-score-alist)
|
|
|
691
|
|
|
692 (defsubst gnus-score-get (symbol &optional alist)
|
|
|
693 ;; Get SYMBOL's definition in ALIST.
|
|
108
|
694 (cdr (assoc symbol
|
|
|
695 (or alist
|
|
0
|
696 gnus-score-alist
|
|
|
697 (gnus-newsgroup-score-alist)))))
|
|
|
698
|
|
98
|
699 (defun gnus-summary-score-entry (header match type score date
|
|
|
700 &optional prompt silent)
|
|
0
|
701 "Enter score file entry.
|
|
|
702 HEADER is the header being scored.
|
|
|
703 MATCH is the string we are looking for.
|
|
|
704 TYPE is the match type: substring, regexp, exact, fuzzy.
|
|
|
705 SCORE is the score to add.
|
|
|
706 DATE is the expire date, or nil for no expire, or 'now for immediate expire.
|
|
|
707 If optional argument `PROMPT' is non-nil, allow user to edit match.
|
|
|
708 If optional argument `SILENT' is nil, show effect of score entry."
|
|
|
709 (interactive
|
|
|
710 (list (completing-read "Header: "
|
|
|
711 gnus-header-index
|
|
|
712 (lambda (x) (fboundp (nth 2 x)))
|
|
|
713 t)
|
|
|
714 (read-string "Match: ")
|
|
|
715 (if (y-or-n-p "Use regexp match? ") 'r 's)
|
|
|
716 (and current-prefix-arg
|
|
|
717 (prefix-numeric-value current-prefix-arg))
|
|
|
718 (cond ((not (y-or-n-p "Add to score file? "))
|
|
|
719 'now)
|
|
|
720 ((y-or-n-p "Expire kill? ")
|
|
|
721 (current-time-string))
|
|
|
722 (t nil))))
|
|
|
723 ;; Regexp is the default type.
|
|
98
|
724 (when (eq type t)
|
|
|
725 (setq type 'r))
|
|
0
|
726 ;; Simplify matches...
|
|
|
727 (cond ((or (eq type 'r) (eq type 's) (eq type nil))
|
|
|
728 (setq match (if match (gnus-simplify-subject-re match) "")))
|
|
|
729 ((eq type 'f)
|
|
|
730 (setq match (gnus-simplify-subject-fuzzy match))))
|
|
|
731 (let ((score (gnus-score-default score))
|
|
2
|
732 (header (format "%s" (downcase header)))
|
|
0
|
733 new)
|
|
98
|
734 (when prompt
|
|
108
|
735 (setq match (read-string
|
|
|
736 (format "Match %s on %s, %s: "
|
|
98
|
737 (cond ((eq date 'now)
|
|
|
738 "now")
|
|
|
739 ((stringp date)
|
|
|
740 "temp")
|
|
|
741 (t "permanent"))
|
|
|
742 header
|
|
|
743 (if (< score 0) "lower" "raise"))
|
|
|
744 (if (numberp match)
|
|
|
745 (int-to-string match)
|
|
|
746 match))))
|
|
0
|
747
|
|
2
|
748 ;; Get rid of string props.
|
|
|
749 (setq match (format "%s" match))
|
|
|
750
|
|
108
|
751 ;; If this is an integer comparison, we transform from string to int.
|
|
98
|
752 (when (eq (nth 2 (assoc header gnus-header-index)) 'gnus-score-integer)
|
|
|
753 (setq match (string-to-int match)))
|
|
0
|
754
|
|
|
755 (unless (eq date 'now)
|
|
|
756 ;; Add the score entry to the score file.
|
|
|
757 (when (= score gnus-score-interactive-default-score)
|
|
98
|
758 (setq score nil))
|
|
0
|
759 (let ((old (gnus-score-get header))
|
|
|
760 elem)
|
|
|
761 (setq new
|
|
108
|
762 (cond
|
|
98
|
763 (type
|
|
|
764 (list match score
|
|
|
765 (and date (if (numberp date) date
|
|
|
766 (gnus-day-number date)))
|
|
|
767 type))
|
|
0
|
768 (date (list match score (gnus-day-number date)))
|
|
|
769 (score (list match score))
|
|
|
770 (t (list match))))
|
|
|
771 ;; We see whether we can collapse some score entries.
|
|
|
772 ;; This isn't quite correct, because there may be more elements
|
|
98
|
773 ;; later on with the same key that have matching elems... Hm.
|
|
0
|
774 (if (and old
|
|
|
775 (setq elem (assoc match old))
|
|
|
776 (eq (nth 3 elem) (nth 3 new))
|
|
|
777 (or (and (numberp (nth 2 elem)) (numberp (nth 2 new)))
|
|
|
778 (and (not (nth 2 elem)) (not (nth 2 new)))))
|
|
|
779 ;; Yup, we just add this new score to the old elem.
|
|
98
|
780 (setcar (cdr elem) (+ (or (nth 1 elem)
|
|
0
|
781 gnus-score-interactive-default-score)
|
|
|
782 (or (nth 1 new)
|
|
|
783 gnus-score-interactive-default-score)))
|
|
|
784 ;; Nope, we have to add a new elem.
|
|
|
785 (gnus-score-set header (if old (cons new old) (list new))))
|
|
|
786 (gnus-score-set 'touched '(t))))
|
|
|
787
|
|
|
788 ;; Score the current buffer.
|
|
|
789 (unless silent
|
|
|
790 (if (and (>= (nth 1 (assoc header gnus-header-index)) 0)
|
|
|
791 (eq (nth 2 (assoc header gnus-header-index))
|
|
|
792 'gnus-score-string))
|
|
|
793 (gnus-summary-score-effect header match type score)
|
|
|
794 (gnus-summary-rescore)))
|
|
|
795
|
|
|
796 ;; Return the new scoring rule.
|
|
|
797 new))
|
|
|
798
|
|
|
799 (defun gnus-summary-score-effect (header match type score)
|
|
|
800 "Simulate the effect of a score file entry.
|
|
|
801 HEADER is the header being scored.
|
|
|
802 MATCH is the string we are looking for.
|
|
98
|
803 TYPE is the score type.
|
|
0
|
804 SCORE is the score to add."
|
|
|
805 (interactive (list (completing-read "Header: "
|
|
|
806 gnus-header-index
|
|
|
807 (lambda (x) (fboundp (nth 2 x)))
|
|
|
808 t)
|
|
|
809 (read-string "Match: ")
|
|
|
810 (y-or-n-p "Use regexp match? ")
|
|
|
811 (prefix-numeric-value current-prefix-arg)))
|
|
|
812 (save-excursion
|
|
98
|
813 (unless (and (stringp match) (> (length match) 0))
|
|
|
814 (error "No match"))
|
|
0
|
815 (goto-char (point-min))
|
|
|
816 (let ((regexp (cond ((eq type 'f)
|
|
|
817 (gnus-simplify-subject-fuzzy match))
|
|
98
|
818 ((eq type 'r)
|
|
0
|
819 match)
|
|
|
820 ((eq type 'e)
|
|
|
821 (concat "\\`" (regexp-quote match) "\\'"))
|
|
108
|
822 (t
|
|
0
|
823 (regexp-quote match)))))
|
|
|
824 (while (not (eobp))
|
|
|
825 (let ((content (gnus-summary-header header 'noerr))
|
|
|
826 (case-fold-search t))
|
|
|
827 (and content
|
|
98
|
828 (when (if (eq type 'f)
|
|
|
829 (string-equal (gnus-simplify-subject-fuzzy content)
|
|
|
830 regexp)
|
|
|
831 (string-match regexp content))
|
|
|
832 (gnus-summary-raise-score score))))
|
|
|
833 (beginning-of-line 2))))
|
|
|
834 (gnus-set-mode-line 'summary))
|
|
0
|
835
|
|
|
836 (defun gnus-summary-score-crossposting (score date)
|
|
|
837 ;; Enter score file entry for current crossposting.
|
|
|
838 ;; SCORE is the score to add.
|
|
|
839 ;; DATE is the expire date.
|
|
|
840 (let ((xref (gnus-summary-header "xref"))
|
|
|
841 (start 0)
|
|
|
842 group)
|
|
98
|
843 (unless xref
|
|
|
844 (error "This article is not crossposted"))
|
|
0
|
845 (while (string-match " \\([^ \t]+\\):" xref start)
|
|
|
846 (setq start (match-end 0))
|
|
108
|
847 (when (not (string=
|
|
|
848 (setq group
|
|
98
|
849 (substring xref (match-beginning 1) (match-end 1)))
|
|
|
850 gnus-newsgroup-name))
|
|
|
851 (gnus-summary-score-entry
|
|
|
852 "xref" (concat " " group ":") nil score date t)))))
|
|
0
|
853
|
|
|
854
|
|
|
855 ;;;
|
|
|
856 ;;; Gnus Score Files
|
|
|
857 ;;;
|
|
|
858
|
|
|
859 ;; All score code written by Per Abrahamsen <abraham@iesd.auc.dk>.
|
|
|
860
|
|
|
861 ;; Added by Per Abrahamsen <amanda@iesd.auc.dk>.
|
|
|
862 (defun gnus-score-set-mark-below (score)
|
|
|
863 "Automatically mark articles with score below SCORE as read."
|
|
108
|
864 (interactive
|
|
0
|
865 (list (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg))
|
|
|
866 (string-to-int (read-string "Mark below: ")))))
|
|
|
867 (setq score (or score gnus-summary-default-score 0))
|
|
|
868 (gnus-score-set 'mark (list score))
|
|
|
869 (gnus-score-set 'touched '(t))
|
|
|
870 (setq gnus-summary-mark-below score)
|
|
|
871 (gnus-score-update-lines))
|
|
|
872
|
|
|
873 (defun gnus-score-update-lines ()
|
|
|
874 "Update all lines in the summary buffer."
|
|
|
875 (save-excursion
|
|
|
876 (goto-char (point-min))
|
|
|
877 (while (not (eobp))
|
|
|
878 (gnus-summary-update-line)
|
|
|
879 (forward-line 1))))
|
|
|
880
|
|
|
881 (defun gnus-score-update-all-lines ()
|
|
|
882 "Update all lines in the summary buffer, even the hidden ones."
|
|
|
883 (save-excursion
|
|
|
884 (goto-char (point-min))
|
|
|
885 (let (hidden)
|
|
|
886 (while (not (eobp))
|
|
|
887 (when (gnus-summary-show-thread)
|
|
|
888 (push (point) hidden))
|
|
|
889 (gnus-summary-update-line)
|
|
|
890 (forward-line 1))
|
|
|
891 ;; Re-hide the hidden threads.
|
|
|
892 (while hidden
|
|
|
893 (goto-char (pop hidden))
|
|
|
894 (gnus-summary-hide-thread)))))
|
|
|
895
|
|
|
896 (defun gnus-score-set-expunge-below (score)
|
|
|
897 "Automatically expunge articles with score below SCORE."
|
|
108
|
898 (interactive
|
|
0
|
899 (list (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg))
|
|
2
|
900 (string-to-int (read-string "Set expunge below: ")))))
|
|
0
|
901 (setq score (or score gnus-summary-default-score 0))
|
|
|
902 (gnus-score-set 'expunge (list score))
|
|
|
903 (gnus-score-set 'touched '(t)))
|
|
|
904
|
|
|
905 (defun gnus-score-followup-article (&optional score)
|
|
|
906 "Add SCORE to all followups to the article in the current buffer."
|
|
|
907 (interactive "P")
|
|
|
908 (setq score (gnus-score-default score))
|
|
44
|
909 (when (gnus-buffer-live-p gnus-summary-buffer)
|
|
0
|
910 (save-excursion
|
|
|
911 (save-restriction
|
|
98
|
912 (message-narrow-to-headers)
|
|
0
|
913 (let ((id (mail-fetch-field "message-id")))
|
|
|
914 (when id
|
|
2
|
915 (set-buffer gnus-summary-buffer)
|
|
0
|
916 (gnus-summary-score-entry
|
|
|
917 "references" (concat id "[ \t]*$") 'r
|
|
|
918 score (current-time-string) nil t)))))))
|
|
|
919
|
|
|
920 (defun gnus-score-followup-thread (&optional score)
|
|
|
921 "Add SCORE to all later articles in the thread the current buffer is part of."
|
|
|
922 (interactive "P")
|
|
|
923 (setq score (gnus-score-default score))
|
|
44
|
924 (when (gnus-buffer-live-p gnus-summary-buffer)
|
|
0
|
925 (save-excursion
|
|
|
926 (save-restriction
|
|
|
927 (goto-char (point-min))
|
|
|
928 (let ((id (mail-fetch-field "message-id")))
|
|
|
929 (when id
|
|
2
|
930 (set-buffer gnus-summary-buffer)
|
|
0
|
931 (gnus-summary-score-entry
|
|
|
932 "references" id 's
|
|
|
933 score (current-time-string))))))))
|
|
|
934
|
|
|
935 (defun gnus-score-set (symbol value &optional alist)
|
|
|
936 ;; Set SYMBOL to VALUE in ALIST.
|
|
108
|
937 (let* ((alist
|
|
|
938 (or alist
|
|
0
|
939 gnus-score-alist
|
|
|
940 (gnus-newsgroup-score-alist)))
|
|
|
941 (entry (assoc symbol alist)))
|
|
|
942 (cond ((gnus-score-get 'read-only alist)
|
|
|
943 ;; This is a read-only score file, so we do nothing.
|
|
|
944 )
|
|
|
945 (entry
|
|
|
946 (setcdr entry value))
|
|
|
947 ((null alist)
|
|
|
948 (error "Empty alist"))
|
|
|
949 (t
|
|
|
950 (setcdr alist
|
|
|
951 (cons (cons symbol value) (cdr alist)))))))
|
|
|
952
|
|
|
953 (defun gnus-summary-raise-score (n)
|
|
|
954 "Raise the score of the current article by N."
|
|
|
955 (interactive "p")
|
|
|
956 (gnus-set-global-variables)
|
|
98
|
957 (gnus-summary-set-score (+ (gnus-summary-article-score)
|
|
0
|
958 (or n gnus-score-interactive-default-score ))))
|
|
|
959
|
|
|
960 (defun gnus-summary-set-score (n)
|
|
|
961 "Set the score of the current article to N."
|
|
|
962 (interactive "p")
|
|
|
963 (gnus-set-global-variables)
|
|
|
964 (save-excursion
|
|
|
965 (gnus-summary-show-thread)
|
|
|
966 (let ((buffer-read-only nil))
|
|
|
967 ;; Set score.
|
|
|
968 (gnus-summary-update-mark
|
|
|
969 (if (= n (or gnus-summary-default-score 0)) ?
|
|
|
970 (if (< n (or gnus-summary-default-score 0))
|
|
98
|
971 gnus-score-below-mark gnus-score-over-mark))
|
|
|
972 'score))
|
|
0
|
973 (let* ((article (gnus-summary-article-number))
|
|
|
974 (score (assq article gnus-newsgroup-scored)))
|
|
|
975 (if score (setcdr score n)
|
|
98
|
976 (push (cons article n) gnus-newsgroup-scored)))
|
|
0
|
977 (gnus-summary-update-line)))
|
|
|
978
|
|
|
979 (defun gnus-summary-current-score ()
|
|
|
980 "Return the score of the current article."
|
|
|
981 (interactive)
|
|
|
982 (gnus-set-global-variables)
|
|
|
983 (gnus-message 1 "%s" (gnus-summary-article-score)))
|
|
|
984
|
|
|
985 (defun gnus-score-change-score-file (file)
|
|
|
986 "Change current score alist."
|
|
108
|
987 (interactive
|
|
0
|
988 (list (read-file-name "Change to score file: " gnus-kill-files-directory)))
|
|
|
989 (gnus-score-load-file file)
|
|
|
990 (gnus-set-mode-line 'summary))
|
|
|
991
|
|
|
992 (defvar gnus-score-edit-exit-function)
|
|
|
993 (defun gnus-score-edit-current-scores (file)
|
|
|
994 "Edit the current score alist."
|
|
|
995 (interactive (list gnus-current-score-file))
|
|
98
|
996 (gnus-set-global-variables)
|
|
0
|
997 (let ((winconf (current-window-configuration)))
|
|
98
|
998 (when (buffer-name gnus-summary-buffer)
|
|
|
999 (gnus-score-save))
|
|
0
|
1000 (gnus-make-directory (file-name-directory file))
|
|
|
1001 (setq gnus-score-edit-buffer (find-file-noselect file))
|
|
|
1002 (gnus-configure-windows 'edit-score)
|
|
|
1003 (gnus-score-mode)
|
|
|
1004 (setq gnus-score-edit-exit-function 'gnus-score-edit-done)
|
|
|
1005 (make-local-variable 'gnus-prev-winconf)
|
|
|
1006 (setq gnus-prev-winconf winconf))
|
|
108
|
1007 (gnus-message
|
|
|
1008 4 (substitute-command-keys
|
|
0
|
1009 "\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits")))
|
|
108
|
1010
|
|
0
|
1011 (defun gnus-score-edit-file (file)
|
|
|
1012 "Edit a score file."
|
|
108
|
1013 (interactive
|
|
0
|
1014 (list (read-file-name "Edit score file: " gnus-kill-files-directory)))
|
|
|
1015 (gnus-make-directory (file-name-directory file))
|
|
98
|
1016 (when (buffer-name gnus-summary-buffer)
|
|
|
1017 (gnus-score-save))
|
|
0
|
1018 (let ((winconf (current-window-configuration)))
|
|
|
1019 (setq gnus-score-edit-buffer (find-file-noselect file))
|
|
|
1020 (gnus-configure-windows 'edit-score)
|
|
|
1021 (gnus-score-mode)
|
|
|
1022 (setq gnus-score-edit-exit-function 'gnus-score-edit-done)
|
|
|
1023 (make-local-variable 'gnus-prev-winconf)
|
|
|
1024 (setq gnus-prev-winconf winconf))
|
|
108
|
1025 (gnus-message
|
|
|
1026 4 (substitute-command-keys
|
|
0
|
1027 "\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits")))
|
|
108
|
1028
|
|
0
|
1029 (defun gnus-score-load-file (file)
|
|
|
1030 ;; Load score file FILE. Returns a list a retrieved score-alists.
|
|
108
|
1031 (let* ((file (expand-file-name
|
|
0
|
1032 (or (and (string-match
|
|
|
1033 (concat "^" (expand-file-name
|
|
98
|
1034 gnus-kill-files-directory))
|
|
0
|
1035 (expand-file-name file))
|
|
|
1036 file)
|
|
|
1037 (concat (file-name-as-directory gnus-kill-files-directory)
|
|
|
1038 file))))
|
|
|
1039 (cached (assoc file gnus-score-cache))
|
|
|
1040 (global (member file gnus-internal-global-score-files))
|
|
|
1041 lists alist)
|
|
|
1042 (if cached
|
|
|
1043 ;; The score file was already loaded.
|
|
|
1044 (setq alist (cdr cached))
|
|
|
1045 ;; We load the score file.
|
|
|
1046 (setq gnus-score-alist nil)
|
|
|
1047 (setq alist (gnus-score-load-score-alist file))
|
|
|
1048 ;; We add '(touched) to the alist to signify that it hasn't been
|
|
108
|
1049 ;; touched (yet).
|
|
98
|
1050 (unless (assq 'touched alist)
|
|
|
1051 (push (list 'touched nil) alist))
|
|
0
|
1052 ;; If it is a global score file, we make it read-only.
|
|
|
1053 (and global
|
|
|
1054 (not (assq 'read-only alist))
|
|
98
|
1055 (push (list 'read-only t) alist))
|
|
|
1056 (push (cons file alist) gnus-score-cache))
|
|
0
|
1057 (let ((a alist)
|
|
|
1058 found)
|
|
|
1059 (while a
|
|
|
1060 ;; Downcase all header names.
|
|
|
1061 (when (stringp (caar a))
|
|
|
1062 (setcar (car a) (downcase (caar a)))
|
|
|
1063 (setq found t))
|
|
|
1064 (pop a))
|
|
|
1065 ;; If there are actual scores in the alist, we add it to the
|
|
|
1066 ;; return value of this function.
|
|
|
1067 (when found
|
|
|
1068 (setq lists (list alist))))
|
|
|
1069 ;; Treat the other possible atoms in the score alist.
|
|
|
1070 (let ((mark (car (gnus-score-get 'mark alist)))
|
|
|
1071 (expunge (car (gnus-score-get 'expunge alist)))
|
|
|
1072 (mark-and-expunge (car (gnus-score-get 'mark-and-expunge alist)))
|
|
|
1073 (files (gnus-score-get 'files alist))
|
|
|
1074 (exclude-files (gnus-score-get 'exclude-files alist))
|
|
|
1075 (orphan (car (gnus-score-get 'orphan alist)))
|
|
|
1076 (adapt (gnus-score-get 'adapt alist))
|
|
|
1077 (thread-mark-and-expunge
|
|
|
1078 (car (gnus-score-get 'thread-mark-and-expunge alist)))
|
|
|
1079 (adapt-file (car (gnus-score-get 'adapt-file alist)))
|
|
|
1080 (local (gnus-score-get 'local alist))
|
|
98
|
1081 (decay (car (gnus-score-get 'decay alist)))
|
|
0
|
1082 (eval (car (gnus-score-get 'eval alist))))
|
|
98
|
1083 ;; Perform possible decays.
|
|
|
1084 (when (and gnus-decay-scores
|
|
108
|
1085 (gnus-decay-scores
|
|
98
|
1086 alist (or decay (gnus-time-to-day (current-time)))))
|
|
|
1087 (gnus-score-set 'touched '(t) alist)
|
|
|
1088 (gnus-score-set 'decay (list (gnus-time-to-day (current-time)))))
|
|
0
|
1089 ;; We do not respect eval and files atoms from global score
|
|
108
|
1090 ;; files.
|
|
0
|
1091 (and files (not global)
|
|
|
1092 (setq lists (apply 'append lists
|
|
|
1093 (mapcar (lambda (file)
|
|
98
|
1094 (gnus-score-load-file file))
|
|
0
|
1095 (if adapt-file (cons adapt-file files)
|
|
|
1096 files)))))
|
|
|
1097 (and eval (not global) (eval eval))
|
|
|
1098 ;; We then expand any exclude-file directives.
|
|
108
|
1099 (setq gnus-scores-exclude-files
|
|
|
1100 (nconc
|
|
|
1101 (mapcar
|
|
98
|
1102 (lambda (sfile)
|
|
0
|
1103 (expand-file-name sfile (file-name-directory file)))
|
|
98
|
1104 exclude-files)
|
|
|
1105 gnus-scores-exclude-files))
|
|
0
|
1106 (if (not local)
|
|
|
1107 ()
|
|
|
1108 (save-excursion
|
|
|
1109 (set-buffer gnus-summary-buffer)
|
|
|
1110 (while local
|
|
|
1111 (and (consp (car local))
|
|
|
1112 (symbolp (caar local))
|
|
|
1113 (progn
|
|
|
1114 (make-local-variable (caar local))
|
|
|
1115 (set (caar local) (nth 1 (car local)))))
|
|
|
1116 (setq local (cdr local)))))
|
|
98
|
1117 (when orphan
|
|
|
1118 (setq gnus-orphan-score orphan))
|
|
0
|
1119 (setq gnus-adaptive-score-alist
|
|
|
1120 (cond ((equal adapt '(t))
|
|
|
1121 (setq gnus-newsgroup-adaptive t)
|
|
|
1122 gnus-default-adaptive-score-alist)
|
|
|
1123 ((equal adapt '(ignore))
|
|
|
1124 (setq gnus-newsgroup-adaptive nil))
|
|
|
1125 ((consp adapt)
|
|
|
1126 (setq gnus-newsgroup-adaptive t)
|
|
|
1127 adapt)
|
|
|
1128 (t
|
|
|
1129 ;;(setq gnus-newsgroup-adaptive gnus-use-adaptive-scoring)
|
|
|
1130 gnus-default-adaptive-score-alist)))
|
|
108
|
1131 (setq gnus-thread-expunge-below
|
|
0
|
1132 (or thread-mark-and-expunge gnus-thread-expunge-below))
|
|
108
|
1133 (setq gnus-summary-mark-below
|
|
0
|
1134 (or mark mark-and-expunge gnus-summary-mark-below))
|
|
108
|
1135 (setq gnus-summary-expunge-below
|
|
0
|
1136 (or expunge mark-and-expunge gnus-summary-expunge-below))
|
|
108
|
1137 (setq gnus-newsgroup-adaptive-score-file
|
|
0
|
1138 (or adapt-file gnus-newsgroup-adaptive-score-file)))
|
|
|
1139 (setq gnus-current-score-file file)
|
|
|
1140 (setq gnus-score-alist alist)
|
|
|
1141 lists))
|
|
|
1142
|
|
|
1143 (defun gnus-score-load (file)
|
|
|
1144 ;; Load score FILE.
|
|
|
1145 (let ((cache (assoc file gnus-score-cache)))
|
|
|
1146 (if cache
|
|
|
1147 (setq gnus-score-alist (cdr cache))
|
|
|
1148 (setq gnus-score-alist nil)
|
|
|
1149 (gnus-score-load-score-alist file)
|
|
98
|
1150 (unless gnus-score-alist
|
|
|
1151 (setq gnus-score-alist (copy-alist '((touched nil)))))
|
|
|
1152 (push (cons file gnus-score-alist) gnus-score-cache))))
|
|
0
|
1153
|
|
|
1154 (defun gnus-score-remove-from-cache (file)
|
|
108
|
1155 (setq gnus-score-cache
|
|
0
|
1156 (delq (assoc file gnus-score-cache) gnus-score-cache)))
|
|
|
1157
|
|
|
1158 (defun gnus-score-load-score-alist (file)
|
|
98
|
1159 "Read score FILE."
|
|
0
|
1160 (let (alist)
|
|
|
1161 (if (not (file-readable-p file))
|
|
98
|
1162 ;; Couldn't read file.
|
|
0
|
1163 (setq gnus-score-alist nil)
|
|
98
|
1164 ;; Read file.
|
|
0
|
1165 (save-excursion
|
|
|
1166 (gnus-set-work-buffer)
|
|
|
1167 (insert-file-contents file)
|
|
|
1168 (goto-char (point-min))
|
|
|
1169 ;; Only do the loading if the score file isn't empty.
|
|
|
1170 (when (save-excursion (re-search-forward "[()0-9a-zA-Z]" nil t))
|
|
|
1171 (setq alist
|
|
|
1172 (condition-case ()
|
|
|
1173 (read (current-buffer))
|
|
108
|
1174 (error
|
|
98
|
1175 (gnus-error 3.2 "Problem with score file %s" file))))))
|
|
0
|
1176 (if (eq (car alist) 'setq)
|
|
|
1177 ;; This is an old-style score file.
|
|
|
1178 (setq gnus-score-alist (gnus-score-transform-old-to-new alist))
|
|
|
1179 (setq gnus-score-alist alist))
|
|
|
1180 ;; Check the syntax of the score file.
|
|
|
1181 (setq gnus-score-alist
|
|
|
1182 (gnus-score-check-syntax gnus-score-alist file)))))
|
|
|
1183
|
|
|
1184 (defun gnus-score-check-syntax (alist file)
|
|
|
1185 "Check the syntax of the score ALIST."
|
|
108
|
1186 (cond
|
|
0
|
1187 ((null alist)
|
|
|
1188 nil)
|
|
|
1189 ((not (consp alist))
|
|
|
1190 (gnus-message 1 "Score file is not a list: %s" file)
|
|
|
1191 (ding)
|
|
|
1192 nil)
|
|
|
1193 (t
|
|
|
1194 (let ((a alist)
|
|
|
1195 sr err s type)
|
|
|
1196 (while (and a (not err))
|
|
|
1197 (setq
|
|
|
1198 err
|
|
|
1199 (cond
|
|
|
1200 ((not (listp (car a)))
|
|
|
1201 (format "Illegal score element %s in %s" (car a) file))
|
|
|
1202 ((stringp (caar a))
|
|
108
|
1203 (cond
|
|
0
|
1204 ((not (listp (setq sr (cdar a))))
|
|
|
1205 (format "Illegal header match %s in %s" (nth 1 (car a)) file))
|
|
|
1206 (t
|
|
|
1207 (setq type (caar a))
|
|
|
1208 (while (and sr (not err))
|
|
|
1209 (setq s (pop sr))
|
|
108
|
1210 (setq
|
|
0
|
1211 err
|
|
|
1212 (cond
|
|
|
1213 ((if (member (downcase type) '("lines" "chars"))
|
|
|
1214 (not (numberp (car s)))
|
|
|
1215 (not (stringp (car s))))
|
|
|
1216 (format "Illegal match %s in %s" (car s) file))
|
|
|
1217 ((and (cadr s) (not (integerp (cadr s))))
|
|
|
1218 (format "Non-integer score %s in %s" (cadr s) file))
|
|
|
1219 ((and (caddr s) (not (integerp (caddr s))))
|
|
|
1220 (format "Non-integer date %s in %s" (caddr s) file))
|
|
|
1221 ((and (cadddr s) (not (symbolp (cadddr s))))
|
|
|
1222 (format "Non-symbol match type %s in %s" (cadddr s) file)))))
|
|
|
1223 err)))))
|
|
|
1224 (setq a (cdr a)))
|
|
|
1225 (if err
|
|
|
1226 (progn
|
|
|
1227 (ding)
|
|
|
1228 (gnus-message 3 err)
|
|
|
1229 (sit-for 2)
|
|
|
1230 nil)
|
|
98
|
1231 alist)))))
|
|
0
|
1232
|
|
|
1233 (defun gnus-score-transform-old-to-new (alist)
|
|
|
1234 (let* ((alist (nth 2 alist))
|
|
|
1235 out entry)
|
|
98
|
1236 (when (eq (car alist) 'quote)
|
|
|
1237 (setq alist (nth 1 alist)))
|
|
0
|
1238 (while alist
|
|
|
1239 (setq entry (car alist))
|
|
|
1240 (if (stringp (car entry))
|
|
|
1241 (let ((scor (cdr entry)))
|
|
98
|
1242 (push entry out)
|
|
0
|
1243 (while scor
|
|
|
1244 (setcar scor
|
|
|
1245 (list (caar scor) (nth 2 (car scor))
|
|
|
1246 (and (nth 3 (car scor))
|
|
|
1247 (gnus-day-number (nth 3 (car scor))))
|
|
|
1248 (if (nth 1 (car scor)) 'r 's)))
|
|
|
1249 (setq scor (cdr scor))))
|
|
98
|
1250 (push (if (not (listp (cdr entry)))
|
|
|
1251 (list (car entry) (cdr entry))
|
|
|
1252 entry)
|
|
|
1253 out))
|
|
0
|
1254 (setq alist (cdr alist)))
|
|
|
1255 (cons (list 'touched t) (nreverse out))))
|
|
108
|
1256
|
|
0
|
1257 (defun gnus-score-save ()
|
|
|
1258 ;; Save all score information.
|
|
98
|
1259 (let ((cache gnus-score-cache)
|
|
|
1260 entry score file)
|
|
0
|
1261 (save-excursion
|
|
|
1262 (setq gnus-score-alist nil)
|
|
98
|
1263 (nnheader-set-temp-buffer " *Gnus Scores*")
|
|
|
1264 (while cache
|
|
|
1265 (current-buffer)
|
|
|
1266 (setq entry (pop cache)
|
|
|
1267 file (car entry)
|
|
|
1268 score (cdr entry))
|
|
|
1269 (if (or (not (equal (gnus-score-get 'touched score) '(t)))
|
|
|
1270 (gnus-score-get 'read-only score)
|
|
|
1271 (and (file-exists-p file)
|
|
|
1272 (not (file-writable-p file))))
|
|
|
1273 ()
|
|
|
1274 (setq score (setcdr entry (delq (assq 'touched score) score)))
|
|
|
1275 (erase-buffer)
|
|
|
1276 (let (emacs-lisp-mode-hook)
|
|
108
|
1277 (if (string-match
|
|
98
|
1278 (concat (regexp-quote gnus-adaptive-file-suffix)
|
|
|
1279 "$")
|
|
|
1280 file)
|
|
|
1281 ;; This is an adaptive score file, so we do not run
|
|
|
1282 ;; it through `pp'. These files can get huge, and
|
|
|
1283 ;; are not meant to be edited by human hands.
|
|
|
1284 (gnus-prin1 score)
|
|
|
1285 ;; This is a normal score file, so we print it very
|
|
108
|
1286 ;; prettily.
|
|
98
|
1287 (pp score (current-buffer))))
|
|
|
1288 (gnus-make-directory (file-name-directory file))
|
|
|
1289 ;; If the score file is empty, we delete it.
|
|
|
1290 (if (zerop (buffer-size))
|
|
|
1291 (delete-file file)
|
|
108
|
1292 ;; There are scores, so we write the file.
|
|
98
|
1293 (when (file-writable-p file)
|
|
|
1294 (gnus-write-buffer file)
|
|
|
1295 (when gnus-score-after-write-file-function
|
|
|
1296 (funcall gnus-score-after-write-file-function file)))))
|
|
|
1297 (and gnus-score-uncacheable-files
|
|
|
1298 (string-match gnus-score-uncacheable-files file)
|
|
|
1299 (gnus-score-remove-from-cache file)))
|
|
0
|
1300 (kill-buffer (current-buffer)))))
|
|
98
|
1301
|
|
|
1302 (defun gnus-score-load-files (score-files)
|
|
|
1303 "Load all score files in SCORE-FILES."
|
|
|
1304 ;; Load the score files.
|
|
|
1305 (let (scores)
|
|
0
|
1306 (while score-files
|
|
|
1307 (if (stringp (car score-files))
|
|
|
1308 ;; It is a string, which means that it's a score file name,
|
|
|
1309 ;; so we load the score file and add the score alist to
|
|
|
1310 ;; the list of alists.
|
|
|
1311 (setq scores (nconc (gnus-score-load-file (car score-files)) scores))
|
|
|
1312 ;; It is an alist, so we just add it to the list directly.
|
|
|
1313 (setq scores (nconc (car score-files) scores)))
|
|
|
1314 (setq score-files (cdr score-files)))
|
|
|
1315 ;; Prune the score files that are to be excluded, if any.
|
|
|
1316 (when gnus-scores-exclude-files
|
|
|
1317 (let ((s scores)
|
|
|
1318 c)
|
|
|
1319 (while s
|
|
|
1320 (and (setq c (rassq (car s) gnus-score-cache))
|
|
|
1321 (member (car c) gnus-scores-exclude-files)
|
|
|
1322 (setq scores (delq (car s) scores)))
|
|
|
1323 (setq s (cdr s)))))
|
|
98
|
1324 scores))
|
|
|
1325
|
|
|
1326 (defun gnus-score-headers (score-files &optional trace)
|
|
|
1327 ;; Score `gnus-newsgroup-headers'.
|
|
|
1328 (let (scores news)
|
|
|
1329 ;; PLM: probably this is not the best place to clear orphan-score
|
|
|
1330 (setq gnus-orphan-score nil
|
|
|
1331 gnus-scores-articles nil
|
|
|
1332 gnus-scores-exclude-files nil
|
|
|
1333 scores (gnus-score-load-files score-files))
|
|
0
|
1334 (setq news scores)
|
|
|
1335 ;; Do the scoring.
|
|
|
1336 (while news
|
|
|
1337 (setq scores news
|
|
|
1338 news nil)
|
|
|
1339 (when (and gnus-summary-default-score
|
|
|
1340 scores)
|
|
|
1341 (let* ((entries gnus-header-index)
|
|
|
1342 (now (gnus-day-number (current-time-string)))
|
|
|
1343 (expire (and gnus-score-expiry-days
|
|
|
1344 (- now gnus-score-expiry-days)))
|
|
|
1345 (headers gnus-newsgroup-headers)
|
|
|
1346 (current-score-file gnus-current-score-file)
|
|
|
1347 entry header new)
|
|
|
1348 (gnus-message 5 "Scoring...")
|
|
|
1349 ;; Create articles, an alist of the form `(HEADER . SCORE)'.
|
|
|
1350 (while (setq header (pop headers))
|
|
|
1351 ;; WARNING: The assq makes the function O(N*S) while it could
|
|
|
1352 ;; be written as O(N+S), where N is (length gnus-newsgroup-headers)
|
|
|
1353 ;; and S is (length gnus-newsgroup-scored).
|
|
98
|
1354 (unless (assq (mail-header-number header) gnus-newsgroup-scored)
|
|
|
1355 (setq gnus-scores-articles ;Total of 2 * N cons-cells used.
|
|
|
1356 (cons (cons header (or gnus-summary-default-score 0))
|
|
|
1357 gnus-scores-articles))))
|
|
0
|
1358
|
|
|
1359 (save-excursion
|
|
|
1360 (set-buffer (get-buffer-create "*Headers*"))
|
|
|
1361 (buffer-disable-undo (current-buffer))
|
|
|
1362
|
|
|
1363 ;; Set the global variant of this variable.
|
|
|
1364 (setq gnus-current-score-file current-score-file)
|
|
|
1365 ;; score orphans
|
|
108
|
1366 (when gnus-orphan-score
|
|
|
1367 (setq gnus-score-index
|
|
0
|
1368 (nth 1 (assoc "references" gnus-header-index)))
|
|
|
1369 (gnus-score-orphans gnus-orphan-score))
|
|
|
1370 ;; Run each header through the score process.
|
|
|
1371 (while entries
|
|
|
1372 (setq entry (pop entries)
|
|
|
1373 header (nth 0 entry)
|
|
|
1374 gnus-score-index (nth 1 (assoc header gnus-header-index)))
|
|
|
1375 (when (< 0 (apply 'max (mapcar
|
|
|
1376 (lambda (score)
|
|
|
1377 (length (gnus-score-get header score)))
|
|
|
1378 scores)))
|
|
|
1379 ;; Call the scoring function for this type of "header".
|
|
|
1380 (when (setq new (funcall (nth 2 entry) scores header
|
|
|
1381 now expire trace))
|
|
|
1382 (push new news))))
|
|
|
1383 ;; Remove the buffer.
|
|
|
1384 (kill-buffer (current-buffer)))
|
|
|
1385
|
|
|
1386 ;; Add articles to `gnus-newsgroup-scored'.
|
|
|
1387 (while gnus-scores-articles
|
|
98
|
1388 (when (or (/= gnus-summary-default-score
|
|
|
1389 (cdar gnus-scores-articles))
|
|
|
1390 gnus-save-score)
|
|
|
1391 (push (cons (mail-header-number (caar gnus-scores-articles))
|
|
|
1392 (cdar gnus-scores-articles))
|
|
|
1393 gnus-newsgroup-scored))
|
|
0
|
1394 (setq gnus-scores-articles (cdr gnus-scores-articles)))
|
|
|
1395
|
|
98
|
1396 (let (score)
|
|
|
1397 (while (setq score (pop scores))
|
|
|
1398 (while score
|
|
|
1399 (when (listp (caar score))
|
|
|
1400 (gnus-score-advanced (car score) trace))
|
|
|
1401 (pop score))))
|
|
108
|
1402
|
|
0
|
1403 (gnus-message 5 "Scoring...done"))))))
|
|
|
1404
|
|
|
1405
|
|
|
1406 (defun gnus-get-new-thread-ids (articles)
|
|
|
1407 (let ((index (nth 1 (assoc "message-id" gnus-header-index)))
|
|
|
1408 (refind gnus-score-index)
|
|
|
1409 id-list art this tref)
|
|
|
1410 (while articles
|
|
|
1411 (setq art (car articles)
|
|
|
1412 this (aref (car art) index)
|
|
|
1413 tref (aref (car art) refind)
|
|
|
1414 articles (cdr articles))
|
|
98
|
1415 (when (string-equal tref "") ;no references line
|
|
|
1416 (push this id-list)))
|
|
0
|
1417 id-list))
|
|
|
1418
|
|
|
1419 ;; Orphan functions written by plm@atcmp.nl (Peter Mutsaers).
|
|
|
1420 (defun gnus-score-orphans (score)
|
|
|
1421 (let ((new-thread-ids (gnus-get-new-thread-ids gnus-scores-articles))
|
|
|
1422 alike articles art arts this last this-id)
|
|
108
|
1423
|
|
0
|
1424 (setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<)
|
|
|
1425 articles gnus-scores-articles)
|
|
|
1426
|
|
|
1427 ;;more or less the same as in gnus-score-string
|
|
|
1428 (erase-buffer)
|
|
|
1429 (while articles
|
|
|
1430 (setq art (car articles)
|
|
|
1431 this (aref (car art) gnus-score-index)
|
|
|
1432 articles (cdr articles))
|
|
|
1433 ;;completely skip if this is empty (not a child, so not an orphan)
|
|
98
|
1434 (when (not (string= this ""))
|
|
|
1435 (if (equal last this)
|
|
|
1436 ;; O(N*H) cons-cells used here, where H is the number of
|
|
|
1437 ;; headers.
|
|
|
1438 (push art alike)
|
|
|
1439 (when last
|
|
|
1440 ;; Insert the line, with a text property on the
|
|
|
1441 ;; terminating newline referring to the articles with
|
|
|
1442 ;; this line.
|
|
|
1443 (insert last ?\n)
|
|
|
1444 (put-text-property (1- (point)) (point) 'articles alike))
|
|
|
1445 (setq alike (list art)
|
|
|
1446 last this))))
|
|
|
1447 (when last ; Bwadr, duplicate code.
|
|
|
1448 (insert last ?\n)
|
|
|
1449 (put-text-property (1- (point)) (point) 'articles alike))
|
|
0
|
1450
|
|
|
1451 ;; PLM: now delete those lines that contain an entry from new-thread-ids
|
|
|
1452 (while new-thread-ids
|
|
|
1453 (setq this-id (car new-thread-ids)
|
|
|
1454 new-thread-ids (cdr new-thread-ids))
|
|
|
1455 (goto-char (point-min))
|
|
|
1456 (while (search-forward this-id nil t)
|
|
98
|
1457 ;; found a match. remove this line
|
|
0
|
1458 (beginning-of-line)
|
|
|
1459 (kill-line 1)))
|
|
|
1460
|
|
|
1461 ;; now for each line: update its articles with score by moving to
|
|
|
1462 ;; every end-of-line in the buffer and read the articles property
|
|
|
1463 (goto-char (point-min))
|
|
|
1464 (while (eq 0 (progn
|
|
|
1465 (end-of-line)
|
|
|
1466 (setq arts (get-text-property (point) 'articles))
|
|
|
1467 (while arts
|
|
|
1468 (setq art (car arts)
|
|
|
1469 arts (cdr arts))
|
|
|
1470 (setcdr art (+ score (cdr art))))
|
|
|
1471 (forward-line))))))
|
|
108
|
1472
|
|
0
|
1473
|
|
|
1474 (defun gnus-score-integer (scores header now expire &optional trace)
|
|
|
1475 (let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
|
|
|
1476 entries alist)
|
|
|
1477
|
|
|
1478 ;; Find matches.
|
|
|
1479 (while scores
|
|
|
1480 (setq alist (car scores)
|
|
|
1481 scores (cdr scores)
|
|
|
1482 entries (assoc header alist))
|
|
|
1483 (while (cdr entries) ;First entry is the header index.
|
|
98
|
1484 (let* ((rest (cdr entries))
|
|
0
|
1485 (kill (car rest))
|
|
|
1486 (match (nth 0 kill))
|
|
|
1487 (type (or (nth 3 kill) '>))
|
|
|
1488 (score (or (nth 1 kill) gnus-score-interactive-default-score))
|
|
|
1489 (date (nth 2 kill))
|
|
|
1490 (found nil)
|
|
|
1491 (match-func (if (or (eq type '>) (eq type '<) (eq type '<=)
|
|
|
1492 (eq type '>=) (eq type '=))
|
|
|
1493 type
|
|
|
1494 (error "Illegal match type: %s" type)))
|
|
|
1495 (articles gnus-scores-articles))
|
|
|
1496 ;; Instead of doing all the clever stuff that
|
|
|
1497 ;; `gnus-score-string' does to minimize searches and stuff,
|
|
|
1498 ;; I will assume that people generally will put so few
|
|
|
1499 ;; matches on numbers that any cleverness will take more
|
|
|
1500 ;; time than one would gain.
|
|
|
1501 (while articles
|
|
108
|
1502 (when (funcall match-func
|
|
98
|
1503 (or (aref (caar articles) gnus-score-index) 0)
|
|
|
1504 match)
|
|
108
|
1505 (when trace
|
|
98
|
1506 (push (cons (car-safe (rassq alist gnus-score-cache)) kill)
|
|
|
1507 gnus-score-trace))
|
|
|
1508 (setq found t)
|
|
|
1509 (setcdr (car articles) (+ score (cdar articles))))
|
|
0
|
1510 (setq articles (cdr articles)))
|
|
|
1511 ;; Update expire date
|
|
|
1512 (cond ((null date)) ;Permanent entry.
|
|
|
1513 ((and found gnus-update-score-entry-dates) ;Match, update date.
|
|
|
1514 (gnus-score-set 'touched '(t) alist)
|
|
|
1515 (setcar (nthcdr 2 kill) now))
|
|
|
1516 ((and expire (< date expire)) ;Old entry, remove.
|
|
|
1517 (gnus-score-set 'touched '(t) alist)
|
|
|
1518 (setcdr entries (cdr rest))
|
|
|
1519 (setq rest entries)))
|
|
|
1520 (setq entries rest)))))
|
|
|
1521 nil)
|
|
|
1522
|
|
|
1523 (defun gnus-score-date (scores header now expire &optional trace)
|
|
|
1524 (let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
|
|
98
|
1525 entries alist match match-func article)
|
|
0
|
1526
|
|
|
1527 ;; Find matches.
|
|
|
1528 (while scores
|
|
|
1529 (setq alist (car scores)
|
|
|
1530 scores (cdr scores)
|
|
|
1531 entries (assoc header alist))
|
|
|
1532 (while (cdr entries) ;First entry is the header index.
|
|
98
|
1533 (let* ((rest (cdr entries))
|
|
0
|
1534 (kill (car rest))
|
|
|
1535 (type (or (nth 3 kill) 'before))
|
|
|
1536 (score (or (nth 1 kill) gnus-score-interactive-default-score))
|
|
|
1537 (date (nth 2 kill))
|
|
|
1538 (found nil)
|
|
|
1539 (articles gnus-scores-articles)
|
|
|
1540 l)
|
|
98
|
1541 (cond
|
|
|
1542 ((eq type 'after)
|
|
|
1543 (setq match-func 'string<
|
|
|
1544 match (gnus-date-iso8601 (nth 0 kill))))
|
|
|
1545 ((eq type 'before)
|
|
|
1546 (setq match-func 'gnus-string>
|
|
|
1547 match (gnus-date-iso8601 (nth 0 kill))))
|
|
|
1548 ((eq type 'at)
|
|
|
1549 (setq match-func 'string=
|
|
|
1550 match (gnus-date-iso8601 (nth 0 kill))))
|
|
|
1551 ((eq type 'regexp)
|
|
|
1552 (setq match-func 'string-match
|
|
|
1553 match (nth 0 kill)))
|
|
|
1554 (t (error "Illegal match type: %s" type)))
|
|
0
|
1555 ;; Instead of doing all the clever stuff that
|
|
|
1556 ;; `gnus-score-string' does to minimize searches and stuff,
|
|
|
1557 ;; I will assume that people generally will put so few
|
|
|
1558 ;; matches on numbers that any cleverness will take more
|
|
|
1559 ;; time than one would gain.
|
|
98
|
1560 (while (setq article (pop articles))
|
|
|
1561 (when (and
|
|
|
1562 (setq l (aref (car article) gnus-score-index))
|
|
|
1563 (funcall match-func match (gnus-date-iso8601 l)))
|
|
|
1564 (when trace
|
|
|
1565 (push (cons (car-safe (rassq alist gnus-score-cache)) kill)
|
|
|
1566 gnus-score-trace))
|
|
|
1567 (setq found t)
|
|
|
1568 (setcdr article (+ score (cdr article)))))
|
|
0
|
1569 ;; Update expire date
|
|
|
1570 (cond ((null date)) ;Permanent entry.
|
|
|
1571 ((and found gnus-update-score-entry-dates) ;Match, update date.
|
|
|
1572 (gnus-score-set 'touched '(t) alist)
|
|
|
1573 (setcar (nthcdr 2 kill) now))
|
|
98
|
1574 ((and expire (< date expire)) ;Old entry, remove.
|
|
0
|
1575 (gnus-score-set 'touched '(t) alist)
|
|
|
1576 (setcdr entries (cdr rest))
|
|
|
1577 (setq rest entries)))
|
|
|
1578 (setq entries rest)))))
|
|
|
1579 nil)
|
|
|
1580
|
|
|
1581 (defun gnus-score-body (scores header now expire &optional trace)
|
|
|
1582 (save-excursion
|
|
|
1583 (setq gnus-scores-articles
|
|
|
1584 (sort gnus-scores-articles
|
|
|
1585 (lambda (a1 a2)
|
|
|
1586 (< (mail-header-number (car a1))
|
|
|
1587 (mail-header-number (car a2))))))
|
|
98
|
1588 (set-buffer nntp-server-buffer)
|
|
0
|
1589 (save-restriction
|
|
|
1590 (let* ((buffer-read-only nil)
|
|
|
1591 (articles gnus-scores-articles)
|
|
|
1592 (all-scores scores)
|
|
|
1593 (request-func (cond ((string= "head" header)
|
|
|
1594 'gnus-request-head)
|
|
|
1595 ((string= "body" header)
|
|
|
1596 'gnus-request-body)
|
|
|
1597 (t 'gnus-request-article)))
|
|
|
1598 entries alist ofunc article last)
|
|
|
1599 (when articles
|
|
98
|
1600 (setq last (mail-header-number (caar (last articles))))
|
|
0
|
1601 ;; Not all backends support partial fetching. In that case,
|
|
|
1602 ;; we just fetch the entire article.
|
|
108
|
1603 (unless (gnus-check-backend-function
|
|
98
|
1604 (and (string-match "^gnus-" (symbol-name request-func))
|
|
|
1605 (intern (substring (symbol-name request-func)
|
|
|
1606 (match-end 0))))
|
|
|
1607 gnus-newsgroup-name)
|
|
|
1608 (setq ofunc request-func)
|
|
|
1609 (setq request-func 'gnus-request-article))
|
|
0
|
1610 (while articles
|
|
|
1611 (setq article (mail-header-number (caar articles)))
|
|
|
1612 (gnus-message 7 "Scoring on article %s of %s..." article last)
|
|
|
1613 (when (funcall request-func article gnus-newsgroup-name)
|
|
|
1614 (widen)
|
|
|
1615 (goto-char (point-min))
|
|
|
1616 ;; If just parts of the article is to be searched, but the
|
|
|
1617 ;; backend didn't support partial fetching, we just narrow
|
|
|
1618 ;; to the relevant parts.
|
|
98
|
1619 (when ofunc
|
|
|
1620 (if (eq ofunc 'gnus-request-head)
|
|
0
|
1621 (narrow-to-region
|
|
98
|
1622 (point)
|
|
|
1623 (or (search-forward "\n\n" nil t) (point-max)))
|
|
|
1624 (narrow-to-region
|
|
|
1625 (or (search-forward "\n\n" nil t) (point))
|
|
|
1626 (point-max))))
|
|
0
|
1627 (setq scores all-scores)
|
|
|
1628 ;; Find matches.
|
|
|
1629 (while scores
|
|
98
|
1630 (setq alist (pop scores)
|
|
0
|
1631 entries (assoc header alist))
|
|
|
1632 (while (cdr entries) ;First entry is the header index.
|
|
98
|
1633 (let* ((rest (cdr entries))
|
|
0
|
1634 (kill (car rest))
|
|
|
1635 (match (nth 0 kill))
|
|
|
1636 (type (or (nth 3 kill) 's))
|
|
98
|
1637 (score (or (nth 1 kill)
|
|
0
|
1638 gnus-score-interactive-default-score))
|
|
|
1639 (date (nth 2 kill))
|
|
|
1640 (found nil)
|
|
108
|
1641 (case-fold-search
|
|
0
|
1642 (not (or (eq type 'R) (eq type 'S)
|
|
|
1643 (eq type 'Regexp) (eq type 'String))))
|
|
108
|
1644 (search-func
|
|
0
|
1645 (cond ((or (eq type 'r) (eq type 'R)
|
|
|
1646 (eq type 'regexp) (eq type 'Regexp))
|
|
|
1647 're-search-forward)
|
|
|
1648 ((or (eq type 's) (eq type 'S)
|
|
|
1649 (eq type 'string) (eq type 'String))
|
|
|
1650 'search-forward)
|
|
|
1651 (t
|
|
|
1652 (error "Illegal match type: %s" type)))))
|
|
|
1653 (goto-char (point-min))
|
|
98
|
1654 (when (funcall search-func match nil t)
|
|
|
1655 ;; Found a match, update scores.
|
|
|
1656 (setcdr (car articles) (+ score (cdar articles)))
|
|
|
1657 (setq found t)
|
|
|
1658 (when trace
|
|
|
1659 (push
|
|
|
1660 (cons (car-safe (rassq alist gnus-score-cache)) kill)
|
|
|
1661 gnus-score-trace)))
|
|
0
|
1662 ;; Update expire date
|
|
98
|
1663 (unless trace
|
|
|
1664 (cond
|
|
|
1665 ((null date)) ;Permanent entry.
|
|
108
|
1666 ((and found gnus-update-score-entry-dates)
|
|
98
|
1667 ;; Match, update date.
|
|
|
1668 (gnus-score-set 'touched '(t) alist)
|
|
|
1669 (setcar (nthcdr 2 kill) now))
|
|
|
1670 ((and expire (< date expire)) ;Old entry, remove.
|
|
|
1671 (gnus-score-set 'touched '(t) alist)
|
|
|
1672 (setcdr entries (cdr rest))
|
|
|
1673 (setq rest entries))))
|
|
0
|
1674 (setq entries rest)))))
|
|
|
1675 (setq articles (cdr articles)))))))
|
|
|
1676 nil)
|
|
|
1677
|
|
98
|
1678 (defun gnus-score-thread (scores header now expire &optional trace)
|
|
|
1679 (gnus-score-followup scores header now expire trace t))
|
|
|
1680
|
|
0
|
1681 (defun gnus-score-followup (scores header now expire &optional trace thread)
|
|
|
1682 ;; Insert the unique article headers in the buffer.
|
|
|
1683 (let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
|
|
|
1684 (current-score-file gnus-current-score-file)
|
|
|
1685 (all-scores scores)
|
|
|
1686 ;; gnus-score-index is used as a free variable.
|
|
|
1687 alike last this art entries alist articles
|
|
|
1688 new news)
|
|
|
1689
|
|
|
1690 ;; Change score file to the adaptive score file. All entries that
|
|
|
1691 ;; this function makes will be put into this file.
|
|
|
1692 (save-excursion
|
|
|
1693 (set-buffer gnus-summary-buffer)
|
|
|
1694 (gnus-score-load-file
|
|
|
1695 (or gnus-newsgroup-adaptive-score-file
|
|
108
|
1696 (gnus-score-file-name
|
|
0
|
1697 gnus-newsgroup-name gnus-adaptive-file-suffix))))
|
|
|
1698
|
|
|
1699 (setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<)
|
|
|
1700 articles gnus-scores-articles)
|
|
|
1701
|
|
|
1702 (erase-buffer)
|
|
|
1703 (while articles
|
|
|
1704 (setq art (car articles)
|
|
|
1705 this (aref (car art) gnus-score-index)
|
|
|
1706 articles (cdr articles))
|
|
|
1707 (if (equal last this)
|
|
98
|
1708 (push art alike)
|
|
|
1709 (when last
|
|
|
1710 (insert last ?\n)
|
|
|
1711 (put-text-property (1- (point)) (point) 'articles alike))
|
|
0
|
1712 (setq alike (list art)
|
|
|
1713 last this)))
|
|
98
|
1714 (when last ; Bwadr, duplicate code.
|
|
|
1715 (insert last ?\n)
|
|
|
1716 (put-text-property (1- (point)) (point) 'articles alike))
|
|
108
|
1717
|
|
0
|
1718 ;; Find matches.
|
|
|
1719 (while scores
|
|
|
1720 (setq alist (car scores)
|
|
|
1721 scores (cdr scores)
|
|
|
1722 entries (assoc header alist))
|
|
|
1723 (while (cdr entries) ;First entry is the header index.
|
|
98
|
1724 (let* ((rest (cdr entries))
|
|
0
|
1725 (kill (car rest))
|
|
|
1726 (match (nth 0 kill))
|
|
|
1727 (type (or (nth 3 kill) 's))
|
|
|
1728 (score (or (nth 1 kill) gnus-score-interactive-default-score))
|
|
|
1729 (date (nth 2 kill))
|
|
|
1730 (found nil)
|
|
|
1731 (mt (aref (symbol-name type) 0))
|
|
108
|
1732 (case-fold-search
|
|
0
|
1733 (not (or (= mt ?R) (= mt ?S) (= mt ?E) (= mt ?F))))
|
|
|
1734 (dmt (downcase mt))
|
|
108
|
1735 (search-func
|
|
0
|
1736 (cond ((= dmt ?r) 're-search-forward)
|
|
|
1737 ((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward)
|
|
|
1738 (t (error "Illegal match type: %s" type))))
|
|
|
1739 arts art)
|
|
|
1740 (goto-char (point-min))
|
|
|
1741 (if (= dmt ?e)
|
|
|
1742 (while (funcall search-func match nil t)
|
|
|
1743 (and (= (progn (beginning-of-line) (point))
|
|
|
1744 (match-beginning 0))
|
|
|
1745 (= (progn (end-of-line) (point))
|
|
|
1746 (match-end 0))
|
|
|
1747 (progn
|
|
108
|
1748 (setq found (setq arts (get-text-property
|
|
0
|
1749 (point) 'articles)))
|
|
|
1750 ;; Found a match, update scores.
|
|
|
1751 (while arts
|
|
|
1752 (setq art (car arts)
|
|
|
1753 arts (cdr arts))
|
|
108
|
1754 (gnus-score-add-followups
|
|
0
|
1755 (car art) score all-scores thread))))
|
|
|
1756 (end-of-line))
|
|
|
1757 (while (funcall search-func match nil t)
|
|
|
1758 (end-of-line)
|
|
|
1759 (setq found (setq arts (get-text-property (point) 'articles)))
|
|
|
1760 ;; Found a match, update scores.
|
|
|
1761 (while (setq art (pop arts))
|
|
|
1762 (when (setq new (gnus-score-add-followups
|
|
|
1763 (car art) score all-scores thread))
|
|
|
1764 (push new news)))))
|
|
|
1765 ;; Update expire date
|
|
|
1766 (cond ((null date)) ;Permanent entry.
|
|
|
1767 ((and found gnus-update-score-entry-dates) ;Match, update date.
|
|
|
1768 (gnus-score-set 'touched '(t) alist)
|
|
|
1769 (setcar (nthcdr 2 kill) now))
|
|
98
|
1770 ((and expire (< date expire)) ;Old entry, remove.
|
|
0
|
1771 (gnus-score-set 'touched '(t) alist)
|
|
|
1772 (setcdr entries (cdr rest))
|
|
|
1773 (setq rest entries)))
|
|
|
1774 (setq entries rest))))
|
|
|
1775 ;; We change the score file back to the previous one.
|
|
|
1776 (save-excursion
|
|
|
1777 (set-buffer gnus-summary-buffer)
|
|
|
1778 (gnus-score-load-file current-score-file))
|
|
|
1779 (list (cons "references" news))))
|
|
|
1780
|
|
|
1781 (defun gnus-score-add-followups (header score scores &optional thread)
|
|
|
1782 "Add a score entry to the adapt file."
|
|
|
1783 (save-excursion
|
|
|
1784 (set-buffer gnus-summary-buffer)
|
|
|
1785 (let* ((id (mail-header-id header))
|
|
|
1786 (scores (car scores))
|
|
|
1787 entry dont)
|
|
|
1788 ;; Don't enter a score if there already is one.
|
|
|
1789 (while (setq entry (pop scores))
|
|
|
1790 (and (equal "references" (car entry))
|
|
|
1791 (or (null (nth 3 (cadr entry)))
|
|
|
1792 (eq 's (nth 3 (cadr entry))))
|
|
|
1793 (assoc id entry)
|
|
|
1794 (setq dont t)))
|
|
|
1795 (unless dont
|
|
108
|
1796 (gnus-summary-score-entry
|
|
0
|
1797 (if thread "thread" "references")
|
|
|
1798 id 's score (current-time-string) nil t)))))
|
|
|
1799
|
|
|
1800 (defun gnus-score-string (score-list header now expire &optional trace)
|
|
|
1801 ;; Score ARTICLES according to HEADER in SCORE-LIST.
|
|
|
1802 ;; Update matching entries to NOW and remove unmatched entries older
|
|
|
1803 ;; than EXPIRE.
|
|
108
|
1804
|
|
0
|
1805 ;; Insert the unique article headers in the buffer.
|
|
|
1806 (let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
|
|
|
1807 ;; gnus-score-index is used as a free variable.
|
|
108
|
1808 alike last this art entries alist articles
|
|
98
|
1809 fuzzies arts words kill)
|
|
0
|
1810
|
|
|
1811 ;; Sorting the articles costs os O(N*log N) but will allow us to
|
|
|
1812 ;; only match with each unique header. Thus the actual matching
|
|
|
1813 ;; will be O(M*U) where M is the number of strings to match with,
|
|
|
1814 ;; and U is the number of unique headers. It is assumed (but
|
|
|
1815 ;; untested) this will be a net win because of the large constant
|
|
|
1816 ;; factor involved with string matching.
|
|
|
1817 (setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<)
|
|
|
1818 articles gnus-scores-articles)
|
|
|
1819
|
|
|
1820 (erase-buffer)
|
|
98
|
1821 (while (setq art (pop articles))
|
|
|
1822 (setq this (aref (car art) gnus-score-index))
|
|
0
|
1823 (if (equal last this)
|
|
|
1824 ;; O(N*H) cons-cells used here, where H is the number of
|
|
|
1825 ;; headers.
|
|
98
|
1826 (push art alike)
|
|
|
1827 (when last
|
|
|
1828 ;; Insert the line, with a text property on the
|
|
|
1829 ;; terminating newline referring to the articles with
|
|
|
1830 ;; this line.
|
|
|
1831 (insert last ?\n)
|
|
|
1832 (put-text-property (1- (point)) (point) 'articles alike))
|
|
0
|
1833 (setq alike (list art)
|
|
|
1834 last this)))
|
|
98
|
1835 (when last ; Bwadr, duplicate code.
|
|
|
1836 (insert last ?\n)
|
|
|
1837 (put-text-property (1- (point)) (point) 'articles alike))
|
|
0
|
1838
|
|
98
|
1839 ;; Go through all the score alists and pick out the entries
|
|
|
1840 ;; for this header.
|
|
|
1841 (while score-list
|
|
|
1842 (setq alist (pop score-list)
|
|
|
1843 ;; There's only one instance of this header for
|
|
|
1844 ;; each score alist.
|
|
0
|
1845 entries (assoc header alist))
|
|
|
1846 (while (cdr entries) ;First entry is the header index.
|
|
98
|
1847 (let* ((kill (cadr entries))
|
|
0
|
1848 (match (nth 0 kill))
|
|
|
1849 (type (or (nth 3 kill) 's))
|
|
|
1850 (score (or (nth 1 kill) gnus-score-interactive-default-score))
|
|
|
1851 (date (nth 2 kill))
|
|
|
1852 (found nil)
|
|
|
1853 (mt (aref (symbol-name type) 0))
|
|
98
|
1854 (case-fold-search (not (memq mt '(?R ?S ?E ?F))))
|
|
0
|
1855 (dmt (downcase mt))
|
|
108
|
1856 (search-func
|
|
0
|
1857 (cond ((= dmt ?r) 're-search-forward)
|
|
|
1858 ((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward)
|
|
98
|
1859 ((= dmt ?w) nil)
|
|
|
1860 (t (error "Illegal match type: %s" type)))))
|
|
|
1861 (cond
|
|
|
1862 ;; Fuzzy matches. We save these for later.
|
|
|
1863 ((= dmt ?f)
|
|
|
1864 (push (cons entries alist) fuzzies))
|
|
|
1865 ;; Word matches. Save these for even later.
|
|
|
1866 ((= dmt ?w)
|
|
|
1867 (push (cons entries alist) words))
|
|
|
1868 ;; Exact matches.
|
|
|
1869 ((= dmt ?e)
|
|
|
1870 ;; Do exact matching.
|
|
0
|
1871 (goto-char (point-min))
|
|
98
|
1872 (while (and (not (eobp))
|
|
|
1873 (funcall search-func match nil t))
|
|
|
1874 ;; Is it really exact?
|
|
|
1875 (and (eolp)
|
|
|
1876 (= (gnus-point-at-bol) (match-beginning 0))
|
|
|
1877 ;; Yup.
|
|
|
1878 (progn
|
|
108
|
1879 (setq found (setq arts (get-text-property
|
|
98
|
1880 (point) 'articles)))
|
|
|
1881 ;; Found a match, update scores.
|
|
|
1882 (if trace
|
|
|
1883 (while (setq art (pop arts))
|
|
|
1884 (setcdr art (+ score (cdr art)))
|
|
|
1885 (push
|
|
108
|
1886 (cons
|
|
98
|
1887 (car-safe (rassq alist gnus-score-cache))
|
|
|
1888 kill)
|
|
0
|
1889 gnus-score-trace))
|
|
98
|
1890 (while (setq art (pop arts))
|
|
|
1891 (setcdr art (+ score (cdr art)))))))
|
|
|
1892 (forward-line 1)))
|
|
|
1893 ;; Regexp and substring matching.
|
|
|
1894 (t
|
|
|
1895 (goto-char (point-min))
|
|
|
1896 (when (string= match "")
|
|
|
1897 (setq match "\n"))
|
|
|
1898 (while (and (not (eobp))
|
|
|
1899 (funcall search-func match nil t))
|
|
|
1900 (goto-char (match-beginning 0))
|
|
|
1901 (end-of-line)
|
|
|
1902 (setq found (setq arts (get-text-property (point) 'articles)))
|
|
|
1903 ;; Found a match, update scores.
|
|
|
1904 (if trace
|
|
|
1905 (while (setq art (pop arts))
|
|
|
1906 (setcdr art (+ score (cdr art)))
|
|
|
1907 (push (cons (car-safe (rassq alist gnus-score-cache)) kill)
|
|
|
1908 gnus-score-trace))
|
|
|
1909 (while (setq art (pop arts))
|
|
|
1910 (setcdr art (+ score (cdr art)))))
|
|
|
1911 (forward-line 1))))
|
|
|
1912 ;; Update expiry date
|
|
|
1913 (if trace
|
|
|
1914 (setq entries (cdr entries))
|
|
108
|
1915 (cond
|
|
98
|
1916 ;; Permanent entry.
|
|
|
1917 ((null date)
|
|
|
1918 (setq entries (cdr entries)))
|
|
|
1919 ;; We have a match, so we update the date.
|
|
|
1920 ((and found gnus-update-score-entry-dates)
|
|
0
|
1921 (gnus-score-set 'touched '(t) alist)
|
|
98
|
1922 (setcar (nthcdr 2 kill) now)
|
|
|
1923 (setq entries (cdr entries)))
|
|
|
1924 ;; This entry has expired, so we remove it.
|
|
|
1925 ((and expire (< date expire))
|
|
0
|
1926 (gnus-score-set 'touched '(t) alist)
|
|
98
|
1927 (setcdr entries (cddr entries)))
|
|
|
1928 ;; No match; go to next entry.
|
|
|
1929 (t
|
|
|
1930 (setq entries (cdr entries))))))))
|
|
0
|
1931
|
|
|
1932 ;; Find fuzzy matches.
|
|
98
|
1933 (when fuzzies
|
|
|
1934 ;; Simplify the entire buffer for easy matching.
|
|
0
|
1935 (gnus-simplify-buffer-fuzzy)
|
|
98
|
1936 (while (setq kill (cadaar fuzzies))
|
|
|
1937 (let* ((match (nth 0 kill))
|
|
|
1938 (type (nth 3 kill))
|
|
|
1939 (score (or (nth 1 kill) gnus-score-interactive-default-score))
|
|
|
1940 (date (nth 2 kill))
|
|
|
1941 (mt (aref (symbol-name type) 0))
|
|
|
1942 (case-fold-search (not (= mt ?F)))
|
|
|
1943 found)
|
|
|
1944 (goto-char (point-min))
|
|
|
1945 (while (and (not (eobp))
|
|
|
1946 (search-forward match nil t))
|
|
|
1947 (when (and (= (gnus-point-at-bol) (match-beginning 0))
|
|
|
1948 (eolp))
|
|
|
1949 (setq found (setq arts (get-text-property (point) 'articles)))
|
|
|
1950 (if trace
|
|
|
1951 (while (setq art (pop arts))
|
|
|
1952 (setcdr art (+ score (cdr art)))
|
|
|
1953 (push (cons
|
|
108
|
1954 (car-safe (rassq (cdar fuzzies) gnus-score-cache))
|
|
98
|
1955 kill)
|
|
|
1956 gnus-score-trace))
|
|
|
1957 ;; Found a match, update scores.
|
|
|
1958 (while (setq art (pop arts))
|
|
|
1959 (setcdr art (+ score (cdr art))))))
|
|
|
1960 (forward-line 1))
|
|
|
1961 ;; Update expiry date
|
|
|
1962 (cond
|
|
|
1963 ;; Permanent.
|
|
|
1964 ((null date)
|
|
|
1965 )
|
|
|
1966 ;; Match, update date.
|
|
|
1967 ((and found gnus-update-score-entry-dates)
|
|
|
1968 (gnus-score-set 'touched '(t) (cdar fuzzies))
|
|
|
1969 (setcar (nthcdr 2 kill) now))
|
|
|
1970 ;; Old entry, remove.
|
|
|
1971 ((and expire (< date expire))
|
|
|
1972 (gnus-score-set 'touched '(t) (cdar fuzzies))
|
|
|
1973 (setcdr (caar fuzzies) (cddaar fuzzies))))
|
|
|
1974 (setq fuzzies (cdr fuzzies)))))
|
|
|
1975
|
|
|
1976 (when words
|
|
|
1977 ;; Enter all words into the hashtb.
|
|
|
1978 (let ((hashtb (gnus-make-hashtable
|
|
|
1979 (* 10 (count-lines (point-min) (point-max))))))
|
|
|
1980 (gnus-enter-score-words-into-hashtb hashtb)
|
|
|
1981 (while (setq kill (cadaar words))
|
|
|
1982 (let* ((score (or (nth 1 kill) gnus-score-interactive-default-score))
|
|
0
|
1983 (date (nth 2 kill))
|
|
98
|
1984 found)
|
|
|
1985 (when (setq arts (intern-soft (nth 0 kill) hashtb))
|
|
|
1986 (setq arts (symbol-value arts))
|
|
|
1987 (setq found t)
|
|
|
1988 (if trace
|
|
|
1989 (while (setq art (pop arts))
|
|
|
1990 (setcdr art (+ score (cdr art)))
|
|
|
1991 (push (cons
|
|
|
1992 (car-safe (rassq (cdar words) gnus-score-cache))
|
|
|
1993 kill)
|
|
|
1994 gnus-score-trace))
|
|
|
1995 ;; Found a match, update scores.
|
|
|
1996 (while (setq art (pop arts))
|
|
|
1997 (setcdr art (+ score (cdr art))))))
|
|
|
1998 ;; Update expiry date
|
|
|
1999 (cond
|
|
|
2000 ;; Permanent.
|
|
|
2001 ((null date)
|
|
|
2002 )
|
|
|
2003 ;; Match, update date.
|
|
|
2004 ((and found gnus-update-score-entry-dates)
|
|
|
2005 (gnus-score-set 'touched '(t) (cdar words))
|
|
|
2006 (setcar (nthcdr 2 kill) now))
|
|
|
2007 ;; Old entry, remove.
|
|
|
2008 ((and expire (< date expire))
|
|
|
2009 (gnus-score-set 'touched '(t) (cdar words))
|
|
|
2010 (setcdr (caar words) (cddaar words))))
|
|
|
2011 (setq words (cdr words))))))
|
|
|
2012 nil))
|
|
|
2013
|
|
|
2014 (defun gnus-enter-score-words-into-hashtb (hashtb)
|
|
|
2015 ;; Find all the words in the buffer and enter them into
|
|
|
2016 ;; the hashtable.
|
|
|
2017 (let ((syntab (syntax-table))
|
|
|
2018 word val)
|
|
|
2019 (goto-char (point-min))
|
|
|
2020 (unwind-protect
|
|
|
2021 (progn
|
|
|
2022 (set-syntax-table gnus-adaptive-word-syntax-table)
|
|
|
2023 (while (re-search-forward "\\b\\w+\\b" nil t)
|
|
|
2024 (setq val
|
|
108
|
2025 (gnus-gethash
|
|
98
|
2026 (setq word (downcase (buffer-substring
|
|
|
2027 (match-beginning 0) (match-end 0))))
|
|
|
2028 hashtb))
|
|
|
2029 (gnus-sethash
|
|
|
2030 word
|
|
|
2031 (append (get-text-property (gnus-point-at-eol) 'articles) val)
|
|
|
2032 hashtb)))
|
|
|
2033 (set-syntax-table syntab))
|
|
|
2034 ;; Make all the ignorable words ignored.
|
|
|
2035 (let ((ignored (append gnus-ignored-adaptive-words
|
|
|
2036 gnus-default-ignored-adaptive-words)))
|
|
|
2037 (while ignored
|
|
|
2038 (gnus-sethash (pop ignored) nil hashtb)))))
|
|
0
|
2039
|
|
|
2040 (defun gnus-score-string< (a1 a2)
|
|
|
2041 ;; Compare headers in articles A2 and A2.
|
|
|
2042 ;; The header index used is the free variable `gnus-score-index'.
|
|
|
2043 (string-lessp (aref (car a1) gnus-score-index)
|
|
|
2044 (aref (car a2) gnus-score-index)))
|
|
|
2045
|
|
|
2046 (defun gnus-current-score-file-nondirectory (&optional score-file)
|
|
|
2047 (let ((score-file (or score-file gnus-current-score-file)))
|
|
108
|
2048 (if score-file
|
|
0
|
2049 (gnus-short-group-name (file-name-nondirectory score-file))
|
|
|
2050 "none")))
|
|
|
2051
|
|
|
2052 (defun gnus-score-adaptive ()
|
|
98
|
2053 "Create adaptive score rules for this newsgroup."
|
|
100
|
2054 (when gnus-newsgroup-adaptive
|
|
98
|
2055 ;; We change the score file to the adaptive score file.
|
|
|
2056 (save-excursion
|
|
|
2057 (set-buffer gnus-summary-buffer)
|
|
108
|
2058 (gnus-score-load-file
|
|
98
|
2059 (or gnus-newsgroup-adaptive-score-file
|
|
108
|
2060 (gnus-score-file-name
|
|
98
|
2061 gnus-newsgroup-name gnus-adaptive-file-suffix))))
|
|
|
2062 ;; Perform ordinary line scoring.
|
|
100
|
2063 (when (or (not (listp gnus-newsgroup-adaptive))
|
|
|
2064 (memq 'line gnus-newsgroup-adaptive))
|
|
0
|
2065 (save-excursion
|
|
98
|
2066 (let* ((malist (gnus-copy-sequence gnus-adaptive-score-alist))
|
|
|
2067 (alist malist)
|
|
|
2068 (date (current-time-string))
|
|
|
2069 (data gnus-newsgroup-data)
|
|
|
2070 elem headers match)
|
|
|
2071 ;; First we transform the adaptive rule alist into something
|
|
|
2072 ;; that's faster to process.
|
|
|
2073 (while malist
|
|
|
2074 (setq elem (car malist))
|
|
|
2075 (when (symbolp (car elem))
|
|
|
2076 (setcar elem (symbol-value (car elem))))
|
|
|
2077 (setq elem (cdr elem))
|
|
|
2078 (while elem
|
|
|
2079 (setcdr (car elem)
|
|
|
2080 (cons (if (eq (caar elem) 'followup)
|
|
|
2081 "references"
|
|
|
2082 (symbol-name (caar elem)))
|
|
|
2083 (cdar elem)))
|
|
|
2084 (setcar (car elem)
|
|
|
2085 `(lambda (h)
|
|
108
|
2086 (,(intern
|
|
|
2087 (concat "mail-header-"
|
|
98
|
2088 (if (eq (caar elem) 'followup)
|
|
|
2089 "message-id"
|
|
|
2090 (downcase (symbol-name (caar elem))))))
|
|
|
2091 h)))
|
|
|
2092 (setq elem (cdr elem)))
|
|
|
2093 (setq malist (cdr malist)))
|
|
|
2094 ;; Then we score away.
|
|
|
2095 (while data
|
|
|
2096 (setq elem (cdr (assq (gnus-data-mark (car data)) alist)))
|
|
|
2097 (if (or (not elem)
|
|
|
2098 (gnus-data-pseudo-p (car data)))
|
|
|
2099 ()
|
|
|
2100 (when (setq headers (gnus-data-header (car data)))
|
|
108
|
2101 (while elem
|
|
98
|
2102 (setq match (funcall (caar elem) headers))
|
|
108
|
2103 (gnus-summary-score-entry
|
|
98
|
2104 (nth 1 (car elem)) match
|
|
|
2105 (cond
|
|
|
2106 ((numberp match)
|
|
|
2107 '=)
|
|
|
2108 ((equal (nth 1 (car elem)) "date")
|
|
|
2109 'a)
|
|
|
2110 (t
|
|
|
2111 ;; Whether we use substring or exact matches is
|
|
108
|
2112 ;; controlled here.
|
|
98
|
2113 (if (or (not gnus-score-exact-adapt-limit)
|
|
|
2114 (< (length match) gnus-score-exact-adapt-limit))
|
|
108
|
2115 'e
|
|
98
|
2116 (if (equal (nth 1 (car elem)) "subject")
|
|
|
2117 'f 's))))
|
|
|
2118 (nth 2 (car elem)) date nil t)
|
|
|
2119 (setq elem (cdr elem)))))
|
|
|
2120 (setq data (cdr data))))))
|
|
|
2121
|
|
|
2122 ;; Perform adaptive word scoring.
|
|
100
|
2123 (when (and (listp gnus-newsgroup-adaptive)
|
|
|
2124 (memq 'word gnus-newsgroup-adaptive))
|
|
98
|
2125 (nnheader-temp-write nil
|
|
|
2126 (let* ((hashtb (gnus-make-hashtable 1000))
|
|
|
2127 (date (gnus-day-number (current-time-string)))
|
|
|
2128 (data gnus-newsgroup-data)
|
|
|
2129 (syntab (syntax-table))
|
|
|
2130 word d score val)
|
|
|
2131 (unwind-protect
|
|
|
2132 (progn
|
|
|
2133 (set-syntax-table gnus-adaptive-word-syntax-table)
|
|
|
2134 ;; Go through all articles.
|
|
|
2135 (while (setq d (pop data))
|
|
|
2136 (when (and
|
|
|
2137 (not (gnus-data-pseudo-p d))
|
|
|
2138 (setq score
|
|
108
|
2139 (cdr (assq
|
|
98
|
2140 (gnus-data-mark d)
|
|
|
2141 gnus-adaptive-word-score-alist))))
|
|
|
2142 ;; This article has a mark that should lead to
|
|
|
2143 ;; adaptive word rules, so we insert the subject
|
|
|
2144 ;; and find all words in that string.
|
|
|
2145 (insert (mail-header-subject (gnus-data-header d)))
|
|
|
2146 (downcase-region (point-min) (point-max))
|
|
|
2147 (goto-char (point-min))
|
|
|
2148 (while (re-search-forward "\\b\\w+\\b" nil t)
|
|
|
2149 ;; Put the word and score into the hashtb.
|
|
|
2150 (setq val (gnus-gethash (setq word (match-string 0))
|
|
|
2151 hashtb))
|
|
|
2152 (gnus-sethash word (+ (or val 0) score) hashtb))
|
|
|
2153 (erase-buffer))))
|
|
|
2154 (set-syntax-table syntab))
|
|
|
2155 ;; Make all the ignorable words ignored.
|
|
|
2156 (let ((ignored (append gnus-ignored-adaptive-words
|
|
|
2157 gnus-default-ignored-adaptive-words)))
|
|
|
2158 (while ignored
|
|
|
2159 (gnus-sethash (pop ignored) nil hashtb)))
|
|
|
2160 ;; Now we have all the words and scores, so we
|
|
|
2161 ;; add these rules to the ADAPT file.
|
|
|
2162 (set-buffer gnus-summary-buffer)
|
|
|
2163 (mapatoms
|
|
|
2164 (lambda (word)
|
|
|
2165 (when (symbol-value word)
|
|
|
2166 (gnus-summary-score-entry
|
|
|
2167 "subject" (symbol-name word) 'w (symbol-value word)
|
|
|
2168 date nil t)))
|
|
|
2169 hashtb))))))
|
|
0
|
2170
|
|
|
2171 (defun gnus-score-edit-done ()
|
|
|
2172 (let ((bufnam (buffer-file-name (current-buffer)))
|
|
|
2173 (winconf gnus-prev-winconf))
|
|
98
|
2174 (when winconf
|
|
|
2175 (set-window-configuration winconf))
|
|
0
|
2176 (gnus-score-remove-from-cache bufnam)
|
|
|
2177 (gnus-score-load-file bufnam)))
|
|
|
2178
|
|
|
2179 (defun gnus-score-find-trace ()
|
|
|
2180 "Find all score rules that applies to the current article."
|
|
|
2181 (interactive)
|
|
110
|
2182 (let ((old-scored gnus-newsgroup-scored))
|
|
|
2183 (let ((gnus-newsgroup-headers
|
|
|
2184 (list (gnus-summary-article-header)))
|
|
|
2185 (gnus-newsgroup-scored nil)
|
|
|
2186 trace)
|
|
|
2187 (save-excursion
|
|
|
2188 (nnheader-set-temp-buffer "*Score Trace*"))
|
|
|
2189 (setq gnus-score-trace nil)
|
|
|
2190 (gnus-possibly-score-headers 'trace)
|
|
|
2191 (if (not (setq trace gnus-score-trace))
|
|
|
2192 (gnus-error
|
|
|
2193 1 "No score rules apply to the current article (default score %d)."
|
|
|
2194 gnus-summary-default-score)
|
|
|
2195 (set-buffer "*Score Trace*")
|
|
|
2196 (gnus-add-current-to-buffer-list)
|
|
|
2197 (while trace
|
|
|
2198 (insert (format "%S -> %s\n" (cdar trace)
|
|
|
2199 (file-name-nondirectory (caar trace))))
|
|
|
2200 (setq trace (cdr trace)))
|
|
|
2201 (goto-char (point-min))
|
|
|
2202 (gnus-configure-windows 'score-trace)))
|
|
|
2203 (set-buffer gnus-summary-buffer)
|
|
|
2204 (setq gnus-newsgroup-scored old-scored)))
|
|
98
|
2205
|
|
|
2206 (defun gnus-score-find-favourite-words ()
|
|
|
2207 "List words used in scoring."
|
|
|
2208 (interactive)
|
|
|
2209 (let ((alists (gnus-score-load-files (gnus-all-score-files)))
|
|
|
2210 alist rule rules kill)
|
|
|
2211 ;; Go through all the score alists for this group
|
|
|
2212 ;; and find all `w' rules.
|
|
|
2213 (while (setq alist (pop alists))
|
|
|
2214 (while (setq rule (pop alist))
|
|
|
2215 (when (and (stringp (car rule))
|
|
|
2216 (equal "subject" (downcase (pop rule))))
|
|
|
2217 (while (setq kill (pop rule))
|
|
|
2218 (when (memq (nth 3 kill) '(w W word Word))
|
|
|
2219 (push (cons (or (nth 1 kill)
|
|
|
2220 gnus-score-interactive-default-score)
|
|
|
2221 (car kill))
|
|
|
2222 rules))))))
|
|
|
2223 (setq rules (sort rules (lambda (r1 r2)
|
|
|
2224 (string-lessp (cdr r1) (cdr r2)))))
|
|
|
2225 ;; Add up words that have appeared several times.
|
|
|
2226 (let ((r rules))
|
|
|
2227 (while (cdr r)
|
|
|
2228 (if (equal (cdar r) (cdadr r))
|
|
|
2229 (progn
|
|
|
2230 (setcar (car r) (+ (caar r) (caadr r)))
|
|
|
2231 (setcdr r (cddr r)))
|
|
|
2232 (pop r))))
|
|
|
2233 ;; Insert the words.
|
|
|
2234 (nnheader-set-temp-buffer "*Score Words*")
|
|
|
2235 (if (not (setq rules (sort rules (lambda (r1 r2) (> (car r1) (car r2))))))
|
|
|
2236 (gnus-error 3 "No word score rules")
|
|
|
2237 (while rules
|
|
|
2238 (insert (format "%-5d: %s\n" (caar rules) (cdar rules)))
|
|
|
2239 (pop rules))
|
|
|
2240 (gnus-add-current-to-buffer-list)
|
|
|
2241 (goto-char (point-min))
|
|
|
2242 (gnus-configure-windows 'score-words))))
|
|
0
|
2243
|
|
|
2244 (defun gnus-summary-rescore ()
|
|
|
2245 "Redo the entire scoring process in the current summary."
|
|
|
2246 (interactive)
|
|
|
2247 (gnus-score-save)
|
|
|
2248 (setq gnus-score-cache nil)
|
|
|
2249 (setq gnus-newsgroup-scored nil)
|
|
|
2250 (gnus-possibly-score-headers)
|
|
|
2251 (gnus-score-update-all-lines))
|
|
108
|
2252
|
|
0
|
2253 (defun gnus-score-flush-cache ()
|
|
|
2254 "Flush the cache of score files."
|
|
|
2255 (interactive)
|
|
|
2256 (gnus-score-save)
|
|
|
2257 (setq gnus-score-cache nil
|
|
|
2258 gnus-score-alist nil
|
|
|
2259 gnus-short-name-score-file-cache nil)
|
|
|
2260 (gnus-message 6 "The score cache is now flushed"))
|
|
|
2261
|
|
|
2262 (gnus-add-shutdown 'gnus-score-close 'gnus)
|
|
|
2263
|
|
|
2264 (defvar gnus-score-file-alist-cache nil)
|
|
|
2265
|
|
|
2266 (defun gnus-score-close ()
|
|
|
2267 "Clear all internal score variables."
|
|
|
2268 (setq gnus-score-cache nil
|
|
|
2269 gnus-internal-global-score-files nil
|
|
|
2270 gnus-score-file-list nil
|
|
|
2271 gnus-score-file-alist-cache nil))
|
|
|
2272
|
|
|
2273 ;; Summary score marking commands.
|
|
|
2274
|
|
|
2275 (defun gnus-summary-raise-same-subject-and-select (score)
|
|
|
2276 "Raise articles which has the same subject with SCORE and select the next."
|
|
|
2277 (interactive "p")
|
|
|
2278 (let ((subject (gnus-summary-article-subject)))
|
|
|
2279 (gnus-summary-raise-score score)
|
|
|
2280 (while (gnus-summary-find-subject subject)
|
|
|
2281 (gnus-summary-raise-score score))
|
|
|
2282 (gnus-summary-next-article t)))
|
|
|
2283
|
|
|
2284 (defun gnus-summary-raise-same-subject (score)
|
|
|
2285 "Raise articles which has the same subject with SCORE."
|
|
|
2286 (interactive "p")
|
|
|
2287 (let ((subject (gnus-summary-article-subject)))
|
|
|
2288 (gnus-summary-raise-score score)
|
|
|
2289 (while (gnus-summary-find-subject subject)
|
|
|
2290 (gnus-summary-raise-score score))
|
|
|
2291 (gnus-summary-next-subject 1 t)))
|
|
|
2292
|
|
|
2293 (defun gnus-score-default (level)
|
|
98
|
2294 (if level (prefix-numeric-value level)
|
|
0
|
2295 gnus-score-interactive-default-score))
|
|
|
2296
|
|
|
2297 (defun gnus-summary-raise-thread (&optional score)
|
|
|
2298 "Raise the score of the articles in the current thread with SCORE."
|
|
|
2299 (interactive "P")
|
|
|
2300 (setq score (gnus-score-default score))
|
|
|
2301 (let (e)
|
|
|
2302 (save-excursion
|
|
|
2303 (let ((articles (gnus-summary-articles-in-thread)))
|
|
|
2304 (while articles
|
|
|
2305 (gnus-summary-goto-subject (car articles))
|
|
|
2306 (gnus-summary-raise-score score)
|
|
|
2307 (setq articles (cdr articles))))
|
|
|
2308 (setq e (point)))
|
|
|
2309 (let ((gnus-summary-check-current t))
|
|
98
|
2310 (unless (zerop (gnus-summary-next-subject 1 t))
|
|
|
2311 (goto-char e))))
|
|
0
|
2312 (gnus-summary-recenter)
|
|
|
2313 (gnus-summary-position-point)
|
|
|
2314 (gnus-set-mode-line 'summary))
|
|
|
2315
|
|
|
2316 (defun gnus-summary-lower-same-subject-and-select (score)
|
|
|
2317 "Raise articles which has the same subject with SCORE and select the next."
|
|
|
2318 (interactive "p")
|
|
|
2319 (gnus-summary-raise-same-subject-and-select (- score)))
|
|
|
2320
|
|
|
2321 (defun gnus-summary-lower-same-subject (score)
|
|
|
2322 "Raise articles which has the same subject with SCORE."
|
|
|
2323 (interactive "p")
|
|
|
2324 (gnus-summary-raise-same-subject (- score)))
|
|
|
2325
|
|
|
2326 (defun gnus-summary-lower-thread (&optional score)
|
|
|
2327 "Lower score of articles in the current thread with SCORE."
|
|
|
2328 (interactive "P")
|
|
|
2329 (gnus-summary-raise-thread (- (1- (gnus-score-default score)))))
|
|
|
2330
|
|
108
|
2331 ;;; Finding score files.
|
|
0
|
2332
|
|
|
2333 (defun gnus-score-score-files (group)
|
|
|
2334 "Return a list of all possible score files."
|
|
|
2335 ;; Search and set any global score files.
|
|
108
|
2336 (when gnus-global-score-files
|
|
98
|
2337 (unless gnus-internal-global-score-files
|
|
|
2338 (gnus-score-search-global-directories gnus-global-score-files)))
|
|
0
|
2339 ;; Fix the kill-file dir variable.
|
|
108
|
2340 (setq gnus-kill-files-directory
|
|
0
|
2341 (file-name-as-directory gnus-kill-files-directory))
|
|
|
2342 ;; If we can't read it, there are no score files.
|
|
|
2343 (if (not (file-exists-p (expand-file-name gnus-kill-files-directory)))
|
|
|
2344 (setq gnus-score-file-list nil)
|
|
|
2345 (if (not (gnus-use-long-file-name 'not-score))
|
|
|
2346 ;; We do not use long file names, so we have to do some
|
|
108
|
2347 ;; directory traversing.
|
|
|
2348 (setq gnus-score-file-list
|
|
|
2349 (cons nil
|
|
0
|
2350 (or gnus-short-name-score-file-cache
|
|
|
2351 (prog2
|
|
|
2352 (gnus-message 6 "Finding all score files...")
|
|
|
2353 (setq gnus-short-name-score-file-cache
|
|
|
2354 (gnus-score-score-files-1
|
|
|
2355 gnus-kill-files-directory))
|
|
|
2356 (gnus-message 6 "Finding all score files...done")))))
|
|
|
2357 ;; We want long file names.
|
|
|
2358 (when (or (not gnus-score-file-list)
|
|
|
2359 (not (car gnus-score-file-list))
|
|
|
2360 (gnus-file-newer-than gnus-kill-files-directory
|
|
|
2361 (car gnus-score-file-list)))
|
|
108
|
2362 (setq gnus-score-file-list
|
|
0
|
2363 (cons (nth 5 (file-attributes gnus-kill-files-directory))
|
|
108
|
2364 (nreverse
|
|
|
2365 (directory-files
|
|
|
2366 gnus-kill-files-directory t
|
|
0
|
2367 (gnus-score-file-regexp)))))))
|
|
|
2368 (cdr gnus-score-file-list)))
|
|
|
2369
|
|
|
2370 (defun gnus-score-score-files-1 (dir)
|
|
|
2371 "Return all possible score files under DIR."
|
|
98
|
2372 (let ((files (list (expand-file-name dir)))
|
|
0
|
2373 (regexp (gnus-score-file-regexp))
|
|
98
|
2374 (case-fold-search nil)
|
|
|
2375 seen out file)
|
|
0
|
2376 (while (setq file (pop files))
|
|
108
|
2377 (cond
|
|
0
|
2378 ;; Ignore "." and "..".
|
|
|
2379 ((member (file-name-nondirectory file) '("." ".."))
|
|
|
2380 nil)
|
|
98
|
2381 ;; Add subtrees of directory to also be searched.
|
|
|
2382 ((and (file-directory-p file)
|
|
|
2383 (not (member (file-truename file) seen)))
|
|
|
2384 (push (file-truename file) seen)
|
|
|
2385 (setq files (nconc (directory-files file t nil t) files)))
|
|
0
|
2386 ;; Add files to the list of score files.
|
|
|
2387 ((string-match regexp file)
|
|
|
2388 (push file out))))
|
|
|
2389 (or out
|
|
|
2390 ;; Return a dummy value.
|
|
|
2391 (list "~/News/this.file.does.not.exist.SCORE"))))
|
|
108
|
2392
|
|
0
|
2393 (defun gnus-score-file-regexp ()
|
|
|
2394 "Return a regexp that match all score files."
|
|
|
2395 (concat "\\(" (regexp-quote gnus-score-file-suffix )
|
|
|
2396 "\\|" (regexp-quote gnus-adaptive-file-suffix) "\\)\\'"))
|
|
108
|
2397
|
|
0
|
2398 (defun gnus-score-find-bnews (group)
|
|
|
2399 "Return a list of score files for GROUP.
|
|
|
2400 The score files are those files in the ~/News/ directory which matches
|
|
|
2401 GROUP using BNews sys file syntax."
|
|
|
2402 (let* ((sfiles (append (gnus-score-score-files group)
|
|
|
2403 gnus-internal-global-score-files))
|
|
108
|
2404 (kill-dir (file-name-as-directory
|
|
0
|
2405 (expand-file-name gnus-kill-files-directory)))
|
|
|
2406 (klen (length kill-dir))
|
|
|
2407 (score-regexp (gnus-score-file-regexp))
|
|
|
2408 (trans (cdr (assq ?: nnheader-file-name-translation-alist)))
|
|
|
2409 ofiles not-match regexp)
|
|
|
2410 (save-excursion
|
|
|
2411 (set-buffer (get-buffer-create "*gnus score files*"))
|
|
|
2412 (buffer-disable-undo (current-buffer))
|
|
|
2413 ;; Go through all score file names and create regexp with them
|
|
108
|
2414 ;; as the source.
|
|
0
|
2415 (while sfiles
|
|
|
2416 (erase-buffer)
|
|
|
2417 (insert (car sfiles))
|
|
|
2418 (goto-char (point-min))
|
|
|
2419 ;; First remove the suffix itself.
|
|
|
2420 (when (re-search-forward (concat "." score-regexp) nil t)
|
|
98
|
2421 (replace-match "" t t)
|
|
0
|
2422 (goto-char (point-min))
|
|
|
2423 (if (looking-at (regexp-quote kill-dir))
|
|
|
2424 ;; If the file name was just "SCORE", `klen' is one character
|
|
|
2425 ;; too much.
|
|
|
2426 (delete-char (min (1- (point-max)) klen))
|
|
|
2427 (goto-char (point-max))
|
|
|
2428 (search-backward "/")
|
|
|
2429 (delete-region (1+ (point)) (point-min)))
|
|
|
2430 ;; If short file names were used, we have to translate slashes.
|
|
|
2431 (goto-char (point-min))
|
|
|
2432 (let ((regexp (concat
|
|
|
2433 "[/:" (if trans (char-to-string trans) "") "]")))
|
|
|
2434 (while (re-search-forward regexp nil t)
|
|
|
2435 (replace-match "." t t)))
|
|
98
|
2436 ;; Kludge to get rid of "nntp+" problems.
|
|
0
|
2437 (goto-char (point-min))
|
|
98
|
2438 (when (looking-at "nn[a-z]+\\+")
|
|
|
2439 (search-forward "+")
|
|
|
2440 (forward-char -1)
|
|
|
2441 (insert "\\")
|
|
|
2442 (forward-char 1))
|
|
0
|
2443 ;; Kludge to deal with "++".
|
|
98
|
2444 (while (search-forward "+" nil t)
|
|
|
2445 (replace-match "\\+" t t))
|
|
0
|
2446 ;; Translate "all" to ".*".
|
|
|
2447 (goto-char (point-min))
|
|
|
2448 (while (search-forward "all" nil t)
|
|
|
2449 (replace-match ".*" t t))
|
|
|
2450 (goto-char (point-min))
|
|
|
2451 ;; Deal with "not."s.
|
|
|
2452 (if (looking-at "not.")
|
|
|
2453 (progn
|
|
|
2454 (setq not-match t)
|
|
140
|
2455 (setq regexp (concat "^" (buffer-substring 5 (point-max)) "$")))
|
|
|
2456 (setq regexp (concat "^" (buffer-substring 1 (point-max)) "$"))
|
|
0
|
2457 (setq not-match nil))
|
|
|
2458 ;; Finally - if this resulting regexp matches the group name,
|
|
|
2459 ;; we add this score file to the list of score files
|
|
|
2460 ;; applicable to this group.
|
|
98
|
2461 (when (or (and not-match
|
|
|
2462 (not (string-match regexp group)))
|
|
|
2463 (and (not not-match)
|
|
|
2464 (string-match regexp group)))
|
|
|
2465 (push (car sfiles) ofiles)))
|
|
0
|
2466 (setq sfiles (cdr sfiles)))
|
|
|
2467 (kill-buffer (current-buffer))
|
|
|
2468 ;; Slight kludge here - the last score file returned should be
|
|
98
|
2469 ;; the local score file, whether it exists or not. This is so
|
|
0
|
2470 ;; that any score commands the user enters will go to the right
|
|
|
2471 ;; file, and not end up in some global score file.
|
|
|
2472 (let ((localscore (gnus-score-file-name group)))
|
|
|
2473 (setq ofiles (cons localscore (delete localscore ofiles))))
|
|
98
|
2474 (gnus-sort-score-files (nreverse ofiles)))))
|
|
0
|
2475
|
|
|
2476 (defun gnus-score-find-single (group)
|
|
|
2477 "Return list containing the score file for GROUP."
|
|
|
2478 (list (or gnus-newsgroup-adaptive-score-file
|
|
|
2479 (gnus-score-file-name group gnus-adaptive-file-suffix))
|
|
|
2480 (gnus-score-file-name group)))
|
|
|
2481
|
|
|
2482 (defun gnus-score-find-hierarchical (group)
|
|
|
2483 "Return list of score files for GROUP.
|
|
|
2484 This includes the score file for the group and all its parents."
|
|
98
|
2485 (let* ((prefix (gnus-group-real-prefix group))
|
|
|
2486 (all (list nil))
|
|
|
2487 (group (gnus-group-real-name group))
|
|
|
2488 (start 0))
|
|
0
|
2489 (while (string-match "\\." group (1+ start))
|
|
|
2490 (setq start (match-beginning 0))
|
|
98
|
2491 (push (substring group 0 start) all))
|
|
|
2492 (push group all)
|
|
|
2493 (setq all
|
|
|
2494 (nconc
|
|
|
2495 (mapcar (lambda (group)
|
|
|
2496 (gnus-score-file-name group gnus-adaptive-file-suffix))
|
|
|
2497 (setq all (nreverse all)))
|
|
|
2498 (mapcar 'gnus-score-file-name all)))
|
|
|
2499 (if (equal prefix "")
|
|
|
2500 all
|
|
108
|
2501 (mapcar
|
|
98
|
2502 (lambda (file)
|
|
118
|
2503 (nnheader-translate-file-chars
|
|
|
2504 (concat (file-name-directory file) prefix
|
|
|
2505 (file-name-nondirectory file))))
|
|
98
|
2506 all))))
|
|
|
2507
|
|
|
2508 (defun gnus-score-file-rank (file)
|
|
|
2509 "Return a number that says how specific score FILE is.
|
|
|
2510 Destroys the current buffer."
|
|
|
2511 (if (member file gnus-internal-global-score-files)
|
|
|
2512 0
|
|
|
2513 (when (string-match
|
|
|
2514 (concat "^" (regexp-quote
|
|
|
2515 (expand-file-name
|
|
|
2516 (file-name-as-directory gnus-kill-files-directory))))
|
|
|
2517 file)
|
|
|
2518 (setq file (substring file (match-end 0))))
|
|
|
2519 (insert file)
|
|
|
2520 (goto-char (point-min))
|
|
|
2521 (let ((beg (point))
|
|
|
2522 elems)
|
|
|
2523 (while (re-search-forward "[./]" nil t)
|
|
|
2524 (push (buffer-substring beg (1- (point)))
|
|
|
2525 elems))
|
|
|
2526 (erase-buffer)
|
|
|
2527 (setq elems (delete "all" elems))
|
|
|
2528 (length elems))))
|
|
108
|
2529
|
|
98
|
2530 (defun gnus-sort-score-files (files)
|
|
|
2531 "Sort FILES so that the most general files come first."
|
|
|
2532 (nnheader-temp-write nil
|
|
|
2533 (let ((alist
|
|
|
2534 (mapcar
|
|
|
2535 (lambda (file)
|
|
|
2536 (cons (inline (gnus-score-file-rank file)) file))
|
|
|
2537 files)))
|
|
|
2538 (mapcar
|
|
|
2539 (lambda (f) (cdr f))
|
|
|
2540 (sort alist (lambda (f1 f2) (< (car f1) (car f2))))))))
|
|
0
|
2541
|
|
|
2542 (defun gnus-score-find-alist (group)
|
|
|
2543 "Return list of score files for GROUP.
|
|
|
2544 The list is determined from the variable gnus-score-file-alist."
|
|
|
2545 (let ((alist gnus-score-file-multiple-match-alist)
|
|
|
2546 score-files)
|
|
|
2547 ;; if this group has been seen before, return the cached entry
|
|
|
2548 (if (setq score-files (assoc group gnus-score-file-alist-cache))
|
|
|
2549 (cdr score-files) ;ensures caching groups with no matches
|
|
|
2550 ;; handle the multiple match alist
|
|
|
2551 (while alist
|
|
98
|
2552 (when (string-match (caar alist) group)
|
|
|
2553 (setq score-files
|
|
|
2554 (nconc score-files (copy-sequence (cdar alist)))))
|
|
0
|
2555 (setq alist (cdr alist)))
|
|
|
2556 (setq alist gnus-score-file-single-match-alist)
|
|
|
2557 ;; handle the single match alist
|
|
|
2558 (while alist
|
|
98
|
2559 (when (string-match (caar alist) group)
|
|
|
2560 ;; progn used just in case ("regexp") has no files
|
|
|
2561 ;; and score-files is still nil. -sj
|
|
|
2562 ;; this can be construed as a "stop searching here" feature :>
|
|
108
|
2563 ;; and used to simplify regexps in the single-alist
|
|
98
|
2564 (setq score-files
|
|
|
2565 (nconc score-files (copy-sequence (cdar alist))))
|
|
|
2566 (setq alist nil))
|
|
0
|
2567 (setq alist (cdr alist)))
|
|
|
2568 ;; cache the score files
|
|
98
|
2569 (push (cons group score-files) gnus-score-file-alist-cache)
|
|
0
|
2570 score-files)))
|
|
|
2571
|
|
98
|
2572 (defun gnus-all-score-files (&optional group)
|
|
|
2573 "Return a list of all score files for the current group."
|
|
0
|
2574 (let ((funcs gnus-score-find-score-files-function)
|
|
98
|
2575 (group (or group gnus-newsgroup-name))
|
|
0
|
2576 score-files)
|
|
|
2577 ;; Make sure funcs is a list.
|
|
|
2578 (and funcs
|
|
|
2579 (not (listp funcs))
|
|
|
2580 (setq funcs (list funcs)))
|
|
|
2581 ;; Get the initial score files for this group.
|
|
108
|
2582 (when funcs
|
|
98
|
2583 (setq score-files (nreverse (gnus-score-find-alist group))))
|
|
|
2584 ;; Add any home adapt files.
|
|
|
2585 (let ((home (gnus-home-score-file group t)))
|
|
|
2586 (when home
|
|
|
2587 (push home score-files)
|
|
|
2588 (setq gnus-newsgroup-adaptive-score-file home)))
|
|
|
2589 ;; Check whether there is a `adapt-file' group parameter.
|
|
|
2590 (let ((param-file (gnus-group-find-parameter group 'adapt-file)))
|
|
|
2591 (when param-file
|
|
|
2592 (push param-file score-files)
|
|
|
2593 (setq gnus-newsgroup-adaptive-score-file param-file)))
|
|
0
|
2594 ;; Go through all the functions for finding score files (or actual
|
|
|
2595 ;; scores) and add them to a list.
|
|
|
2596 (while funcs
|
|
|
2597 (when (gnus-functionp (car funcs))
|
|
108
|
2598 (setq score-files
|
|
98
|
2599 (nconc score-files (nreverse (funcall (car funcs) group)))))
|
|
0
|
2600 (setq funcs (cdr funcs)))
|
|
98
|
2601 ;; Add any home score files.
|
|
|
2602 (let ((home (gnus-home-score-file group)))
|
|
|
2603 (when home
|
|
|
2604 (push home score-files)))
|
|
0
|
2605 ;; Check whether there is a `score-file' group parameter.
|
|
98
|
2606 (let ((param-file (gnus-group-find-parameter group 'score-file)))
|
|
0
|
2607 (when param-file
|
|
|
2608 (push param-file score-files)))
|
|
98
|
2609 ;; Expand all files names.
|
|
|
2610 (let ((files score-files))
|
|
|
2611 (while files
|
|
|
2612 (when (stringp (car files))
|
|
|
2613 (setcar files (expand-file-name
|
|
|
2614 (car files) gnus-kill-files-directory)))
|
|
|
2615 (pop files)))
|
|
|
2616 (setq score-files (nreverse score-files))
|
|
|
2617 ;; Remove any duplicate score files.
|
|
|
2618 (while (and score-files
|
|
|
2619 (member (car score-files) (cdr score-files)))
|
|
|
2620 (pop score-files))
|
|
|
2621 (let ((files score-files))
|
|
|
2622 (while (cdr files)
|
|
110
|
2623 (if (member (cadr files) (cddr files))
|
|
|
2624 (setcdr files (cddr files))
|
|
|
2625 (pop files))))
|
|
0
|
2626 ;; Do the scoring if there are any score files for this group.
|
|
98
|
2627 score-files))
|
|
108
|
2628
|
|
98
|
2629 (defun gnus-possibly-score-headers (&optional trace)
|
|
|
2630 "Do scoring if scoring is required."
|
|
|
2631 (let ((score-files (gnus-all-score-files)))
|
|
0
|
2632 (when score-files
|
|
|
2633 (gnus-score-headers score-files trace))))
|
|
|
2634
|
|
|
2635 (defun gnus-score-file-name (newsgroup &optional suffix)
|
|
|
2636 "Return the name of a score file for NEWSGROUP."
|
|
|
2637 (let ((suffix (or suffix gnus-score-file-suffix)))
|
|
|
2638 (nnheader-translate-file-chars
|
|
|
2639 (cond
|
|
|
2640 ((or (null newsgroup)
|
|
|
2641 (string-equal newsgroup ""))
|
|
|
2642 ;; The global score file is placed at top of the directory.
|
|
108
|
2643 (expand-file-name
|
|
0
|
2644 suffix gnus-kill-files-directory))
|
|
|
2645 ((gnus-use-long-file-name 'not-score)
|
|
|
2646 ;; Append ".SCORE" to newsgroup name.
|
|
|
2647 (expand-file-name (concat (gnus-newsgroup-savable-name newsgroup)
|
|
|
2648 "." suffix)
|
|
|
2649 gnus-kill-files-directory))
|
|
|
2650 (t
|
|
|
2651 ;; Place "SCORE" under the hierarchical directory.
|
|
|
2652 (expand-file-name (concat (gnus-newsgroup-directory-form newsgroup)
|
|
|
2653 "/" suffix)
|
|
|
2654 gnus-kill-files-directory))))))
|
|
|
2655
|
|
|
2656 (defun gnus-score-search-global-directories (files)
|
|
|
2657 "Scan all global score directories for score files."
|
|
|
2658 ;; Set the variable `gnus-internal-global-score-files' to all
|
|
|
2659 ;; available global score files.
|
|
|
2660 (interactive (list gnus-global-score-files))
|
|
|
2661 (let (out)
|
|
|
2662 (while files
|
|
|
2663 (if (string-match "/$" (car files))
|
|
108
|
2664 (setq out (nconc (directory-files
|
|
0
|
2665 (car files) t
|
|
|
2666 (concat (gnus-score-file-regexp) "$"))))
|
|
98
|
2667 (push (car files) out))
|
|
0
|
2668 (setq files (cdr files)))
|
|
|
2669 (setq gnus-internal-global-score-files out)))
|
|
|
2670
|
|
|
2671 (defun gnus-score-default-fold-toggle ()
|
|
|
2672 "Toggle folding for new score file entries."
|
|
|
2673 (interactive)
|
|
|
2674 (setq gnus-score-default-fold (not gnus-score-default-fold))
|
|
|
2675 (if gnus-score-default-fold
|
|
|
2676 (gnus-message 1 "New score file entries will be case insensitive.")
|
|
|
2677 (gnus-message 1 "New score file entries will be case sensitive.")))
|
|
|
2678
|
|
98
|
2679 ;;; Home score file.
|
|
|
2680
|
|
|
2681 (defun gnus-home-score-file (group &optional adapt)
|
|
|
2682 "Return the home score file for GROUP.
|
|
|
2683 If ADAPT, return the home adaptive file instead."
|
|
|
2684 (let ((list (if adapt gnus-home-adapt-file gnus-home-score-file))
|
|
|
2685 elem found)
|
|
|
2686 ;; Make sure we have a list.
|
|
|
2687 (unless (listp list)
|
|
|
2688 (setq list (list list)))
|
|
|
2689 ;; Go through the list and look for matches.
|
|
|
2690 (while (and (not found)
|
|
|
2691 (setq elem (pop list)))
|
|
|
2692 (setq found
|
|
|
2693 (cond
|
|
|
2694 ;; Simple string.
|
|
|
2695 ((stringp elem)
|
|
|
2696 elem)
|
|
|
2697 ;; Function.
|
|
|
2698 ((gnus-functionp elem)
|
|
|
2699 (funcall elem group))
|
|
|
2700 ;; Regexp-file cons
|
|
|
2701 ((consp elem)
|
|
|
2702 (when (string-match (car elem) group)
|
|
|
2703 (cadr elem))))))
|
|
|
2704 (when found
|
|
|
2705 (nnheader-concat gnus-kill-files-directory found))))
|
|
|
2706
|
|
|
2707 (defun gnus-hierarchial-home-score-file (group)
|
|
|
2708 "Return the score file of the top-level hierarchy of GROUP."
|
|
|
2709 (if (string-match "^[^.]+\\." group)
|
|
|
2710 (concat (match-string 0 group) gnus-score-file-suffix)
|
|
|
2711 ;; Group name without any dots.
|
|
100
|
2712 (concat group (if (gnus-use-long-file-name 'not-score) "." "/")
|
|
|
2713 gnus-score-file-suffix)))
|
|
108
|
2714
|
|
98
|
2715 (defun gnus-hierarchial-home-adapt-file (group)
|
|
|
2716 "Return the adapt file of the top-level hierarchy of GROUP."
|
|
|
2717 (if (string-match "^[^.]+\\." group)
|
|
|
2718 (concat (match-string 0 group) gnus-adaptive-file-suffix)
|
|
|
2719 ;; Group name without any dots.
|
|
100
|
2720 (concat group (if (gnus-use-long-file-name 'not-score) "." "/")
|
|
|
2721 gnus-adaptive-file-suffix)))
|
|
98
|
2722
|
|
|
2723 ;;;
|
|
|
2724 ;;; Score decays
|
|
|
2725 ;;;
|
|
|
2726
|
|
|
2727 (defun gnus-decay-score (score)
|
|
155
|
2728 "Decay SCORE according to `gnus-score-decay-constant' and `gnus-score-decay-scale'."
|
|
98
|
2729 (floor
|
|
|
2730 (- score
|
|
|
2731 (* (if (< score 0) 1 -1)
|
|
155
|
2732 (min (abs score)
|
|
98
|
2733 (max gnus-score-decay-constant
|
|
|
2734 (* (abs score)
|
|
|
2735 gnus-score-decay-scale)))))))
|
|
|
2736
|
|
|
2737 (defun gnus-decay-scores (alist day)
|
|
|
2738 "Decay non-permanent scores in ALIST."
|
|
|
2739 (let ((times (- (gnus-time-to-day (current-time)) day))
|
|
|
2740 kill entry updated score n)
|
|
|
2741 (unless (zerop times) ;Done decays today already?
|
|
|
2742 (while (setq entry (pop alist))
|
|
|
2743 (when (stringp (car entry))
|
|
|
2744 (setq entry (cdr entry))
|
|
|
2745 (while (setq kill (pop entry))
|
|
|
2746 (when (nth 2 kill)
|
|
|
2747 (setq updated t)
|
|
|
2748 (setq score (or (car kill) gnus-score-interactive-default-score)
|
|
|
2749 n times)
|
|
|
2750 (while (natnump (decf n))
|
|
|
2751 (setq score (funcall gnus-decay-score-function score)))
|
|
|
2752 (setcar kill score))))))
|
|
|
2753 ;; Return whether this score file needs to be saved. By Je-haysuss!
|
|
|
2754 updated))
|
|
|
2755
|
|
0
|
2756 (provide 'gnus-score)
|
|
|
2757
|
|
|
2758 ;;; gnus-score.el ends here
|
