/[emacs]/emacs/lisp/gnus/gnus-score.el
ViewVC logotype

Diff of /emacs/lisp/gnus/gnus-score.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.12.4.3 by miles, Thu Apr 1 04:29:05 2004 UTC revision 1.12.4.4 by miles, Thu Sep 16 00:12:16 2004 UTC
# Line 1  Line 1 
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>
# Line 32  Line 32 
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
# Line 47  score files in the \"/ftp.some-where:/pu Line 50  score files in the \"/ftp.some-where:/pu
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    
# Line 232  This variable allows the same syntax as Line 235  This variable allows the same syntax as
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
# Line 483  of the last successful match.") Line 492  of the last successful match.")
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    
# Line 497  used as score." Line 507  used as score."
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))
# Line 637  used as score." Line 648  used as score."
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
# Line 729  used as score." Line 740  used as score."
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.
# Line 863  If optional argument `EXTRA' is non-nil, Line 877  If optional argument `EXTRA' is non-nil,
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.
# Line 875  EXTRA is the possible non-standard heade Line 889  EXTRA is the possible non-standard heade
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"))
# Line 926  EXTRA is the possible non-standard heade Line 940  EXTRA is the possible non-standard heade
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
# Line 1093  EXTRA is the possible non-standard heade Line 1106  EXTRA is the possible non-standard heade
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
# Line 1143  EXTRA is the possible non-standard heade Line 1189  EXTRA is the possible non-standard heade
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)))
# Line 1202  EXTRA is the possible non-standard heade Line 1248  EXTRA is the possible non-standard heade
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))
# Line 1366  EXTRA is the possible non-standard heade Line 1411  EXTRA is the possible non-standard heade
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))
# Line 1428  EXTRA is the possible non-standard heade Line 1473  EXTRA is the possible non-standard heade
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
# Line 1470  EXTRA is the possible non-standard heade Line 1515  EXTRA is the possible non-standard heade
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
# Line 1489  EXTRA is the possible non-standard heade Line 1534  EXTRA is the possible non-standard heade
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.
# Line 1516  A root is an article with no references. Line 1561  A root is an article with no references.
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)))
# Line 1718  score in `gnus-newsgroup-scored' by SCOR Line 1761  score in `gnus-newsgroup-scored' by SCOR
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
# Line 1776  score in `gnus-newsgroup-scored' by SCOR Line 1820  score in `gnus-newsgroup-scored' by SCOR
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    
# Line 1785  score in `gnus-newsgroup-scored' by SCOR Line 1829  score in `gnus-newsgroup-scored' by SCOR
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))
# Line 1805  score in `gnus-newsgroup-scored' by SCOR Line 1849  score in `gnus-newsgroup-scored' by SCOR
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))
# Line 1824  score in `gnus-newsgroup-scored' by SCOR Line 1868  score in `gnus-newsgroup-scored' by SCOR
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)))))
# Line 1871  score in `gnus-newsgroup-scored' by SCOR Line 1921  score in `gnus-newsgroup-scored' by SCOR
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    
# Line 1897  score in `gnus-newsgroup-scored' by SCOR Line 1947  score in `gnus-newsgroup-scored' by SCOR
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)))
# Line 1936  score in `gnus-newsgroup-scored' by SCOR Line 1986  score in `gnus-newsgroup-scored' by SCOR
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)
# Line 1949  score in `gnus-newsgroup-scored' by SCOR Line 1999  score in `gnus-newsgroup-scored' by SCOR
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
# Line 2275  score in `gnus-newsgroup-scored' by SCOR Line 2325  score in `gnus-newsgroup-scored' by SCOR
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.
# Line 2318  score in `gnus-newsgroup-scored' by SCOR Line 2371  score in `gnus-newsgroup-scored' by SCOR
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)
# Line 2328  score in `gnus-newsgroup-scored' by SCOR Line 2384  score in `gnus-newsgroup-scored' by SCOR
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)
# Line 2460  score in `gnus-newsgroup-scored' by SCOR Line 2549  score in `gnus-newsgroup-scored' by SCOR
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    
# Line 2522  score in `gnus-newsgroup-scored' by SCOR Line 2611  score in `gnus-newsgroup-scored' by SCOR
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."
# Line 2586  GROUP using BNews sys file syntax." Line 2676  GROUP using BNews sys file syntax."
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.
# Line 2601  GROUP using BNews sys file syntax." Line 2693  GROUP using BNews sys file syntax."
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
# Line 2733  The list is determined from the variable Line 2825  The list is determined from the variable
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.
# Line 2800  The list is determined from the variable Line 2893  The list is determined from the variable
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) "$"))))
# Line 2835  If ADAPT, return the home adaptive file Line 2928  If ADAPT, return the home adaptive file
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."
# Line 2872  If ADAPT, return the home adaptive file Line 2966  If ADAPT, return the home adaptive file
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."
# Line 2911  In the `new' case, the string is a safe Line 3011  In the `new' case, the string is a safe
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.

Legend:
Removed from v.1.12.4.3  
changed lines
  Added in v.1.12.4.4

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26