Mercurial > hg > xemacs-beta
comparison lisp/gnus/gnus-score.el @ 30:ec9a17fef872 r19-15b98
Import from CVS: tag r19-15b98
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 08:52:29 +0200 |
| parents | 4103f0995bd7 |
| children | e04119814345 |
comparison
equal
deleted
inserted
replaced
| 29:7976500f47f9 | 30:ec9a17fef872 |
|---|---|
| 178 allowed so that one may use gnus-score-file-single-match-alist to | 178 allowed so that one may use gnus-score-file-single-match-alist to |
| 179 set this variable.) | 179 set this variable.) |
| 180 | 180 |
| 181 * A function. | 181 * A function. |
| 182 If the function returns non-nil, the result will be used | 182 If the function returns non-nil, the result will be used |
| 183 as the home score file. The function will be passed the | 183 as the home score file. The function will be passed the |
| 184 name of the group as its parameter. | 184 name of the group as its parameter. |
| 185 | 185 |
| 186 * A string. Use the string as the home score file. | 186 * A string. Use the string as the home score file. |
| 187 | 187 |
| 188 The list will be traversed from the beginning towards the end looking | 188 The list will be traversed from the beginning towards the end looking |
| 203 (repeat (choice string | 203 (repeat (choice string |
| 204 (cons regexp (repeat file)) | 204 (cons regexp (repeat file)) |
| 205 function)) | 205 function)) |
| 206 function)) | 206 function)) |
| 207 | 207 |
| 208 (defcustom gnus-default-adaptive-score-alist | 208 (defcustom gnus-default-adaptive-score-alist |
| 209 '((gnus-kill-file-mark) | 209 '((gnus-kill-file-mark) |
| 210 (gnus-unread-mark) | 210 (gnus-unread-mark) |
| 211 (gnus-read-mark (from 3) (subject 30)) | 211 (gnus-read-mark (from 3) (subject 30)) |
| 212 (gnus-catchup-mark (subject -10)) | 212 (gnus-catchup-mark (subject -10)) |
| 213 (gnus-killed-mark (from -1) (subject -20)) | 213 (gnus-killed-mark (from -1) (subject -20)) |
| 243 "try" "re") | 243 "try" "re") |
| 244 "Default list of words to be ignored when doing adaptive word scoring." | 244 "Default list of words to be ignored when doing adaptive word scoring." |
| 245 :group 'gnus-score-adapt | 245 :group 'gnus-score-adapt |
| 246 :type '(repeat string)) | 246 :type '(repeat string)) |
| 247 | 247 |
| 248 (defcustom gnus-default-adaptive-word-score-alist | 248 (defcustom gnus-default-adaptive-word-score-alist |
| 249 `((,gnus-read-mark . 30) | 249 `((,gnus-read-mark . 30) |
| 250 (,gnus-catchup-mark . -10) | 250 (,gnus-catchup-mark . -10) |
| 251 (,gnus-killed-mark . -20) | 251 (,gnus-killed-mark . -20) |
| 252 (,gnus-del-mark . -15)) | 252 (,gnus-del-mark . -15)) |
| 253 "Alist of marks and scores." | 253 "Alist of marks and scores." |
| 385 (defvar gnus-score-trace nil) | 385 (defvar gnus-score-trace nil) |
| 386 (defvar gnus-score-edit-buffer nil) | 386 (defvar gnus-score-edit-buffer nil) |
| 387 | 387 |
| 388 (defvar gnus-score-alist nil | 388 (defvar gnus-score-alist nil |
| 389 "Alist containing score information. | 389 "Alist containing score information. |
| 390 The keys can be symbols or strings. The following symbols are defined. | 390 The keys can be symbols or strings. The following symbols are defined. |
| 391 | 391 |
| 392 touched: If this alist has been modified. | 392 touched: If this alist has been modified. |
| 393 mark: Automatically mark articles below this. | 393 mark: Automatically mark articles below this. |
| 394 expunge: Automatically expunge articles below this. | 394 expunge: Automatically expunge articles below this. |
| 395 files: List of other score files to load when loading this one. | 395 files: List of other score files to load when loading this one. |
| 467 (interactive "P") | 467 (interactive "P") |
| 468 (gnus-set-global-variables) | 468 (gnus-set-global-variables) |
| 469 (let* ((nscore (gnus-score-default score)) | 469 (let* ((nscore (gnus-score-default score)) |
| 470 (prefix (if (< nscore 0) ?L ?I)) | 470 (prefix (if (< nscore 0) ?L ?I)) |
| 471 (increase (> nscore 0)) | 471 (increase (> nscore 0)) |
| 472 (char-to-header | 472 (char-to-header |
| 473 '((?a "from" nil nil string) | 473 '((?a "from" nil nil string) |
| 474 (?s "subject" nil nil string) | 474 (?s "subject" nil nil string) |
| 475 (?b "body" "" nil body-string) | 475 (?b "body" "" nil body-string) |
| 476 (?h "head" "" nil body-string) | 476 (?h "head" "" nil body-string) |
| 477 (?i "message-id" nil t string) | 477 (?i "message-id" nil t string) |
| 496 (?= = "equal to number" number))) | 496 (?= = "equal to number" number))) |
| 497 (char-to-perm | 497 (char-to-perm |
| 498 (list (list ?t (current-time-string) "temporary") | 498 (list (list ?t (current-time-string) "temporary") |
| 499 '(?p perm "permanent") '(?i now "immediate"))) | 499 '(?p perm "permanent") '(?i now "immediate"))) |
| 500 (mimic gnus-score-mimic-keymap) | 500 (mimic gnus-score-mimic-keymap) |
| 501 (hchar (and gnus-score-default-header | 501 (hchar (and gnus-score-default-header |
| 502 (aref (symbol-name gnus-score-default-header) 0))) | 502 (aref (symbol-name gnus-score-default-header) 0))) |
| 503 (tchar (and gnus-score-default-type | 503 (tchar (and gnus-score-default-type |
| 504 (aref (symbol-name gnus-score-default-type) 0))) | 504 (aref (symbol-name gnus-score-default-type) 0))) |
| 505 (pchar (and gnus-score-default-duration | 505 (pchar (and gnus-score-default-duration |
| 506 (aref (symbol-name gnus-score-default-duration) 0))) | 506 (aref (symbol-name gnus-score-default-duration) 0))) |
| 507 entry temporary type match) | 507 entry temporary type match) |
| 508 | 508 |
| 509 (unwind-protect | 509 (unwind-protect |
| 510 (progn | 510 (progn |
| 511 | 511 |
| 512 ;; First we read the header to score. | 512 ;; First we read the header to score. |
| 513 (while (not hchar) | 513 (while (not hchar) |
| 514 (if mimic | 514 (if mimic |
| 515 (progn | 515 (progn |
| 516 (sit-for 1) | 516 (sit-for 1) |
| 517 (message "%c-" prefix)) | 517 (message "%c-" prefix)) |
| 518 (message "%s header (%s?): " (if increase "Increase" "Lower") | 518 (message "%s header (%s?): " (if increase "Increase" "Lower") |
| 519 (mapconcat (lambda (s) (char-to-string (car s))) | 519 (mapconcat (lambda (s) (char-to-string (car s))) |
| 520 char-to-header ""))) | 520 char-to-header ""))) |
| 530 (when (/= (downcase hchar) hchar) | 530 (when (/= (downcase hchar) hchar) |
| 531 ;; This was a majuscule, so we end reading and set the defaults. | 531 ;; This was a majuscule, so we end reading and set the defaults. |
| 532 (if mimic (message "%c %c" prefix hchar) (message "")) | 532 (if mimic (message "%c %c" prefix hchar) (message "")) |
| 533 (setq tchar (or tchar ?s) | 533 (setq tchar (or tchar ?s) |
| 534 pchar (or pchar ?t))) | 534 pchar (or pchar ?t))) |
| 535 | 535 |
| 536 ;; We continue reading - the type. | 536 ;; We continue reading - the type. |
| 537 (while (not tchar) | 537 (while (not tchar) |
| 538 (if mimic | 538 (if mimic |
| 539 (progn | 539 (progn |
| 540 (sit-for 1) (message "%c %c-" prefix hchar)) | 540 (sit-for 1) (message "%c %c-" prefix hchar)) |
| 591 (when (and (eq (1+ prefix) 77) | 591 (when (and (eq (1+ prefix) 77) |
| 592 (eq (+ hchar 12) 109) | 592 (eq (+ hchar 12) 109) |
| 593 (eq tchar 114) | 593 (eq tchar 114) |
| 594 (eq (- pchar 4) 111)) | 594 (eq (- pchar 4) 111)) |
| 595 (error "You rang?")) | 595 (error "You rang?")) |
| 596 (if mimic | 596 (if mimic |
| 597 (error "%c %c %c %c" prefix hchar tchar pchar) | 597 (error "%c %c %c %c" prefix hchar tchar pchar) |
| 598 (error "")))) | 598 (error "")))) |
| 599 ;; Always kill the score help buffer. | 599 ;; Always kill the score help buffer. |
| 600 (gnus-score-kill-help-buffer)) | 600 (gnus-score-kill-help-buffer)) |
| 601 | 601 |
| 602 ;; We have all the data, so we enter this score. | 602 ;; We have all the data, so we enter this score. |
| 603 (setq match (if (string= (nth 2 entry) "") "" | 603 (setq match (if (string= (nth 2 entry) "") "" |
| 604 (gnus-summary-header (or (nth 2 entry) (nth 1 entry))))) | 604 (gnus-summary-header (or (nth 2 entry) (nth 1 entry))))) |
| 605 | 605 |
| 606 ;; Modify the match, perhaps. | 606 ;; Modify the match, perhaps. |
| 607 (cond | 607 (cond |
| 608 ((equal (nth 1 entry) "xref") | 608 ((equal (nth 1 entry) "xref") |
| 609 (when (string-match "^Xref: *" match) | 609 (when (string-match "^Xref: *" match) |
| 610 (setq match (substring match (match-end 0)))) | 610 (setq match (substring match (match-end 0)))) |
| 611 (when (string-match "^[^:]* +" match) | 611 (when (string-match "^[^:]* +" match) |
| 612 (setq match (substring match (match-end 0)))))) | 612 (setq match (substring match (match-end 0)))))) |
| 613 | 613 |
| 614 (when (memq type '(r R regexp Regexp)) | 614 (when (memq type '(r R regexp Regexp)) |
| 615 (setq match (regexp-quote match))) | 615 (setq match (regexp-quote match))) |
| 616 | 616 |
| 617 (gnus-summary-score-entry | 617 (gnus-summary-score-entry |
| 618 (nth 1 entry) ; Header | 618 (nth 1 entry) ; Header |
| 622 (if (eq temporary 'perm) ; Temp | 622 (if (eq temporary 'perm) ; Temp |
| 623 nil | 623 nil |
| 624 temporary) | 624 temporary) |
| 625 (not (nth 3 entry))) ; Prompt | 625 (not (nth 3 entry))) ; Prompt |
| 626 )) | 626 )) |
| 627 | 627 |
| 628 (defun gnus-score-insert-help (string alist idx) | 628 (defun gnus-score-insert-help (string alist idx) |
| 629 (setq gnus-score-help-winconf (current-window-configuration)) | 629 (setq gnus-score-help-winconf (current-window-configuration)) |
| 630 (save-excursion | 630 (save-excursion |
| 631 (set-buffer (get-buffer-create "*Score Help*")) | 631 (set-buffer (get-buffer-create "*Score Help*")) |
| 632 (buffer-disable-undo (current-buffer)) | 632 (buffer-disable-undo (current-buffer)) |
| 644 (setq max n)) | 644 (setq max n)) |
| 645 (setq list (cdr list))) | 645 (setq list (cdr list))) |
| 646 (setq max (+ max 4)) ; %c, `:', SPACE, a SPACE at end | 646 (setq max (+ max 4)) ; %c, `:', SPACE, a SPACE at end |
| 647 (setq n (/ (1- (window-width)) max)) ; items per line | 647 (setq n (/ (1- (window-width)) max)) ; items per line |
| 648 (setq width (/ (1- (window-width)) n)) ; width of each item | 648 (setq width (/ (1- (window-width)) n)) ; width of each item |
| 649 ;; insert `n' items, each in a field of width `width' | 649 ;; insert `n' items, each in a field of width `width' |
| 650 (while alist | 650 (while alist |
| 651 (if (< i n) | 651 (if (< i n) |
| 652 () | 652 () |
| 653 (setq i 0) | 653 (setq i 0) |
| 654 (delete-char -1) ; the `\n' takes a char | 654 (delete-char -1) ; the `\n' takes a char |
| 663 (split-window) | 663 (split-window) |
| 664 (pop-to-buffer "*Score Help*") | 664 (pop-to-buffer "*Score Help*") |
| 665 (let ((window-min-height 1)) | 665 (let ((window-min-height 1)) |
| 666 (shrink-window-if-larger-than-buffer)) | 666 (shrink-window-if-larger-than-buffer)) |
| 667 (select-window (get-buffer-window gnus-summary-buffer)))) | 667 (select-window (get-buffer-window gnus-summary-buffer)))) |
| 668 | 668 |
| 669 (defun gnus-summary-header (header &optional no-err) | 669 (defun gnus-summary-header (header &optional no-err) |
| 670 ;; Return HEADER for current articles, or error. | 670 ;; Return HEADER for current articles, or error. |
| 671 (let ((article (gnus-summary-article-number)) | 671 (let ((article (gnus-summary-article-number)) |
| 672 headers) | 672 headers) |
| 673 (if article | 673 (if article |
| 681 (error "No article on current line") | 681 (error "No article on current line") |
| 682 nil)))) | 682 nil)))) |
| 683 | 683 |
| 684 (defun gnus-newsgroup-score-alist () | 684 (defun gnus-newsgroup-score-alist () |
| 685 (or | 685 (or |
| 686 (let ((param-file (gnus-group-find-parameter | 686 (let ((param-file (gnus-group-find-parameter |
| 687 gnus-newsgroup-name 'score-file))) | 687 gnus-newsgroup-name 'score-file))) |
| 688 (when param-file | 688 (when param-file |
| 689 (gnus-score-load param-file))) | 689 (gnus-score-load param-file))) |
| 690 (gnus-score-load | 690 (gnus-score-load |
| 691 (gnus-score-file-name gnus-newsgroup-name))) | 691 (gnus-score-file-name gnus-newsgroup-name))) |
| 692 gnus-score-alist) | 692 gnus-score-alist) |
| 693 | 693 |
| 694 (defsubst gnus-score-get (symbol &optional alist) | 694 (defsubst gnus-score-get (symbol &optional alist) |
| 695 ;; Get SYMBOL's definition in ALIST. | 695 ;; Get SYMBOL's definition in ALIST. |
| 696 (cdr (assoc symbol | 696 (cdr (assoc symbol |
| 697 (or alist | 697 (or alist |
| 698 gnus-score-alist | 698 gnus-score-alist |
| 699 (gnus-newsgroup-score-alist))))) | 699 (gnus-newsgroup-score-alist))))) |
| 700 | 700 |
| 701 (defun gnus-summary-score-entry (header match type score date | 701 (defun gnus-summary-score-entry (header match type score date |
| 702 &optional prompt silent) | 702 &optional prompt silent) |
| 732 (setq match (gnus-simplify-subject-fuzzy match)))) | 732 (setq match (gnus-simplify-subject-fuzzy match)))) |
| 733 (let ((score (gnus-score-default score)) | 733 (let ((score (gnus-score-default score)) |
| 734 (header (format "%s" (downcase header))) | 734 (header (format "%s" (downcase header))) |
| 735 new) | 735 new) |
| 736 (when prompt | 736 (when prompt |
| 737 (setq match (read-string | 737 (setq match (read-string |
| 738 (format "Match %s on %s, %s: " | 738 (format "Match %s on %s, %s: " |
| 739 (cond ((eq date 'now) | 739 (cond ((eq date 'now) |
| 740 "now") | 740 "now") |
| 741 ((stringp date) | 741 ((stringp date) |
| 742 "temp") | 742 "temp") |
| 743 (t "permanent")) | 743 (t "permanent")) |
| 748 match)))) | 748 match)))) |
| 749 | 749 |
| 750 ;; Get rid of string props. | 750 ;; Get rid of string props. |
| 751 (setq match (format "%s" match)) | 751 (setq match (format "%s" match)) |
| 752 | 752 |
| 753 ;; If this is an integer comparison, we transform from string to int. | 753 ;; If this is an integer comparison, we transform from string to int. |
| 754 (when (eq (nth 2 (assoc header gnus-header-index)) 'gnus-score-integer) | 754 (when (eq (nth 2 (assoc header gnus-header-index)) 'gnus-score-integer) |
| 755 (setq match (string-to-int match))) | 755 (setq match (string-to-int match))) |
| 756 | 756 |
| 757 (unless (eq date 'now) | 757 (unless (eq date 'now) |
| 758 ;; Add the score entry to the score file. | 758 ;; Add the score entry to the score file. |
| 759 (when (= score gnus-score-interactive-default-score) | 759 (when (= score gnus-score-interactive-default-score) |
| 760 (setq score nil)) | 760 (setq score nil)) |
| 761 (let ((old (gnus-score-get header)) | 761 (let ((old (gnus-score-get header)) |
| 762 elem) | 762 elem) |
| 763 (setq new | 763 (setq new |
| 764 (cond | 764 (cond |
| 765 (type | 765 (type |
| 766 (list match score | 766 (list match score |
| 767 (and date (if (numberp date) date | 767 (and date (if (numberp date) date |
| 768 (gnus-day-number date))) | 768 (gnus-day-number date))) |
| 769 type)) | 769 type)) |
| 819 (gnus-simplify-subject-fuzzy match)) | 819 (gnus-simplify-subject-fuzzy match)) |
| 820 ((eq type 'r) | 820 ((eq type 'r) |
| 821 match) | 821 match) |
| 822 ((eq type 'e) | 822 ((eq type 'e) |
| 823 (concat "\\`" (regexp-quote match) "\\'")) | 823 (concat "\\`" (regexp-quote match) "\\'")) |
| 824 (t | 824 (t |
| 825 (regexp-quote match))))) | 825 (regexp-quote match))))) |
| 826 (while (not (eobp)) | 826 (while (not (eobp)) |
| 827 (let ((content (gnus-summary-header header 'noerr)) | 827 (let ((content (gnus-summary-header header 'noerr)) |
| 828 (case-fold-search t)) | 828 (case-fold-search t)) |
| 829 (and content | 829 (and content |
| 844 group) | 844 group) |
| 845 (unless xref | 845 (unless xref |
| 846 (error "This article is not crossposted")) | 846 (error "This article is not crossposted")) |
| 847 (while (string-match " \\([^ \t]+\\):" xref start) | 847 (while (string-match " \\([^ \t]+\\):" xref start) |
| 848 (setq start (match-end 0)) | 848 (setq start (match-end 0)) |
| 849 (when (not (string= | 849 (when (not (string= |
| 850 (setq group | 850 (setq group |
| 851 (substring xref (match-beginning 1) (match-end 1))) | 851 (substring xref (match-beginning 1) (match-end 1))) |
| 852 gnus-newsgroup-name)) | 852 gnus-newsgroup-name)) |
| 853 (gnus-summary-score-entry | 853 (gnus-summary-score-entry |
| 854 "xref" (concat " " group ":") nil score date t))))) | 854 "xref" (concat " " group ":") nil score date t))))) |
| 855 | 855 |
| 861 ;; All score code written by Per Abrahamsen <abraham@iesd.auc.dk>. | 861 ;; All score code written by Per Abrahamsen <abraham@iesd.auc.dk>. |
| 862 | 862 |
| 863 ;; Added by Per Abrahamsen <amanda@iesd.auc.dk>. | 863 ;; Added by Per Abrahamsen <amanda@iesd.auc.dk>. |
| 864 (defun gnus-score-set-mark-below (score) | 864 (defun gnus-score-set-mark-below (score) |
| 865 "Automatically mark articles with score below SCORE as read." | 865 "Automatically mark articles with score below SCORE as read." |
| 866 (interactive | 866 (interactive |
| 867 (list (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg)) | 867 (list (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg)) |
| 868 (string-to-int (read-string "Mark below: "))))) | 868 (string-to-int (read-string "Mark below: "))))) |
| 869 (setq score (or score gnus-summary-default-score 0)) | 869 (setq score (or score gnus-summary-default-score 0)) |
| 870 (gnus-score-set 'mark (list score)) | 870 (gnus-score-set 'mark (list score)) |
| 871 (gnus-score-set 'touched '(t)) | 871 (gnus-score-set 'touched '(t)) |
| 895 (goto-char (pop hidden)) | 895 (goto-char (pop hidden)) |
| 896 (gnus-summary-hide-thread))))) | 896 (gnus-summary-hide-thread))))) |
| 897 | 897 |
| 898 (defun gnus-score-set-expunge-below (score) | 898 (defun gnus-score-set-expunge-below (score) |
| 899 "Automatically expunge articles with score below SCORE." | 899 "Automatically expunge articles with score below SCORE." |
| 900 (interactive | 900 (interactive |
| 901 (list (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg)) | 901 (list (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg)) |
| 902 (string-to-int (read-string "Set expunge below: "))))) | 902 (string-to-int (read-string "Set expunge below: "))))) |
| 903 (setq score (or score gnus-summary-default-score 0)) | 903 (setq score (or score gnus-summary-default-score 0)) |
| 904 (gnus-score-set 'expunge (list score)) | 904 (gnus-score-set 'expunge (list score)) |
| 905 (gnus-score-set 'touched '(t))) | 905 (gnus-score-set 'touched '(t))) |
| 934 "references" id 's | 934 "references" id 's |
| 935 score (current-time-string)))))))) | 935 score (current-time-string)))))))) |
| 936 | 936 |
| 937 (defun gnus-score-set (symbol value &optional alist) | 937 (defun gnus-score-set (symbol value &optional alist) |
| 938 ;; Set SYMBOL to VALUE in ALIST. | 938 ;; Set SYMBOL to VALUE in ALIST. |
| 939 (let* ((alist | 939 (let* ((alist |
| 940 (or alist | 940 (or alist |
| 941 gnus-score-alist | 941 gnus-score-alist |
| 942 (gnus-newsgroup-score-alist))) | 942 (gnus-newsgroup-score-alist))) |
| 943 (entry (assoc symbol alist))) | 943 (entry (assoc symbol alist))) |
| 944 (cond ((gnus-score-get 'read-only alist) | 944 (cond ((gnus-score-get 'read-only alist) |
| 945 ;; This is a read-only score file, so we do nothing. | 945 ;; This is a read-only score file, so we do nothing. |
| 984 (gnus-set-global-variables) | 984 (gnus-set-global-variables) |
| 985 (gnus-message 1 "%s" (gnus-summary-article-score))) | 985 (gnus-message 1 "%s" (gnus-summary-article-score))) |
| 986 | 986 |
| 987 (defun gnus-score-change-score-file (file) | 987 (defun gnus-score-change-score-file (file) |
| 988 "Change current score alist." | 988 "Change current score alist." |
| 989 (interactive | 989 (interactive |
| 990 (list (read-file-name "Change to score file: " gnus-kill-files-directory))) | 990 (list (read-file-name "Change to score file: " gnus-kill-files-directory))) |
| 991 (gnus-score-load-file file) | 991 (gnus-score-load-file file) |
| 992 (gnus-set-mode-line 'summary)) | 992 (gnus-set-mode-line 'summary)) |
| 993 | 993 |
| 994 (defvar gnus-score-edit-exit-function) | 994 (defvar gnus-score-edit-exit-function) |
| 1004 (gnus-configure-windows 'edit-score) | 1004 (gnus-configure-windows 'edit-score) |
| 1005 (gnus-score-mode) | 1005 (gnus-score-mode) |
| 1006 (setq gnus-score-edit-exit-function 'gnus-score-edit-done) | 1006 (setq gnus-score-edit-exit-function 'gnus-score-edit-done) |
| 1007 (make-local-variable 'gnus-prev-winconf) | 1007 (make-local-variable 'gnus-prev-winconf) |
| 1008 (setq gnus-prev-winconf winconf)) | 1008 (setq gnus-prev-winconf winconf)) |
| 1009 (gnus-message | 1009 (gnus-message |
| 1010 4 (substitute-command-keys | 1010 4 (substitute-command-keys |
| 1011 "\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits"))) | 1011 "\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits"))) |
| 1012 | 1012 |
| 1013 (defun gnus-score-edit-file (file) | 1013 (defun gnus-score-edit-file (file) |
| 1014 "Edit a score file." | 1014 "Edit a score file." |
| 1015 (interactive | 1015 (interactive |
| 1016 (list (read-file-name "Edit score file: " gnus-kill-files-directory))) | 1016 (list (read-file-name "Edit score file: " gnus-kill-files-directory))) |
| 1017 (gnus-make-directory (file-name-directory file)) | 1017 (gnus-make-directory (file-name-directory file)) |
| 1018 (when (buffer-name gnus-summary-buffer) | 1018 (when (buffer-name gnus-summary-buffer) |
| 1019 (gnus-score-save)) | 1019 (gnus-score-save)) |
| 1020 (let ((winconf (current-window-configuration))) | 1020 (let ((winconf (current-window-configuration))) |
| 1022 (gnus-configure-windows 'edit-score) | 1022 (gnus-configure-windows 'edit-score) |
| 1023 (gnus-score-mode) | 1023 (gnus-score-mode) |
| 1024 (setq gnus-score-edit-exit-function 'gnus-score-edit-done) | 1024 (setq gnus-score-edit-exit-function 'gnus-score-edit-done) |
| 1025 (make-local-variable 'gnus-prev-winconf) | 1025 (make-local-variable 'gnus-prev-winconf) |
| 1026 (setq gnus-prev-winconf winconf)) | 1026 (setq gnus-prev-winconf winconf)) |
| 1027 (gnus-message | 1027 (gnus-message |
| 1028 4 (substitute-command-keys | 1028 4 (substitute-command-keys |
| 1029 "\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits"))) | 1029 "\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits"))) |
| 1030 | 1030 |
| 1031 (defun gnus-score-load-file (file) | 1031 (defun gnus-score-load-file (file) |
| 1032 ;; Load score file FILE. Returns a list a retrieved score-alists. | 1032 ;; Load score file FILE. Returns a list a retrieved score-alists. |
| 1033 (let* ((file (expand-file-name | 1033 (let* ((file (expand-file-name |
| 1034 (or (and (string-match | 1034 (or (and (string-match |
| 1035 (concat "^" (expand-file-name | 1035 (concat "^" (expand-file-name |
| 1036 gnus-kill-files-directory)) | 1036 gnus-kill-files-directory)) |
| 1037 (expand-file-name file)) | 1037 (expand-file-name file)) |
| 1038 file) | 1038 file) |
| 1046 (setq alist (cdr cached)) | 1046 (setq alist (cdr cached)) |
| 1047 ;; We load the score file. | 1047 ;; We load the score file. |
| 1048 (setq gnus-score-alist nil) | 1048 (setq gnus-score-alist nil) |
| 1049 (setq alist (gnus-score-load-score-alist file)) | 1049 (setq alist (gnus-score-load-score-alist file)) |
| 1050 ;; We add '(touched) to the alist to signify that it hasn't been | 1050 ;; We add '(touched) to the alist to signify that it hasn't been |
| 1051 ;; touched (yet). | 1051 ;; touched (yet). |
| 1052 (unless (assq 'touched alist) | 1052 (unless (assq 'touched alist) |
| 1053 (push (list 'touched nil) alist)) | 1053 (push (list 'touched nil) alist)) |
| 1054 ;; If it is a global score file, we make it read-only. | 1054 ;; If it is a global score file, we make it read-only. |
| 1055 (and global | 1055 (and global |
| 1056 (not (assq 'read-only alist)) | 1056 (not (assq 'read-only alist)) |
| 1082 (local (gnus-score-get 'local alist)) | 1082 (local (gnus-score-get 'local alist)) |
| 1083 (decay (car (gnus-score-get 'decay alist))) | 1083 (decay (car (gnus-score-get 'decay alist))) |
| 1084 (eval (car (gnus-score-get 'eval alist)))) | 1084 (eval (car (gnus-score-get 'eval alist)))) |
| 1085 ;; Perform possible decays. | 1085 ;; Perform possible decays. |
| 1086 (when (and gnus-decay-scores | 1086 (when (and gnus-decay-scores |
| 1087 (gnus-decay-scores | 1087 (gnus-decay-scores |
| 1088 alist (or decay (gnus-time-to-day (current-time))))) | 1088 alist (or decay (gnus-time-to-day (current-time))))) |
| 1089 (gnus-score-set 'touched '(t) alist) | 1089 (gnus-score-set 'touched '(t) alist) |
| 1090 (gnus-score-set 'decay (list (gnus-time-to-day (current-time))))) | 1090 (gnus-score-set 'decay (list (gnus-time-to-day (current-time))))) |
| 1091 ;; We do not respect eval and files atoms from global score | 1091 ;; We do not respect eval and files atoms from global score |
| 1092 ;; files. | 1092 ;; files. |
| 1093 (and files (not global) | 1093 (and files (not global) |
| 1094 (setq lists (apply 'append lists | 1094 (setq lists (apply 'append lists |
| 1095 (mapcar (lambda (file) | 1095 (mapcar (lambda (file) |
| 1096 (gnus-score-load-file file)) | 1096 (gnus-score-load-file file)) |
| 1097 (if adapt-file (cons adapt-file files) | 1097 (if adapt-file (cons adapt-file files) |
| 1098 files))))) | 1098 files))))) |
| 1099 (and eval (not global) (eval eval)) | 1099 (and eval (not global) (eval eval)) |
| 1100 ;; We then expand any exclude-file directives. | 1100 ;; We then expand any exclude-file directives. |
| 1101 (setq gnus-scores-exclude-files | 1101 (setq gnus-scores-exclude-files |
| 1102 (nconc | 1102 (nconc |
| 1103 (mapcar | 1103 (mapcar |
| 1104 (lambda (sfile) | 1104 (lambda (sfile) |
| 1105 (expand-file-name sfile (file-name-directory file))) | 1105 (expand-file-name sfile (file-name-directory file))) |
| 1106 exclude-files) | 1106 exclude-files) |
| 1107 gnus-scores-exclude-files)) | 1107 gnus-scores-exclude-files)) |
| 1108 (if (not local) | 1108 (if (not local) |
| 1128 (setq gnus-newsgroup-adaptive t) | 1128 (setq gnus-newsgroup-adaptive t) |
| 1129 adapt) | 1129 adapt) |
| 1130 (t | 1130 (t |
| 1131 ;;(setq gnus-newsgroup-adaptive gnus-use-adaptive-scoring) | 1131 ;;(setq gnus-newsgroup-adaptive gnus-use-adaptive-scoring) |
| 1132 gnus-default-adaptive-score-alist))) | 1132 gnus-default-adaptive-score-alist))) |
| 1133 (setq gnus-thread-expunge-below | 1133 (setq gnus-thread-expunge-below |
| 1134 (or thread-mark-and-expunge gnus-thread-expunge-below)) | 1134 (or thread-mark-and-expunge gnus-thread-expunge-below)) |
| 1135 (setq gnus-summary-mark-below | 1135 (setq gnus-summary-mark-below |
| 1136 (or mark mark-and-expunge gnus-summary-mark-below)) | 1136 (or mark mark-and-expunge gnus-summary-mark-below)) |
| 1137 (setq gnus-summary-expunge-below | 1137 (setq gnus-summary-expunge-below |
| 1138 (or expunge mark-and-expunge gnus-summary-expunge-below)) | 1138 (or expunge mark-and-expunge gnus-summary-expunge-below)) |
| 1139 (setq gnus-newsgroup-adaptive-score-file | 1139 (setq gnus-newsgroup-adaptive-score-file |
| 1140 (or adapt-file gnus-newsgroup-adaptive-score-file))) | 1140 (or adapt-file gnus-newsgroup-adaptive-score-file))) |
| 1141 (setq gnus-current-score-file file) | 1141 (setq gnus-current-score-file file) |
| 1142 (setq gnus-score-alist alist) | 1142 (setq gnus-score-alist alist) |
| 1143 lists)) | 1143 lists)) |
| 1144 | 1144 |
| 1152 (unless gnus-score-alist | 1152 (unless gnus-score-alist |
| 1153 (setq gnus-score-alist (copy-alist '((touched nil))))) | 1153 (setq gnus-score-alist (copy-alist '((touched nil))))) |
| 1154 (push (cons file gnus-score-alist) gnus-score-cache)))) | 1154 (push (cons file gnus-score-alist) gnus-score-cache)))) |
| 1155 | 1155 |
| 1156 (defun gnus-score-remove-from-cache (file) | 1156 (defun gnus-score-remove-from-cache (file) |
| 1157 (setq gnus-score-cache | 1157 (setq gnus-score-cache |
| 1158 (delq (assoc file gnus-score-cache) gnus-score-cache))) | 1158 (delq (assoc file gnus-score-cache) gnus-score-cache))) |
| 1159 | 1159 |
| 1160 (defun gnus-score-load-score-alist (file) | 1160 (defun gnus-score-load-score-alist (file) |
| 1161 "Read score FILE." | 1161 "Read score FILE." |
| 1162 (let (alist) | 1162 (let (alist) |
| 1171 ;; Only do the loading if the score file isn't empty. | 1171 ;; Only do the loading if the score file isn't empty. |
| 1172 (when (save-excursion (re-search-forward "[()0-9a-zA-Z]" nil t)) | 1172 (when (save-excursion (re-search-forward "[()0-9a-zA-Z]" nil t)) |
| 1173 (setq alist | 1173 (setq alist |
| 1174 (condition-case () | 1174 (condition-case () |
| 1175 (read (current-buffer)) | 1175 (read (current-buffer)) |
| 1176 (error | 1176 (error |
| 1177 (gnus-error 3.2 "Problem with score file %s" file)))))) | 1177 (gnus-error 3.2 "Problem with score file %s" file)))))) |
| 1178 (if (eq (car alist) 'setq) | 1178 (if (eq (car alist) 'setq) |
| 1179 ;; This is an old-style score file. | 1179 ;; This is an old-style score file. |
| 1180 (setq gnus-score-alist (gnus-score-transform-old-to-new alist)) | 1180 (setq gnus-score-alist (gnus-score-transform-old-to-new alist)) |
| 1181 (setq gnus-score-alist alist)) | 1181 (setq gnus-score-alist alist)) |
| 1183 (setq gnus-score-alist | 1183 (setq gnus-score-alist |
| 1184 (gnus-score-check-syntax gnus-score-alist file))))) | 1184 (gnus-score-check-syntax gnus-score-alist file))))) |
| 1185 | 1185 |
| 1186 (defun gnus-score-check-syntax (alist file) | 1186 (defun gnus-score-check-syntax (alist file) |
| 1187 "Check the syntax of the score ALIST." | 1187 "Check the syntax of the score ALIST." |
| 1188 (cond | 1188 (cond |
| 1189 ((null alist) | 1189 ((null alist) |
| 1190 nil) | 1190 nil) |
| 1191 ((not (consp alist)) | 1191 ((not (consp alist)) |
| 1192 (gnus-message 1 "Score file is not a list: %s" file) | 1192 (gnus-message 1 "Score file is not a list: %s" file) |
| 1193 (ding) | 1193 (ding) |
| 1200 err | 1200 err |
| 1201 (cond | 1201 (cond |
| 1202 ((not (listp (car a))) | 1202 ((not (listp (car a))) |
| 1203 (format "Illegal score element %s in %s" (car a) file)) | 1203 (format "Illegal score element %s in %s" (car a) file)) |
| 1204 ((stringp (caar a)) | 1204 ((stringp (caar a)) |
| 1205 (cond | 1205 (cond |
| 1206 ((not (listp (setq sr (cdar a)))) | 1206 ((not (listp (setq sr (cdar a)))) |
| 1207 (format "Illegal header match %s in %s" (nth 1 (car a)) file)) | 1207 (format "Illegal header match %s in %s" (nth 1 (car a)) file)) |
| 1208 (t | 1208 (t |
| 1209 (setq type (caar a)) | 1209 (setq type (caar a)) |
| 1210 (while (and sr (not err)) | 1210 (while (and sr (not err)) |
| 1211 (setq s (pop sr)) | 1211 (setq s (pop sr)) |
| 1212 (setq | 1212 (setq |
| 1213 err | 1213 err |
| 1214 (cond | 1214 (cond |
| 1215 ((if (member (downcase type) '("lines" "chars")) | 1215 ((if (member (downcase type) '("lines" "chars")) |
| 1216 (not (numberp (car s))) | 1216 (not (numberp (car s))) |
| 1217 (not (stringp (car s)))) | 1217 (not (stringp (car s)))) |
| 1253 (list (car entry) (cdr entry)) | 1253 (list (car entry) (cdr entry)) |
| 1254 entry) | 1254 entry) |
| 1255 out)) | 1255 out)) |
| 1256 (setq alist (cdr alist))) | 1256 (setq alist (cdr alist))) |
| 1257 (cons (list 'touched t) (nreverse out)))) | 1257 (cons (list 'touched t) (nreverse out)))) |
| 1258 | 1258 |
| 1259 (defun gnus-score-save () | 1259 (defun gnus-score-save () |
| 1260 ;; Save all score information. | 1260 ;; Save all score information. |
| 1261 (let ((cache gnus-score-cache) | 1261 (let ((cache gnus-score-cache) |
| 1262 entry score file) | 1262 entry score file) |
| 1263 (save-excursion | 1263 (save-excursion |
| 1274 (not (file-writable-p file)))) | 1274 (not (file-writable-p file)))) |
| 1275 () | 1275 () |
| 1276 (setq score (setcdr entry (delq (assq 'touched score) score))) | 1276 (setq score (setcdr entry (delq (assq 'touched score) score))) |
| 1277 (erase-buffer) | 1277 (erase-buffer) |
| 1278 (let (emacs-lisp-mode-hook) | 1278 (let (emacs-lisp-mode-hook) |
| 1279 (if (string-match | 1279 (if (string-match |
| 1280 (concat (regexp-quote gnus-adaptive-file-suffix) | 1280 (concat (regexp-quote gnus-adaptive-file-suffix) |
| 1281 "$") | 1281 "$") |
| 1282 file) | 1282 file) |
| 1283 ;; This is an adaptive score file, so we do not run | 1283 ;; This is an adaptive score file, so we do not run |
| 1284 ;; it through `pp'. These files can get huge, and | 1284 ;; it through `pp'. These files can get huge, and |
| 1285 ;; are not meant to be edited by human hands. | 1285 ;; are not meant to be edited by human hands. |
| 1286 (gnus-prin1 score) | 1286 (gnus-prin1 score) |
| 1287 ;; This is a normal score file, so we print it very | 1287 ;; This is a normal score file, so we print it very |
| 1288 ;; prettily. | 1288 ;; prettily. |
| 1289 (pp score (current-buffer)))) | 1289 (pp score (current-buffer)))) |
| 1290 (gnus-make-directory (file-name-directory file)) | 1290 (gnus-make-directory (file-name-directory file)) |
| 1291 ;; If the score file is empty, we delete it. | 1291 ;; If the score file is empty, we delete it. |
| 1292 (if (zerop (buffer-size)) | 1292 (if (zerop (buffer-size)) |
| 1293 (delete-file file) | 1293 (delete-file file) |
| 1294 ;; There are scores, so we write the file. | 1294 ;; There are scores, so we write the file. |
| 1295 (when (file-writable-p file) | 1295 (when (file-writable-p file) |
| 1296 (gnus-write-buffer file) | 1296 (gnus-write-buffer file) |
| 1297 (when gnus-score-after-write-file-function | 1297 (when gnus-score-after-write-file-function |
| 1298 (funcall gnus-score-after-write-file-function file))))) | 1298 (funcall gnus-score-after-write-file-function file))))) |
| 1299 (and gnus-score-uncacheable-files | 1299 (and gnus-score-uncacheable-files |
| 1363 (buffer-disable-undo (current-buffer)) | 1363 (buffer-disable-undo (current-buffer)) |
| 1364 | 1364 |
| 1365 ;; Set the global variant of this variable. | 1365 ;; Set the global variant of this variable. |
| 1366 (setq gnus-current-score-file current-score-file) | 1366 (setq gnus-current-score-file current-score-file) |
| 1367 ;; score orphans | 1367 ;; score orphans |
| 1368 (when gnus-orphan-score | 1368 (when gnus-orphan-score |
| 1369 (setq gnus-score-index | 1369 (setq gnus-score-index |
| 1370 (nth 1 (assoc "references" gnus-header-index))) | 1370 (nth 1 (assoc "references" gnus-header-index))) |
| 1371 (gnus-score-orphans gnus-orphan-score)) | 1371 (gnus-score-orphans gnus-orphan-score)) |
| 1372 ;; Run each header through the score process. | 1372 ;; Run each header through the score process. |
| 1373 (while entries | 1373 (while entries |
| 1374 (setq entry (pop entries) | 1374 (setq entry (pop entries) |
| 1399 (while (setq score (pop scores)) | 1399 (while (setq score (pop scores)) |
| 1400 (while score | 1400 (while score |
| 1401 (when (listp (caar score)) | 1401 (when (listp (caar score)) |
| 1402 (gnus-score-advanced (car score) trace)) | 1402 (gnus-score-advanced (car score) trace)) |
| 1403 (pop score)))) | 1403 (pop score)))) |
| 1404 | 1404 |
| 1405 (gnus-message 5 "Scoring...done")))))) | 1405 (gnus-message 5 "Scoring...done")))))) |
| 1406 | 1406 |
| 1407 | 1407 |
| 1408 (defun gnus-get-new-thread-ids (articles) | 1408 (defun gnus-get-new-thread-ids (articles) |
| 1409 (let ((index (nth 1 (assoc "message-id" gnus-header-index))) | 1409 (let ((index (nth 1 (assoc "message-id" gnus-header-index))) |
| 1420 | 1420 |
| 1421 ;; Orphan functions written by plm@atcmp.nl (Peter Mutsaers). | 1421 ;; Orphan functions written by plm@atcmp.nl (Peter Mutsaers). |
| 1422 (defun gnus-score-orphans (score) | 1422 (defun gnus-score-orphans (score) |
| 1423 (let ((new-thread-ids (gnus-get-new-thread-ids gnus-scores-articles)) | 1423 (let ((new-thread-ids (gnus-get-new-thread-ids gnus-scores-articles)) |
| 1424 alike articles art arts this last this-id) | 1424 alike articles art arts this last this-id) |
| 1425 | 1425 |
| 1426 (setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<) | 1426 (setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<) |
| 1427 articles gnus-scores-articles) | 1427 articles gnus-scores-articles) |
| 1428 | 1428 |
| 1429 ;;more or less the same as in gnus-score-string | 1429 ;;more or less the same as in gnus-score-string |
| 1430 (erase-buffer) | 1430 (erase-buffer) |
| 1469 (while arts | 1469 (while arts |
| 1470 (setq art (car arts) | 1470 (setq art (car arts) |
| 1471 arts (cdr arts)) | 1471 arts (cdr arts)) |
| 1472 (setcdr art (+ score (cdr art)))) | 1472 (setcdr art (+ score (cdr art)))) |
| 1473 (forward-line)))))) | 1473 (forward-line)))))) |
| 1474 | 1474 |
| 1475 | 1475 |
| 1476 (defun gnus-score-integer (scores header now expire &optional trace) | 1476 (defun gnus-score-integer (scores header now expire &optional trace) |
| 1477 (let ((gnus-score-index (nth 1 (assoc header gnus-header-index))) | 1477 (let ((gnus-score-index (nth 1 (assoc header gnus-header-index))) |
| 1478 entries alist) | 1478 entries alist) |
| 1479 | 1479 |
| 1499 ;; `gnus-score-string' does to minimize searches and stuff, | 1499 ;; `gnus-score-string' does to minimize searches and stuff, |
| 1500 ;; I will assume that people generally will put so few | 1500 ;; I will assume that people generally will put so few |
| 1501 ;; matches on numbers that any cleverness will take more | 1501 ;; matches on numbers that any cleverness will take more |
| 1502 ;; time than one would gain. | 1502 ;; time than one would gain. |
| 1503 (while articles | 1503 (while articles |
| 1504 (when (funcall match-func | 1504 (when (funcall match-func |
| 1505 (or (aref (caar articles) gnus-score-index) 0) | 1505 (or (aref (caar articles) gnus-score-index) 0) |
| 1506 match) | 1506 match) |
| 1507 (when trace | 1507 (when trace |
| 1508 (push (cons (car-safe (rassq alist gnus-score-cache)) kill) | 1508 (push (cons (car-safe (rassq alist gnus-score-cache)) kill) |
| 1509 gnus-score-trace)) | 1509 gnus-score-trace)) |
| 1510 (setq found t) | 1510 (setq found t) |
| 1511 (setcdr (car articles) (+ score (cdar articles)))) | 1511 (setcdr (car articles) (+ score (cdar articles)))) |
| 1512 (setq articles (cdr articles))) | 1512 (setq articles (cdr articles))) |
| 1600 entries alist ofunc article last) | 1600 entries alist ofunc article last) |
| 1601 (when articles | 1601 (when articles |
| 1602 (setq last (mail-header-number (caar (last articles)))) | 1602 (setq last (mail-header-number (caar (last articles)))) |
| 1603 ;; Not all backends support partial fetching. In that case, | 1603 ;; Not all backends support partial fetching. In that case, |
| 1604 ;; we just fetch the entire article. | 1604 ;; we just fetch the entire article. |
| 1605 (unless (gnus-check-backend-function | 1605 (unless (gnus-check-backend-function |
| 1606 (and (string-match "^gnus-" (symbol-name request-func)) | 1606 (and (string-match "^gnus-" (symbol-name request-func)) |
| 1607 (intern (substring (symbol-name request-func) | 1607 (intern (substring (symbol-name request-func) |
| 1608 (match-end 0)))) | 1608 (match-end 0)))) |
| 1609 gnus-newsgroup-name) | 1609 gnus-newsgroup-name) |
| 1610 (setq ofunc request-func) | 1610 (setq ofunc request-func) |
| 1638 (type (or (nth 3 kill) 's)) | 1638 (type (or (nth 3 kill) 's)) |
| 1639 (score (or (nth 1 kill) | 1639 (score (or (nth 1 kill) |
| 1640 gnus-score-interactive-default-score)) | 1640 gnus-score-interactive-default-score)) |
| 1641 (date (nth 2 kill)) | 1641 (date (nth 2 kill)) |
| 1642 (found nil) | 1642 (found nil) |
| 1643 (case-fold-search | 1643 (case-fold-search |
| 1644 (not (or (eq type 'R) (eq type 'S) | 1644 (not (or (eq type 'R) (eq type 'S) |
| 1645 (eq type 'Regexp) (eq type 'String)))) | 1645 (eq type 'Regexp) (eq type 'String)))) |
| 1646 (search-func | 1646 (search-func |
| 1647 (cond ((or (eq type 'r) (eq type 'R) | 1647 (cond ((or (eq type 'r) (eq type 'R) |
| 1648 (eq type 'regexp) (eq type 'Regexp)) | 1648 (eq type 'regexp) (eq type 'Regexp)) |
| 1649 're-search-forward) | 1649 're-search-forward) |
| 1650 ((or (eq type 's) (eq type 'S) | 1650 ((or (eq type 's) (eq type 'S) |
| 1651 (eq type 'string) (eq type 'String)) | 1651 (eq type 'string) (eq type 'String)) |
| 1663 gnus-score-trace))) | 1663 gnus-score-trace))) |
| 1664 ;; Update expire date | 1664 ;; Update expire date |
| 1665 (unless trace | 1665 (unless trace |
| 1666 (cond | 1666 (cond |
| 1667 ((null date)) ;Permanent entry. | 1667 ((null date)) ;Permanent entry. |
| 1668 ((and found gnus-update-score-entry-dates) | 1668 ((and found gnus-update-score-entry-dates) |
| 1669 ;; Match, update date. | 1669 ;; Match, update date. |
| 1670 (gnus-score-set 'touched '(t) alist) | 1670 (gnus-score-set 'touched '(t) alist) |
| 1671 (setcar (nthcdr 2 kill) now)) | 1671 (setcar (nthcdr 2 kill) now)) |
| 1672 ((and expire (< date expire)) ;Old entry, remove. | 1672 ((and expire (< date expire)) ;Old entry, remove. |
| 1673 (gnus-score-set 'touched '(t) alist) | 1673 (gnus-score-set 'touched '(t) alist) |
| 1693 ;; this function makes will be put into this file. | 1693 ;; this function makes will be put into this file. |
| 1694 (save-excursion | 1694 (save-excursion |
| 1695 (set-buffer gnus-summary-buffer) | 1695 (set-buffer gnus-summary-buffer) |
| 1696 (gnus-score-load-file | 1696 (gnus-score-load-file |
| 1697 (or gnus-newsgroup-adaptive-score-file | 1697 (or gnus-newsgroup-adaptive-score-file |
| 1698 (gnus-score-file-name | 1698 (gnus-score-file-name |
| 1699 gnus-newsgroup-name gnus-adaptive-file-suffix)))) | 1699 gnus-newsgroup-name gnus-adaptive-file-suffix)))) |
| 1700 | 1700 |
| 1701 (setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<) | 1701 (setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<) |
| 1702 articles gnus-scores-articles) | 1702 articles gnus-scores-articles) |
| 1703 | 1703 |
| 1714 (setq alike (list art) | 1714 (setq alike (list art) |
| 1715 last this))) | 1715 last this))) |
| 1716 (when last ; Bwadr, duplicate code. | 1716 (when last ; Bwadr, duplicate code. |
| 1717 (insert last ?\n) | 1717 (insert last ?\n) |
| 1718 (put-text-property (1- (point)) (point) 'articles alike)) | 1718 (put-text-property (1- (point)) (point) 'articles alike)) |
| 1719 | 1719 |
| 1720 ;; Find matches. | 1720 ;; Find matches. |
| 1721 (while scores | 1721 (while scores |
| 1722 (setq alist (car scores) | 1722 (setq alist (car scores) |
| 1723 scores (cdr scores) | 1723 scores (cdr scores) |
| 1724 entries (assoc header alist)) | 1724 entries (assoc header alist)) |
| 1729 (type (or (nth 3 kill) 's)) | 1729 (type (or (nth 3 kill) 's)) |
| 1730 (score (or (nth 1 kill) gnus-score-interactive-default-score)) | 1730 (score (or (nth 1 kill) gnus-score-interactive-default-score)) |
| 1731 (date (nth 2 kill)) | 1731 (date (nth 2 kill)) |
| 1732 (found nil) | 1732 (found nil) |
| 1733 (mt (aref (symbol-name type) 0)) | 1733 (mt (aref (symbol-name type) 0)) |
| 1734 (case-fold-search | 1734 (case-fold-search |
| 1735 (not (or (= mt ?R) (= mt ?S) (= mt ?E) (= mt ?F)))) | 1735 (not (or (= mt ?R) (= mt ?S) (= mt ?E) (= mt ?F)))) |
| 1736 (dmt (downcase mt)) | 1736 (dmt (downcase mt)) |
| 1737 (search-func | 1737 (search-func |
| 1738 (cond ((= dmt ?r) 're-search-forward) | 1738 (cond ((= dmt ?r) 're-search-forward) |
| 1739 ((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward) | 1739 ((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward) |
| 1740 (t (error "Illegal match type: %s" type)))) | 1740 (t (error "Illegal match type: %s" type)))) |
| 1741 arts art) | 1741 arts art) |
| 1742 (goto-char (point-min)) | 1742 (goto-char (point-min)) |
| 1745 (and (= (progn (beginning-of-line) (point)) | 1745 (and (= (progn (beginning-of-line) (point)) |
| 1746 (match-beginning 0)) | 1746 (match-beginning 0)) |
| 1747 (= (progn (end-of-line) (point)) | 1747 (= (progn (end-of-line) (point)) |
| 1748 (match-end 0)) | 1748 (match-end 0)) |
| 1749 (progn | 1749 (progn |
| 1750 (setq found (setq arts (get-text-property | 1750 (setq found (setq arts (get-text-property |
| 1751 (point) 'articles))) | 1751 (point) 'articles))) |
| 1752 ;; Found a match, update scores. | 1752 ;; Found a match, update scores. |
| 1753 (while arts | 1753 (while arts |
| 1754 (setq art (car arts) | 1754 (setq art (car arts) |
| 1755 arts (cdr arts)) | 1755 arts (cdr arts)) |
| 1756 (gnus-score-add-followups | 1756 (gnus-score-add-followups |
| 1757 (car art) score all-scores thread)))) | 1757 (car art) score all-scores thread)))) |
| 1758 (end-of-line)) | 1758 (end-of-line)) |
| 1759 (while (funcall search-func match nil t) | 1759 (while (funcall search-func match nil t) |
| 1760 (end-of-line) | 1760 (end-of-line) |
| 1761 (setq found (setq arts (get-text-property (point) 'articles))) | 1761 (setq found (setq arts (get-text-property (point) 'articles))) |
| 1793 (or (null (nth 3 (cadr entry))) | 1793 (or (null (nth 3 (cadr entry))) |
| 1794 (eq 's (nth 3 (cadr entry)))) | 1794 (eq 's (nth 3 (cadr entry)))) |
| 1795 (assoc id entry) | 1795 (assoc id entry) |
| 1796 (setq dont t))) | 1796 (setq dont t))) |
| 1797 (unless dont | 1797 (unless dont |
| 1798 (gnus-summary-score-entry | 1798 (gnus-summary-score-entry |
| 1799 (if thread "thread" "references") | 1799 (if thread "thread" "references") |
| 1800 id 's score (current-time-string) nil t))))) | 1800 id 's score (current-time-string) nil t))))) |
| 1801 | 1801 |
| 1802 (defun gnus-score-string (score-list header now expire &optional trace) | 1802 (defun gnus-score-string (score-list header now expire &optional trace) |
| 1803 ;; Score ARTICLES according to HEADER in SCORE-LIST. | 1803 ;; Score ARTICLES according to HEADER in SCORE-LIST. |
| 1804 ;; Update matching entries to NOW and remove unmatched entries older | 1804 ;; Update matching entries to NOW and remove unmatched entries older |
| 1805 ;; than EXPIRE. | 1805 ;; than EXPIRE. |
| 1806 | 1806 |
| 1807 ;; Insert the unique article headers in the buffer. | 1807 ;; Insert the unique article headers in the buffer. |
| 1808 (let ((gnus-score-index (nth 1 (assoc header gnus-header-index))) | 1808 (let ((gnus-score-index (nth 1 (assoc header gnus-header-index))) |
| 1809 ;; gnus-score-index is used as a free variable. | 1809 ;; gnus-score-index is used as a free variable. |
| 1810 alike last this art entries alist articles | 1810 alike last this art entries alist articles |
| 1811 fuzzies arts words kill) | 1811 fuzzies arts words kill) |
| 1812 | 1812 |
| 1813 ;; Sorting the articles costs os O(N*log N) but will allow us to | 1813 ;; Sorting the articles costs os O(N*log N) but will allow us to |
| 1814 ;; only match with each unique header. Thus the actual matching | 1814 ;; only match with each unique header. Thus the actual matching |
| 1815 ;; will be O(M*U) where M is the number of strings to match with, | 1815 ;; will be O(M*U) where M is the number of strings to match with, |
| 1853 (date (nth 2 kill)) | 1853 (date (nth 2 kill)) |
| 1854 (found nil) | 1854 (found nil) |
| 1855 (mt (aref (symbol-name type) 0)) | 1855 (mt (aref (symbol-name type) 0)) |
| 1856 (case-fold-search (not (memq mt '(?R ?S ?E ?F)))) | 1856 (case-fold-search (not (memq mt '(?R ?S ?E ?F)))) |
| 1857 (dmt (downcase mt)) | 1857 (dmt (downcase mt)) |
| 1858 (search-func | 1858 (search-func |
| 1859 (cond ((= dmt ?r) 're-search-forward) | 1859 (cond ((= dmt ?r) 're-search-forward) |
| 1860 ((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward) | 1860 ((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward) |
| 1861 ((= dmt ?w) nil) | 1861 ((= dmt ?w) nil) |
| 1862 (t (error "Illegal match type: %s" type))))) | 1862 (t (error "Illegal match type: %s" type))))) |
| 1863 (cond | 1863 (cond |
| 1876 ;; Is it really exact? | 1876 ;; Is it really exact? |
| 1877 (and (eolp) | 1877 (and (eolp) |
| 1878 (= (gnus-point-at-bol) (match-beginning 0)) | 1878 (= (gnus-point-at-bol) (match-beginning 0)) |
| 1879 ;; Yup. | 1879 ;; Yup. |
| 1880 (progn | 1880 (progn |
| 1881 (setq found (setq arts (get-text-property | 1881 (setq found (setq arts (get-text-property |
| 1882 (point) 'articles))) | 1882 (point) 'articles))) |
| 1883 ;; Found a match, update scores. | 1883 ;; Found a match, update scores. |
| 1884 (if trace | 1884 (if trace |
| 1885 (while (setq art (pop arts)) | 1885 (while (setq art (pop arts)) |
| 1886 (setcdr art (+ score (cdr art))) | 1886 (setcdr art (+ score (cdr art))) |
| 1887 (push | 1887 (push |
| 1888 (cons | 1888 (cons |
| 1889 (car-safe (rassq alist gnus-score-cache)) | 1889 (car-safe (rassq alist gnus-score-cache)) |
| 1890 kill) | 1890 kill) |
| 1891 gnus-score-trace)) | 1891 gnus-score-trace)) |
| 1892 (while (setq art (pop arts)) | 1892 (while (setq art (pop arts)) |
| 1893 (setcdr art (+ score (cdr art))))))) | 1893 (setcdr art (+ score (cdr art))))))) |
| 1912 (setcdr art (+ score (cdr art))))) | 1912 (setcdr art (+ score (cdr art))))) |
| 1913 (forward-line 1)))) | 1913 (forward-line 1)))) |
| 1914 ;; Update expiry date | 1914 ;; Update expiry date |
| 1915 (if trace | 1915 (if trace |
| 1916 (setq entries (cdr entries)) | 1916 (setq entries (cdr entries)) |
| 1917 (cond | 1917 (cond |
| 1918 ;; Permanent entry. | 1918 ;; Permanent entry. |
| 1919 ((null date) | 1919 ((null date) |
| 1920 (setq entries (cdr entries))) | 1920 (setq entries (cdr entries))) |
| 1921 ;; We have a match, so we update the date. | 1921 ;; We have a match, so we update the date. |
| 1922 ((and found gnus-update-score-entry-dates) | 1922 ((and found gnus-update-score-entry-dates) |
| 1951 (setq found (setq arts (get-text-property (point) 'articles))) | 1951 (setq found (setq arts (get-text-property (point) 'articles))) |
| 1952 (if trace | 1952 (if trace |
| 1953 (while (setq art (pop arts)) | 1953 (while (setq art (pop arts)) |
| 1954 (setcdr art (+ score (cdr art))) | 1954 (setcdr art (+ score (cdr art))) |
| 1955 (push (cons | 1955 (push (cons |
| 1956 (car-safe (rassq (cdar fuzzies) gnus-score-cache)) | 1956 (car-safe (rassq (cdar fuzzies) gnus-score-cache)) |
| 1957 kill) | 1957 kill) |
| 1958 gnus-score-trace)) | 1958 gnus-score-trace)) |
| 1959 ;; Found a match, update scores. | 1959 ;; Found a match, update scores. |
| 1960 (while (setq art (pop arts)) | 1960 (while (setq art (pop arts)) |
| 1961 (setcdr art (+ score (cdr art)))))) | 1961 (setcdr art (+ score (cdr art)))))) |
| 2022 (unwind-protect | 2022 (unwind-protect |
| 2023 (progn | 2023 (progn |
| 2024 (set-syntax-table gnus-adaptive-word-syntax-table) | 2024 (set-syntax-table gnus-adaptive-word-syntax-table) |
| 2025 (while (re-search-forward "\\b\\w+\\b" nil t) | 2025 (while (re-search-forward "\\b\\w+\\b" nil t) |
| 2026 (setq val | 2026 (setq val |
| 2027 (gnus-gethash | 2027 (gnus-gethash |
| 2028 (setq word (downcase (buffer-substring | 2028 (setq word (downcase (buffer-substring |
| 2029 (match-beginning 0) (match-end 0)))) | 2029 (match-beginning 0) (match-end 0)))) |
| 2030 hashtb)) | 2030 hashtb)) |
| 2031 (gnus-sethash | 2031 (gnus-sethash |
| 2032 word | 2032 word |
| 2045 (string-lessp (aref (car a1) gnus-score-index) | 2045 (string-lessp (aref (car a1) gnus-score-index) |
| 2046 (aref (car a2) gnus-score-index))) | 2046 (aref (car a2) gnus-score-index))) |
| 2047 | 2047 |
| 2048 (defun gnus-current-score-file-nondirectory (&optional score-file) | 2048 (defun gnus-current-score-file-nondirectory (&optional score-file) |
| 2049 (let ((score-file (or score-file gnus-current-score-file))) | 2049 (let ((score-file (or score-file gnus-current-score-file))) |
| 2050 (if score-file | 2050 (if score-file |
| 2051 (gnus-short-group-name (file-name-nondirectory score-file)) | 2051 (gnus-short-group-name (file-name-nondirectory score-file)) |
| 2052 "none"))) | 2052 "none"))) |
| 2053 | 2053 |
| 2054 (defun gnus-score-adaptive () | 2054 (defun gnus-score-adaptive () |
| 2055 "Create adaptive score rules for this newsgroup." | 2055 "Create adaptive score rules for this newsgroup." |
| 2056 (when gnus-newsgroup-adaptive | 2056 (when gnus-newsgroup-adaptive |
| 2057 ;; We change the score file to the adaptive score file. | 2057 ;; We change the score file to the adaptive score file. |
| 2058 (save-excursion | 2058 (save-excursion |
| 2059 (set-buffer gnus-summary-buffer) | 2059 (set-buffer gnus-summary-buffer) |
| 2060 (gnus-score-load-file | 2060 (gnus-score-load-file |
| 2061 (or gnus-newsgroup-adaptive-score-file | 2061 (or gnus-newsgroup-adaptive-score-file |
| 2062 (gnus-score-file-name | 2062 (gnus-score-file-name |
| 2063 gnus-newsgroup-name gnus-adaptive-file-suffix)))) | 2063 gnus-newsgroup-name gnus-adaptive-file-suffix)))) |
| 2064 ;; Perform ordinary line scoring. | 2064 ;; Perform ordinary line scoring. |
| 2065 (when (or (not (listp gnus-newsgroup-adaptive)) | 2065 (when (or (not (listp gnus-newsgroup-adaptive)) |
| 2066 (memq 'line gnus-newsgroup-adaptive)) | 2066 (memq 'line gnus-newsgroup-adaptive)) |
| 2067 (save-excursion | 2067 (save-excursion |
| 2083 "references" | 2083 "references" |
| 2084 (symbol-name (caar elem))) | 2084 (symbol-name (caar elem))) |
| 2085 (cdar elem))) | 2085 (cdar elem))) |
| 2086 (setcar (car elem) | 2086 (setcar (car elem) |
| 2087 `(lambda (h) | 2087 `(lambda (h) |
| 2088 (,(intern | 2088 (,(intern |
| 2089 (concat "mail-header-" | 2089 (concat "mail-header-" |
| 2090 (if (eq (caar elem) 'followup) | 2090 (if (eq (caar elem) 'followup) |
| 2091 "message-id" | 2091 "message-id" |
| 2092 (downcase (symbol-name (caar elem)))))) | 2092 (downcase (symbol-name (caar elem)))))) |
| 2093 h))) | 2093 h))) |
| 2094 (setq elem (cdr elem))) | 2094 (setq elem (cdr elem))) |
| 2098 (setq elem (cdr (assq (gnus-data-mark (car data)) alist))) | 2098 (setq elem (cdr (assq (gnus-data-mark (car data)) alist))) |
| 2099 (if (or (not elem) | 2099 (if (or (not elem) |
| 2100 (gnus-data-pseudo-p (car data))) | 2100 (gnus-data-pseudo-p (car data))) |
| 2101 () | 2101 () |
| 2102 (when (setq headers (gnus-data-header (car data))) | 2102 (when (setq headers (gnus-data-header (car data))) |
| 2103 (while elem | 2103 (while elem |
| 2104 (setq match (funcall (caar elem) headers)) | 2104 (setq match (funcall (caar elem) headers)) |
| 2105 (gnus-summary-score-entry | 2105 (gnus-summary-score-entry |
| 2106 (nth 1 (car elem)) match | 2106 (nth 1 (car elem)) match |
| 2107 (cond | 2107 (cond |
| 2108 ((numberp match) | 2108 ((numberp match) |
| 2109 '=) | 2109 '=) |
| 2110 ((equal (nth 1 (car elem)) "date") | 2110 ((equal (nth 1 (car elem)) "date") |
| 2111 'a) | 2111 'a) |
| 2112 (t | 2112 (t |
| 2113 ;; Whether we use substring or exact matches is | 2113 ;; Whether we use substring or exact matches is |
| 2114 ;; controlled here. | 2114 ;; controlled here. |
| 2115 (if (or (not gnus-score-exact-adapt-limit) | 2115 (if (or (not gnus-score-exact-adapt-limit) |
| 2116 (< (length match) gnus-score-exact-adapt-limit)) | 2116 (< (length match) gnus-score-exact-adapt-limit)) |
| 2117 'e | 2117 'e |
| 2118 (if (equal (nth 1 (car elem)) "subject") | 2118 (if (equal (nth 1 (car elem)) "subject") |
| 2119 'f 's)))) | 2119 'f 's)))) |
| 2120 (nth 2 (car elem)) date nil t) | 2120 (nth 2 (car elem)) date nil t) |
| 2121 (setq elem (cdr elem))))) | 2121 (setq elem (cdr elem))))) |
| 2122 (setq data (cdr data)))))) | 2122 (setq data (cdr data)))))) |
| 2136 ;; Go through all articles. | 2136 ;; Go through all articles. |
| 2137 (while (setq d (pop data)) | 2137 (while (setq d (pop data)) |
| 2138 (when (and | 2138 (when (and |
| 2139 (not (gnus-data-pseudo-p d)) | 2139 (not (gnus-data-pseudo-p d)) |
| 2140 (setq score | 2140 (setq score |
| 2141 (cdr (assq | 2141 (cdr (assq |
| 2142 (gnus-data-mark d) | 2142 (gnus-data-mark d) |
| 2143 gnus-adaptive-word-score-alist)))) | 2143 gnus-adaptive-word-score-alist)))) |
| 2144 ;; This article has a mark that should lead to | 2144 ;; This article has a mark that should lead to |
| 2145 ;; adaptive word rules, so we insert the subject | 2145 ;; adaptive word rules, so we insert the subject |
| 2146 ;; and find all words in that string. | 2146 ;; and find all words in that string. |
| 2244 (gnus-score-save) | 2244 (gnus-score-save) |
| 2245 (setq gnus-score-cache nil) | 2245 (setq gnus-score-cache nil) |
| 2246 (setq gnus-newsgroup-scored nil) | 2246 (setq gnus-newsgroup-scored nil) |
| 2247 (gnus-possibly-score-headers) | 2247 (gnus-possibly-score-headers) |
| 2248 (gnus-score-update-all-lines)) | 2248 (gnus-score-update-all-lines)) |
| 2249 | 2249 |
| 2250 (defun gnus-score-flush-cache () | 2250 (defun gnus-score-flush-cache () |
| 2251 "Flush the cache of score files." | 2251 "Flush the cache of score files." |
| 2252 (interactive) | 2252 (interactive) |
| 2253 (gnus-score-save) | 2253 (gnus-score-save) |
| 2254 (setq gnus-score-cache nil | 2254 (setq gnus-score-cache nil |
| 2323 (defun gnus-summary-lower-thread (&optional score) | 2323 (defun gnus-summary-lower-thread (&optional score) |
| 2324 "Lower score of articles in the current thread with SCORE." | 2324 "Lower score of articles in the current thread with SCORE." |
| 2325 (interactive "P") | 2325 (interactive "P") |
| 2326 (gnus-summary-raise-thread (- (1- (gnus-score-default score))))) | 2326 (gnus-summary-raise-thread (- (1- (gnus-score-default score))))) |
| 2327 | 2327 |
| 2328 ;;; Finding score files. | 2328 ;;; Finding score files. |
| 2329 | 2329 |
| 2330 (defun gnus-score-score-files (group) | 2330 (defun gnus-score-score-files (group) |
| 2331 "Return a list of all possible score files." | 2331 "Return a list of all possible score files." |
| 2332 ;; Search and set any global score files. | 2332 ;; Search and set any global score files. |
| 2333 (when gnus-global-score-files | 2333 (when gnus-global-score-files |
| 2334 (unless gnus-internal-global-score-files | 2334 (unless gnus-internal-global-score-files |
| 2335 (gnus-score-search-global-directories gnus-global-score-files))) | 2335 (gnus-score-search-global-directories gnus-global-score-files))) |
| 2336 ;; Fix the kill-file dir variable. | 2336 ;; Fix the kill-file dir variable. |
| 2337 (setq gnus-kill-files-directory | 2337 (setq gnus-kill-files-directory |
| 2338 (file-name-as-directory gnus-kill-files-directory)) | 2338 (file-name-as-directory gnus-kill-files-directory)) |
| 2339 ;; If we can't read it, there are no score files. | 2339 ;; If we can't read it, there are no score files. |
| 2340 (if (not (file-exists-p (expand-file-name gnus-kill-files-directory))) | 2340 (if (not (file-exists-p (expand-file-name gnus-kill-files-directory))) |
| 2341 (setq gnus-score-file-list nil) | 2341 (setq gnus-score-file-list nil) |
| 2342 (if (not (gnus-use-long-file-name 'not-score)) | 2342 (if (not (gnus-use-long-file-name 'not-score)) |
| 2343 ;; We do not use long file names, so we have to do some | 2343 ;; We do not use long file names, so we have to do some |
| 2344 ;; directory traversing. | 2344 ;; directory traversing. |
| 2345 (setq gnus-score-file-list | 2345 (setq gnus-score-file-list |
| 2346 (cons nil | 2346 (cons nil |
| 2347 (or gnus-short-name-score-file-cache | 2347 (or gnus-short-name-score-file-cache |
| 2348 (prog2 | 2348 (prog2 |
| 2349 (gnus-message 6 "Finding all score files...") | 2349 (gnus-message 6 "Finding all score files...") |
| 2350 (setq gnus-short-name-score-file-cache | 2350 (setq gnus-short-name-score-file-cache |
| 2351 (gnus-score-score-files-1 | 2351 (gnus-score-score-files-1 |
| 2354 ;; We want long file names. | 2354 ;; We want long file names. |
| 2355 (when (or (not gnus-score-file-list) | 2355 (when (or (not gnus-score-file-list) |
| 2356 (not (car gnus-score-file-list)) | 2356 (not (car gnus-score-file-list)) |
| 2357 (gnus-file-newer-than gnus-kill-files-directory | 2357 (gnus-file-newer-than gnus-kill-files-directory |
| 2358 (car gnus-score-file-list))) | 2358 (car gnus-score-file-list))) |
| 2359 (setq gnus-score-file-list | 2359 (setq gnus-score-file-list |
| 2360 (cons (nth 5 (file-attributes gnus-kill-files-directory)) | 2360 (cons (nth 5 (file-attributes gnus-kill-files-directory)) |
| 2361 (nreverse | 2361 (nreverse |
| 2362 (directory-files | 2362 (directory-files |
| 2363 gnus-kill-files-directory t | 2363 gnus-kill-files-directory t |
| 2364 (gnus-score-file-regexp))))))) | 2364 (gnus-score-file-regexp))))))) |
| 2365 (cdr gnus-score-file-list))) | 2365 (cdr gnus-score-file-list))) |
| 2366 | 2366 |
| 2367 (defun gnus-score-score-files-1 (dir) | 2367 (defun gnus-score-score-files-1 (dir) |
| 2368 "Return all possible score files under DIR." | 2368 "Return all possible score files under DIR." |
| 2369 (let ((files (list (expand-file-name dir))) | 2369 (let ((files (list (expand-file-name dir))) |
| 2370 (regexp (gnus-score-file-regexp)) | 2370 (regexp (gnus-score-file-regexp)) |
| 2371 (case-fold-search nil) | 2371 (case-fold-search nil) |
| 2372 seen out file) | 2372 seen out file) |
| 2373 (while (setq file (pop files)) | 2373 (while (setq file (pop files)) |
| 2374 (cond | 2374 (cond |
| 2375 ;; Ignore "." and "..". | 2375 ;; Ignore "." and "..". |
| 2376 ((member (file-name-nondirectory file) '("." "..")) | 2376 ((member (file-name-nondirectory file) '("." "..")) |
| 2377 nil) | 2377 nil) |
| 2378 ;; Add subtrees of directory to also be searched. | 2378 ;; Add subtrees of directory to also be searched. |
| 2379 ((and (file-directory-p file) | 2379 ((and (file-directory-p file) |
| 2384 ((string-match regexp file) | 2384 ((string-match regexp file) |
| 2385 (push file out)))) | 2385 (push file out)))) |
| 2386 (or out | 2386 (or out |
| 2387 ;; Return a dummy value. | 2387 ;; Return a dummy value. |
| 2388 (list "~/News/this.file.does.not.exist.SCORE")))) | 2388 (list "~/News/this.file.does.not.exist.SCORE")))) |
| 2389 | 2389 |
| 2390 (defun gnus-score-file-regexp () | 2390 (defun gnus-score-file-regexp () |
| 2391 "Return a regexp that match all score files." | 2391 "Return a regexp that match all score files." |
| 2392 (concat "\\(" (regexp-quote gnus-score-file-suffix ) | 2392 (concat "\\(" (regexp-quote gnus-score-file-suffix ) |
| 2393 "\\|" (regexp-quote gnus-adaptive-file-suffix) "\\)\\'")) | 2393 "\\|" (regexp-quote gnus-adaptive-file-suffix) "\\)\\'")) |
| 2394 | 2394 |
| 2395 (defun gnus-score-find-bnews (group) | 2395 (defun gnus-score-find-bnews (group) |
| 2396 "Return a list of score files for GROUP. | 2396 "Return a list of score files for GROUP. |
| 2397 The score files are those files in the ~/News/ directory which matches | 2397 The score files are those files in the ~/News/ directory which matches |
| 2398 GROUP using BNews sys file syntax." | 2398 GROUP using BNews sys file syntax." |
| 2399 (let* ((sfiles (append (gnus-score-score-files group) | 2399 (let* ((sfiles (append (gnus-score-score-files group) |
| 2400 gnus-internal-global-score-files)) | 2400 gnus-internal-global-score-files)) |
| 2401 (kill-dir (file-name-as-directory | 2401 (kill-dir (file-name-as-directory |
| 2402 (expand-file-name gnus-kill-files-directory))) | 2402 (expand-file-name gnus-kill-files-directory))) |
| 2403 (klen (length kill-dir)) | 2403 (klen (length kill-dir)) |
| 2404 (score-regexp (gnus-score-file-regexp)) | 2404 (score-regexp (gnus-score-file-regexp)) |
| 2405 (trans (cdr (assq ?: nnheader-file-name-translation-alist))) | 2405 (trans (cdr (assq ?: nnheader-file-name-translation-alist))) |
| 2406 ofiles not-match regexp) | 2406 ofiles not-match regexp) |
| 2407 (save-excursion | 2407 (save-excursion |
| 2408 (set-buffer (get-buffer-create "*gnus score files*")) | 2408 (set-buffer (get-buffer-create "*gnus score files*")) |
| 2409 (buffer-disable-undo (current-buffer)) | 2409 (buffer-disable-undo (current-buffer)) |
| 2410 ;; Go through all score file names and create regexp with them | 2410 ;; Go through all score file names and create regexp with them |
| 2411 ;; as the source. | 2411 ;; as the source. |
| 2412 (while sfiles | 2412 (while sfiles |
| 2413 (erase-buffer) | 2413 (erase-buffer) |
| 2414 (insert (car sfiles)) | 2414 (insert (car sfiles)) |
| 2415 (goto-char (point-min)) | 2415 (goto-char (point-min)) |
| 2416 ;; First remove the suffix itself. | 2416 ;; First remove the suffix itself. |
| 2493 (gnus-score-file-name group gnus-adaptive-file-suffix)) | 2493 (gnus-score-file-name group gnus-adaptive-file-suffix)) |
| 2494 (setq all (nreverse all))) | 2494 (setq all (nreverse all))) |
| 2495 (mapcar 'gnus-score-file-name all))) | 2495 (mapcar 'gnus-score-file-name all))) |
| 2496 (if (equal prefix "") | 2496 (if (equal prefix "") |
| 2497 all | 2497 all |
| 2498 (mapcar | 2498 (mapcar |
| 2499 (lambda (file) | 2499 (lambda (file) |
| 2500 (concat (file-name-directory file) prefix | 2500 (concat (file-name-directory file) prefix |
| 2501 (file-name-nondirectory file))) | 2501 (file-name-nondirectory file))) |
| 2502 all)))) | 2502 all)))) |
| 2503 | 2503 |
| 2520 (push (buffer-substring beg (1- (point))) | 2520 (push (buffer-substring beg (1- (point))) |
| 2521 elems)) | 2521 elems)) |
| 2522 (erase-buffer) | 2522 (erase-buffer) |
| 2523 (setq elems (delete "all" elems)) | 2523 (setq elems (delete "all" elems)) |
| 2524 (length elems)))) | 2524 (length elems)))) |
| 2525 | 2525 |
| 2526 (defun gnus-sort-score-files (files) | 2526 (defun gnus-sort-score-files (files) |
| 2527 "Sort FILES so that the most general files come first." | 2527 "Sort FILES so that the most general files come first." |
| 2528 (nnheader-temp-write nil | 2528 (nnheader-temp-write nil |
| 2529 (let ((alist | 2529 (let ((alist |
| 2530 (mapcar | 2530 (mapcar |
| 2554 (while alist | 2554 (while alist |
| 2555 (when (string-match (caar alist) group) | 2555 (when (string-match (caar alist) group) |
| 2556 ;; progn used just in case ("regexp") has no files | 2556 ;; progn used just in case ("regexp") has no files |
| 2557 ;; and score-files is still nil. -sj | 2557 ;; and score-files is still nil. -sj |
| 2558 ;; this can be construed as a "stop searching here" feature :> | 2558 ;; this can be construed as a "stop searching here" feature :> |
| 2559 ;; and used to simplify regexps in the single-alist | 2559 ;; and used to simplify regexps in the single-alist |
| 2560 (setq score-files | 2560 (setq score-files |
| 2561 (nconc score-files (copy-sequence (cdar alist)))) | 2561 (nconc score-files (copy-sequence (cdar alist)))) |
| 2562 (setq alist nil)) | 2562 (setq alist nil)) |
| 2563 (setq alist (cdr alist))) | 2563 (setq alist (cdr alist))) |
| 2564 ;; cache the score files | 2564 ;; cache the score files |
| 2573 ;; Make sure funcs is a list. | 2573 ;; Make sure funcs is a list. |
| 2574 (and funcs | 2574 (and funcs |
| 2575 (not (listp funcs)) | 2575 (not (listp funcs)) |
| 2576 (setq funcs (list funcs))) | 2576 (setq funcs (list funcs))) |
| 2577 ;; Get the initial score files for this group. | 2577 ;; Get the initial score files for this group. |
| 2578 (when funcs | 2578 (when funcs |
| 2579 (setq score-files (nreverse (gnus-score-find-alist group)))) | 2579 (setq score-files (nreverse (gnus-score-find-alist group)))) |
| 2580 ;; Add any home adapt files. | 2580 ;; Add any home adapt files. |
| 2581 (let ((home (gnus-home-score-file group t))) | 2581 (let ((home (gnus-home-score-file group t))) |
| 2582 (when home | 2582 (when home |
| 2583 (push home score-files) | 2583 (push home score-files) |
| 2589 (setq gnus-newsgroup-adaptive-score-file param-file))) | 2589 (setq gnus-newsgroup-adaptive-score-file param-file))) |
| 2590 ;; Go through all the functions for finding score files (or actual | 2590 ;; Go through all the functions for finding score files (or actual |
| 2591 ;; scores) and add them to a list. | 2591 ;; scores) and add them to a list. |
| 2592 (while funcs | 2592 (while funcs |
| 2593 (when (gnus-functionp (car funcs)) | 2593 (when (gnus-functionp (car funcs)) |
| 2594 (setq score-files | 2594 (setq score-files |
| 2595 (nconc score-files (nreverse (funcall (car funcs) group))))) | 2595 (nconc score-files (nreverse (funcall (car funcs) group))))) |
| 2596 (setq funcs (cdr funcs))) | 2596 (setq funcs (cdr funcs))) |
| 2597 ;; Add any home score files. | 2597 ;; Add any home score files. |
| 2598 (let ((home (gnus-home-score-file group))) | 2598 (let ((home (gnus-home-score-file group))) |
| 2599 (when home | 2599 (when home |
| 2619 (when (member (cadr files) (cddr files)) | 2619 (when (member (cadr files) (cddr files)) |
| 2620 (setcdr files (cddr files))) | 2620 (setcdr files (cddr files))) |
| 2621 (pop files))) | 2621 (pop files))) |
| 2622 ;; Do the scoring if there are any score files for this group. | 2622 ;; Do the scoring if there are any score files for this group. |
| 2623 score-files)) | 2623 score-files)) |
| 2624 | 2624 |
| 2625 (defun gnus-possibly-score-headers (&optional trace) | 2625 (defun gnus-possibly-score-headers (&optional trace) |
| 2626 "Do scoring if scoring is required." | 2626 "Do scoring if scoring is required." |
| 2627 (let ((score-files (gnus-all-score-files))) | 2627 (let ((score-files (gnus-all-score-files))) |
| 2628 (when score-files | 2628 (when score-files |
| 2629 (gnus-score-headers score-files trace)))) | 2629 (gnus-score-headers score-files trace)))) |
| 2634 (nnheader-translate-file-chars | 2634 (nnheader-translate-file-chars |
| 2635 (cond | 2635 (cond |
| 2636 ((or (null newsgroup) | 2636 ((or (null newsgroup) |
| 2637 (string-equal newsgroup "")) | 2637 (string-equal newsgroup "")) |
| 2638 ;; The global score file is placed at top of the directory. | 2638 ;; The global score file is placed at top of the directory. |
| 2639 (expand-file-name | 2639 (expand-file-name |
| 2640 suffix gnus-kill-files-directory)) | 2640 suffix gnus-kill-files-directory)) |
| 2641 ((gnus-use-long-file-name 'not-score) | 2641 ((gnus-use-long-file-name 'not-score) |
| 2642 ;; Append ".SCORE" to newsgroup name. | 2642 ;; Append ".SCORE" to newsgroup name. |
| 2643 (expand-file-name (concat (gnus-newsgroup-savable-name newsgroup) | 2643 (expand-file-name (concat (gnus-newsgroup-savable-name newsgroup) |
| 2644 "." suffix) | 2644 "." suffix) |
| 2655 ;; available global score files. | 2655 ;; available global score files. |
| 2656 (interactive (list gnus-global-score-files)) | 2656 (interactive (list gnus-global-score-files)) |
| 2657 (let (out) | 2657 (let (out) |
| 2658 (while files | 2658 (while files |
| 2659 (if (string-match "/$" (car files)) | 2659 (if (string-match "/$" (car files)) |
| 2660 (setq out (nconc (directory-files | 2660 (setq out (nconc (directory-files |
| 2661 (car files) t | 2661 (car files) t |
| 2662 (concat (gnus-score-file-regexp) "$")))) | 2662 (concat (gnus-score-file-regexp) "$")))) |
| 2663 (push (car files) out)) | 2663 (push (car files) out)) |
| 2664 (setq files (cdr files))) | 2664 (setq files (cdr files))) |
| 2665 (setq gnus-internal-global-score-files out))) | 2665 (setq gnus-internal-global-score-files out))) |
| 2705 (if (string-match "^[^.]+\\." group) | 2705 (if (string-match "^[^.]+\\." group) |
| 2706 (concat (match-string 0 group) gnus-score-file-suffix) | 2706 (concat (match-string 0 group) gnus-score-file-suffix) |
| 2707 ;; Group name without any dots. | 2707 ;; Group name without any dots. |
| 2708 (concat group (if (gnus-use-long-file-name 'not-score) "." "/") | 2708 (concat group (if (gnus-use-long-file-name 'not-score) "." "/") |
| 2709 gnus-score-file-suffix))) | 2709 gnus-score-file-suffix))) |
| 2710 | 2710 |
| 2711 (defun gnus-hierarchial-home-adapt-file (group) | 2711 (defun gnus-hierarchial-home-adapt-file (group) |
| 2712 "Return the adapt file of the top-level hierarchy of GROUP." | 2712 "Return the adapt file of the top-level hierarchy of GROUP." |
| 2713 (if (string-match "^[^.]+\\." group) | 2713 (if (string-match "^[^.]+\\." group) |
| 2714 (concat (match-string 0 group) gnus-adaptive-file-suffix) | 2714 (concat (match-string 0 group) gnus-adaptive-file-suffix) |
| 2715 ;; Group name without any dots. | 2715 ;; Group name without any dots. |