1 |
;;; gnus-score.el --- scoring code for Gnus |
;;; gnus-score.el --- scoring code for Gnus |
2 |
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2004 |
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004 |
3 |
;; Free Software Foundation, Inc. |
;; Free Software Foundation, Inc. |
4 |
|
|
5 |
;; Author: Per Abrahamsen <amanda@iesd.auc.dk> |
;; Author: Per Abrahamsen <amanda@iesd.auc.dk> |
32 |
(require 'gnus) |
(require 'gnus) |
33 |
(require 'gnus-sum) |
(require 'gnus-sum) |
34 |
(require 'gnus-range) |
(require 'gnus-range) |
35 |
|
(require 'gnus-win) |
36 |
(require 'message) |
(require 'message) |
37 |
(require 'score-mode) |
(require 'score-mode) |
38 |
|
|
39 |
|
(autoload 'ffap-string-at-point "ffap") |
40 |
|
|
41 |
(defcustom gnus-global-score-files nil |
(defcustom gnus-global-score-files nil |
42 |
"List of global score files and directories. |
"List of global score files and directories. |
43 |
Set this variable if you want to use people's score files. One entry |
Set this variable if you want to use people's score files. One entry |
50 |
|
|
51 |
(setq gnus-global-score-files |
(setq gnus-global-score-files |
52 |
'(\"/ftp.gnus.org:/pub/larsi/ding/score/soc.motss.SCORE\" |
'(\"/ftp.gnus.org:/pub/larsi/ding/score/soc.motss.SCORE\" |
53 |
\"/ftp.some-where:/pub/score\"))" |
\"/ftp.some-where:/pub/score\"))" |
54 |
:group 'gnus-score-files |
:group 'gnus-score-files |
55 |
:type '(repeat file)) |
:type '(repeat file)) |
56 |
|
|
235 |
(symbol :tag "other")) |
(symbol :tag "other")) |
236 |
(integer :tag "Score")))))) |
(integer :tag "Score")))))) |
237 |
|
|
238 |
|
(defcustom gnus-adaptive-word-length-limit nil |
239 |
|
"*Words of a length lesser than this limit will be ignored when doing adaptive scoring." |
240 |
|
:group 'gnus-score-adapt |
241 |
|
:type '(radio (const :format "Unlimited " nil) |
242 |
|
(integer :format "Maximum length: %v\n" :size 0))) |
243 |
|
|
244 |
(defcustom gnus-ignored-adaptive-words nil |
(defcustom gnus-ignored-adaptive-words nil |
245 |
"List of words to be ignored when doing adaptive word scoring." |
"List of words to be ignored when doing adaptive word scoring." |
246 |
:group 'gnus-score-adapt |
:group 'gnus-score-adapt |
492 |
"Make a score entry based on the current article. |
"Make a score entry based on the current article. |
493 |
The user will be prompted for header to score on, match type, |
The user will be prompted for header to score on, match type, |
494 |
permanence, and the string to be used. The numerical prefix will be |
permanence, and the string to be used. The numerical prefix will be |
495 |
used as score." |
used as score. A symbolic prefix of `a' says to use the `all.SCORE' |
496 |
|
file for the command instead of the current score file." |
497 |
(interactive (gnus-interactive "P\ny")) |
(interactive (gnus-interactive "P\ny")) |
498 |
(gnus-summary-increase-score (- (gnus-score-delta-default score)) symp)) |
(gnus-summary-increase-score (- (gnus-score-delta-default score)) symp)) |
499 |
|
|
507 |
"Make a score entry based on the current article. |
"Make a score entry based on the current article. |
508 |
The user will be prompted for header to score on, match type, |
The user will be prompted for header to score on, match type, |
509 |
permanence, and the string to be used. The numerical prefix will be |
permanence, and the string to be used. The numerical prefix will be |
510 |
used as score." |
used as score. A symbolic prefix of `a' says to use the `all.SCORE' |
511 |
|
file for the command instead of the current score file." |
512 |
(interactive (gnus-interactive "P\ny")) |
(interactive (gnus-interactive "P\ny")) |
513 |
(let* ((nscore (gnus-score-delta-default score)) |
(let* ((nscore (gnus-score-delta-default score)) |
514 |
(prefix (if (< nscore 0) ?L ?I)) |
(prefix (if (< nscore 0) ?L ?I)) |
648 |
(and gnus-extra-headers |
(and gnus-extra-headers |
649 |
(equal (nth 1 entry) "extra") |
(equal (nth 1 entry) "extra") |
650 |
(intern ; need symbol |
(intern ; need symbol |
651 |
(gnus-completing-read |
(gnus-completing-read-with-default |
652 |
(symbol-name (car gnus-extra-headers)) ; default response |
(symbol-name (car gnus-extra-headers)) ; default response |
653 |
"Score extra header:" ; prompt |
"Score extra header:" ; prompt |
654 |
(mapcar (lambda (x) ; completion list |
(mapcar (lambda (x) ; completion list |
740 |
(insert (format format (caar alist) (nth idx (car alist)))) |
(insert (format format (caar alist) (nth idx (car alist)))) |
741 |
(setq alist (cdr alist)) |
(setq alist (cdr alist)) |
742 |
(setq i (1+ i)))) |
(setq i (1+ i)))) |
743 |
|
(goto-char (point-min)) |
744 |
;; display ourselves in a small window at the bottom |
;; display ourselves in a small window at the bottom |
745 |
(gnus-appt-select-lowest-window) |
(gnus-appt-select-lowest-window) |
746 |
(split-window) |
(if (< (/ (window-height) 2) window-min-height) |
747 |
(pop-to-buffer "*Score Help*") |
(switch-to-buffer "*Score Help*") |
748 |
|
(split-window) |
749 |
|
(pop-to-buffer "*Score Help*")) |
750 |
(let ((window-min-height 1)) |
(let ((window-min-height 1)) |
751 |
(shrink-window-if-larger-than-buffer)) |
(shrink-window-if-larger-than-buffer)) |
752 |
(select-window (get-buffer-window gnus-summary-buffer t)))) |
(select-window (gnus-get-buffer-window gnus-summary-buffer t)))) |
753 |
|
|
754 |
(defun gnus-summary-header (header &optional no-err extra) |
(defun gnus-summary-header (header &optional no-err extra) |
755 |
;; Return HEADER for current articles, or error. |
;; Return HEADER for current articles, or error. |
877 |
;; Return the new scoring rule. |
;; Return the new scoring rule. |
878 |
new)) |
new)) |
879 |
|
|
880 |
(defun gnus-summary-score-effect (header match type score extra) |
(defun gnus-summary-score-effect (header match type score &optional extra) |
881 |
"Simulate the effect of a score file entry. |
"Simulate the effect of a score file entry. |
882 |
HEADER is the header being scored. |
HEADER is the header being scored. |
883 |
MATCH is the string we are looking for. |
MATCH is the string we are looking for. |
889 |
(lambda (x) (fboundp (nth 2 x))) |
(lambda (x) (fboundp (nth 2 x))) |
890 |
t) |
t) |
891 |
(read-string "Match: ") |
(read-string "Match: ") |
892 |
(y-or-n-p "Use regexp match? ") |
(if (y-or-n-p "Use regexp match? ") 'r 's) |
893 |
(prefix-numeric-value current-prefix-arg))) |
(string-to-int (read-string "Score: ")))) |
894 |
(save-excursion |
(save-excursion |
895 |
(unless (and (stringp match) (> (length match) 0)) |
(unless (and (stringp match) (> (length match) 0)) |
896 |
(error "No match")) |
(error "No match")) |
940 |
|
|
941 |
;; All score code written by Per Abrahamsen <abraham@iesd.auc.dk>. |
;; All score code written by Per Abrahamsen <abraham@iesd.auc.dk>. |
942 |
|
|
|
;; Added by Per Abrahamsen <amanda@iesd.auc.dk>. |
|
943 |
(defun gnus-score-set-mark-below (score) |
(defun gnus-score-set-mark-below (score) |
944 |
"Automatically mark articles with score below SCORE as read." |
"Automatically mark articles with score below SCORE as read." |
945 |
(interactive |
(interactive |
1106 |
4 (substitute-command-keys |
4 (substitute-command-keys |
1107 |
"\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits"))) |
"\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits"))) |
1108 |
|
|
1109 |
|
(defun gnus-score-edit-file-at-point (&optional format) |
1110 |
|
"Edit score file at point in Score Trace buffers. |
1111 |
|
If FORMAT, also format the current score file." |
1112 |
|
(let* ((rule (save-excursion |
1113 |
|
(beginning-of-line) |
1114 |
|
(read (current-buffer)))) |
1115 |
|
(sep "[ \n\r\t]*") |
1116 |
|
;; Must be synced with `gnus-score-find-trace': |
1117 |
|
(reg " -> +") |
1118 |
|
(file (save-excursion |
1119 |
|
(end-of-line) |
1120 |
|
(if (and (re-search-backward reg (gnus-point-at-bol) t) |
1121 |
|
(re-search-forward reg (gnus-point-at-eol) t)) |
1122 |
|
(buffer-substring (point) (gnus-point-at-eol)) |
1123 |
|
nil)))) |
1124 |
|
(if (or (not file) |
1125 |
|
(string-match "\\<\\(non-file rule\\|A file\\)\\>" file) |
1126 |
|
;; (see `gnus-score-find-trace' and `gnus-score-advanced') |
1127 |
|
(string= "" file)) |
1128 |
|
(gnus-error 3 "Can't find a score file in current line.") |
1129 |
|
(gnus-score-edit-file file) |
1130 |
|
(when format |
1131 |
|
(gnus-score-pretty-print)) |
1132 |
|
(when (consp rule) ;; the rule exists |
1133 |
|
(setq rule (mapconcat #'(lambda (obj) |
1134 |
|
(regexp-quote (format "%S" obj))) |
1135 |
|
rule |
1136 |
|
sep)) |
1137 |
|
(goto-char (point-min)) |
1138 |
|
(re-search-forward rule nil t) |
1139 |
|
;; make it easy to use `kill-sexp': |
1140 |
|
(goto-char (1- (match-beginning 0))))))) |
1141 |
|
|
1142 |
(defun gnus-score-load-file (file) |
(defun gnus-score-load-file (file) |
1143 |
;; Load score file FILE. Returns a list a retrieved score-alists. |
;; Load score file FILE. Returns a list a retrieved score-alists. |
1144 |
(let* ((file (expand-file-name |
(let* ((file (expand-file-name |
1189 |
(mark-and-expunge (car (gnus-score-get 'mark-and-expunge alist))) |
(mark-and-expunge (car (gnus-score-get 'mark-and-expunge alist))) |
1190 |
(files (gnus-score-get 'files alist)) |
(files (gnus-score-get 'files alist)) |
1191 |
(exclude-files (gnus-score-get 'exclude-files alist)) |
(exclude-files (gnus-score-get 'exclude-files alist)) |
1192 |
(orphan (car (gnus-score-get 'orphan alist))) |
(orphan (car (gnus-score-get 'orphan alist))) |
1193 |
(adapt (gnus-score-get 'adapt alist)) |
(adapt (gnus-score-get 'adapt alist)) |
1194 |
(thread-mark-and-expunge |
(thread-mark-and-expunge |
1195 |
(car (gnus-score-get 'thread-mark-and-expunge alist))) |
(car (gnus-score-get 'thread-mark-and-expunge alist))) |
1248 |
(setq gnus-newsgroup-adaptive t) |
(setq gnus-newsgroup-adaptive t) |
1249 |
adapt) |
adapt) |
1250 |
(t |
(t |
|
;;(setq gnus-newsgroup-adaptive gnus-use-adaptive-scoring) |
|
1251 |
gnus-default-adaptive-score-alist))) |
gnus-default-adaptive-score-alist))) |
1252 |
(setq gnus-thread-expunge-below |
(setq gnus-thread-expunge-below |
1253 |
(or thread-mark-and-expunge gnus-thread-expunge-below)) |
(or thread-mark-and-expunge gnus-thread-expunge-below)) |
1411 |
;; This is a normal score file, so we print it very |
;; This is a normal score file, so we print it very |
1412 |
;; prettily. |
;; prettily. |
1413 |
(let ((lisp-mode-syntax-table score-mode-syntax-table)) |
(let ((lisp-mode-syntax-table score-mode-syntax-table)) |
1414 |
(pp score (current-buffer))))) |
(gnus-pp score)))) |
1415 |
(gnus-make-directory (file-name-directory file)) |
(gnus-make-directory (file-name-directory file)) |
1416 |
;; If the score file is empty, we delete it. |
;; If the score file is empty, we delete it. |
1417 |
(if (zerop (buffer-size)) |
(if (zerop (buffer-size)) |
1473 |
(headers gnus-newsgroup-headers) |
(headers gnus-newsgroup-headers) |
1474 |
(current-score-file gnus-current-score-file) |
(current-score-file gnus-current-score-file) |
1475 |
entry header new) |
entry header new) |
1476 |
(gnus-message 5 "Scoring...") |
(gnus-message 7 "Scoring...") |
1477 |
;; Create articles, an alist of the form `(HEADER . SCORE)'. |
;; Create articles, an alist of the form `(HEADER . SCORE)'. |
1478 |
(while (setq header (pop headers)) |
(while (setq header (pop headers)) |
1479 |
;; WARNING: The assq makes the function O(N*S) while it could |
;; WARNING: The assq makes the function O(N*S) while it could |
1515 |
(with-current-buffer gnus-summary-buffer |
(with-current-buffer gnus-summary-buffer |
1516 |
(setq gnus-newsgroup-scored scored)))) |
(setq gnus-newsgroup-scored scored)))) |
1517 |
;; Remove the buffer. |
;; Remove the buffer. |
1518 |
(kill-buffer (current-buffer))) |
(gnus-kill-buffer (current-buffer))) |
1519 |
|
|
1520 |
;; Add articles to `gnus-newsgroup-scored'. |
;; Add articles to `gnus-newsgroup-scored'. |
1521 |
(while gnus-scores-articles |
(while gnus-scores-articles |
1534 |
(gnus-score-advanced (car score) trace)) |
(gnus-score-advanced (car score) trace)) |
1535 |
(pop score)))) |
(pop score)))) |
1536 |
|
|
1537 |
(gnus-message 5 "Scoring...done")))))) |
(gnus-message 7 "Scoring...done")))))) |
1538 |
|
|
1539 |
(defun gnus-score-lower-thread (thread score-adjust) |
(defun gnus-score-lower-thread (thread score-adjust) |
1540 |
"Lower the score on THREAD with SCORE-ADJUST. |
"Lower the score on THREAD with SCORE-ADJUST. |
1561 |
which has references, but is not connected via its references to a |
which has references, but is not connected via its references to a |
1562 |
root article. This function finds all the orphans, and adjusts their |
root article. This function finds all the orphans, and adjusts their |
1563 |
score in `gnus-newsgroup-scored' by SCORE." |
score in `gnus-newsgroup-scored' by SCORE." |
1564 |
(let ((threads (gnus-make-threads))) |
;; gnus-make-threads produces a list, where each entry is a "thread" |
1565 |
;; gnus-make-threads produces a list, where each entry is a "thread" |
;; as described in the gnus-score-lower-thread docs. This function |
1566 |
;; as described in the gnus-score-lower-thread docs. This function |
;; will be called again (after limiting has been done) if the display |
1567 |
;; will be called again (after limiting has been done) if the display |
;; is threaded. It would be nice to somehow save this info and use |
1568 |
;; is threaded. It would be nice to somehow save this info and use |
;; it later. |
1569 |
;; it later. |
(dolist (thread (gnus-make-threads)) |
1570 |
(while threads |
(let ((id (aref (car thread) gnus-score-index))) |
1571 |
(let* ((thread (car threads)) |
;; If the parent of the thread is not a root, lower the score of |
1572 |
(id (aref (car thread) gnus-score-index))) |
;; it and its descendants. Note that some roots seem to satisfy |
1573 |
;; If the parent of the thread is not a root, lower the score of |
;; (eq id nil) and some (eq id ""); not sure why. |
1574 |
;; it and its descendants. Note that some roots seem to satisfy |
(when (and id |
1575 |
;; (eq id nil) and some (eq id ""); not sure why. |
(not (string= id ""))) |
1576 |
(if (and id (not (string= id ""))) |
(gnus-score-lower-thread thread score))))) |
|
(gnus-score-lower-thread thread score))) |
|
|
(setq threads (cdr threads))))) |
|
1577 |
|
|
1578 |
(defun gnus-score-integer (scores header now expire &optional trace) |
(defun gnus-score-integer (scores header now expire &optional trace) |
1579 |
(let ((gnus-score-index (nth 1 (assoc header gnus-header-index))) |
(let ((gnus-score-index (nth 1 (assoc header gnus-header-index))) |
1761 |
(setq found t) |
(setq found t) |
1762 |
(when trace |
(when trace |
1763 |
(push |
(push |
1764 |
(cons (car-safe (rassq alist gnus-score-cache)) kill) |
(cons (car-safe (rassq alist gnus-score-cache)) |
1765 |
|
kill) |
1766 |
gnus-score-trace))) |
gnus-score-trace))) |
1767 |
;; Update expire date |
;; Update expire date |
1768 |
(unless trace |
(unless trace |
1820 |
(put-text-property (1- (point)) (point) 'articles alike)) |
(put-text-property (1- (point)) (point) 'articles alike)) |
1821 |
(setq alike (list art) |
(setq alike (list art) |
1822 |
last this))) |
last this))) |
1823 |
(when last ; Bwadr, duplicate code. |
(when last ; Bwadr, duplicate code. |
1824 |
(insert last ?\n) |
(insert last ?\n) |
1825 |
(put-text-property (1- (point)) (point) 'articles alike)) |
(put-text-property (1- (point)) (point) 'articles alike)) |
1826 |
|
|
1829 |
(setq alist (car scores) |
(setq alist (car scores) |
1830 |
scores (cdr scores) |
scores (cdr scores) |
1831 |
entries (assoc header alist)) |
entries (assoc header alist)) |
1832 |
(while (cdr entries) ;First entry is the header index. |
(while (cdr entries) ;First entry is the header index. |
1833 |
(let* ((rest (cdr entries)) |
(let* ((rest (cdr entries)) |
1834 |
(kill (car rest)) |
(kill (car rest)) |
1835 |
(match (nth 0 kill)) |
(match (nth 0 kill)) |
1849 |
(goto-char (point-min)) |
(goto-char (point-min)) |
1850 |
(if (= dmt ?e) |
(if (= dmt ?e) |
1851 |
(while (funcall search-func match nil t) |
(while (funcall search-func match nil t) |
1852 |
(and (= (progn (beginning-of-line) (point)) |
(and (= (gnus-point-at-bol) |
1853 |
(match-beginning 0)) |
(match-beginning 0)) |
1854 |
(= (progn (end-of-line) (point)) |
(= (progn (end-of-line) (point)) |
1855 |
(match-end 0)) |
(match-end 0)) |
1868 |
(setq found (setq arts (get-text-property (point) 'articles))) |
(setq found (setq arts (get-text-property (point) 'articles))) |
1869 |
;; Found a match, update scores. |
;; Found a match, update scores. |
1870 |
(while (setq art (pop arts)) |
(while (setq art (pop arts)) |
1871 |
|
(setcdr art (+ score (cdr art))) |
1872 |
|
(when trace |
1873 |
|
(push (cons |
1874 |
|
(car-safe (rassq alist gnus-score-cache)) |
1875 |
|
kill) |
1876 |
|
gnus-score-trace)) |
1877 |
(when (setq new (gnus-score-add-followups |
(when (setq new (gnus-score-add-followups |
1878 |
(car art) score all-scores thread)) |
(car art) score all-scores thread)) |
1879 |
(push new news))))) |
(push new news))))) |
1921 |
;; Insert the unique article headers in the buffer. |
;; Insert the unique article headers in the buffer. |
1922 |
(let ((gnus-score-index (nth 1 (assoc header gnus-header-index))) |
(let ((gnus-score-index (nth 1 (assoc header gnus-header-index))) |
1923 |
;; gnus-score-index is used as a free variable. |
;; gnus-score-index is used as a free variable. |
1924 |
(simplify (and gnus-score-thread-simplify |
(simplify (and gnus-score-thread-simplify |
1925 |
(string= "subject" header))) |
(string= "subject" header))) |
1926 |
alike last this art entries alist articles |
alike last this art entries alist articles |
1927 |
fuzzies arts words kill) |
fuzzies arts words kill) |
1928 |
|
|
1947 |
;; with working on them as a group. What a hassle. |
;; with working on them as a group. What a hassle. |
1948 |
;; Just wait 'til you see what horrors we commit against `match'... |
;; Just wait 'til you see what horrors we commit against `match'... |
1949 |
(if (= gnus-score-index 9) |
(if (= gnus-score-index 9) |
1950 |
(setq this (prin1-to-string this))) ; ick. |
(setq this (gnus-prin1-to-string this))) ; ick. |
1951 |
|
|
1952 |
(if simplify |
(if simplify |
1953 |
(setq this (gnus-map-function gnus-simplify-subject-functions this))) |
(setq this (gnus-map-function gnus-simplify-subject-functions this))) |
1986 |
(dmt (downcase mt)) |
(dmt (downcase mt)) |
1987 |
;; Assume user already simplified regexp and fuzzies |
;; Assume user already simplified regexp and fuzzies |
1988 |
(match (if (and simplify (not (memq dmt '(?f ?r)))) |
(match (if (and simplify (not (memq dmt '(?f ?r)))) |
1989 |
(gnus-map-function |
(gnus-map-function |
1990 |
gnus-simplify-subject-functions |
gnus-simplify-subject-functions |
1991 |
(nth 0 kill)) |
(nth 0 kill)) |
1992 |
(nth 0 kill))) |
(nth 0 kill))) |
1993 |
(search-func |
(search-func |
1994 |
(cond ((= dmt ?r) 're-search-forward) |
(cond ((= dmt ?r) 're-search-forward) |
1995 |
((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward) |
((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward) |
1999 |
;; Evil hackery to make match usable in non-standard headers. |
;; Evil hackery to make match usable in non-standard headers. |
2000 |
(when extra |
(when extra |
2001 |
(setq match (concat "[ (](" extra " \\. \"[^)]*" |
(setq match (concat "[ (](" extra " \\. \"[^)]*" |
2002 |
match "[^(]*\")[ )]") |
match "[^\"]*\")[ )]") |
2003 |
search-func 're-search-forward)) ; XXX danger?!? |
search-func 're-search-forward)) ; XXX danger?!? |
2004 |
|
|
2005 |
(cond |
(cond |
2325 |
;; Put the word and score into the hashtb. |
;; Put the word and score into the hashtb. |
2326 |
(setq val (gnus-gethash (setq word (match-string 0)) |
(setq val (gnus-gethash (setq word (match-string 0)) |
2327 |
hashtb)) |
hashtb)) |
2328 |
(setq val (+ score (or val 0))) |
(when (or (not gnus-adaptive-word-length-limit) |
2329 |
(if (and gnus-adaptive-word-minimum |
(> (length word) |
2330 |
(< val gnus-adaptive-word-minimum)) |
gnus-adaptive-word-length-limit)) |
2331 |
(setq val gnus-adaptive-word-minimum)) |
(setq val (+ score (or val 0))) |
2332 |
(gnus-sethash word val hashtb)) |
(if (and gnus-adaptive-word-minimum |
2333 |
|
(< val gnus-adaptive-word-minimum)) |
2334 |
|
(setq val gnus-adaptive-word-minimum)) |
2335 |
|
(gnus-sethash word val hashtb))) |
2336 |
(erase-buffer)))) |
(erase-buffer)))) |
2337 |
(set-syntax-table syntab)) |
(set-syntax-table syntab)) |
2338 |
;; Make all the ignorable words ignored. |
;; Make all the ignorable words ignored. |
2371 |
(let ((gnus-newsgroup-headers |
(let ((gnus-newsgroup-headers |
2372 |
(list (gnus-summary-article-header))) |
(list (gnus-summary-article-header))) |
2373 |
(gnus-newsgroup-scored nil) |
(gnus-newsgroup-scored nil) |
2374 |
trace) |
;; Must be synced with `gnus-score-edit-file-at-point': |
2375 |
|
(frmt "%S [%s] -> %s\n") |
2376 |
|
trace |
2377 |
|
file) |
2378 |
(save-excursion |
(save-excursion |
2379 |
(nnheader-set-temp-buffer "*Score Trace*")) |
(nnheader-set-temp-buffer "*Score Trace*")) |
2380 |
(setq gnus-score-trace nil) |
(setq gnus-score-trace nil) |
2384 |
1 "No score rules apply to the current article (default score %d)." |
1 "No score rules apply to the current article (default score %d)." |
2385 |
gnus-summary-default-score) |
gnus-summary-default-score) |
2386 |
(set-buffer "*Score Trace*") |
(set-buffer "*Score Trace*") |
2387 |
|
;; Use a keymap instead? |
2388 |
|
(local-set-key "q" |
2389 |
|
(lambda () |
2390 |
|
(interactive) |
2391 |
|
(bury-buffer nil) |
2392 |
|
(gnus-summary-expand-window))) |
2393 |
|
(local-set-key "e" (lambda () |
2394 |
|
"Run `gnus-score-edit-file-at-point'." |
2395 |
|
(interactive) |
2396 |
|
(gnus-score-edit-file-at-point))) |
2397 |
|
(local-set-key "f" (lambda () |
2398 |
|
"Run `gnus-score-edit-file-at-point'." |
2399 |
|
(interactive) |
2400 |
|
(gnus-score-edit-file-at-point 'format))) |
2401 |
|
(local-set-key "t" 'toggle-truncate-lines) |
2402 |
(setq truncate-lines t) |
(setq truncate-lines t) |
2403 |
(while trace |
(dolist (entry trace) |
2404 |
(insert (format "%S -> %s\n" (cdar trace) |
(setq file (or (car entry) |
2405 |
(or (caar trace) "(non-file rule)"))) |
;; Must be synced with |
2406 |
(setq trace (cdr trace))) |
;; `gnus-score-edit-file-at-point': |
2407 |
|
"(non-file rule)")) |
2408 |
|
(insert |
2409 |
|
(format frmt |
2410 |
|
(cdr entry) |
2411 |
|
;; Don't use `file-name-sans-extension' to see .SCORE and |
2412 |
|
;; .ADAPT directly: |
2413 |
|
(file-name-nondirectory file) |
2414 |
|
(abbreviate-file-name file)))) |
2415 |
|
(insert |
2416 |
|
"\n\nQuick help: |
2417 |
|
|
2418 |
|
Type `e' to edit score file corresponding to the score rule on current line, |
2419 |
|
`f' to format (pretty print) the score file and edit it, |
2420 |
|
`t' toggle to truncate long lines in this buffer, |
2421 |
|
`q' to quit. |
2422 |
|
|
2423 |
|
The first sexp on each line is the score rule, followed by the file name of |
2424 |
|
the score file and its full name, including the directory.") |
2425 |
(goto-char (point-min)) |
(goto-char (point-min)) |
2426 |
(gnus-configure-windows 'score-trace))) |
(gnus-configure-windows 'score-trace))) |
2427 |
(set-buffer gnus-summary-buffer) |
(set-buffer gnus-summary-buffer) |
2549 |
(defun gnus-summary-lower-thread (&optional score) |
(defun gnus-summary-lower-thread (&optional score) |
2550 |
"Lower score of articles in the current thread with SCORE." |
"Lower score of articles in the current thread with SCORE." |
2551 |
(interactive "P") |
(interactive "P") |
2552 |
(gnus-summary-raise-thread (- (1- (gnus-score-delta-default score))))) |
(gnus-summary-raise-thread (- (gnus-score-delta-default score)))) |
2553 |
|
|
2554 |
;;; Finding score files. |
;;; Finding score files. |
2555 |
|
|
2611 |
(push file out)))) |
(push file out)))) |
2612 |
(or out |
(or out |
2613 |
;; Return a dummy value. |
;; Return a dummy value. |
2614 |
(list "~/News/this.file.does.not.exist.SCORE")))) |
(list (expand-file-name "this.file.does.not.exist.SCORE" |
2615 |
|
gnus-kill-files-directory))))) |
2616 |
|
|
2617 |
(defun gnus-score-file-regexp () |
(defun gnus-score-file-regexp () |
2618 |
"Return a regexp that match all score files." |
"Return a regexp that match all score files." |
2676 |
(replace-match ".*" t t)) |
(replace-match ".*" t t)) |
2677 |
(goto-char (point-min)) |
(goto-char (point-min)) |
2678 |
;; Deal with "not."s. |
;; Deal with "not."s. |
2679 |
(setq not-match (looking-at "not.")) |
(if (looking-at "not.") |
2680 |
(setq regexp |
(progn |
2681 |
(concat "^" (buffer-substring (+ (point-min) (if not-match 4 0)) |
(setq not-match t) |
2682 |
(point-max)) |
(setq regexp |
2683 |
"$")) |
(concat "^" (buffer-substring 5 (point-max)) "$"))) |
2684 |
|
(setq regexp (concat "^" (buffer-substring 1 (point-max)) "$")) |
2685 |
|
(setq not-match nil)) |
2686 |
;; Finally - if this resulting regexp matches the group name, |
;; Finally - if this resulting regexp matches the group name, |
2687 |
;; we add this score file to the list of score files |
;; we add this score file to the list of score files |
2688 |
;; applicable to this group. |
;; applicable to this group. |
2693 |
(ignore-errors (string-match regexp group-trans)))) |
(ignore-errors (string-match regexp group-trans)))) |
2694 |
(push (car sfiles) ofiles))) |
(push (car sfiles) ofiles))) |
2695 |
(setq sfiles (cdr sfiles))) |
(setq sfiles (cdr sfiles))) |
2696 |
(kill-buffer (current-buffer)) |
(gnus-kill-buffer (current-buffer)) |
2697 |
;; Slight kludge here - the last score file returned should be |
;; Slight kludge here - the last score file returned should be |
2698 |
;; the local score file, whether it exists or not. This is so |
;; the local score file, whether it exists or not. This is so |
2699 |
;; that any score commands the user enters will go to the right |
;; that any score commands the user enters will go to the right |
2825 |
;; Go through all the functions for finding score files (or actual |
;; Go through all the functions for finding score files (or actual |
2826 |
;; scores) and add them to a list. |
;; scores) and add them to a list. |
2827 |
(while funcs |
(while funcs |
2828 |
(when (gnus-functionp (car funcs)) |
(when (functionp (car funcs)) |
2829 |
(setq score-files |
(setq score-files |
2830 |
(nconc score-files (nreverse (funcall (car funcs) group))))) |
(append score-files |
2831 |
|
(nreverse (funcall (car funcs) group))))) |
2832 |
(setq funcs (cdr funcs))) |
(setq funcs (cdr funcs))) |
2833 |
(when gnus-score-use-all-scores |
(when gnus-score-use-all-scores |
2834 |
;; Add any home score files. |
;; Add any home score files. |
2893 |
(let (out) |
(let (out) |
2894 |
(while files |
(while files |
2895 |
;; #### /$ Unix-specific? |
;; #### /$ Unix-specific? |
2896 |
(if (string-match "/$" (car files)) |
(if (file-directory-p (car files)) |
2897 |
(setq out (nconc (directory-files |
(setq out (nconc (directory-files |
2898 |
(car files) t |
(car files) t |
2899 |
(concat (gnus-score-file-regexp) "$")))) |
(concat (gnus-score-file-regexp) "$")))) |
2928 |
((stringp elem) |
((stringp elem) |
2929 |
elem) |
elem) |
2930 |
;; Function. |
;; Function. |
2931 |
((gnus-functionp elem) |
((functionp elem) |
2932 |
(funcall elem group)) |
(funcall elem group)) |
2933 |
;; Regexp-file cons. |
;; Regexp-file cons. |
2934 |
((consp elem) |
((consp elem) |
2935 |
(when (string-match (gnus-globalify-regexp (car elem)) group) |
(when (string-match (gnus-globalify-regexp (car elem)) group) |
2936 |
(replace-match (cadr elem) t nil group)))))) |
(replace-match (cadr elem) t nil group)))))) |
2937 |
(when found |
(when found |
2938 |
|
(setq found (nnheader-translate-file-chars found)) |
2939 |
(if (file-name-absolute-p found) |
(if (file-name-absolute-p found) |
2940 |
found |
found |
2941 |
(nnheader-concat gnus-kill-files-directory found))))) |
(nnheader-concat gnus-kill-files-directory found))))) |
2942 |
|
|
2943 |
(defun gnus-hierarchial-home-score-file (group) |
(defun gnus-hierarchial-home-score-file (group) |
2944 |
"Return the score file of the top-level hierarchy of GROUP." |
"Return the score file of the top-level hierarchy of GROUP." |
2966 |
|
|
2967 |
(defun gnus-decay-score (score) |
(defun gnus-decay-score (score) |
2968 |
"Decay SCORE according to `gnus-score-decay-constant' and `gnus-score-decay-scale'." |
"Decay SCORE according to `gnus-score-decay-constant' and `gnus-score-decay-scale'." |
2969 |
(floor |
(let ((n (- score |
2970 |
(- score |
(* (if (< score 0) -1 1) |
2971 |
(* (if (< score 0) -1 1) |
(min (abs score) |
2972 |
(min (abs score) |
(max gnus-score-decay-constant |
2973 |
(max gnus-score-decay-constant |
(* (abs score) |
2974 |
(* (abs score) |
gnus-score-decay-scale))))))) |
2975 |
gnus-score-decay-scale))))))) |
(if (and (featurep 'xemacs) |
2976 |
|
;; XEmacs' floor can handle only the floating point |
2977 |
|
;; number below the half of the maximum integer. |
2978 |
|
(> (abs n) (lsh -1 -2))) |
2979 |
|
(string-to-number |
2980 |
|
(car (split-string (number-to-string n) "\\."))) |
2981 |
|
(floor n)))) |
2982 |
|
|
2983 |
(defun gnus-decay-scores (alist day) |
(defun gnus-decay-scores (alist day) |
2984 |
"Decay non-permanent scores in ALIST." |
"Decay non-permanent scores in ALIST." |
3011 |
In the `bad' case, the string is a unsafe subexpression of REGEXP, |
In the `bad' case, the string is a unsafe subexpression of REGEXP, |
3012 |
and we do not have a simple replacement to suggest. |
and we do not have a simple replacement to suggest. |
3013 |
|
|
3014 |
See `(Gnus)Scoring Tips' for examples of good regular expressions." |
See Info node `(gnus)Scoring Tips' for examples of good regular expressions." |
3015 |
(let (case-fold-search) |
(let (case-fold-search) |
3016 |
(and |
(and |
3017 |
;; First, try a relatively fast necessary condition. |
;; First, try a relatively fast necessary condition. |