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