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