comparison lisp/gnus/spam.el @ 111968:1156a55fd2a9

spam.el: Reindent and fix long lines. (spam-copy-or-move-routine): Exclude invalid move destinations.
author Katsumi Yamaoka <yamaoka@jpl.org>
date Tue, 14 Dec 2010 23:08:31 +0000
parents e36c65ac23bf
children 417b1e4d63cd
comparison
equal deleted inserted replaced
111967:4de98954e350 111968:1156a55fd2a9
43 (eval-and-compile 43 (eval-and-compile
44 (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) 44 (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
45 45
46 (eval-when-compile (require 'cl)) 46 (eval-when-compile (require 'cl))
47 47
48 (require 'message) ;for the message-fetch-field functions 48 (require 'message) ;for the message-fetch-field functions
49 (require 'gnus-sum) 49 (require 'gnus-sum)
50 (require 'gnus-uu) ; because of key prefix issues 50 (require 'gnus-uu) ; because of key prefix issues
51 ;;; for the definitions of group content classification and spam processors 51 ;;; for the definitions of group content classification and spam processors
52 (require 'gnus) 52 (require 'gnus)
53 53
54 (eval-when-compile (require 'spam-report)) 54 (eval-when-compile (require 'spam-report))
55 (eval-when-compile (require 'hashcash)) 55 (eval-when-compile (require 'hashcash))
91 91
92 (defcustom spam-summary-exit-behavior 'default 92 (defcustom spam-summary-exit-behavior 'default
93 "Exit behavior at the time of summary exit. 93 "Exit behavior at the time of summary exit.
94 Note that setting the `spam-use-move' or `spam-use-copy' backends on 94 Note that setting the `spam-use-move' or `spam-use-copy' backends on
95 a group through group/topic parameters overrides this mechanism." 95 a group through group/topic parameters overrides this mechanism."
96 :type '(choice (const 'default :tag 96 :type '(choice
97 "Move spam out of all groups. Move ham out of spam groups.") 97 (const
98 (const 'move-all :tag 98 'default
99 "Move spam out of all groups. Move ham out of all groups.") 99 :tag "Move spam out of all groups and ham out of spam groups.")
100 (const 'move-none :tag 100 (const
101 "Never move spam or ham out of any groups.")) 101 'move-all
102 :tag "Move spam out of all groups and ham out of all groups.")
103 (const
104 'move-none
105 :tag "Never move spam or ham out of any groups."))
102 :group 'spam) 106 :group 'spam)
103 107
104 (defcustom spam-directory (nnheader-concat gnus-directory "spam/") 108 (defcustom spam-directory (nnheader-concat gnus-directory "spam/")
105 "Directory for spam whitelists and blacklists." 109 "Directory for spam whitelists and blacklists."
106 :type 'directory 110 :type 'directory
294 "Whether the CRM114 Mailfilter should be used by `spam-split'." 298 "Whether the CRM114 Mailfilter should be used by `spam-split'."
295 :type 'boolean 299 :type 'boolean
296 :group 'spam) 300 :group 'spam)
297 301
298 (defcustom spam-install-hooks (or 302 (defcustom spam-install-hooks (or
299 spam-use-dig 303 spam-use-dig
300 spam-use-gmane-xref 304 spam-use-gmane-xref
301 spam-use-blacklist 305 spam-use-blacklist
302 spam-use-whitelist 306 spam-use-whitelist
303 spam-use-whitelist-exclusive 307 spam-use-whitelist-exclusive
304 spam-use-blackholes 308 spam-use-blackholes
305 spam-use-hashcash 309 spam-use-hashcash
306 spam-use-regex-headers 310 spam-use-regex-headers
307 spam-use-regex-body 311 spam-use-regex-body
308 spam-use-bogofilter 312 spam-use-bogofilter
309 spam-use-bogofilter-headers 313 spam-use-bogofilter-headers
310 spam-use-spamassassin 314 spam-use-spamassassin
311 spam-use-spamassassin-headers 315 spam-use-spamassassin-headers
312 spam-use-bsfilter 316 spam-use-bsfilter
313 spam-use-bsfilter-headers 317 spam-use-bsfilter-headers
314 spam-use-BBDB 318 spam-use-BBDB
315 spam-use-BBDB-exclusive 319 spam-use-BBDB-exclusive
316 spam-use-ifile 320 spam-use-ifile
317 spam-use-stat 321 spam-use-stat
318 spam-use-spamoracle 322 spam-use-spamoracle
319 spam-use-crm114) 323 spam-use-crm114)
320 "Whether the spam hooks should be installed. 324 "Whether the spam hooks should be installed.
321 Default to t if one of the spam-use-* variables is set." 325 Default to t if one of the spam-use-* variables is set."
322 :group 'spam 326 :group 'spam
323 :type 'boolean) 327 :type 'boolean)
324 328
328 :group 'spam) 332 :group 'spam)
329 333
330 ;;; TODO: deprecate this variable, it's confusing since it's a list of strings, 334 ;;; TODO: deprecate this variable, it's confusing since it's a list of strings,
331 ;;; not regular expressions 335 ;;; not regular expressions
332 (defcustom spam-junk-mailgroups (cons 336 (defcustom spam-junk-mailgroups (cons
333 spam-split-group 337 spam-split-group
334 '("mail.junk" "poste.pourriel")) 338 '("mail.junk" "poste.pourriel"))
335 "Mailgroups with spam contents. 339 "Mailgroups with spam contents.
336 All unmarked article in such group receive the spam mark on group entry." 340 All unmarked article in such group receive the spam mark on group entry."
337 :type '(repeat (string :tag "Group")) 341 :type '(repeat (string :tag "Group"))
338 :group 'spam) 342 :group 'spam)
339 343
343 Only meaningful if you enable `spam-use-gmane-xref'." 347 Only meaningful if you enable `spam-use-gmane-xref'."
344 :type 'string 348 :type 'string
345 :group 'spam) 349 :group 'spam)
346 350
347 (defcustom spam-blackhole-servers '("bl.spamcop.net" "relays.ordb.org" 351 (defcustom spam-blackhole-servers '("bl.spamcop.net" "relays.ordb.org"
348 "dev.null.dk" "relays.visi.com") 352 "dev.null.dk" "relays.visi.com")
349 "List of blackhole servers. 353 "List of blackhole servers.
350 Only meaningful if you enable `spam-use-blackholes'." 354 Only meaningful if you enable `spam-use-blackholes'."
351 :type '(repeat (string :tag "Server")) 355 :type '(repeat (string :tag "Server"))
352 :group 'spam) 356 :group 'spam)
353 357
403 :group 'spam) 407 :group 'spam)
404 408
405 (defcustom spam-summary-score-preferred-header nil 409 (defcustom spam-summary-score-preferred-header nil
406 "Preferred header to use for `spam-summary-score'." 410 "Preferred header to use for `spam-summary-score'."
407 :type '(choice :tag "Header name" 411 :type '(choice :tag "Header name"
408 (symbol :tag "SpamAssassin etc" X-Spam-Status) 412 (symbol :tag "SpamAssassin etc" X-Spam-Status)
409 (symbol :tag "Bogofilter" X-Bogosity) 413 (symbol :tag "Bogofilter" X-Bogosity)
410 (const :tag "No preference, take best guess." nil)) 414 (const :tag "No preference, take best guess." nil))
411 :group 'spam) 415 :group 'spam)
412 416
413 (defgroup spam-ifile nil 417 (defgroup spam-ifile nil
414 "Spam ifile configuration." 418 "Spam ifile configuration."
415 :group 'spam) 419 :group 'spam)
417 (make-obsolete-variable 'spam-ifile-path 'spam-ifile-program 421 (make-obsolete-variable 'spam-ifile-path 'spam-ifile-program
418 "Gnus 5.10.9 (Emacs 22.1)") 422 "Gnus 5.10.9 (Emacs 22.1)")
419 (defcustom spam-ifile-program (executable-find "ifile") 423 (defcustom spam-ifile-program (executable-find "ifile")
420 "Name of the ifile program." 424 "Name of the ifile program."
421 :type '(choice (file :tag "Location of ifile") 425 :type '(choice (file :tag "Location of ifile")
422 (const :tag "ifile is not installed")) 426 (const :tag "ifile is not installed"))
423 :group 'spam-ifile) 427 :group 'spam-ifile)
424 428
425 (make-obsolete-variable 'spam-ifile-database-path 'spam-ifile-database 429 (make-obsolete-variable 'spam-ifile-database-path 'spam-ifile-database
426 "Gnus 5.10.9 (Emacs 22.1)") 430 "Gnus 5.10.9 (Emacs 22.1)")
427 (defcustom spam-ifile-database nil 431 (defcustom spam-ifile-database nil
428 "File name of the ifile database." 432 "File name of the ifile database."
429 :type '(choice (file :tag "Location of the ifile database") 433 :type '(choice (file :tag "Location of the ifile database")
430 (const :tag "Use the default")) 434 (const :tag "Use the default"))
431 :group 'spam-ifile) 435 :group 'spam-ifile)
432 436
433 (defcustom spam-ifile-spam-category "spam" 437 (defcustom spam-ifile-spam-category "spam"
434 "Name of the spam ifile category." 438 "Name of the spam ifile category."
435 :type 'string 439 :type 'string
437 441
438 (defcustom spam-ifile-ham-category nil 442 (defcustom spam-ifile-ham-category nil
439 "Name of the ham ifile category. 443 "Name of the ham ifile category.
440 If nil, the current group name will be used." 444 If nil, the current group name will be used."
441 :type '(choice (string :tag "Use a fixed category") 445 :type '(choice (string :tag "Use a fixed category")
442 (const :tag "Use the current group name")) 446 (const :tag "Use the current group name"))
443 :group 'spam-ifile) 447 :group 'spam-ifile)
444 448
445 (defcustom spam-ifile-all-categories nil 449 (defcustom spam-ifile-all-categories nil
446 "Whether the ifile check will return all categories, or just spam. 450 "Whether the ifile check will return all categories, or just spam.
447 Set this to t if you want to use the `spam-split' invocation of ifile as 451 Set this to t if you want to use the `spam-split' invocation of ifile as
456 (make-obsolete-variable 'spam-bogofilter-path 'spam-bogofilter-program 460 (make-obsolete-variable 'spam-bogofilter-path 'spam-bogofilter-program
457 "Gnus 5.10.9 (Emacs 22.1)") 461 "Gnus 5.10.9 (Emacs 22.1)")
458 (defcustom spam-bogofilter-program (executable-find "bogofilter") 462 (defcustom spam-bogofilter-program (executable-find "bogofilter")
459 "Name of the Bogofilter program." 463 "Name of the Bogofilter program."
460 :type '(choice (file :tag "Location of bogofilter") 464 :type '(choice (file :tag "Location of bogofilter")
461 (const :tag "Bogofilter is not installed")) 465 (const :tag "Bogofilter is not installed"))
462 :group 'spam-bogofilter) 466 :group 'spam-bogofilter)
463 467
464 (defvar spam-bogofilter-valid 'unknown "Is the bogofilter version valid?") 468 (defvar spam-bogofilter-valid 'unknown "Is the bogofilter version valid?")
465 469
466 (defcustom spam-bogofilter-header "X-Bogosity" 470 (defcustom spam-bogofilter-header "X-Bogosity"
495 499
496 (defcustom spam-bogofilter-database-directory nil 500 (defcustom spam-bogofilter-database-directory nil
497 "Location of the Bogofilter database. 501 "Location of the Bogofilter database.
498 When nil, use the default location." 502 When nil, use the default location."
499 :type '(choice (directory 503 :type '(choice (directory
500 :tag "Location of the Bogofilter database directory") 504 :tag "Location of the Bogofilter database directory")
501 (const :tag "Use the default")) 505 (const :tag "Use the default"))
502 :group 'spam-bogofilter) 506 :group 'spam-bogofilter)
503 507
504 (defgroup spam-bsfilter nil 508 (defgroup spam-bsfilter nil
505 "Spam bsfilter configuration." 509 "Spam bsfilter configuration."
506 :group 'spam) 510 :group 'spam)
508 (make-obsolete-variable 'spam-bsfilter-path 'spam-bsfilter-program 512 (make-obsolete-variable 'spam-bsfilter-path 'spam-bsfilter-program
509 "Gnus 5.10.9 (Emacs 22.1)") 513 "Gnus 5.10.9 (Emacs 22.1)")
510 (defcustom spam-bsfilter-program (executable-find "bsfilter") 514 (defcustom spam-bsfilter-program (executable-find "bsfilter")
511 "Name of the Bsfilter program." 515 "Name of the Bsfilter program."
512 :type '(choice (file :tag "Location of bsfilter") 516 :type '(choice (file :tag "Location of bsfilter")
513 (const :tag "Bsfilter is not installed")) 517 (const :tag "Bsfilter is not installed"))
514 :group 'spam-bsfilter) 518 :group 'spam-bsfilter)
515 519
516 (defcustom spam-bsfilter-header "X-Spam-Flag" 520 (defcustom spam-bsfilter-header "X-Spam-Flag"
517 "The header inserted by Bsfilter to flag spam." 521 "The header inserted by Bsfilter to flag spam."
518 :type 'string 522 :type 'string
544 :group 'spam-bsfilter) 548 :group 'spam-bsfilter)
545 549
546 (defcustom spam-bsfilter-database-directory nil 550 (defcustom spam-bsfilter-database-directory nil
547 "Directory path of the Bsfilter databases." 551 "Directory path of the Bsfilter databases."
548 :type '(choice (directory 552 :type '(choice (directory
549 :tag "Location of the Bsfilter database directory") 553 :tag "Location of the Bsfilter database directory")
550 (const :tag "Use the default")) 554 (const :tag "Use the default"))
551 :group 'spam-bsfilter) 555 :group 'spam-bsfilter)
552 556
553 (defgroup spam-spamoracle nil 557 (defgroup spam-spamoracle nil
554 "Spam spamoracle configuration." 558 "Spam spamoracle configuration."
555 :group 'spam) 559 :group 'spam)
556 560
557 (defcustom spam-spamoracle-database nil 561 (defcustom spam-spamoracle-database nil
558 "Location of spamoracle database file. 562 "Location of spamoracle database file.
559 When nil, use the default spamoracle database." 563 When nil, use the default spamoracle database."
560 :type '(choice (directory :tag "Location of spamoracle database file.") 564 :type '(choice (directory :tag "Location of spamoracle database file.")
561 (const :tag "Use the default")) 565 (const :tag "Use the default"))
562 :group 'spam-spamoracle) 566 :group 'spam-spamoracle)
563 567
564 (defcustom spam-spamoracle-binary (executable-find "spamoracle") 568 (defcustom spam-spamoracle-binary (executable-find "spamoracle")
565 "Location of the spamoracle binary." 569 "Location of the spamoracle binary."
566 :type '(choice (directory :tag "Location of the spamoracle binary") 570 :type '(choice (directory :tag "Location of the spamoracle binary")
567 (const :tag "Use the default")) 571 (const :tag "Use the default"))
568 :group 'spam-spamoracle) 572 :group 'spam-spamoracle)
569 573
570 (defgroup spam-spamassassin nil 574 (defgroup spam-spamassassin nil
571 "Spam SpamAssassin configuration." 575 "Spam SpamAssassin configuration."
572 :group 'spam) 576 :group 'spam)
576 (defcustom spam-assassin-program (executable-find "spamassassin") 580 (defcustom spam-assassin-program (executable-find "spamassassin")
577 "Name of the spamassassin program. 581 "Name of the spamassassin program.
578 Hint: set this to \"spamc\" if you have spamd running. See the spamc and 582 Hint: set this to \"spamc\" if you have spamd running. See the spamc and
579 spamd man pages for more information on these programs." 583 spamd man pages for more information on these programs."
580 :type '(choice (file :tag "Location of spamc") 584 :type '(choice (file :tag "Location of spamc")
581 (const :tag "spamassassin is not installed")) 585 (const :tag "spamassassin is not installed"))
582 :group 'spam-spamassassin) 586 :group 'spam-spamassassin)
583 587
584 (defcustom spam-spamassassin-arguments () 588 (defcustom spam-spamassassin-arguments ()
585 "Arguments to pass to the spamassassin executable. 589 "Arguments to pass to the spamassassin executable.
586 This must be a list. For example, `(\"-C\" \"configfile\")'." 590 This must be a list. For example, `(\"-C\" \"configfile\")'."
606 (make-obsolete-variable 'spam-sa-learn-path 'spam-sa-learn-program 610 (make-obsolete-variable 'spam-sa-learn-path 'spam-sa-learn-program
607 "Gnus 5.10.9 (Emacs 22.1)") 611 "Gnus 5.10.9 (Emacs 22.1)")
608 (defcustom spam-sa-learn-program (executable-find "sa-learn") 612 (defcustom spam-sa-learn-program (executable-find "sa-learn")
609 "Name of the sa-learn program." 613 "Name of the sa-learn program."
610 :type '(choice (file :tag "Location of spamassassin") 614 :type '(choice (file :tag "Location of spamassassin")
611 (const :tag "spamassassin is not installed")) 615 (const :tag "spamassassin is not installed"))
612 :group 'spam-spamassassin) 616 :group 'spam-spamassassin)
613 617
614 (defcustom spam-sa-learn-rebuild t 618 (defcustom spam-sa-learn-rebuild t
615 "Whether sa-learn should rebuild the database every time it is called 619 "Whether sa-learn should rebuild the database every time it is called
616 Enable this if you want sa-learn to rebuild the database automatically. Doing 620 Enable this if you want sa-learn to rebuild the database automatically. Doing
640 :group 'spam) 644 :group 'spam)
641 645
642 (defcustom spam-crm114-program (executable-find "mailfilter.crm") 646 (defcustom spam-crm114-program (executable-find "mailfilter.crm")
643 "File path of the CRM114 Mailfilter executable program." 647 "File path of the CRM114 Mailfilter executable program."
644 :type '(choice (file :tag "Location of CRM114 Mailfilter") 648 :type '(choice (file :tag "Location of CRM114 Mailfilter")
645 (const :tag "CRM114 Mailfilter is not installed")) 649 (const :tag "CRM114 Mailfilter is not installed"))
646 :group 'spam-crm114) 650 :group 'spam-crm114)
647 651
648 (defcustom spam-crm114-header "X-CRM114-Status" 652 (defcustom spam-crm114-header "X-CRM114-Status"
649 "The header that CRM114 Mailfilter inserts in messages." 653 "The header that CRM114 Mailfilter inserts in messages."
650 :type 'string 654 :type 'string
676 :group 'spam-crm114) 680 :group 'spam-crm114)
677 681
678 (defcustom spam-crm114-database-directory nil 682 (defcustom spam-crm114-database-directory nil
679 "Directory path of the CRM114 Mailfilter databases." 683 "Directory path of the CRM114 Mailfilter databases."
680 :type '(choice (directory 684 :type '(choice (directory
681 :tag "Location of the CRM114 Mailfilter database directory") 685 :tag "Location of the CRM114 Mailfilter database directory")
682 (const :tag "Use the default")) 686 (const :tag "Use the default"))
683 :group 'spam-crm114) 687 :group 'spam-crm114)
684 688
685 ;;; Key bindings for spam control. 689 ;;; Key bindings for spam control.
686 690
687 (gnus-define-keys gnus-summary-mode-map 691 (gnus-define-keys gnus-summary-mode-map
694 698
695 (defvar spam-cache-lookups t 699 (defvar spam-cache-lookups t
696 "Whether spam.el will try to cache lookups using `spam-caches'.") 700 "Whether spam.el will try to cache lookups using `spam-caches'.")
697 701
698 (defvar spam-caches (make-hash-table 702 (defvar spam-caches (make-hash-table
699 :size 10 703 :size 10
700 :test 'equal) 704 :test 'equal)
701 "Cache of spam detection entries.") 705 "Cache of spam detection entries.")
702 706
703 (defvar spam-old-articles nil 707 (defvar spam-old-articles nil
704 "List of old ham and spam articles, generated when a group is entered.") 708 "List of old ham and spam articles, generated when a group is entered.")
705 709
734 "Return a set difference of LIST1 and LIST2. 738 "Return a set difference of LIST1 and LIST2.
735 When either list is nil, the other is returned." 739 When either list is nil, the other is returned."
736 (if (and list1 list2) 740 (if (and list1 list2)
737 ;; we have two non-nil lists 741 ;; we have two non-nil lists
738 (progn 742 (progn
739 (dolist (item (append list1 list2)) 743 (dolist (item (append list1 list2))
740 (when (and (memq item list1) (memq item list2)) 744 (when (and (memq item list1) (memq item list2))
741 (setq list1 (delq item list1)) 745 (setq list1 (delq item list1))
742 (setq list2 (delq item list2)))) 746 (setq list2 (delq item list2))))
743 (append list1 list2)) 747 (append list1 list2))
744 ;; if either of the lists was nil, return the other one 748 ;; if either of the lists was nil, return the other one
745 (if list1 list1 list2))) 749 (if list1 list1 list2)))
746 750
747 (defun spam-group-ham-mark-p (group mark &optional spam) 751 (defun spam-group-ham-mark-p (group mark &optional spam)
748 "Checks if MARK is considered a ham mark in GROUP." 752 "Checks if MARK is considered a ham mark in GROUP."
749 (when (stringp group) 753 (when (stringp group)
750 (let* ((marks (spam-group-ham-marks group spam)) 754 (let* ((marks (spam-group-ham-marks group spam))
751 (marks (if (symbolp mark) 755 (marks (if (symbolp mark)
752 marks 756 marks
753 (mapcar 'symbol-value marks)))) 757 (mapcar 'symbol-value marks))))
754 (memq mark marks)))) 758 (memq mark marks))))
755 759
756 (defun spam-group-spam-mark-p (group mark) 760 (defun spam-group-spam-mark-p (group mark)
757 "Checks if MARK is considered a spam mark in GROUP." 761 "Checks if MARK is considered a spam mark in GROUP."
758 (spam-group-ham-mark-p group mark t)) 762 (spam-group-ham-mark-p group mark t))
759 763
760 (defun spam-group-ham-marks (group &optional spam) 764 (defun spam-group-ham-marks (group &optional spam)
761 "In GROUP, get all the ham marks." 765 "In GROUP, get all the ham marks."
762 (when (stringp group) 766 (when (stringp group)
763 (let* ((marks (if spam 767 (let* ((marks (if spam
764 (gnus-parameter-spam-marks group) 768 (gnus-parameter-spam-marks group)
765 (gnus-parameter-ham-marks group))) 769 (gnus-parameter-ham-marks group)))
766 (marks (car marks)) 770 (marks (car marks))
767 (marks (if (listp (car marks)) (car marks) marks))) 771 (marks (if (listp (car marks)) (car marks) marks)))
768 marks))) 772 marks)))
769 773
770 (defun spam-group-spam-marks (group) 774 (defun spam-group-spam-marks (group)
771 "In GROUP, get all the spam marks." 775 "In GROUP, get all the spam marks."
772 (spam-group-ham-marks group t)) 776 (spam-group-ham-marks group t))
773 777
774 (defun spam-group-spam-contents-p (group) 778 (defun spam-group-spam-contents-p (group)
775 "Is GROUP a spam group?" 779 "Is GROUP a spam group?"
776 (if (and (stringp group) (< 0 (length group))) 780 (if (and (stringp group) (< 0 (length group)))
777 (or (member group spam-junk-mailgroups) 781 (or (member group spam-junk-mailgroups)
778 (memq 'gnus-group-spam-classification-spam 782 (memq 'gnus-group-spam-classification-spam
779 (gnus-parameter-spam-contents group))) 783 (gnus-parameter-spam-contents group)))
780 nil)) 784 nil))
781 785
782 (defun spam-group-ham-contents-p (group) 786 (defun spam-group-ham-contents-p (group)
783 "Is GROUP a ham group?" 787 "Is GROUP a ham group?"
784 (if (stringp group) 788 (if (stringp group)
785 (memq 'gnus-group-spam-classification-ham 789 (memq 'gnus-group-spam-classification-ham
786 (gnus-parameter-spam-contents group)) 790 (gnus-parameter-spam-contents group))
787 nil)) 791 nil))
788 792
789 (defun spam-classifications () 793 (defun spam-classifications ()
790 "Return list of valid classifications" 794 "Return list of valid classifications"
791 '(spam ham)) 795 '(spam ham))
810 (or (eq process-type 'incoming) 814 (or (eq process-type 'incoming)
811 (eq process-type 'process))) 815 (eq process-type 'process)))
812 816
813 (defun spam-list-articles (articles classification) 817 (defun spam-list-articles (articles classification)
814 (let ((mark-check (if (eq classification 'spam) 818 (let ((mark-check (if (eq classification 'spam)
815 'spam-group-spam-mark-p 819 'spam-group-spam-mark-p
816 'spam-group-ham-mark-p)) 820 'spam-group-ham-mark-p))
817 alist mark-cache-yes mark-cache-no) 821 alist mark-cache-yes mark-cache-no)
818 (dolist (article articles) 822 (dolist (article articles)
819 (let ((mark (gnus-summary-article-mark article))) 823 (let ((mark (gnus-summary-article-mark article)))
820 (unless (or (memq mark mark-cache-yes) 824 (unless (or (memq mark mark-cache-yes)
821 (memq mark mark-cache-no)) 825 (memq mark mark-cache-no))
822 (if (funcall mark-check 826 (if (funcall mark-check
823 gnus-newsgroup-name 827 gnus-newsgroup-name
824 mark) 828 mark)
825 (push mark mark-cache-yes) 829 (push mark mark-cache-yes)
826 (push mark mark-cache-no))) 830 (push mark mark-cache-no)))
827 (when (memq mark mark-cache-yes) 831 (when (memq mark mark-cache-yes)
828 (push article alist)))) 832 (push article alist))))
829 alist)) 833 alist))
830 834
831 ;;}}} 835 ;;}}}
832 836
833 ;;{{{ backend installation functions and procedures 837 ;;{{{ backend installation functions and procedures
839 unregistration function SUF, and an indication whether the 843 unregistration function SUF, and an indication whether the
840 backend is STATISTICAL." 844 backend is STATISTICAL."
841 (setq spam-backends (add-to-list 'spam-backends backend)) 845 (setq spam-backends (add-to-list 'spam-backends backend))
842 (while properties 846 (while properties
843 (let ((property (pop properties)) 847 (let ((property (pop properties))
844 (value (pop properties))) 848 (value (pop properties)))
845 (if (spam-backend-property-valid-p property) 849 (if (spam-backend-property-valid-p property)
846 (put backend property value) 850 (put backend property value)
847 (gnus-error 851 (gnus-error
848 5 852 5
849 "spam-install-backend-super got an invalid property %s" 853 "spam-install-backend-super got an invalid property %s"
850 property))))) 854 property)))))
851 855
852 (defun spam-backend-list (&optional type) 856 (defun spam-backend-list (&optional type)
853 "Return a list of all the backend symbols, constrained by TYPE. 857 "Return a list of all the backend symbols, constrained by TYPE.
854 When TYPE is 'non-mover, only non-mover backends are returned. 858 When TYPE is 'non-mover, only non-mover backends are returned.
855 When TYPE is 'mover, only mover backends are returned." 859 When TYPE is 'mover, only mover backends are returned."
856 (let (list) 860 (let (list)
857 (dolist (backend spam-backends) 861 (dolist (backend spam-backends)
858 (when (or 862 (when (or
859 (null type) ;either no type was requested 863 (null type) ;either no type was requested
860 ;; or the type is 'mover and the backend is a mover 864 ;; or the type is 'mover and the backend is a mover
861 (and 865 (and
862 (eq type 'mover) 866 (eq type 'mover)
863 (spam-backend-mover-p backend)) 867 (spam-backend-mover-p backend))
864 ;; or the type is 'non-mover and the backend is not a mover 868 ;; or the type is 'non-mover and the backend is not a mover
865 (and 869 (and
866 (eq type 'non-mover) 870 (eq type 'non-mover)
867 (not (spam-backend-mover-p backend)))) 871 (not (spam-backend-mover-p backend))))
868 (push backend list))) 872 (push backend list)))
869 list)) 873 list))
870 874
871 (defun spam-backend-check (backend) 875 (defun spam-backend-check (backend)
872 "Get the check function for BACKEND. 876 "Get the check function for BACKEND.
873 Each individual check may return nil, t, or a mailgroup name. 877 Each individual check may return nil, t, or a mailgroup name.
887 891
888 (defun spam-backend-info (backend) 892 (defun spam-backend-info (backend)
889 "Return information about BACKEND." 893 "Return information about BACKEND."
890 (if (spam-backend-valid-p backend) 894 (if (spam-backend-valid-p backend)
891 (let (info) 895 (let (info)
892 (setq info (format "Backend %s has the following properties:\n" 896 (setq info (format "Backend %s has the following properties:\n"
893 backend)) 897 backend))
894 (dolist (property (spam-backend-properties)) 898 (dolist (property (spam-backend-properties))
895 (setq info (format "%s%s=%s\n" 899 (setq info (format "%s%s=%s\n"
896 info 900 info
897 property 901 property
898 (get backend property)))) 902 (get backend property))))
899 info) 903 info)
900 (gnus-error 5 "spam-backend-info was asked about an invalid backend %s" 904 (gnus-error 5 "spam-backend-info was asked about an invalid backend %s"
901 backend))) 905 backend)))
902 906
903 (defun spam-backend-function (backend classification type) 907 (defun spam-backend-function (backend classification type)
904 "Get the BACKEND function for CLASSIFICATION and TYPE. 908 "Get the BACKEND function for CLASSIFICATION and TYPE.
905 TYPE is 'registration or 'unregistration. 909 TYPE is 'registration or 'unregistration.
906 CLASSIFICATION is 'ham or 'spam." 910 CLASSIFICATION is 'ham or 'spam."
907 (if (and 911 (if (and
908 (spam-classification-valid-p classification) 912 (spam-classification-valid-p classification)
909 (spam-backend-function-type-valid-p type)) 913 (spam-backend-function-type-valid-p type))
910 (let ((retrieval 914 (let ((retrieval
911 (intern 915 (intern
912 (format "spam-backend-%s-%s-function" 916 (format "spam-backend-%s-%s-function"
913 classification 917 classification
914 type)))) 918 type))))
915 (funcall retrieval backend)) 919 (funcall retrieval backend))
916 (gnus-error 920 (gnus-error
917 5 921 5
918 "%s was passed invalid backend %s, classification %s, or type %s" 922 "%s was passed invalid backend %s, classification %s, or type %s"
919 "spam-backend-function" 923 "spam-backend-function"
920 backend 924 backend
921 classification 925 classification
922 type))) 926 type)))
923 927
924 (defun spam-backend-article-list-property (classification 928 (defun spam-backend-article-list-property (classification
925 &optional unregister) 929 &optional unregister)
926 "Property name of article list with CLASSIFICATION and UNREGISTER." 930 "Property name of article list with CLASSIFICATION and UNREGISTER."
927 (let* ((r (if unregister "unregister" "register")) 931 (let* ((r (if unregister "unregister" "register"))
928 (prop (format "%s-%s" classification r))) 932 (prop (format "%s-%s" classification r)))
929 prop)) 933 prop))
930 934
931 (defun spam-backend-get-article-todo-list (backend 935 (defun spam-backend-get-article-todo-list (backend
932 classification 936 classification
933 &optional unregister) 937 &optional unregister)
934 "Get the articles to be processed for BACKEND and CLASSIFICATION. 938 "Get the articles to be processed for BACKEND and CLASSIFICATION.
935 With UNREGISTER, get articles to be unregistered. 939 With UNREGISTER, get articles to be unregistered.
936 This is a temporary storage function - nothing here persists." 940 This is a temporary storage function - nothing here persists."
937 (get 941 (get
938 backend 942 backend
939 (intern (spam-backend-article-list-property classification unregister)))) 943 (intern (spam-backend-article-list-property classification unregister))))
940 944
941 (defun spam-backend-put-article-todo-list (backend classification list &optional unregister) 945 (defun spam-backend-put-article-todo-list (backend classification list
946 &optional unregister)
942 "Set the LIST of articles to be processed for BACKEND and CLASSIFICATION. 947 "Set the LIST of articles to be processed for BACKEND and CLASSIFICATION.
943 With UNREGISTER, set articles to be unregistered. 948 With UNREGISTER, set articles to be unregistered.
944 This is a temporary storage function - nothing here persists." 949 This is a temporary storage function - nothing here persists."
945 (put 950 (put
946 backend 951 backend
1034 1039
1035 ;;}}} 1040 ;;}}}
1036 1041
1037 ;;{{{ backend installations 1042 ;;{{{ backend installations
1038 (spam-install-checkonly-backend 'spam-use-blackholes 1043 (spam-install-checkonly-backend 'spam-use-blackholes
1039 'spam-check-blackholes) 1044 'spam-check-blackholes)
1040 1045
1041 (spam-install-checkonly-backend 'spam-use-hashcash 1046 (spam-install-checkonly-backend 'spam-use-hashcash
1042 'spam-check-hashcash) 1047 'spam-check-hashcash)
1043 1048
1044 (spam-install-checkonly-backend 'spam-use-spamassassin-headers 1049 (spam-install-checkonly-backend 'spam-use-spamassassin-headers
1045 'spam-check-spamassassin-headers) 1050 'spam-check-spamassassin-headers)
1046 1051
1047 (spam-install-checkonly-backend 'spam-use-bogofilter-headers 1052 (spam-install-checkonly-backend 'spam-use-bogofilter-headers
1048 'spam-check-bogofilter-headers) 1053 'spam-check-bogofilter-headers)
1049 1054
1050 (spam-install-checkonly-backend 'spam-use-bsfilter-headers 1055 (spam-install-checkonly-backend 'spam-use-bsfilter-headers
1051 'spam-check-bsfilter-headers) 1056 'spam-check-bsfilter-headers)
1052 1057
1053 (spam-install-checkonly-backend 'spam-use-gmane-xref 1058 (spam-install-checkonly-backend 'spam-use-gmane-xref
1054 'spam-check-gmane-xref) 1059 'spam-check-gmane-xref)
1055 1060
1056 (spam-install-checkonly-backend 'spam-use-regex-headers 1061 (spam-install-checkonly-backend 'spam-use-regex-headers
1057 'spam-check-regex-headers) 1062 'spam-check-regex-headers)
1058 1063
1059 (spam-install-statistical-checkonly-backend 'spam-use-regex-body 1064 (spam-install-statistical-checkonly-backend 'spam-use-regex-body
1060 'spam-check-regex-body) 1065 'spam-check-regex-body)
1061 1066
1062 ;; TODO: NOTE: spam-use-ham-copy is now obsolete, use (ham spam-use-copy) instead 1067 ;; TODO: NOTE: spam-use-ham-copy is now obsolete, use (ham spam-use-copy)
1063 (spam-install-mover-backend 'spam-use-move 1068 (spam-install-mover-backend 'spam-use-move
1064 'spam-move-ham-routine 1069 'spam-move-ham-routine
1065 'spam-move-spam-routine 1070 'spam-move-spam-routine
1066 nil 1071 nil
1067 nil) 1072 nil)
1068 1073
1069 (spam-install-nocheck-backend 'spam-use-copy 1074 (spam-install-nocheck-backend 'spam-use-copy
1070 'spam-copy-ham-routine 1075 'spam-copy-ham-routine
1071 'spam-copy-spam-routine 1076 'spam-copy-spam-routine
1072 nil 1077 nil
1073 nil) 1078 nil)
1074 1079
1075 (spam-install-nocheck-backend 'spam-use-gmane 1080 (spam-install-nocheck-backend 'spam-use-gmane
1076 'spam-report-gmane-unregister-routine 1081 'spam-report-gmane-unregister-routine
1077 'spam-report-gmane-register-routine 1082 'spam-report-gmane-register-routine
1078 'spam-report-gmane-register-routine 1083 'spam-report-gmane-register-routine
1079 'spam-report-gmane-unregister-routine) 1084 'spam-report-gmane-unregister-routine)
1080 1085
1081 (spam-install-nocheck-backend 'spam-use-resend 1086 (spam-install-nocheck-backend 'spam-use-resend
1082 'spam-report-resend-register-ham-routine 1087 'spam-report-resend-register-ham-routine
1083 'spam-report-resend-register-routine 1088 'spam-report-resend-register-routine
1084 nil 1089 nil
1085 nil) 1090 nil)
1086 1091
1087 (spam-install-backend 'spam-use-BBDB 1092 (spam-install-backend 'spam-use-BBDB
1088 'spam-check-BBDB 1093 'spam-check-BBDB
1089 'spam-BBDB-register-routine 1094 'spam-BBDB-register-routine
1090 nil 1095 nil
1091 'spam-BBDB-unregister-routine 1096 'spam-BBDB-unregister-routine
1092 nil) 1097 nil)
1093 1098
1094 (spam-install-backend-alias 'spam-use-BBDB 'spam-use-BBDB-exclusive) 1099 (spam-install-backend-alias 'spam-use-BBDB 'spam-use-BBDB-exclusive)
1095 1100
1096 (spam-install-backend 'spam-use-blacklist 1101 (spam-install-backend 'spam-use-blacklist
1097 'spam-check-blacklist 1102 'spam-check-blacklist
1098 nil 1103 nil
1099 'spam-blacklist-register-routine 1104 'spam-blacklist-register-routine
1100 nil 1105 nil
1101 'spam-blacklist-unregister-routine) 1106 'spam-blacklist-unregister-routine)
1102 1107
1103 (spam-install-backend 'spam-use-whitelist 1108 (spam-install-backend 'spam-use-whitelist
1104 'spam-check-whitelist 1109 'spam-check-whitelist
1105 'spam-whitelist-register-routine 1110 'spam-whitelist-register-routine
1106 nil 1111 nil
1107 'spam-whitelist-unregister-routine 1112 'spam-whitelist-unregister-routine
1108 nil) 1113 nil)
1109 1114
1110 (spam-install-statistical-backend 'spam-use-ifile 1115 (spam-install-statistical-backend 'spam-use-ifile
1111 'spam-check-ifile 1116 'spam-check-ifile
1112 'spam-ifile-register-ham-routine 1117 'spam-ifile-register-ham-routine
1113 'spam-ifile-register-spam-routine 1118 'spam-ifile-register-spam-routine
1114 'spam-ifile-unregister-ham-routine 1119 'spam-ifile-unregister-ham-routine
1115 'spam-ifile-unregister-spam-routine) 1120 'spam-ifile-unregister-spam-routine)
1116 1121
1117 (spam-install-statistical-backend 'spam-use-spamoracle 1122 (spam-install-statistical-backend 'spam-use-spamoracle
1118 'spam-check-spamoracle 1123 'spam-check-spamoracle
1119 'spam-spamoracle-learn-ham 1124 'spam-spamoracle-learn-ham
1120 'spam-spamoracle-learn-spam 1125 'spam-spamoracle-learn-spam
1121 'spam-spamoracle-unlearn-ham 1126 'spam-spamoracle-unlearn-ham
1122 'spam-spamoracle-unlearn-spam) 1127 'spam-spamoracle-unlearn-spam)
1123 1128
1124 (spam-install-statistical-backend 'spam-use-stat 1129 (spam-install-statistical-backend 'spam-use-stat
1125 'spam-check-stat 1130 'spam-check-stat
1126 'spam-stat-register-ham-routine 1131 'spam-stat-register-ham-routine
1127 'spam-stat-register-spam-routine 1132 'spam-stat-register-spam-routine
1128 'spam-stat-unregister-ham-routine 1133 'spam-stat-unregister-ham-routine
1129 'spam-stat-unregister-spam-routine) 1134 'spam-stat-unregister-spam-routine)
1130 1135
1131 (spam-install-statistical-backend 'spam-use-spamassassin 1136 (spam-install-statistical-backend 'spam-use-spamassassin
1132 'spam-check-spamassassin 1137 'spam-check-spamassassin
1133 'spam-spamassassin-register-ham-routine 1138 'spam-spamassassin-register-ham-routine
1134 'spam-spamassassin-register-spam-routine 1139 'spam-spamassassin-register-spam-routine
1135 'spam-spamassassin-unregister-ham-routine 1140 'spam-spamassassin-unregister-ham-routine
1136 'spam-spamassassin-unregister-spam-routine) 1141 'spam-spamassassin-unregister-spam-routine)
1137 1142
1138 (spam-install-statistical-backend 'spam-use-bogofilter 1143 (spam-install-statistical-backend 'spam-use-bogofilter
1139 'spam-check-bogofilter 1144 'spam-check-bogofilter
1140 'spam-bogofilter-register-ham-routine 1145 'spam-bogofilter-register-ham-routine
1141 'spam-bogofilter-register-spam-routine 1146 'spam-bogofilter-register-spam-routine
1142 'spam-bogofilter-unregister-ham-routine 1147 'spam-bogofilter-unregister-ham-routine
1143 'spam-bogofilter-unregister-spam-routine) 1148 'spam-bogofilter-unregister-spam-routine)
1144 1149
1145 (spam-install-statistical-backend 'spam-use-bsfilter 1150 (spam-install-statistical-backend 'spam-use-bsfilter
1146 'spam-check-bsfilter 1151 'spam-check-bsfilter
1147 'spam-bsfilter-register-ham-routine 1152 'spam-bsfilter-register-ham-routine
1148 'spam-bsfilter-register-spam-routine 1153 'spam-bsfilter-register-spam-routine
1149 'spam-bsfilter-unregister-ham-routine 1154 'spam-bsfilter-unregister-ham-routine
1150 'spam-bsfilter-unregister-spam-routine) 1155 'spam-bsfilter-unregister-spam-routine)
1151 1156
1152 (spam-install-statistical-backend 'spam-use-crm114 1157 (spam-install-statistical-backend 'spam-use-crm114
1153 'spam-check-crm114 1158 'spam-check-crm114
1154 'spam-crm114-register-ham-routine 1159 'spam-crm114-register-ham-routine
1155 'spam-crm114-register-spam-routine 1160 'spam-crm114-register-spam-routine
1156 'spam-crm114-unregister-ham-routine 1161 'spam-crm114-unregister-ham-routine
1157 'spam-crm114-unregister-spam-routine) 1162 'spam-crm114-unregister-spam-routine)
1158 ;;}}} 1163 ;;}}}
1159 1164
1160 ;;{{{ scoring and summary formatting 1165 ;;{{{ scoring and summary formatting
1161 (defun spam-necessary-extra-headers () 1166 (defun spam-necessary-extra-headers ()
1162 "Return the extra headers spam.el thinks are necessary." 1167 "Return the extra headers spam.el thinks are necessary."
1163 (let (list) 1168 (let (list)
1164 (when (or spam-use-spamassassin 1169 (when (or spam-use-spamassassin
1165 spam-use-spamassassin-headers 1170 spam-use-spamassassin-headers
1166 spam-use-regex-headers) 1171 spam-use-regex-headers)
1167 (push 'X-Spam-Status list)) 1172 (push 'X-Spam-Status list))
1168 (when (or spam-use-bogofilter 1173 (when (or spam-use-bogofilter
1169 spam-use-regex-headers) 1174 spam-use-regex-headers)
1170 (push 'X-Bogosity list)) 1175 (push 'X-Bogosity list))
1171 (when (or spam-use-crm114 1176 (when (or spam-use-crm114
1172 spam-use-regex-headers) 1177 spam-use-regex-headers)
1173 (push 'X-CRM114-Status list)) 1178 (push 'X-CRM114-Status list))
1174 list)) 1179 list))
1175 1180
1176 (defun spam-user-format-function-S (headers) 1181 (defun spam-user-format-function-S (headers)
1177 (when headers 1182 (when headers
1178 (format "%3.2f" 1183 (format "%3.2f"
1179 (spam-summary-score headers spam-summary-score-preferred-header)))) 1184 (spam-summary-score headers spam-summary-score-preferred-header))))
1180 1185
1181 (defun spam-article-sort-by-spam-status (h1 h2) 1186 (defun spam-article-sort-by-spam-status (h1 h2)
1182 "Sort articles by score." 1187 "Sort articles by score."
1183 (let (result) 1188 (let (result)
1184 (dolist (header (spam-necessary-extra-headers)) 1189 (dolist (header (spam-necessary-extra-headers))
1185 (let ((s1 (spam-summary-score h1 header)) 1190 (let ((s1 (spam-summary-score h1 header))
1186 (s2 (spam-summary-score h2 header))) 1191 (s2 (spam-summary-score h2 header)))
1187 (unless (= s1 s2) 1192 (unless (= s1 s2)
1188 (setq result (< s1 s2)) 1193 (setq result (< s1 s2))
1189 (return)))) 1194 (return))))
1190 result)) 1195 result))
1191 1196
1192 (defvar spam-spamassassin-score-regexp 1197 (defvar spam-spamassassin-score-regexp
1193 ".*\\b\\(?:score\\|hits\\)=\\(-?[0-9.]+\\)" 1198 ".*\\b\\(?:score\\|hits\\)=\\(-?[0-9.]+\\)"
1194 "Regexp matching SpamAssassin score header. 1199 "Regexp matching SpamAssassin score header.
1221 "Score an article for the summary buffer, as fast as possible. 1226 "Score an article for the summary buffer, as fast as possible.
1222 With SPECIFIC-HEADER, returns only that header's score. 1227 With SPECIFIC-HEADER, returns only that header's score.
1223 Will not return a nil score." 1228 Will not return a nil score."
1224 (let (score) 1229 (let (score)
1225 (dolist (header 1230 (dolist (header
1226 (if specific-header 1231 (if specific-header
1227 (list specific-header) 1232 (list specific-header)
1228 (spam-necessary-extra-headers))) 1233 (spam-necessary-extra-headers)))
1229 (setq score 1234 (setq score
1230 (spam-extra-header-to-number header headers)) 1235 (spam-extra-header-to-number header headers))
1231 (when score 1236 (when score
1232 (return))) 1237 (return)))
1233 (or score 0))) 1238 (or score 0)))
1234 1239
1235 (defun spam-generic-score (&optional recheck) 1240 (defun spam-generic-score (&optional recheck)
1236 "Invoke whatever scoring method we can." 1241 "Invoke whatever scoring method we can."
1237 (interactive "P") 1242 (interactive "P")
1254 1259
1255 (defun spam-widening-needed-p (&optional force-symbols) 1260 (defun spam-widening-needed-p (&optional force-symbols)
1256 (let (found) 1261 (let (found)
1257 (dolist (backend (spam-backend-list)) 1262 (dolist (backend (spam-backend-list))
1258 (when (and (spam-backend-statistical-p backend) 1263 (when (and (spam-backend-statistical-p backend)
1259 (or (symbol-value backend) 1264 (or (symbol-value backend)
1260 (memq backend force-symbols))) 1265 (memq backend force-symbols)))
1261 (setq found backend))) 1266 (setq found backend)))
1262 found)) 1267 found))
1263 1268
1264 (defvar spam-list-of-processors 1269 (defvar spam-list-of-processors
1265 ;; note the nil processors are not defined in gnus.el 1270 ;; note the nil processors are not defined in gnus.el
1266 '((gnus-group-spam-exit-processor-bogofilter spam spam-use-bogofilter) 1271 '((gnus-group-spam-exit-processor-bogofilter spam spam-use-bogofilter)
1267 (gnus-group-spam-exit-processor-bsfilter spam spam-use-bsfilter) 1272 (gnus-group-spam-exit-processor-bsfilter spam spam-use-bsfilter)
1268 (gnus-group-spam-exit-processor-blacklist spam spam-use-blacklist) 1273 (gnus-group-spam-exit-processor-blacklist spam spam-use-blacklist)
1269 (gnus-group-spam-exit-processor-ifile spam spam-use-ifile) 1274 (gnus-group-spam-exit-processor-ifile spam spam-use-ifile)
1270 (gnus-group-spam-exit-processor-stat spam spam-use-stat) 1275 (gnus-group-spam-exit-processor-stat spam spam-use-stat)
1271 (gnus-group-spam-exit-processor-spamoracle spam spam-use-spamoracle) 1276 (gnus-group-spam-exit-processor-spamoracle spam spam-use-spamoracle)
1272 (gnus-group-spam-exit-processor-spamassassin spam spam-use-spamassassin) 1277 (gnus-group-spam-exit-processor-spamassassin spam spam-use-spamassassin)
1294 Also accepts the obsolete processors, which can be found in 1299 Also accepts the obsolete processors, which can be found in
1295 gnus.el and in spam-list-of-processors. In the case of mover 1300 gnus.el and in spam-list-of-processors. In the case of mover
1296 backends, checks the setting of `spam-summary-exit-behavior' in 1301 backends, checks the setting of `spam-summary-exit-behavior' in
1297 addition to the set values for the group." 1302 addition to the set values for the group."
1298 (if (and (stringp group) 1303 (if (and (stringp group)
1299 (symbolp backend)) 1304 (symbolp backend))
1300 (let ((old-style (assq backend spam-list-of-processors)) 1305 (let ((old-style (assq backend spam-list-of-processors))
1301 (parameters (nth 0 (gnus-parameter-spam-process group))) 1306 (parameters (nth 0 (gnus-parameter-spam-process group)))
1302 found) 1307 found)
1303 (if old-style ; old-style processor 1308 (if old-style ; old-style processor
1304 (spam-group-processor-p group (nth 2 old-style) (nth 1 old-style)) 1309 (spam-group-processor-p group (nth 2 old-style) (nth 1 old-style))
1305 ;; now search for the parameter 1310 ;; now search for the parameter
1306 (dolist (parameter parameters) 1311 (dolist (parameter parameters)
1307 (when (and (null found) 1312 (when (and (null found)
1308 (listp parameter) 1313 (listp parameter)
1309 (eq classification (nth 0 parameter)) 1314 (eq classification (nth 0 parameter))
1310 (eq backend (nth 1 parameter))) 1315 (eq backend (nth 1 parameter)))
1311 (setq found t))) 1316 (setq found t)))
1312 1317
1313 ;; now, if the parameter was not found, do the 1318 ;; now, if the parameter was not found, do the
1314 ;; spam-summary-exit-behavior-logic for mover backends 1319 ;; spam-summary-exit-behavior-logic for mover backends
1315 (unless found 1320 (unless found
1316 (when (spam-backend-mover-p backend) 1321 (when (spam-backend-mover-p backend)
1317 (setq 1322 (setq
1318 found 1323 found
1319 (cond 1324 (cond
1320 ((eq spam-summary-exit-behavior 'move-all) t) 1325 ((eq spam-summary-exit-behavior 'move-all) t)
1321 ((eq spam-summary-exit-behavior 'move-none) nil) 1326 ((eq spam-summary-exit-behavior 'move-none) nil)
1322 ((eq spam-summary-exit-behavior 'default) 1327 ((eq spam-summary-exit-behavior 'default)
1323 (or (eq classification 'spam) ;move spam out of all groups 1328 (or (eq classification 'spam) ;move spam out of all groups
1324 ;; move ham out of spam groups 1329 ;; move ham out of spam groups
1325 (and (eq classification 'ham) 1330 (and (eq classification 'ham)
1326 (spam-group-spam-contents-p group)))) 1331 (spam-group-spam-contents-p group))))
1327 (t (gnus-error 5 "Unknown spam-summary-exit-behavior: %s" 1332 (t (gnus-error 5 "Unknown spam-summary-exit-behavior: %s"
1328 spam-summary-exit-behavior)))))) 1333 spam-summary-exit-behavior))))))
1329 1334
1330 found)) 1335 found))
1331 nil)) 1336 nil))
1332 1337
1333 ;;}}} 1338 ;;}}}
1334 1339
1335 ;;{{{ Summary entry and exit processing. 1340 ;;{{{ Summary entry and exit processing.
1337 (defun spam-mark-junk-as-spam-routine () 1342 (defun spam-mark-junk-as-spam-routine ()
1338 ;; check the global list of group names spam-junk-mailgroups and the 1343 ;; check the global list of group names spam-junk-mailgroups and the
1339 ;; group parameters 1344 ;; group parameters
1340 (when (spam-group-spam-contents-p gnus-newsgroup-name) 1345 (when (spam-group-spam-contents-p gnus-newsgroup-name)
1341 (gnus-message 6 "Marking %s articles as spam" 1346 (gnus-message 6 "Marking %s articles as spam"
1342 (if spam-mark-only-unseen-as-spam 1347 (if spam-mark-only-unseen-as-spam
1343 "unseen" 1348 "unseen"
1344 "unread")) 1349 "unread"))
1345 (let ((articles (if spam-mark-only-unseen-as-spam 1350 (let ((articles (if spam-mark-only-unseen-as-spam
1346 gnus-newsgroup-unseen 1351 gnus-newsgroup-unseen
1347 gnus-newsgroup-unreads))) 1352 gnus-newsgroup-unreads)))
1348 (if spam-mark-new-messages-in-spam-group-as-spam 1353 (if spam-mark-new-messages-in-spam-group-as-spam
1349 (dolist (article articles) 1354 (dolist (article articles)
1350 (gnus-summary-mark-article article gnus-spam-mark)) 1355 (gnus-summary-mark-article article gnus-spam-mark))
1351 (gnus-message 9 "Did not mark new messages as spam."))))) 1356 (gnus-message 9 "Did not mark new messages as spam.")))))
1352 1357
1353 (defun spam-summary-prepare () 1358 (defun spam-summary-prepare ()
1354 (setq spam-old-articles 1359 (setq spam-old-articles
1355 (list (cons 'ham (spam-list-articles gnus-newsgroup-articles 'ham)) 1360 (list (cons 'ham (spam-list-articles gnus-newsgroup-articles 'ham))
1356 (cons 'spam (spam-list-articles gnus-newsgroup-articles 'spam)))) 1361 (cons 'spam (spam-list-articles gnus-newsgroup-articles 'spam))))
1357 (spam-mark-junk-as-spam-routine)) 1362 (spam-mark-junk-as-spam-routine))
1358 1363
1359 ;; The spam processors are invoked for any group, spam or ham or neither 1364 ;; The spam processors are invoked for any group, spam or ham or neither
1360 (defun spam-summary-prepare-exit () 1365 (defun spam-summary-prepare-exit ()
1361 (unless gnus-group-is-exiting-without-update-p 1366 (unless gnus-group-is-exiting-without-update-p
1367 1372
1368 ;; first of all, unregister any articles that are no longer ham or spam 1373 ;; first of all, unregister any articles that are no longer ham or spam
1369 ;; we have to iterate over the processors, or else we'll be too slow 1374 ;; we have to iterate over the processors, or else we'll be too slow
1370 (dolist (classification (spam-classifications)) 1375 (dolist (classification (spam-classifications))
1371 (let* ((old-articles (cdr-safe (assq classification spam-old-articles))) 1376 (let* ((old-articles (cdr-safe (assq classification spam-old-articles)))
1372 (new-articles (spam-list-articles 1377 (new-articles (spam-list-articles
1373 gnus-newsgroup-articles 1378 gnus-newsgroup-articles
1374 classification)) 1379 classification))
1375 (changed-articles (spam-set-difference new-articles old-articles))) 1380 (changed-articles (spam-set-difference new-articles old-articles)))
1376 ;; now that we have the changed articles, we go through the processors 1381 ;; now that we have the changed articles, we go through the processors
1377 (dolist (backend (spam-backend-list)) 1382 (dolist (backend (spam-backend-list))
1378 (let (unregister-list) 1383 (let (unregister-list)
1379 (dolist (article changed-articles) 1384 (dolist (article changed-articles)
1380 (let ((id (spam-fetch-field-message-id-fast article))) 1385 (let ((id (spam-fetch-field-message-id-fast article)))
1381 (when (spam-log-unregistration-needed-p 1386 (when (spam-log-unregistration-needed-p
1382 id 'process classification backend) 1387 id 'process classification backend)
1383 (push article unregister-list)))) 1388 (push article unregister-list))))
1384 ;; call spam-register-routine with specific articles to unregister, 1389 ;; call spam-register-routine with specific articles to unregister,
1385 ;; when there are articles to unregister and the check is enabled 1390 ;; when there are articles to unregister and the check is enabled
1386 (when (and unregister-list (symbol-value backend)) 1391 (when (and unregister-list (symbol-value backend))
1387 (spam-backend-put-article-todo-list backend 1392 (spam-backend-put-article-todo-list backend
1388 classification 1393 classification
1389 unregister-list 1394 unregister-list
1390 t)))))) 1395 t))))))
1391 1396
1392 ;; do the non-moving backends first, then the moving ones 1397 ;; do the non-moving backends first, then the moving ones
1393 (dolist (backend-type '(non-mover mover)) 1398 (dolist (backend-type '(non-mover mover))
1394 (dolist (classification (spam-classifications)) 1399 (dolist (classification (spam-classifications))
1395 (dolist (backend (spam-backend-list backend-type)) 1400 (dolist (backend (spam-backend-list backend-type))
1396 (when (spam-group-processor-p 1401 (when (spam-group-processor-p
1397 gnus-newsgroup-name 1402 gnus-newsgroup-name
1398 backend 1403 backend
1399 classification) 1404 classification)
1400 (spam-backend-put-article-todo-list backend 1405 (spam-backend-put-article-todo-list backend
1401 classification 1406 classification
1402 (spam-list-articles 1407 (spam-list-articles
1403 gnus-newsgroup-articles 1408 gnus-newsgroup-articles
1404 classification)))))) 1409 classification))))))
1405 1410
1406 (spam-resolve-registrations-routine) ; do the registrations now 1411 (spam-resolve-registrations-routine) ; do the registrations now
1407 1412
1408 ;; we mark all the leftover spam articles as expired at the end 1413 ;; we mark all the leftover spam articles as expired at the end
1409 (dolist (article (spam-list-articles 1414 (dolist (article (spam-list-articles
1410 gnus-newsgroup-articles 1415 gnus-newsgroup-articles
1411 'spam)) 1416 'spam))
1412 (gnus-summary-mark-article article gnus-expirable-mark))) 1417 (gnus-summary-mark-article article gnus-expirable-mark)))
1413 1418
1414 (setq spam-old-articles nil)) 1419 (setq spam-old-articles nil))
1415 1420
1416 ;;}}} 1421 ;;}}}
1427 1432
1428 ;; remove the current process mark 1433 ;; remove the current process mark
1429 (gnus-summary-kill-process-mark) 1434 (gnus-summary-kill-process-mark)
1430 1435
1431 (let ((backend-supports-deletions 1436 (let ((backend-supports-deletions
1432 (gnus-check-backend-function 1437 (gnus-check-backend-function
1433 'request-move-article gnus-newsgroup-name)) 1438 'request-move-article gnus-newsgroup-name))
1434 (respool-method (gnus-find-method-for-group gnus-newsgroup-name)) 1439 (respool-method (gnus-find-method-for-group gnus-newsgroup-name))
1435 article mark deletep respool) 1440 article mark deletep respool valid-move-destinations)
1436 1441
1437 (when (member 'respool groups) 1442 (when (member 'respool groups)
1438 (setq respool t) ; boolean for later 1443 (setq respool t) ; boolean for later
1439 (setq groups '("fake"))) ; when respooling, groups are dynamic so fake it 1444 (setq groups '("fake"))) ; when respooling, groups are dynamic so fake it
1445
1446 ;; exclude invalid move destinations
1447 (dolist (group groups)
1448 (unless
1449 (or
1450 (and
1451 (eq classification 'spam)
1452 (spam-group-spam-contents-p gnus-newsgroup-name)
1453 (spam-group-spam-contents-p group)
1454 (gnus-message
1455 3
1456 "Sorry, can't move spam from spam group %s to spam group %s"
1457 gnus-newsgroup-name
1458 group))
1459 (and
1460 (eq classification 'ham)
1461 (spam-group-ham-contents-p gnus-newsgroup-name)
1462 (spam-group-ham-contents-p group)
1463 (gnus-message
1464 3
1465 "Sorry, can't move ham from ham group %s to ham group %s"
1466 gnus-newsgroup-name
1467 group)))
1468 (push group valid-move-destinations)))
1469
1470 (setq groups (nreverse valid-move-destinations))
1440 1471
1441 ;; now do the actual move 1472 ;; now do the actual move
1442 (dolist (group groups) 1473 (dolist (group groups)
1474
1443 (when (and articles (stringp group)) 1475 (when (and articles (stringp group))
1444 1476
1445 ;; first, mark the article with the process mark and, if needed, 1477 ;; first, mark the article with the process mark and, if needed,
1446 ;; the unread or expired mark (for ham and spam respectively) 1478 ;; the unread or expired mark (for ham and spam respectively)
1479 (dolist (article articles)
1480 (when (and (eq classification 'ham)
1481 spam-mark-ham-unread-before-move-from-spam-group)
1482 (gnus-message 9 "Marking ham article %d unread before move"
1483 article)
1484 (gnus-summary-mark-article article gnus-unread-mark))
1485 (when (and (eq classification 'spam)
1486 (not copy))
1487 (gnus-message 9 "Marking spam article %d expirable before move"
1488 article)
1489 (gnus-summary-mark-article article gnus-expirable-mark))
1490 (gnus-summary-set-process-mark article)
1491
1492 (if respool ; respooling is with a "fake" group
1493 (let ((spam-split-disabled
1494 (or spam-split-disabled
1495 (and (eq classification 'ham)
1496 spam-disable-spam-split-during-ham-respool))))
1497 (gnus-message 9 "Respooling article %d with method %s"
1498 article respool-method)
1499 (gnus-summary-respool-article nil respool-method))
1500 ;; else, we are not respooling
1501 (if (or (not backend-supports-deletions)
1502 (> (length groups) 1))
1503 (progn ; if copying, copy and set deletep
1504 (gnus-message 9 "Copying article %d to group %s"
1505 article group)
1506 (gnus-summary-copy-article nil group)
1507 (setq deletep t))
1508 (gnus-message 9 "Moving article %d to group %s"
1509 article group)
1510 (gnus-summary-move-article nil group)))))) ; else move articles
1511
1512 ;; now delete the articles, unless a) copy is t, and there was a copy done
1513 ;; b) a move was done to a single group
1514 ;; c) backend-supports-deletions is nil
1515 (unless copy
1516 (when (and deletep backend-supports-deletions)
1447 (dolist (article articles) 1517 (dolist (article articles)
1448 (when (and (eq classification 'ham)
1449 spam-mark-ham-unread-before-move-from-spam-group)
1450 (gnus-message 9 "Marking ham article %d unread before move"
1451 article)
1452 (gnus-summary-mark-article article gnus-unread-mark))
1453 (when (and (eq classification 'spam)
1454 (not copy))
1455 (gnus-message 9 "Marking spam article %d expirable before move"
1456 article)
1457 (gnus-summary-mark-article article gnus-expirable-mark))
1458 (gnus-summary-set-process-mark article) 1518 (gnus-summary-set-process-mark article)
1459 1519 (gnus-message 9 "Deleting article %d" article))
1460 (if respool ; respooling is with a "fake" group 1520 (when articles
1461 (let ((spam-split-disabled 1521 (let ((gnus-novice-user nil)) ; don't ask me if I'm sure
1462 (or spam-split-disabled 1522 (gnus-summary-delete-article nil)))))
1463 (and (eq classification 'ham) 1523 (gnus-summary-yank-process-mark)
1464 spam-disable-spam-split-during-ham-respool)))) 1524 (length articles)))
1465 (gnus-message 9 "Respooling article %d with method %s"
1466 article respool-method)
1467 (gnus-summary-respool-article nil respool-method))
1468 (if (or (not backend-supports-deletions) ; else, we are not respooling
1469 (> (length groups) 1))
1470 (progn ; if copying, copy and set deletep
1471 (gnus-message 9 "Copying article %d to group %s"
1472 article group)
1473 (gnus-summary-copy-article nil group)
1474 (setq deletep t))
1475 (gnus-message 9 "Moving article %d to group %s"
1476 article group)
1477 (gnus-summary-move-article nil group))))) ; else move articles
1478
1479 ;; now delete the articles, unless a) copy is t, and there was a copy done
1480 ;; b) a move was done to a single group
1481 ;; c) backend-supports-deletions is nil
1482 (unless copy
1483 (when (and deletep backend-supports-deletions)
1484 (dolist (article articles)
1485 (gnus-summary-set-process-mark article)
1486 (gnus-message 9 "Deleting article %d" article))
1487 (when articles
1488 (let ((gnus-novice-user nil)) ; don't ask me if I'm sure
1489 (gnus-summary-delete-article nil)))))
1490
1491 (gnus-summary-yank-process-mark)
1492 (length articles))))
1493 1525
1494 (defun spam-copy-spam-routine (articles) 1526 (defun spam-copy-spam-routine (articles)
1495 (spam-copy-or-move-routine 1527 (spam-copy-or-move-routine
1496 t 1528 t
1497 (gnus-parameter-spam-process-destination gnus-newsgroup-name) 1529 (gnus-parameter-spam-process-destination gnus-newsgroup-name)
1535 ;; (let ((article-filename)) 1567 ;; (let ((article-filename))
1536 ;; (when (numberp article) 1568 ;; (when (numberp article)
1537 ;; (nnml-possibly-change-directory 1569 ;; (nnml-possibly-change-directory
1538 ;; (gnus-group-real-name gnus-newsgroup-name)) 1570 ;; (gnus-group-real-name gnus-newsgroup-name))
1539 ;; (setq article-filename (expand-file-name 1571 ;; (setq article-filename (expand-file-name
1540 ;; (int-to-string article) nnml-current-directory))) 1572 ;; (int-to-string article) nnml-current-directory)))
1541 ;; (if (file-exists-p article-filename) 1573 ;; (if (file-exists-p article-filename)
1542 ;; article-filename 1574 ;; article-filename
1543 ;; nil))) 1575 ;; nil)))
1544 1576
1545 (defun spam-fetch-field-fast (article field &optional prepared-data-header) 1577 (defun spam-fetch-field-fast (article field &optional prepared-data-header)
1546 "Fetch a FIELD for ARTICLE quickly, using the internal gnus-data-list function. 1578 "Fetch a FIELD for ARTICLE with the internal `gnus-data-list' function.
1547 When PREPARED-DATA-HEADER is given, don't look in the Gnus data. 1579 When PREPARED-DATA-HEADER is given, don't look in the Gnus data.
1548 When FIELD is 'number, ARTICLE can be any number (since we want 1580 When FIELD is 'number, ARTICLE can be any number (since we want
1549 to find it out)." 1581 to find it out)."
1550 (when (numberp article) 1582 (when (numberp article)
1551 (let* ((data-header (or prepared-data-header 1583 (let* ((data-header (or prepared-data-header
1552 (spam-fetch-article-header article)))) 1584 (spam-fetch-article-header article))))
1553 (if (arrayp data-header) 1585 (if (arrayp data-header)
1554 (cond 1586 (cond
1555 ((equal field 'number) 1587 ((equal field 'number)
1556 (mail-header-number data-header)) 1588 (mail-header-number data-header))
1557 ((equal field 'from) 1589 ((equal field 'from)
1558 (mail-header-from data-header)) 1590 (mail-header-from data-header))
1559 ((equal field 'message-id) 1591 ((equal field 'message-id)
1560 (mail-header-message-id data-header)) 1592 (mail-header-message-id data-header))
1561 ((equal field 'subject) 1593 ((equal field 'subject)
1562 (mail-header-subject data-header)) 1594 (mail-header-subject data-header))
1563 ((equal field 'references) 1595 ((equal field 'references)
1564 (mail-header-references data-header)) 1596 (mail-header-references data-header))
1565 ((equal field 'date) 1597 ((equal field 'date)
1566 (mail-header-date data-header)) 1598 (mail-header-date data-header))
1567 ((equal field 'xref) 1599 ((equal field 'xref)
1568 (mail-header-xref data-header)) 1600 (mail-header-xref data-header))
1569 ((equal field 'extra) 1601 ((equal field 'extra)
1570 (mail-header-extra data-header)) 1602 (mail-header-extra data-header))
1571 (t 1603 (t
1572 (gnus-error 1604 (gnus-error
1573 5 1605 5
1574 "spam-fetch-field-fast: unknown field %s requested" 1606 "spam-fetch-field-fast: unknown field %s requested"
1575 field) 1607 field)
1576 nil)) 1608 nil))
1577 (gnus-message 6 "Article %d has a nil data header" article))))) 1609 (gnus-message 6 "Article %d has a nil data header" article)))))
1578 1610
1579 (defun spam-fetch-field-from-fast (article &optional prepared-data-header) 1611 (defun spam-fetch-field-from-fast (article &optional prepared-data-header)
1580 (spam-fetch-field-fast article 'from prepared-data-header)) 1612 (spam-fetch-field-fast article 'from prepared-data-header))
1581 1613
1582 (defun spam-fetch-field-subject-fast (article &optional prepared-data-header) 1614 (defun spam-fetch-field-subject-fast (article &optional prepared-data-header)
1586 (spam-fetch-field-fast article 'message-id prepared-data-header)) 1618 (spam-fetch-field-fast article 'message-id prepared-data-header))
1587 1619
1588 (defun spam-generate-fake-headers (article) 1620 (defun spam-generate-fake-headers (article)
1589 (let ((dh (spam-fetch-article-header article))) 1621 (let ((dh (spam-fetch-article-header article)))
1590 (if dh 1622 (if dh
1591 (concat 1623 (concat
1592 (format 1624 (format
1593 ;; 80-character limit makes for strange constructs 1625 ;; 80-character limit makes for strange constructs
1594 (concat "From: %s\nSubject: %s\nMessage-ID: %s\n" 1626 (concat "From: %s\nSubject: %s\nMessage-ID: %s\n"
1595 "Date: %s\nReferences: %s\nXref: %s\n") 1627 "Date: %s\nReferences: %s\nXref: %s\n")
1596 (spam-fetch-field-fast article 'from dh) 1628 (spam-fetch-field-fast article 'from dh)
1597 (spam-fetch-field-fast article 'subject dh) 1629 (spam-fetch-field-fast article 'subject dh)
1598 (spam-fetch-field-fast article 'message-id dh) 1630 (spam-fetch-field-fast article 'message-id dh)
1599 (spam-fetch-field-fast article 'date dh) 1631 (spam-fetch-field-fast article 'date dh)
1600 (spam-fetch-field-fast article 'references dh) 1632 (spam-fetch-field-fast article 'references dh)
1601 (spam-fetch-field-fast article 'xref dh)) 1633 (spam-fetch-field-fast article 'xref dh))
1602 (when (spam-fetch-field-fast article 'extra dh) 1634 (when (spam-fetch-field-fast article 'extra dh)
1603 (format "%s\n" (spam-fetch-field-fast article 'extra dh)))) 1635 (format "%s\n" (spam-fetch-field-fast article 'extra dh))))
1604 (gnus-message 1636 (gnus-message
1605 5 1637 5
1606 "spam-generate-fake-headers: article %d didn't have a valid header" 1638 "spam-generate-fake-headers: article %d didn't have a valid header"
1607 article)))) 1639 article))))
1608 1640
1625 (interactive) 1657 (interactive)
1626 (setq spam-split-last-successful-check nil) 1658 (setq spam-split-last-successful-check nil)
1627 (unless spam-split-disabled 1659 (unless spam-split-disabled
1628 (let ((spam-split-group-choice spam-split-group)) 1660 (let ((spam-split-group-choice spam-split-group))
1629 (dolist (check specific-checks) 1661 (dolist (check specific-checks)
1630 (when (stringp check) 1662 (when (stringp check)
1631 (setq spam-split-group-choice check) 1663 (setq spam-split-group-choice check)
1632 (setq specific-checks (delq check specific-checks)))) 1664 (setq specific-checks (delq check specific-checks))))
1633 1665
1634 (let ((spam-split-group spam-split-group-choice) 1666 (let ((spam-split-group spam-split-group-choice)
1635 (widening-needed-check (spam-widening-needed-p specific-checks))) 1667 (widening-needed-check (spam-widening-needed-p specific-checks)))
1636 (save-excursion 1668 (save-excursion
1637 (save-restriction 1669 (save-restriction
1638 (when widening-needed-check 1670 (when widening-needed-check
1639 (widen) 1671 (widen)
1640 (gnus-message 8 "spam-split: widening the buffer (%s requires it)" 1672 (gnus-message 8 "spam-split: widening the buffer (%s requires it)"
1641 widening-needed-check)) 1673 widening-needed-check))
1642 (let ((backends (spam-backend-list)) 1674 (let ((backends (spam-backend-list))
1643 decision) 1675 decision)
1644 (while (and backends (not decision)) 1676 (while (and backends (not decision))
1645 (let* ((backend (pop backends)) 1677 (let* ((backend (pop backends))
1646 (check-function (spam-backend-check backend)) 1678 (check-function (spam-backend-check backend))
1647 (spam-split-group (if spam-split-symbolic-return 1679 (spam-split-group (if spam-split-symbolic-return
1648 'spam 1680 'spam
1649 spam-split-group))) 1681 spam-split-group)))
1650 (when (or 1682 (when (or
1651 ;; either, given specific checks, this is one of them 1683 ;; either, given specific checks, this is one of them
1652 (memq backend specific-checks) 1684 (memq backend specific-checks)
1653 ;; or, given no specific checks, spam-use-CHECK is set 1685 ;; or, given no specific checks, spam-use-CHECK is set
1654 (and (null specific-checks) (symbol-value backend))) 1686 (and (null specific-checks) (symbol-value backend)))
1655 (gnus-message 6 "spam-split: calling the %s function" 1687 (gnus-message 6 "spam-split: calling the %s function"
1656 check-function) 1688 check-function)
1657 (setq decision (funcall check-function)) 1689 (setq decision (funcall check-function))
1658 ;; if we got a decision at all, save the current check 1690 ;; if we got a decision at all, save the current check
1659 (when decision 1691 (when decision
1660 (setq spam-split-last-successful-check backend)) 1692 (setq spam-split-last-successful-check backend))
1661 1693
1662 (when (eq decision 'spam) 1694 (when (eq decision 'spam)
1663 (unless spam-split-symbolic-return 1695 (unless spam-split-symbolic-return
1664 (gnus-error 1696 (gnus-error
1665 5 1697 5
1666 (format "spam-split got %s but %s is nil" 1698 (format "spam-split got %s but %s is nil"
1667 decision 1699 decision
1668 spam-split-symbolic-return))))))) 1700 spam-split-symbolic-return)))))))
1669 (if (eq decision t) 1701 (if (eq decision t)
1670 (if spam-split-symbolic-return-positive 'ham nil) 1702 (if spam-split-symbolic-return-positive 'ham nil)
1671 decision)))))))) 1703 decision))))))))
1672 1704
1673 (defun spam-find-spam () 1705 (defun spam-find-spam ()
1674 "Detect spam in the current newsgroup using `spam-split'." 1706 "Detect spam in the current newsgroup using `spam-split'."
1675 (interactive) 1707 (interactive)
1676 1708
1677 (let* ((group gnus-newsgroup-name) 1709 (let* ((group gnus-newsgroup-name)
1678 (autodetect (gnus-parameter-spam-autodetect group)) 1710 (autodetect (gnus-parameter-spam-autodetect group))
1679 (methods (gnus-parameter-spam-autodetect-methods group)) 1711 (methods (gnus-parameter-spam-autodetect-methods group))
1680 (first-method (nth 0 methods)) 1712 (first-method (nth 0 methods))
1681 (articles (if spam-autodetect-recheck-messages 1713 (articles (if spam-autodetect-recheck-messages
1682 gnus-newsgroup-articles 1714 gnus-newsgroup-articles
1683 gnus-newsgroup-unseen)) 1715 gnus-newsgroup-unseen))
1684 article-cannot-be-faked) 1716 article-cannot-be-faked)
1685 1717
1686 1718
1687 (dolist (backend methods) 1719 (dolist (backend methods)
1688 (when (spam-backend-statistical-p backend) 1720 (when (spam-backend-statistical-p backend)
1689 (setq article-cannot-be-faked t) 1721 (setq article-cannot-be-faked t)
1690 (return))) 1722 (return)))
1691 1723
1692 (when (memq 'default methods) 1724 (when (memq 'default methods)
1693 (setq article-cannot-be-faked t)) 1725 (setq article-cannot-be-faked t))
1694 1726
1695 (when (and autodetect 1727 (when (and autodetect
1696 (not (equal first-method 'none))) 1728 (not (equal first-method 'none)))
1697 (mapcar 1729 (mapcar
1698 (lambda (article) 1730 (lambda (article)
1699 (let ((id (spam-fetch-field-message-id-fast article)) 1731 (let ((id (spam-fetch-field-message-id-fast article))
1700 (subject (spam-fetch-field-subject-fast article)) 1732 (subject (spam-fetch-field-subject-fast article))
1701 (sender (spam-fetch-field-from-fast article)) 1733 (sender (spam-fetch-field-from-fast article))
1702 registry-lookup) 1734 registry-lookup)
1703 1735
1704 (unless id 1736 (unless id
1705 (gnus-message 6 "Article %d has no message ID!" article)) 1737 (gnus-message 6 "Article %d has no message ID!" article))
1706 1738
1707 (when (and id spam-log-to-registry) 1739 (when (and id spam-log-to-registry)
1708 (setq registry-lookup (spam-log-registration-type id 'incoming)) 1740 (setq registry-lookup (spam-log-registration-type id 'incoming))
1709 (when registry-lookup 1741 (when registry-lookup
1710 (gnus-message 1742 (gnus-message
1711 9 1743 9
1712 "spam-find-spam: message %s was already registered incoming" 1744 "spam-find-spam: message %s was already registered incoming"
1713 id))) 1745 id)))
1714 1746
1715 (let* ((spam-split-symbolic-return t) 1747 (let* ((spam-split-symbolic-return t)
1716 (spam-split-symbolic-return-positive t) 1748 (spam-split-symbolic-return-positive t)
1717 (fake-headers (spam-generate-fake-headers article)) 1749 (fake-headers (spam-generate-fake-headers article))
1718 (split-return 1750 (split-return
1719 (or registry-lookup 1751 (or registry-lookup
1720 (with-temp-buffer 1752 (with-temp-buffer
1721 (if article-cannot-be-faked 1753 (if article-cannot-be-faked
1722 (gnus-request-article-this-buffer 1754 (gnus-request-article-this-buffer
1723 article 1755 article
1724 group) 1756 group)
1725 ;; else, we fake the article 1757 ;; else, we fake the article
1726 (when fake-headers (insert fake-headers))) 1758 (when fake-headers (insert fake-headers)))
1727 (if (or (null first-method) 1759 (if (or (null first-method)
1728 (equal first-method 'default)) 1760 (equal first-method 'default))
1729 (spam-split) 1761 (spam-split)
1730 (apply 'spam-split methods)))))) 1762 (apply 'spam-split methods))))))
1731 (if (equal split-return 'spam) 1763 (if (equal split-return 'spam)
1732 (gnus-summary-mark-article article gnus-spam-mark)) 1764 (gnus-summary-mark-article article gnus-spam-mark))
1733 1765
1734 (when (and id split-return spam-log-to-registry) 1766 (when (and id split-return spam-log-to-registry)
1735 (when (zerop (gnus-registry-group-count id)) 1767 (when (zerop (gnus-registry-group-count id))
1736 (gnus-registry-add-group 1768 (gnus-registry-add-group
1737 id group subject sender)) 1769 id group subject sender))
1738 1770
1739 (unless registry-lookup 1771 (unless registry-lookup
1740 (spam-log-processing-to-registry 1772 (spam-log-processing-to-registry
1741 id 1773 id
1742 'incoming 1774 'incoming
1743 split-return 1775 split-return
1744 spam-split-last-successful-check 1776 spam-split-last-successful-check
1745 group)))))) 1777 group))))))
1746 articles)))) 1778 articles))))
1747 1779
1748 ;;}}} 1780 ;;}}}
1749 1781
1750 ;;{{{ registration/unregistration functions 1782 ;;{{{ registration/unregistration functions
1752 (defun spam-resolve-registrations-routine () 1784 (defun spam-resolve-registrations-routine ()
1753 "Go through the backends and register or unregister articles as needed." 1785 "Go through the backends and register or unregister articles as needed."
1754 (dolist (backend-type '(non-mover mover)) 1786 (dolist (backend-type '(non-mover mover))
1755 (dolist (classification (spam-classifications)) 1787 (dolist (classification (spam-classifications))
1756 (dolist (backend (spam-backend-list backend-type)) 1788 (dolist (backend (spam-backend-list backend-type))
1757 (let ((rlist (spam-backend-get-article-todo-list 1789 (let ((rlist (spam-backend-get-article-todo-list
1758 backend classification)) 1790 backend classification))
1759 (ulist (spam-backend-get-article-todo-list 1791 (ulist (spam-backend-get-article-todo-list
1760 backend classification t)) 1792 backend classification t))
1761 (delcount 0)) 1793 (delcount 0))
1762 1794
1763 ;; clear the old lists right away 1795 ;; clear the old lists right away
1764 (spam-backend-put-article-todo-list backend 1796 (spam-backend-put-article-todo-list backend
1765 classification 1797 classification
1766 nil 1798 nil
1767 nil) 1799 nil)
1768 (spam-backend-put-article-todo-list backend 1800 (spam-backend-put-article-todo-list backend
1769 classification 1801 classification
1770 nil 1802 nil
1771 t) 1803 t)
1772 1804
1773 ;; eliminate duplicates 1805 ;; eliminate duplicates
1774 (dolist (article (copy-sequence ulist)) 1806 (dolist (article (copy-sequence ulist))
1775 (when (memq article rlist) 1807 (when (memq article rlist)
1776 (incf delcount) 1808 (incf delcount)
1777 (setq rlist (delq article rlist)) 1809 (setq rlist (delq article rlist))
1778 (setq ulist (delq article ulist)))) 1810 (setq ulist (delq article ulist))))
1779 1811
1780 (unless (zerop delcount) 1812 (unless (zerop delcount)
1781 (gnus-message 1813 (gnus-message
1782 9 1814 9
1783 "%d messages were saved the trouble of unregistering and then registering" 1815 "%d messages did not have to unregister and then register"
1784 delcount)) 1816 delcount))
1785 1817
1786 ;; unregister articles 1818 ;; unregister articles
1787 (unless (zerop (length ulist)) 1819 (unless (zerop (length ulist))
1788 (let ((num (spam-unregister-routine classification backend ulist))) 1820 (let ((num (spam-unregister-routine classification backend ulist)))
1789 (when (> num 0) 1821 (when (> num 0)
1790 (gnus-message 1822 (gnus-message
1791 6 1823 6
1792 "%d %s messages were unregistered by backend %s." 1824 "%d %s messages were unregistered by backend %s."
1793 num 1825 num
1794 classification 1826 classification
1795 backend)))) 1827 backend))))
1796 1828
1797 ;; register articles 1829 ;; register articles
1798 (unless (zerop (length rlist)) 1830 (unless (zerop (length rlist))
1799 (let ((num (spam-register-routine classification backend rlist))) 1831 (let ((num (spam-register-routine classification backend rlist)))
1800 (when (> num 0) 1832 (when (> num 0)
1801 (gnus-message 1833 (gnus-message
1802 6 1834 6
1803 "%d %s messages were registered by backend %s." 1835 "%d %s messages were registered by backend %s."
1804 num 1836 num
1805 classification 1837 classification
1806 backend))))))))) 1838 backend)))))))))
1807 1839
1808 (defun spam-unregister-routine (classification 1840 (defun spam-unregister-routine (classification
1809 backend 1841 backend
1810 specific-articles) 1842 specific-articles)
1811 (spam-register-routine classification backend specific-articles t)) 1843 (spam-register-routine classification backend specific-articles t))
1812 1844
1813 (defun spam-register-routine (classification 1845 (defun spam-register-routine (classification
1814 backend 1846 backend
1815 specific-articles 1847 specific-articles
1816 &optional unregister) 1848 &optional unregister)
1817 (when (and (spam-classification-valid-p classification) 1849 (when (and (spam-classification-valid-p classification)
1818 (spam-backend-valid-p backend)) 1850 (spam-backend-valid-p backend))
1819 (let* ((register-function 1851 (let* ((register-function
1820 (spam-backend-function backend classification 'registration)) 1852 (spam-backend-function backend classification 'registration))
1821 (unregister-function 1853 (unregister-function
1822 (spam-backend-function backend classification 'unregistration)) 1854 (spam-backend-function backend classification 'unregistration))
1823 (run-function (if unregister 1855 (run-function (if unregister
1824 unregister-function 1856 unregister-function
1825 register-function)) 1857 register-function))
1826 (log-function (if unregister 1858 (log-function (if unregister
1827 'spam-log-undo-registration 1859 'spam-log-undo-registration
1828 'spam-log-processing-to-registry)) 1860 'spam-log-processing-to-registry))
1829 article articles) 1861 article articles)
1830 1862
1831 (when run-function 1863 (when run-function
1832 ;; make list of articles, using specific-articles if given 1864 ;; make list of articles, using specific-articles if given
1833 (setq articles (or specific-articles 1865 (setq articles (or specific-articles
1834 (spam-list-articles 1866 (spam-list-articles
1835 gnus-newsgroup-articles 1867 gnus-newsgroup-articles
1836 classification))) 1868 classification)))
1837 ;; process them 1869 ;; process them
1838 (when (> (length articles) 0) 1870 (when (> (length articles) 0)
1839 (gnus-message 5 "%s %d %s articles as %s using backend %s" 1871 (gnus-message 5 "%s %d %s articles as %s using backend %s"
1840 (if unregister "Unregistering" "Registering") 1872 (if unregister "Unregistering" "Registering")
1841 (length articles) 1873 (length articles)
1842 (if specific-articles "specific" "") 1874 (if specific-articles "specific" "")
1843 classification 1875 classification
1844 backend) 1876 backend)
1845 (funcall run-function articles) 1877 (funcall run-function articles)
1846 ;; now log all the registrations (or undo them, depending on 1878 ;; now log all the registrations (or undo them, depending on
1847 ;; unregister) 1879 ;; unregister)
1848 (dolist (article articles) 1880 (dolist (article articles)
1849 (funcall log-function 1881 (funcall log-function
1850 (spam-fetch-field-message-id-fast article) 1882 (spam-fetch-field-message-id-fast article)
1851 'process 1883 'process
1852 classification 1884 classification
1853 backend 1885 backend
1854 gnus-newsgroup-name)))) 1886 gnus-newsgroup-name))))
1855 ;; return the number of articles processed 1887 ;; return the number of articles processed
1856 (length articles)))) 1888 (length articles))))
1857 1889
1858 ;;; log a ham- or spam-processor invocation to the registry 1890 ;;; log a ham- or spam-processor invocation to the registry
1859 (defun spam-log-processing-to-registry (id type classification backend group) 1891 (defun spam-log-processing-to-registry (id type classification backend group)
1860 (when spam-log-to-registry 1892 (when spam-log-to-registry
1861 (if (and (stringp id) 1893 (if (and (stringp id)
1862 (stringp group) 1894 (stringp group)
1863 (spam-process-type-valid-p type) 1895 (spam-process-type-valid-p type)
1864 (spam-classification-valid-p classification) 1896 (spam-classification-valid-p classification)
1865 (spam-backend-valid-p backend)) 1897 (spam-backend-valid-p backend))
1866 (let ((cell-list (cdr-safe (gnus-registry-fetch-extra id type))) 1898 (let ((cell-list (cdr-safe (gnus-registry-fetch-extra id type)))
1867 (cell (list classification backend group))) 1899 (cell (list classification backend group)))
1868 (push cell cell-list) 1900 (push cell cell-list)
1869 (gnus-registry-store-extra-entry 1901 (gnus-registry-store-extra-entry
1870 id 1902 id
1871 type 1903 type
1872 cell-list)) 1904 cell-list))
1873 1905
1874 (gnus-error 1906 (gnus-error
1875 7 1907 7
1876 (format "%s call with bad ID, type, classification, spam-backend, or group" 1908 (format
1877 "spam-log-processing-to-registry"))))) 1909 "%s call with bad ID, type, classification, spam-backend, or group"
1910 "spam-log-processing-to-registry")))))
1878 1911
1879 ;;; check if a ham- or spam-processor registration has been done 1912 ;;; check if a ham- or spam-processor registration has been done
1880 (defun spam-log-registered-p (id type) 1913 (defun spam-log-registered-p (id type)
1881 (when spam-log-to-registry 1914 (when spam-log-to-registry
1882 (if (and (stringp id) 1915 (if (and (stringp id)
1883 (spam-process-type-valid-p type)) 1916 (spam-process-type-valid-p type))
1884 (cdr-safe (gnus-registry-fetch-extra id type)) 1917 (cdr-safe (gnus-registry-fetch-extra id type))
1885 (progn 1918 (progn
1886 (gnus-error 1919 (gnus-error
1887 7 1920 7
1888 (format "%s called with bad ID, type, classification, or spam-backend" 1921 (format "%s called with bad ID, type, classification, or spam-backend"
1889 "spam-log-registered-p")) 1922 "spam-log-registered-p"))
1890 nil)))) 1923 nil))))
1891 1924
1892 ;;; check what a ham- or spam-processor registration says 1925 ;;; check what a ham- or spam-processor registration says
1893 ;;; returns nil if conflicting registrations are found 1926 ;;; returns nil if conflicting registrations are found
1894 (defun spam-log-registration-type (id type) 1927 (defun spam-log-registration-type (id type)
1895 (let ((count 0) 1928 (let ((count 0)
1896 decision) 1929 decision)
1897 (dolist (reg (spam-log-registered-p id type)) 1930 (dolist (reg (spam-log-registered-p id type))
1898 (let ((classification (nth 0 reg))) 1931 (let ((classification (nth 0 reg)))
1899 (when (spam-classification-valid-p classification) 1932 (when (spam-classification-valid-p classification)
1900 (when (and decision 1933 (when (and decision
1901 (not (eq classification decision))) 1934 (not (eq classification decision)))
1902 (setq count (+ 1 count))) 1935 (setq count (+ 1 count)))
1903 (setq decision classification)))) 1936 (setq decision classification))))
1904 (if (< 0 count) 1937 (if (< 0 count)
1905 nil 1938 nil
1906 decision))) 1939 decision)))
1907 1940
1908 1941
1909 ;;; check if a ham- or spam-processor registration needs to be undone 1942 ;;; check if a ham- or spam-processor registration needs to be undone
1910 (defun spam-log-unregistration-needed-p (id type classification backend) 1943 (defun spam-log-unregistration-needed-p (id type classification backend)
1911 (when spam-log-to-registry 1944 (when spam-log-to-registry
1912 (if (and (stringp id) 1945 (if (and (stringp id)
1913 (spam-process-type-valid-p type) 1946 (spam-process-type-valid-p type)
1914 (spam-classification-valid-p classification) 1947 (spam-classification-valid-p classification)
1915 (spam-backend-valid-p backend)) 1948 (spam-backend-valid-p backend))
1916 (let ((cell-list (cdr-safe (gnus-registry-fetch-extra id type))) 1949 (let ((cell-list (cdr-safe (gnus-registry-fetch-extra id type)))
1917 found) 1950 found)
1918 (dolist (cell cell-list) 1951 (dolist (cell cell-list)
1919 (unless found 1952 (unless found
1920 (when (and (eq classification (nth 0 cell)) 1953 (when (and (eq classification (nth 0 cell))
1921 (eq backend (nth 1 cell))) 1954 (eq backend (nth 1 cell)))
1922 (setq found t)))) 1955 (setq found t))))
1923 found) 1956 found)
1924 (progn 1957 (progn
1925 (gnus-error 1958 (gnus-error
1926 7 1959 7
1927 (format "%s called with bad ID, type, classification, or spam-backend" 1960 (format "%s called with bad ID, type, classification, or spam-backend"
1928 "spam-log-unregistration-needed-p")) 1961 "spam-log-unregistration-needed-p"))
1929 nil)))) 1962 nil))))
1930 1963
1931 1964
1932 ;;; undo a ham- or spam-processor registration (the group is not used) 1965 ;;; undo a ham- or spam-processor registration (the group is not used)
1933 (defun spam-log-undo-registration (id type classification backend &optional group) 1966 (defun spam-log-undo-registration (id type classification backend
1967 &optional group)
1934 (when (and spam-log-to-registry 1968 (when (and spam-log-to-registry
1935 (spam-log-unregistration-needed-p id type classification backend)) 1969 (spam-log-unregistration-needed-p id type classification backend))
1936 (if (and (stringp id) 1970 (if (and (stringp id)
1937 (spam-process-type-valid-p type) 1971 (spam-process-type-valid-p type)
1938 (spam-classification-valid-p classification) 1972 (spam-classification-valid-p classification)
1939 (spam-backend-valid-p backend)) 1973 (spam-backend-valid-p backend))
1940 (let ((cell-list (cdr-safe (gnus-registry-fetch-extra id type))) 1974 (let ((cell-list (cdr-safe (gnus-registry-fetch-extra id type)))
1941 new-cell-list found) 1975 new-cell-list found)
1942 (dolist (cell cell-list) 1976 (dolist (cell cell-list)
1943 (unless (and (eq classification (nth 0 cell)) 1977 (unless (and (eq classification (nth 0 cell))
1944 (eq backend (nth 1 cell))) 1978 (eq backend (nth 1 cell)))
1945 (push cell new-cell-list))) 1979 (push cell new-cell-list)))
1946 (gnus-registry-store-extra-entry 1980 (gnus-registry-store-extra-entry
1947 id 1981 id
1948 type 1982 type
1949 new-cell-list)) 1983 new-cell-list))
1950 (progn 1984 (progn
1951 (gnus-error 7 (format "%s call with bad ID, type, spam-backend, or group" 1985 (gnus-error 7 (format
1952 "spam-log-undo-registration")) 1986 "%s call with bad ID, type, spam-backend, or group"
1953 nil)))) 1987 "spam-log-undo-registration"))
1988 nil))))
1954 1989
1955 ;;}}} 1990 ;;}}}
1956 1991
1957 ;;{{{ backend functions 1992 ;;{{{ backend functions
1958 1993
1959 ;;{{{ Gmane xrefs 1994 ;;{{{ Gmane xrefs
1960 (defun spam-check-gmane-xref () 1995 (defun spam-check-gmane-xref ()
1961 (let ((header (or 1996 (let ((header (or
1962 (message-fetch-field "Xref") 1997 (message-fetch-field "Xref")
1963 (message-fetch-field "Newsgroups")))) 1998 (message-fetch-field "Newsgroups"))))
1964 (when header ; return nil when no header 1999 (when header ; return nil when no header
1965 (when (string-match spam-gmane-xref-spam-group 2000 (when (string-match spam-gmane-xref-spam-group
1966 header) 2001 header)
1967 spam-split-group)))) 2002 spam-split-group))))
1968 2003
1969 ;;}}} 2004 ;;}}}
1970 2005
1971 ;;{{{ Regex body 2006 ;;{{{ Regex body
1972 2007
1973 (defun spam-check-regex-body () 2008 (defun spam-check-regex-body ()
1974 (let ((spam-regex-headers-ham spam-regex-body-ham) 2009 (let ((spam-regex-headers-ham spam-regex-body-ham)
1975 (spam-regex-headers-spam spam-regex-body-spam)) 2010 (spam-regex-headers-spam spam-regex-body-spam))
1976 (spam-check-regex-headers t))) 2011 (spam-check-regex-headers t)))
1977 2012
1978 ;;}}} 2013 ;;}}}
1979 2014
1980 ;;{{{ Regex headers 2015 ;;{{{ Regex headers
1981 2016
1982 (defun spam-check-regex-headers (&optional body) 2017 (defun spam-check-regex-headers (&optional body)
1983 (let ((type (if body "body" "header")) 2018 (let ((type (if body "body" "header"))
1984 ret found) 2019 ret found)
1985 (dolist (h-regex spam-regex-headers-ham) 2020 (dolist (h-regex spam-regex-headers-ham)
1986 (unless found 2021 (unless found
1987 (goto-char (point-min)) 2022 (goto-char (point-min))
1988 (when (re-search-forward h-regex nil t) 2023 (when (re-search-forward h-regex nil t)
1989 (message "Ham regex %s search positive." type) 2024 (message "Ham regex %s search positive." type)
1990 (setq found t)))) 2025 (setq found t))))
1991 (dolist (s-regex spam-regex-headers-spam) 2026 (dolist (s-regex spam-regex-headers-spam)
1992 (unless found 2027 (unless found
1993 (goto-char (point-min)) 2028 (goto-char (point-min))
1994 (when (re-search-forward s-regex nil t) 2029 (when (re-search-forward s-regex nil t)
1995 (message "Spam regex %s search positive." type) 2030 (message "Spam regex %s search positive." type)
1996 (setq found t) 2031 (setq found t)
1997 (setq ret spam-split-group)))) 2032 (setq ret spam-split-group))))
1998 ret)) 2033 ret))
1999 2034
2000 ;;}}} 2035 ;;}}}
2001 2036
2002 ;;{{{ Blackholes. 2037 ;;{{{ Blackholes.
2003 2038
2004 (defun spam-reverse-ip-string (ip) 2039 (defun spam-reverse-ip-string (ip)
2005 (when (stringp ip) 2040 (when (stringp ip)
2006 (mapconcat 'identity 2041 (mapconcat 'identity
2007 (nreverse (split-string ip "\\.")) 2042 (nreverse (split-string ip "\\."))
2008 "."))) 2043 ".")))
2009 2044
2010 (defun spam-check-blackholes () 2045 (defun spam-check-blackholes ()
2011 "Check the Received headers for blackholed relays." 2046 "Check the Received headers for blackholed relays."
2012 (let ((headers (message-fetch-field "received")) 2047 (let ((headers (message-fetch-field "received"))
2013 ips matches) 2048 ips matches)
2014 (when headers 2049 (when headers
2015 (with-temp-buffer 2050 (with-temp-buffer
2016 (insert headers) 2051 (insert headers)
2017 (goto-char (point-min)) 2052 (goto-char (point-min))
2018 (gnus-message 6 "Checking headers for relay addresses") 2053 (gnus-message 6 "Checking headers for relay addresses")
2019 (while (re-search-forward 2054 (while (re-search-forward
2020 "\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\)" nil t) 2055 "\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\)" nil t)
2021 (gnus-message 9 "Blackhole search found host IP %s." (match-string 1)) 2056 (gnus-message 9 "Blackhole search found host IP %s." (match-string 1))
2022 (push (spam-reverse-ip-string (match-string 1)) 2057 (push (spam-reverse-ip-string (match-string 1))
2023 ips))) 2058 ips)))
2024 (dolist (server spam-blackhole-servers) 2059 (dolist (server spam-blackhole-servers)
2025 (dolist (ip ips) 2060 (dolist (ip ips)
2026 (unless (and spam-blackhole-good-server-regex 2061 (unless (and spam-blackhole-good-server-regex
2027 ;; match the good-server-regex against the reversed (again) IP string 2062 ;; match against the reversed (again) IP string
2028 (string-match 2063 (string-match
2029 spam-blackhole-good-server-regex 2064 spam-blackhole-good-server-regex
2030 (spam-reverse-ip-string ip))) 2065 (spam-reverse-ip-string ip)))
2031 (unless matches 2066 (unless matches
2032 (let ((query-string (concat ip "." server))) 2067 (let ((query-string (concat ip "." server)))
2033 (if spam-use-dig 2068 (if spam-use-dig
2034 (let ((query-result (query-dig query-string))) 2069 (let ((query-result (query-dig query-string)))
2035 (when query-result 2070 (when query-result
2036 (gnus-message 6 "(DIG): positive blackhole check '%s'" 2071 (gnus-message 6 "(DIG): positive blackhole check '%s'"
2037 query-result) 2072 query-result)
2038 (push (list ip server query-result) 2073 (push (list ip server query-result)
2039 matches))) 2074 matches)))
2040 ;; else, if not using dig.el 2075 ;; else, if not using dig.el
2041 (when (dns-query query-string) 2076 (when (dns-query query-string)
2042 (gnus-message 6 "positive blackhole check") 2077 (gnus-message 6 "positive blackhole check")
2043 (push (list ip server (dns-query query-string 'TXT)) 2078 (push (list ip server (dns-query query-string 'TXT))
2044 matches))))))))) 2079 matches)))))))))
2045 (when matches 2080 (when matches
2046 spam-split-group))) 2081 spam-split-group)))
2047 ;;}}} 2082 ;;}}}
2048 2083
2049 ;;{{{ Hashcash. 2084 ;;{{{ Hashcash.
2050 2085
2051 (defun spam-check-hashcash () 2086 (defun spam-check-hashcash ()
2052 "Check the headers for hashcash payments." 2087 "Check the headers for hashcash payments."
2053 (ignore-errors (mail-check-payment))) ;mail-check-payment returns a boolean 2088 (ignore-errors (mail-check-payment))) ;mail-check-payment returns a boolean
2054 2089
2055 ;;}}} 2090 ;;}}}
2056 2091
2057 ;;{{{ BBDB 2092 ;;{{{ BBDB
2058 2093
2069 ;; Autoloaded in message, which we require. 2104 ;; Autoloaded in message, which we require.
2070 (declare-function gnus-extract-address-components "gnus-util" (from)) 2105 (declare-function gnus-extract-address-components "gnus-util" (from))
2071 2106
2072 (eval-and-compile 2107 (eval-and-compile
2073 (when (condition-case nil 2108 (when (condition-case nil
2074 (progn 2109 (progn
2075 (require 'bbdb) 2110 (require 'bbdb)
2076 (require 'bbdb-com)) 2111 (require 'bbdb-com))
2077 (file-error 2112 (file-error
2078 ;; `bbdb-records' should not be bound as an autoload function 2113 ;; `bbdb-records' should not be bound as an autoload function
2079 ;; before loading bbdb because of `bbdb-hashtable-size'. 2114 ;; before loading bbdb because of `bbdb-hashtable-size'.
2080 (defalias 'bbdb-records 'ignore) 2115 (defalias 'bbdb-records 'ignore)
2081 (defalias 'spam-BBDB-register-routine 'ignore) 2116 (defalias 'spam-BBDB-register-routine 'ignore)
2082 (defalias 'spam-enter-ham-BBDB 'ignore) 2117 (defalias 'spam-enter-ham-BBDB 'ignore)
2083 nil)) 2118 nil))
2084 2119
2085 ;; when the BBDB changes, we want to clear out our cache 2120 ;; when the BBDB changes, we want to clear out our cache
2086 (defun spam-clear-cache-BBDB (&rest immaterial) 2121 (defun spam-clear-cache-BBDB (&rest immaterial)
2087 (spam-clear-cache 'spam-use-BBDB)) 2122 (spam-clear-cache 'spam-use-BBDB))
2088 2123
2089 (add-hook 'bbdb-change-hook 'spam-clear-cache-BBDB) 2124 (add-hook 'bbdb-change-hook 'spam-clear-cache-BBDB)
2090 2125
2091 (defun spam-enter-ham-BBDB (addresses &optional remove) 2126 (defun spam-enter-ham-BBDB (addresses &optional remove)
2092 "Enter an address into the BBDB; implies ham (non-spam) sender" 2127 "Enter an address into the BBDB; implies ham (non-spam) sender"
2093 (dolist (from addresses) 2128 (dolist (from addresses)
2094 (when (stringp from) 2129 (when (stringp from)
2095 (let* ((parsed-address (gnus-extract-address-components from)) 2130 (let* ((parsed-address (gnus-extract-address-components from))
2096 (name (or (nth 0 parsed-address) "Ham Sender")) 2131 (name (or (nth 0 parsed-address) "Ham Sender"))
2097 (remove-function (if remove 2132 (remove-function (if remove
2098 'bbdb-delete-record-internal 2133 'bbdb-delete-record-internal
2099 'ignore)) 2134 'ignore))
2100 (net-address (nth 1 parsed-address)) 2135 (net-address (nth 1 parsed-address))
2101 (record (and net-address 2136 (record (and net-address
2102 (bbdb-search-simple nil net-address)))) 2137 (bbdb-search-simple nil net-address))))
2103 (when net-address 2138 (when net-address
2104 (gnus-message 6 "%s address %s %s BBDB" 2139 (gnus-message 6 "%s address %s %s BBDB"
2105 (if remove "Deleting" "Adding") 2140 (if remove "Deleting" "Adding")
2106 from 2141 from
2107 (if remove "from" "to")) 2142 (if remove "from" "to"))
2108 (if record 2143 (if record
2109 (funcall remove-function record) 2144 (funcall remove-function record)
2110 (bbdb-create-internal name nil net-address nil nil 2145 (bbdb-create-internal name nil net-address nil nil
2111 "ham sender added by spam.el"))))))) 2146 "ham sender added by spam.el")))))))
2112 2147
2113 (defun spam-BBDB-register-routine (articles &optional unregister) 2148 (defun spam-BBDB-register-routine (articles &optional unregister)
2114 (let (addresses) 2149 (let (addresses)
2115 (dolist (article articles) 2150 (dolist (article articles)
2116 (when (stringp (spam-fetch-field-from-fast article)) 2151 (when (stringp (spam-fetch-field-from-fast article))
2117 (push (spam-fetch-field-from-fast article) addresses))) 2152 (push (spam-fetch-field-from-fast article) addresses)))
2118 ;; now do the register/unregister action 2153 ;; now do the register/unregister action
2119 (spam-enter-ham-BBDB addresses unregister))) 2154 (spam-enter-ham-BBDB addresses unregister)))
2120 2155
2121 (defun spam-BBDB-unregister-routine (articles) 2156 (defun spam-BBDB-unregister-routine (articles)
2122 (spam-BBDB-register-routine articles t)) 2157 (spam-BBDB-register-routine articles t))
2123 2158
2124 (defun spam-check-BBDB () 2159 (defun spam-check-BBDB ()
2125 "Mail from people in the BBDB is classified as ham or non-spam" 2160 "Mail from people in the BBDB is classified as ham or non-spam"
2126 (let ((who (message-fetch-field "from")) 2161 (let ((who (message-fetch-field "from"))
2127 bbdb-cache bbdb-hashtable) 2162 bbdb-cache bbdb-hashtable)
2128 (when spam-cache-lookups 2163 (when spam-cache-lookups
2129 (setq bbdb-cache (gethash 'spam-use-BBDB spam-caches)) 2164 (setq bbdb-cache (gethash 'spam-use-BBDB spam-caches))
2130 (unless bbdb-cache 2165 (unless bbdb-cache
2131 (setq bbdb-cache (make-vector 17 0)) ; a good starting hash value 2166 (setq bbdb-cache (make-vector 17 0)) ; a good starting hash value
2132 ;; this is based on the expanded (bbdb-hashtable) macro 2167 ;; this is based on the expanded (bbdb-hashtable) macro
2133 ;; without the debugging support 2168 ;; without the debugging support
2134 (with-current-buffer (bbdb-buffer) 2169 (with-current-buffer (bbdb-buffer)
2135 (save-excursion 2170 (save-excursion
2136 (save-window-excursion 2171 (save-window-excursion
2137 (bbdb-records nil t) 2172 (bbdb-records nil t)
2138 (mapatoms 2173 (mapatoms
2139 (lambda (symbol) 2174 (lambda (symbol)
2140 (intern (downcase (symbol-name symbol)) bbdb-cache)) 2175 (intern (downcase (symbol-name symbol)) bbdb-cache))
2141 bbdb-hashtable)))) 2176 bbdb-hashtable))))
2142 (puthash 'spam-use-BBDB bbdb-cache spam-caches))) 2177 (puthash 'spam-use-BBDB bbdb-cache spam-caches)))
2143 (when who 2178 (when who
2144 (setq who (nth 1 (gnus-extract-address-components who))) 2179 (setq who (nth 1 (gnus-extract-address-components who)))
2145 (if 2180 (if
2146 (if spam-cache-lookups 2181 (if spam-cache-lookups
2147 (intern-soft (downcase who) bbdb-cache) 2182 (intern-soft (downcase who) bbdb-cache)
2148 (bbdb-search-simple nil who)) 2183 (bbdb-search-simple nil who))
2149 t 2184 t
2150 (if spam-use-BBDB-exclusive 2185 (if spam-use-BBDB-exclusive
2151 spam-split-group 2186 spam-split-group
2152 nil))))))) 2187 nil)))))))
2153 2188
2154 ;;}}} 2189 ;;}}}
2155 2190
2156 ;;{{{ ifile 2191 ;;{{{ ifile
2157 2192
2167 nil)) 2202 nil))
2168 2203
2169 (defun spam-check-ifile () 2204 (defun spam-check-ifile ()
2170 "Check the ifile backend for the classification of this message." 2205 "Check the ifile backend for the classification of this message."
2171 (let ((article-buffer-name (buffer-name)) 2206 (let ((article-buffer-name (buffer-name))
2172 category return) 2207 category return)
2173 (with-temp-buffer 2208 (with-temp-buffer
2174 (let ((temp-buffer-name (buffer-name)) 2209 (let ((temp-buffer-name (buffer-name))
2175 (db-param (spam-get-ifile-database-parameter))) 2210 (db-param (spam-get-ifile-database-parameter)))
2176 (with-current-buffer article-buffer-name 2211 (with-current-buffer article-buffer-name
2177 (apply 'call-process-region 2212 (apply 'call-process-region
2178 (point-min) (point-max) spam-ifile-program 2213 (point-min) (point-max) spam-ifile-program
2179 nil temp-buffer-name nil "-c" 2214 nil temp-buffer-name nil "-c"
2180 (if db-param `(,db-param "-q") `("-q")))) 2215 (if db-param `(,db-param "-q") `("-q"))))
2181 ;; check the return now (we're back in the temp buffer) 2216 ;; check the return now (we're back in the temp buffer)
2182 (goto-char (point-min)) 2217 (goto-char (point-min))
2183 (if (not (eobp)) 2218 (if (not (eobp))
2184 (setq category (buffer-substring (point) (point-at-eol)))) 2219 (setq category (buffer-substring (point) (point-at-eol))))
2185 (when (not (zerop (length category))) ; we need a category here 2220 (when (not (zerop (length category))) ; we need a category here
2186 (if spam-ifile-all-categories 2221 (if spam-ifile-all-categories
2187 (setq return category) 2222 (setq return category)
2188 ;; else, if spam-ifile-all-categories is not set... 2223 ;; else, if spam-ifile-all-categories is not set...
2189 (when (string-equal spam-ifile-spam-category category) 2224 (when (string-equal spam-ifile-spam-category category)
2190 (setq return spam-split-group)))))) ; note return is nil otherwise 2225 (setq return spam-split-group)))))) ; note return is nil otherwise
2191 return)) 2226 return))
2192 2227
2193 (defun spam-ifile-register-with-ifile (articles category &optional unregister) 2228 (defun spam-ifile-register-with-ifile (articles category &optional unregister)
2194 "Register an article, given as a string, with a category. 2229 "Register an article, given as a string, with a category.
2195 Uses `gnus-newsgroup-name' if category is nil (for ham registration)." 2230 Uses `gnus-newsgroup-name' if category is nil (for ham registration)."
2196 (let ((category (or category gnus-newsgroup-name)) 2231 (let ((category (or category gnus-newsgroup-name))
2197 (add-or-delete-option (if unregister "-d" "-i")) 2232 (add-or-delete-option (if unregister "-d" "-i"))
2198 (db (spam-get-ifile-database-parameter)) 2233 (db (spam-get-ifile-database-parameter))
2199 parameters) 2234 parameters)
2200 (with-temp-buffer 2235 (with-temp-buffer
2201 (dolist (article articles) 2236 (dolist (article articles)
2202 (let ((article-string (spam-get-article-as-string article))) 2237 (let ((article-string (spam-get-article-as-string article)))
2203 (when (stringp article-string) 2238 (when (stringp article-string)
2204 (insert article-string)))) 2239 (insert article-string))))
2205 (apply 'call-process-region 2240 (apply 'call-process-region
2206 (point-min) (point-max) spam-ifile-program 2241 (point-min) (point-max) spam-ifile-program
2207 nil nil nil 2242 nil nil nil
2208 add-or-delete-option category 2243 add-or-delete-option category
2209 (if db `(,db "-h") `("-h")))))) 2244 (if db `(,db "-h") `("-h"))))))
2210 2245
2211 (defun spam-ifile-register-spam-routine (articles &optional unregister) 2246 (defun spam-ifile-register-spam-routine (articles &optional unregister)
2212 (spam-ifile-register-with-ifile articles spam-ifile-spam-category unregister)) 2247 (spam-ifile-register-with-ifile articles spam-ifile-spam-category unregister))
2213 2248
2214 (defun spam-ifile-unregister-spam-routine (articles) 2249 (defun spam-ifile-unregister-spam-routine (articles)
2233 (autoload 'spam-stat-save "spam-stat") 2268 (autoload 'spam-stat-save "spam-stat")
2234 (autoload 'spam-stat-split-fancy "spam-stat")) 2269 (autoload 'spam-stat-split-fancy "spam-stat"))
2235 2270
2236 (eval-and-compile 2271 (eval-and-compile
2237 (when (condition-case nil 2272 (when (condition-case nil
2238 (let ((spam-stat-install-hooks nil)) 2273 (let ((spam-stat-install-hooks nil))
2239 (require 'spam-stat)) 2274 (require 'spam-stat))
2240 (file-error 2275 (file-error
2241 (defalias 'spam-stat-register-ham-routine 'ignore) 2276 (defalias 'spam-stat-register-ham-routine 'ignore)
2242 (defalias 'spam-stat-register-spam-routine 'ignore) 2277 (defalias 'spam-stat-register-spam-routine 'ignore)
2243 nil)) 2278 nil))
2244 2279
2245 (defun spam-check-stat () 2280 (defun spam-check-stat ()
2246 "Check the spam-stat backend for the classification of this message" 2281 "Check the spam-stat backend for the classification of this message"
2247 (let ((spam-stat-split-fancy-spam-group spam-split-group) ; override 2282 (let ((spam-stat-split-fancy-spam-group spam-split-group) ; override
2248 (spam-stat-buffer (buffer-name)) ; stat the current buffer 2283 (spam-stat-buffer (buffer-name)) ; stat the current buffer
2249 category return) 2284 category return)
2250 (spam-stat-split-fancy))) 2285 (spam-stat-split-fancy)))
2251 2286
2252 (defun spam-stat-register-spam-routine (articles &optional unregister) 2287 (defun spam-stat-register-spam-routine (articles &optional unregister)
2253 (dolist (article articles) 2288 (dolist (article articles)
2254 (let ((article-string (spam-get-article-as-string article))) 2289 (let ((article-string (spam-get-article-as-string article)))
2255 (with-temp-buffer 2290 (with-temp-buffer
2256 (insert article-string) 2291 (insert article-string)
2257 (if unregister 2292 (if unregister
2258 (spam-stat-buffer-change-to-non-spam) 2293 (spam-stat-buffer-change-to-non-spam)
2259 (spam-stat-buffer-is-spam)))))) 2294 (spam-stat-buffer-is-spam))))))
2260 2295
2261 (defun spam-stat-unregister-spam-routine (articles) 2296 (defun spam-stat-unregister-spam-routine (articles)
2262 (spam-stat-register-spam-routine articles t)) 2297 (spam-stat-register-spam-routine articles t))
2263 2298
2264 (defun spam-stat-register-ham-routine (articles &optional unregister) 2299 (defun spam-stat-register-ham-routine (articles &optional unregister)
2265 (dolist (article articles) 2300 (dolist (article articles)
2266 (let ((article-string (spam-get-article-as-string article))) 2301 (let ((article-string (spam-get-article-as-string article)))
2267 (with-temp-buffer 2302 (with-temp-buffer
2268 (insert article-string) 2303 (insert article-string)
2269 (if unregister 2304 (if unregister
2270 (spam-stat-buffer-change-to-spam) 2305 (spam-stat-buffer-change-to-spam)
2271 (spam-stat-buffer-is-non-spam)))))) 2306 (spam-stat-buffer-is-non-spam))))))
2272 2307
2273 (defun spam-stat-unregister-ham-routine (articles) 2308 (defun spam-stat-unregister-ham-routine (articles)
2274 (spam-stat-register-ham-routine articles t)) 2309 (spam-stat-register-ham-routine articles t))
2275 2310
2276 (defun spam-maybe-spam-stat-load () 2311 (defun spam-maybe-spam-stat-load ()
2319 (unless (file-exists-p (file-name-directory file)) 2354 (unless (file-exists-p (file-name-directory file))
2320 (make-directory (file-name-directory file) t)) 2355 (make-directory (file-name-directory file) t))
2321 (with-current-buffer 2356 (with-current-buffer
2322 (find-file-noselect file) 2357 (find-file-noselect file)
2323 (dolist (a addresses) 2358 (dolist (a addresses)
2324 (when (stringp a) 2359 (when (stringp a)
2325 (goto-char (point-min)) 2360 (goto-char (point-min))
2326 (if (re-search-forward (regexp-quote a) nil t) 2361 (if (re-search-forward (regexp-quote a) nil t)
2327 ;; found the address 2362 ;; found the address
2328 (when remove 2363 (when remove
2329 (spam-kill-whole-line)) 2364 (spam-kill-whole-line))
2330 ;; else, the address was not found 2365 ;; else, the address was not found
2331 (unless remove 2366 (unless remove
2332 (goto-char (point-max)) 2367 (goto-char (point-max))
2333 (unless (bobp) 2368 (unless (bobp)
2334 (insert "\n")) 2369 (insert "\n"))
2335 (insert a "\n"))))) 2370 (insert a "\n")))))
2336 (save-buffer)))) 2371 (save-buffer))))
2337 2372
2338 (defun spam-filelist-build-cache (type) 2373 (defun spam-filelist-build-cache (type)
2339 (let ((cache (if (eq type 'spam-use-blacklist) 2374 (let ((cache (if (eq type 'spam-use-blacklist)
2340 spam-blacklist-cache 2375 spam-blacklist-cache
2341 spam-whitelist-cache)) 2376 spam-whitelist-cache))
2342 parsed-cache) 2377 parsed-cache)
2343 (unless (gethash type spam-caches) 2378 (unless (gethash type spam-caches)
2344 (while cache 2379 (while cache
2345 (let ((address (pop cache))) 2380 (let ((address (pop cache)))
2346 (unless (zerop (length address)) ; 0 for a nil address too 2381 (unless (zerop (length address)) ; 0 for a nil address too
2347 (setq address (regexp-quote address)) 2382 (setq address (regexp-quote address))
2348 ;; fix regexp-quote's treatment of user-intended regexes 2383 ;; fix regexp-quote's treatment of user-intended regexes
2349 (while (string-match "\\\\\\*" address) 2384 (while (string-match "\\\\\\*" address)
2350 (setq address (replace-match ".*" t t address)))) 2385 (setq address (replace-match ".*" t t address))))
2351 (push address parsed-cache))) 2386 (push address parsed-cache)))
2352 (puthash type parsed-cache spam-caches)))) 2387 (puthash type parsed-cache spam-caches))))
2353 2388
2354 (defun spam-filelist-check-cache (type from) 2389 (defun spam-filelist-check-cache (type from)
2355 (when (stringp from) 2390 (when (stringp from)
2356 (spam-filelist-build-cache type) 2391 (spam-filelist-build-cache type)
2357 (let (found) 2392 (let (found)
2358 (dolist (address (gethash type spam-caches)) 2393 (dolist (address (gethash type spam-caches))
2359 (when (and address (string-match address from)) 2394 (when (and address (string-match address from))
2360 (setq found t) 2395 (setq found t)
2361 (return))) 2396 (return)))
2362 found))) 2397 found)))
2363 2398
2364 ;;; returns t if the sender is in the whitelist, nil or 2399 ;;; returns t if the sender is in the whitelist, nil or
2365 ;;; spam-split-group otherwise 2400 ;;; spam-split-group otherwise
2366 (defun spam-check-whitelist () 2401 (defun spam-check-whitelist ()
2368 (unless spam-whitelist-cache 2403 (unless spam-whitelist-cache
2369 (setq spam-whitelist-cache (spam-parse-list spam-whitelist))) 2404 (setq spam-whitelist-cache (spam-parse-list spam-whitelist)))
2370 (if (spam-from-listed-p 'spam-use-whitelist) 2405 (if (spam-from-listed-p 'spam-use-whitelist)
2371 t 2406 t
2372 (if spam-use-whitelist-exclusive 2407 (if spam-use-whitelist-exclusive
2373 spam-split-group 2408 spam-split-group
2374 nil))) 2409 nil)))
2375 2410
2376 (defun spam-check-blacklist () 2411 (defun spam-check-blacklist ()
2377 ;; FIXME! Should it detect when file timestamps change? 2412 ;; FIXME! Should it detect when file timestamps change?
2378 (unless spam-blacklist-cache 2413 (unless spam-blacklist-cache
2382 2417
2383 (defun spam-parse-list (file) 2418 (defun spam-parse-list (file)
2384 (when (file-readable-p file) 2419 (when (file-readable-p file)
2385 (let (contents address) 2420 (let (contents address)
2386 (with-temp-buffer 2421 (with-temp-buffer
2387 (insert-file-contents file) 2422 (insert-file-contents file)
2388 (while (not (eobp)) 2423 (while (not (eobp))
2389 (setq address (buffer-substring (point) (point-at-eol))) 2424 (setq address (buffer-substring (point) (point-at-eol)))
2390 (forward-line 1) 2425 (forward-line 1)
2391 ;; insert the e-mail address if detected, otherwise the raw data 2426 ;; insert the e-mail address if detected, otherwise the raw data
2392 (unless (zerop (length address)) 2427 (unless (zerop (length address))
2393 (let ((pure-address (nth 1 (gnus-extract-address-components address)))) 2428 (let ((pure-address
2394 (push (or pure-address address) contents))))) 2429 (nth 1 (gnus-extract-address-components address))))
2430 (push (or pure-address address) contents)))))
2395 (nreverse contents)))) 2431 (nreverse contents))))
2396 2432
2397 (defun spam-from-listed-p (type) 2433 (defun spam-from-listed-p (type)
2398 (let ((from (message-fetch-field "from")) 2434 (let ((from (message-fetch-field "from"))
2399 found) 2435 found)
2400 (spam-filelist-check-cache type from))) 2436 (spam-filelist-check-cache type from)))
2401 2437
2402 (defun spam-filelist-register-routine (articles blacklist &optional unregister) 2438 (defun spam-filelist-register-routine (articles blacklist &optional unregister)
2403 (let ((de-symbol (if blacklist 'spam-use-whitelist 'spam-use-blacklist)) 2439 (let ((de-symbol (if blacklist 'spam-use-whitelist 'spam-use-blacklist))
2404 (declassification (if blacklist 'ham 'spam)) 2440 (declassification (if blacklist 'ham 'spam))
2405 (enter-function 2441 (enter-function
2406 (if blacklist 'spam-enter-blacklist 'spam-enter-whitelist)) 2442 (if blacklist 'spam-enter-blacklist 'spam-enter-whitelist))
2407 (remove-function 2443 (remove-function
2408 (if blacklist 'spam-enter-whitelist 'spam-enter-blacklist)) 2444 (if blacklist 'spam-enter-whitelist 'spam-enter-blacklist))
2409 from addresses unregister-list article-unregister-list) 2445 from addresses unregister-list article-unregister-list)
2410 (dolist (article articles) 2446 (dolist (article articles)
2411 (let ((from (spam-fetch-field-from-fast article)) 2447 (let ((from (spam-fetch-field-from-fast article))
2412 (id (spam-fetch-field-message-id-fast article)) 2448 (id (spam-fetch-field-message-id-fast article))
2413 sender-ignored) 2449 sender-ignored)
2414 (when (stringp from) 2450 (when (stringp from)
2415 (dolist (ignore-regex spam-blacklist-ignored-regexes) 2451 (dolist (ignore-regex spam-blacklist-ignored-regexes)
2416 (when (and (not sender-ignored) 2452 (when (and (not sender-ignored)
2417 (stringp ignore-regex) 2453 (stringp ignore-regex)
2418 (string-match ignore-regex from)) 2454 (string-match ignore-regex from))
2419 (setq sender-ignored t))) 2455 (setq sender-ignored t)))
2420 ;; remember the messages we need to unregister, unless remove is set 2456 ;; remember the messages we need to unregister, unless remove is set
2421 (when (and 2457 (when (and
2422 (null unregister) 2458 (null unregister)
2423 (spam-log-unregistration-needed-p 2459 (spam-log-unregistration-needed-p
2424 id 'process declassification de-symbol)) 2460 id 'process declassification de-symbol))
2425 (push article article-unregister-list) 2461 (push article article-unregister-list)
2426 (push from unregister-list)) 2462 (push from unregister-list))
2427 (unless sender-ignored 2463 (unless sender-ignored
2428 (push from addresses))))) 2464 (push from addresses)))))
2429 2465
2430 (if unregister 2466 (if unregister
2431 (funcall enter-function addresses t) ; unregister all these addresses 2467 (funcall enter-function addresses t) ; unregister all these addresses
2432 ;; else, register normally and unregister what we need to 2468 ;; else, register normally and unregister what we need to
2433 (funcall remove-function unregister-list t) 2469 (funcall remove-function unregister-list t)
2434 (dolist (article article-unregister-list) 2470 (dolist (article article-unregister-list)
2435 (spam-log-undo-registration 2471 (spam-log-undo-registration
2436 (spam-fetch-field-message-id-fast article) 2472 (spam-fetch-field-message-id-fast article)
2437 'process 2473 'process
2438 declassification 2474 declassification
2439 de-symbol)) 2475 de-symbol))
2440 (funcall enter-function addresses nil)))) 2476 (funcall enter-function addresses nil))))
2441 2477
2442 (defun spam-blacklist-unregister-routine (articles) 2478 (defun spam-blacklist-unregister-routine (articles)
2443 (spam-blacklist-register-routine articles t)) 2479 (spam-blacklist-register-routine articles t))
2444 2480
2465 (defun spam-report-resend-register-ham-routine (articles) 2501 (defun spam-report-resend-register-ham-routine (articles)
2466 (spam-report-resend-register-routine articles t)) 2502 (spam-report-resend-register-routine articles t))
2467 2503
2468 (defun spam-report-resend-register-routine (articles &optional ham) 2504 (defun spam-report-resend-register-routine (articles &optional ham)
2469 (let* ((resend-to-gp 2505 (let* ((resend-to-gp
2470 (if ham 2506 (if ham
2471 (gnus-parameter-ham-resend-to gnus-newsgroup-name) 2507 (gnus-parameter-ham-resend-to gnus-newsgroup-name)
2472 (gnus-parameter-spam-resend-to gnus-newsgroup-name))) 2508 (gnus-parameter-spam-resend-to gnus-newsgroup-name)))
2473 (spam-report-resend-to (or (car-safe resend-to-gp) 2509 (spam-report-resend-to (or (car-safe resend-to-gp)
2474 spam-report-resend-to))) 2510 spam-report-resend-to)))
2475 (spam-report-resend articles ham))) 2511 (spam-report-resend articles ham)))
2476 2512
2477 ;;}}} 2513 ;;}}}
2478 2514
2479 ;;{{{ Bogofilter 2515 ;;{{{ Bogofilter
2480 (defun spam-check-bogofilter-headers (&optional score) 2516 (defun spam-check-bogofilter-headers (&optional score)
2481 (let ((header (message-fetch-field spam-bogofilter-header))) 2517 (let ((header (message-fetch-field spam-bogofilter-header)))
2482 (when header ; return nil when no header 2518 (when header ; return nil when no header
2483 (if score ; scoring mode 2519 (if score ; scoring mode
2484 (if (string-match "spamicity=\\([0-9.]+\\)" header) 2520 (if (string-match "spamicity=\\([0-9.]+\\)" header)
2485 (match-string 1 header) 2521 (match-string 1 header)
2486 "0") 2522 "0")
2487 ;; spam detection mode 2523 ;; spam detection mode
2488 (when (string-match spam-bogofilter-bogosity-positive-spam-header 2524 (when (string-match spam-bogofilter-bogosity-positive-spam-header
2489 header) 2525 header)
2490 spam-split-group))))) 2526 spam-split-group)))))
2491 2527
2492 ;; return something sensible if the score can't be determined 2528 ;; return something sensible if the score can't be determined
2493 (defun spam-bogofilter-score (&optional recheck) 2529 (defun spam-bogofilter-score (&optional recheck)
2494 "Get the Bogofilter spamicity score." 2530 "Get the Bogofilter spamicity score."
2495 (interactive "P") 2531 (interactive "P")
2496 (save-window-excursion 2532 (save-window-excursion
2497 (gnus-summary-show-article t) 2533 (gnus-summary-show-article t)
2498 (set-buffer gnus-article-buffer) 2534 (set-buffer gnus-article-buffer)
2499 (let ((score (or (unless recheck 2535 (let ((score (or (unless recheck
2500 (spam-check-bogofilter-headers t)) 2536 (spam-check-bogofilter-headers t))
2501 (spam-check-bogofilter t)))) 2537 (spam-check-bogofilter t))))
2502 (gnus-summary-show-article) 2538 (gnus-summary-show-article)
2503 (message "Spamicity score %s" score) 2539 (message "Spamicity score %s" score)
2504 (or score "0")))) 2540 (or score "0"))))
2505 2541
2506 (defun spam-verify-bogofilter () 2542 (defun spam-verify-bogofilter ()
2507 "Verify the Bogofilter version is sufficient." 2543 "Verify the Bogofilter version is sufficient."
2508 (when (eq spam-bogofilter-valid 'unknown) 2544 (when (eq spam-bogofilter-valid 'unknown)
2509 (setq spam-bogofilter-valid 2545 (setq spam-bogofilter-valid
2510 (not (string-match "^bogofilter version 0\\.\\([0-9]\\|1[01]\\)\\." 2546 (not (string-match "^bogofilter version 0\\.\\([0-9]\\|1[01]\\)\\."
2511 (shell-command-to-string 2547 (shell-command-to-string
2512 (format "%s -V" spam-bogofilter-program)))))) 2548 (format "%s -V" spam-bogofilter-program))))))
2513 spam-bogofilter-valid) 2549 spam-bogofilter-valid)
2514 2550
2515 (defun spam-check-bogofilter (&optional score) 2551 (defun spam-check-bogofilter (&optional score)
2516 "Check the Bogofilter backend for the classification of this message." 2552 "Check the Bogofilter backend for the classification of this message."
2517 (if (spam-verify-bogofilter) 2553 (if (spam-verify-bogofilter)
2518 (let ((article-buffer-name (buffer-name)) 2554 (let ((article-buffer-name (buffer-name))
2519 (db spam-bogofilter-database-directory) 2555 (db spam-bogofilter-database-directory)
2520 return) 2556 return)
2521 (with-temp-buffer 2557 (with-temp-buffer
2522 (let ((temp-buffer-name (buffer-name))) 2558 (let ((temp-buffer-name (buffer-name)))
2523 (with-current-buffer article-buffer-name 2559 (with-current-buffer article-buffer-name
2524 (apply 'call-process-region 2560 (apply 'call-process-region
2525 (point-min) (point-max) 2561 (point-min) (point-max)
2526 spam-bogofilter-program 2562 spam-bogofilter-program
2527 nil temp-buffer-name nil 2563 nil temp-buffer-name nil
2528 (if db `("-d" ,db "-v") `("-v")))) 2564 (if db `("-d" ,db "-v") `("-v"))))
2529 (setq return (spam-check-bogofilter-headers score)))) 2565 (setq return (spam-check-bogofilter-headers score))))
2530 return) 2566 return)
2531 (gnus-error 5 "`spam.el' doesn't support obsolete bogofilter versions"))) 2567 (gnus-error 5 "`spam.el' doesn't support obsolete bogofilter versions")))
2532 2568
2533 (defun spam-bogofilter-register-with-bogofilter (articles 2569 (defun spam-bogofilter-register-with-bogofilter (articles
2534 spam 2570 spam
2535 &optional unregister) 2571 &optional unregister)
2536 "Register an article, given as a string, as spam or non-spam." 2572 "Register an article, given as a string, as spam or non-spam."
2537 (if (spam-verify-bogofilter) 2573 (if (spam-verify-bogofilter)
2538 (dolist (article articles) 2574 (dolist (article articles)
2539 (let ((article-string (spam-get-article-as-string article)) 2575 (let ((article-string (spam-get-article-as-string article))
2540 (db spam-bogofilter-database-directory) 2576 (db spam-bogofilter-database-directory)
2541 (switch (if unregister 2577 (switch (if unregister
2542 (if spam 2578 (if spam
2543 spam-bogofilter-spam-strong-switch 2579 spam-bogofilter-spam-strong-switch
2544 spam-bogofilter-ham-strong-switch) 2580 spam-bogofilter-ham-strong-switch)
2545 (if spam 2581 (if spam
2546 spam-bogofilter-spam-switch 2582 spam-bogofilter-spam-switch
2547 spam-bogofilter-ham-switch)))) 2583 spam-bogofilter-ham-switch))))
2548 (when (stringp article-string) 2584 (when (stringp article-string)
2549 (with-temp-buffer 2585 (with-temp-buffer
2550 (insert article-string) 2586 (insert article-string)
2551 2587
2552 (apply 'call-process-region 2588 (apply 'call-process-region
2553 (point-min) (point-max) 2589 (point-min) (point-max)
2554 spam-bogofilter-program 2590 spam-bogofilter-program
2555 nil nil nil switch 2591 nil nil nil switch
2556 (if db `("-d" ,db "-v") `("-v"))))))) 2592 (if db `("-d" ,db "-v") `("-v")))))))
2557 (gnus-error 5 "`spam.el' doesn't support obsolete bogofilter versions"))) 2593 (gnus-error 5 "`spam.el' doesn't support obsolete bogofilter versions")))
2558 2594
2559 (defun spam-bogofilter-register-spam-routine (articles &optional unregister) 2595 (defun spam-bogofilter-register-spam-routine (articles &optional unregister)
2560 (spam-bogofilter-register-with-bogofilter articles t unregister)) 2596 (spam-bogofilter-register-with-bogofilter articles t unregister))
2561 2597
2575 (defun spam-check-spamoracle () 2611 (defun spam-check-spamoracle ()
2576 "Run spamoracle on an article to determine whether it's spam." 2612 "Run spamoracle on an article to determine whether it's spam."
2577 (let ((article-buffer-name (buffer-name))) 2613 (let ((article-buffer-name (buffer-name)))
2578 (with-temp-buffer 2614 (with-temp-buffer
2579 (let ((temp-buffer-name (buffer-name))) 2615 (let ((temp-buffer-name (buffer-name)))
2580 (with-current-buffer article-buffer-name 2616 (with-current-buffer article-buffer-name
2581 (let ((status 2617 (let ((status
2582 (apply 'call-process-region 2618 (apply 'call-process-region
2583 (point-min) (point-max) 2619 (point-min) (point-max)
2584 spam-spamoracle-binary 2620 spam-spamoracle-binary
2585 nil temp-buffer-name nil 2621 nil temp-buffer-name nil
2586 (if spam-spamoracle-database 2622 (if spam-spamoracle-database
2587 `("-f" ,spam-spamoracle-database "mark") 2623 `("-f" ,spam-spamoracle-database "mark")
2588 '("mark"))))) 2624 '("mark")))))
2589 (if (eq 0 status) 2625 (if (eq 0 status)
2590 (progn 2626 (progn
2591 (set-buffer temp-buffer-name) 2627 (set-buffer temp-buffer-name)
2592 (goto-char (point-min)) 2628 (goto-char (point-min))
2593 (when (re-search-forward "^X-Spam: yes;" nil t) 2629 (when (re-search-forward "^X-Spam: yes;" nil t)
2594 spam-split-group)) 2630 spam-split-group))
2595 (error "Error running spamoracle: %s" status)))))))) 2631 (error "Error running spamoracle: %s" status))))))))
2596 2632
2597 (defun spam-spamoracle-learn (articles article-is-spam-p &optional unregister) 2633 (defun spam-spamoracle-learn (articles article-is-spam-p &optional unregister)
2598 "Run spamoracle in training mode." 2634 "Run spamoracle in training mode."
2599 (with-temp-buffer 2635 (with-temp-buffer
2600 (let ((temp-buffer-name (buffer-name))) 2636 (let ((temp-buffer-name (buffer-name)))
2601 (save-excursion 2637 (save-excursion
2602 (goto-char (point-min)) 2638 (goto-char (point-min))
2603 (dolist (article articles) 2639 (dolist (article articles)
2604 (insert (spam-get-article-as-string article))) 2640 (insert (spam-get-article-as-string article)))
2605 (let* ((arg (if (spam-xor unregister article-is-spam-p) 2641 (let* ((arg (if (spam-xor unregister article-is-spam-p)
2606 "-spam" 2642 "-spam"
2607 "-good")) 2643 "-good"))
2608 (status 2644 (status
2609 (apply 'call-process-region 2645 (apply 'call-process-region
2610 (point-min) (point-max) 2646 (point-min) (point-max)
2611 spam-spamoracle-binary 2647 spam-spamoracle-binary
2612 nil temp-buffer-name nil 2648 nil temp-buffer-name nil
2613 (if spam-spamoracle-database 2649 (if spam-spamoracle-database
2614 `("-f" ,spam-spamoracle-database 2650 `("-f" ,spam-spamoracle-database
2615 "add" ,arg) 2651 "add" ,arg)
2616 `("add" ,arg))))) 2652 `("add" ,arg)))))
2617 (unless (eq 0 status) 2653 (unless (eq 0 status)
2618 (error "Error running spamoracle: %s" status))))))) 2654 (error "Error running spamoracle: %s" status)))))))
2619 2655
2620 (defun spam-spamoracle-learn-ham (articles &optional unregister) 2656 (defun spam-spamoracle-learn-ham (articles &optional unregister)
2621 (spam-spamoracle-learn articles nil unregister)) 2657 (spam-spamoracle-learn articles nil unregister))
2622 2658
2623 (defun spam-spamoracle-unlearn-ham (articles &optional unregister) 2659 (defun spam-spamoracle-unlearn-ham (articles &optional unregister)
2633 2669
2634 ;;{{{ SpamAssassin 2670 ;;{{{ SpamAssassin
2635 ;;; based mostly on the bogofilter code 2671 ;;; based mostly on the bogofilter code
2636 (defun spam-check-spamassassin-headers (&optional score) 2672 (defun spam-check-spamassassin-headers (&optional score)
2637 "Check the SpamAssassin headers for the classification of this message." 2673 "Check the SpamAssassin headers for the classification of this message."
2638 (if score ; scoring mode 2674 (if score ; scoring mode
2639 (let ((header (message-fetch-field spam-spamassassin-spam-status-header))) 2675 (let ((header (message-fetch-field spam-spamassassin-spam-status-header)))
2640 (when header 2676 (when header
2641 (if (string-match spam-spamassassin-score-regexp header) 2677 (if (string-match spam-spamassassin-score-regexp header)
2642 (match-string 1 header) 2678 (match-string 1 header)
2643 "0"))) 2679 "0")))
2644 ;; spam detection mode 2680 ;; spam detection mode
2645 (let ((header (message-fetch-field spam-spamassassin-spam-flag-header))) 2681 (let ((header (message-fetch-field spam-spamassassin-spam-flag-header)))
2646 (when header ; return nil when no header 2682 (when header ; return nil when no header
2647 (when (string-match spam-spamassassin-positive-spam-flag-header 2683 (when (string-match spam-spamassassin-positive-spam-flag-header
2648 header) 2684 header)
2649 spam-split-group))))) 2685 spam-split-group)))))
2650 2686
2651 (defun spam-check-spamassassin (&optional score) 2687 (defun spam-check-spamassassin (&optional score)
2652 "Check the SpamAssassin backend for the classification of this message." 2688 "Check the SpamAssassin backend for the classification of this message."
2653 (let ((article-buffer-name (buffer-name))) 2689 (let ((article-buffer-name (buffer-name)))
2654 (with-temp-buffer 2690 (with-temp-buffer
2655 (let ((temp-buffer-name (buffer-name))) 2691 (let ((temp-buffer-name (buffer-name)))
2656 (with-current-buffer article-buffer-name 2692 (with-current-buffer article-buffer-name
2657 (apply 'call-process-region 2693 (apply 'call-process-region
2658 (point-min) (point-max) spam-assassin-program 2694 (point-min) (point-max) spam-assassin-program
2659 nil temp-buffer-name nil spam-spamassassin-arguments)) 2695 nil temp-buffer-name nil spam-spamassassin-arguments))
2660 ;; check the return now (we're back in the temp buffer) 2696 ;; check the return now (we're back in the temp buffer)
2661 (goto-char (point-min)) 2697 (goto-char (point-min))
2662 (spam-check-spamassassin-headers score))))) 2698 (spam-check-spamassassin-headers score)))))
2663 2699
2664 ;; return something sensible if the score can't be determined 2700 ;; return something sensible if the score can't be determined
2665 (defun spam-spamassassin-score (&optional recheck) 2701 (defun spam-spamassassin-score (&optional recheck)
2666 "Get the SpamAssassin score" 2702 "Get the SpamAssassin score"
2667 (interactive "P") 2703 (interactive "P")
2668 (save-window-excursion 2704 (save-window-excursion
2669 (gnus-summary-show-article t) 2705 (gnus-summary-show-article t)
2670 (set-buffer gnus-article-buffer) 2706 (set-buffer gnus-article-buffer)
2671 (let ((score (or (unless recheck 2707 (let ((score (or (unless recheck
2672 (spam-check-spamassassin-headers t)) 2708 (spam-check-spamassassin-headers t))
2673 (spam-check-spamassassin t)))) 2709 (spam-check-spamassassin t))))
2674 (gnus-summary-show-article) 2710 (gnus-summary-show-article)
2675 (message "SpamAssassin score %s" score) 2711 (message "SpamAssassin score %s" score)
2676 (or score "0")))) 2712 (or score "0"))))
2677 2713
2678 (defun spam-spamassassin-register-with-sa-learn (articles spam 2714 (defun spam-spamassassin-register-with-sa-learn (articles spam
2679 &optional unregister) 2715 &optional unregister)
2680 "Register articles with spamassassin's sa-learn as spam or non-spam." 2716 "Register articles with spamassassin's sa-learn as spam or non-spam."
2681 (if articles 2717 (if articles
2682 (let ((action (if unregister spam-sa-learn-unregister-switch 2718 (let ((action (if unregister spam-sa-learn-unregister-switch
2683 (if spam spam-sa-learn-spam-switch 2719 (if spam spam-sa-learn-spam-switch
2684 spam-sa-learn-ham-switch))) 2720 spam-sa-learn-ham-switch)))
2685 (summary-buffer-name (buffer-name))) 2721 (summary-buffer-name (buffer-name)))
2686 (with-temp-buffer 2722 (with-temp-buffer
2687 ;; group the articles into mbox format 2723 ;; group the articles into mbox format
2688 (dolist (article articles) 2724 (dolist (article articles)
2689 (let (article-string) 2725 (let (article-string)
2690 (with-current-buffer summary-buffer-name 2726 (with-current-buffer summary-buffer-name
2691 (setq article-string (spam-get-article-as-string article))) 2727 (setq article-string (spam-get-article-as-string article)))
2692 (when (stringp article-string) 2728 (when (stringp article-string)
2693 (insert "From \n") ; mbox separator (sa-learn only checks the 2729 (insert "From \n") ; mbox separator (sa-learn only checks the
2694 ; first five chars, so we can get away with 2730 ; first five chars, so we can get away with
2695 ; a bogus line)) 2731 ; a bogus line))
2696 (insert article-string) 2732 (insert article-string)
2697 (insert "\n")))) 2733 (insert "\n"))))
2698 ;; call sa-learn on all messages at the same time 2734 ;; call sa-learn on all messages at the same time
2699 (apply 'call-process-region 2735 (apply 'call-process-region
2700 (point-min) (point-max) 2736 (point-min) (point-max)
2701 spam-sa-learn-program 2737 spam-sa-learn-program
2702 nil nil nil "--mbox" 2738 nil nil nil "--mbox"
2703 (if spam-sa-learn-rebuild 2739 (if spam-sa-learn-rebuild
2704 (list action) 2740 (list action)
2705 `("--no-rebuild" ,action))))))) 2741 `("--no-rebuild" ,action)))))))
2706 2742
2707 (defun spam-spamassassin-register-spam-routine (articles &optional unregister) 2743 (defun spam-spamassassin-register-spam-routine (articles &optional unregister)
2708 (spam-spamassassin-register-with-sa-learn articles t unregister)) 2744 (spam-spamassassin-register-with-sa-learn articles t unregister))
2709 2745
2710 (defun spam-spamassassin-register-ham-routine (articles &optional unregister) 2746 (defun spam-spamassassin-register-ham-routine (articles &optional unregister)
2721 ;;{{{ Bsfilter 2757 ;;{{{ Bsfilter
2722 ;;; based mostly on the bogofilter code 2758 ;;; based mostly on the bogofilter code
2723 (defun spam-check-bsfilter-headers (&optional score) 2759 (defun spam-check-bsfilter-headers (&optional score)
2724 (if score 2760 (if score
2725 (or (nnmail-fetch-field spam-bsfilter-probability-header) 2761 (or (nnmail-fetch-field spam-bsfilter-probability-header)
2726 "0") 2762 "0")
2727 (let ((header (nnmail-fetch-field spam-bsfilter-header))) 2763 (let ((header (nnmail-fetch-field spam-bsfilter-header)))
2728 (when header ; return nil when no header 2764 (when header ; return nil when no header
2729 (when (string-match "YES" header) 2765 (when (string-match "YES" header)
2730 spam-split-group))))) 2766 spam-split-group)))))
2731 2767
2732 ;; return something sensible if the score can't be determined 2768 ;; return something sensible if the score can't be determined
2733 (defun spam-bsfilter-score (&optional recheck) 2769 (defun spam-bsfilter-score (&optional recheck)
2734 "Get the Bsfilter spamicity score." 2770 "Get the Bsfilter spamicity score."
2735 (interactive "P") 2771 (interactive "P")
2736 (save-window-excursion 2772 (save-window-excursion
2737 (gnus-summary-show-article t) 2773 (gnus-summary-show-article t)
2738 (set-buffer gnus-article-buffer) 2774 (set-buffer gnus-article-buffer)
2739 (let ((score (or (unless recheck 2775 (let ((score (or (unless recheck
2740 (spam-check-bsfilter-headers t)) 2776 (spam-check-bsfilter-headers t))
2741 (spam-check-bsfilter t)))) 2777 (spam-check-bsfilter t))))
2742 (gnus-summary-show-article) 2778 (gnus-summary-show-article)
2743 (message "Spamicity score %s" score) 2779 (message "Spamicity score %s" score)
2744 (or score "0")))) 2780 (or score "0"))))
2745 2781
2746 (defun spam-check-bsfilter (&optional score) 2782 (defun spam-check-bsfilter (&optional score)
2747 "Check the Bsfilter backend for the classification of this message." 2783 "Check the Bsfilter backend for the classification of this message."
2748 (let ((article-buffer-name (buffer-name)) 2784 (let ((article-buffer-name (buffer-name))
2749 (dir spam-bsfilter-database-directory) 2785 (dir spam-bsfilter-database-directory)
2750 return) 2786 return)
2751 (with-temp-buffer 2787 (with-temp-buffer
2752 (let ((temp-buffer-name (buffer-name))) 2788 (let ((temp-buffer-name (buffer-name)))
2753 (with-current-buffer article-buffer-name 2789 (with-current-buffer article-buffer-name
2754 (apply 'call-process-region 2790 (apply 'call-process-region
2755 (point-min) (point-max) 2791 (point-min) (point-max)
2756 spam-bsfilter-program 2792 spam-bsfilter-program
2757 nil temp-buffer-name nil 2793 nil temp-buffer-name nil
2758 "--pipe" 2794 "--pipe"
2759 "--insert-flag" 2795 "--insert-flag"
2760 "--insert-probability" 2796 "--insert-probability"
2761 (when dir 2797 (when dir
2762 (list "--homedir" dir)))) 2798 (list "--homedir" dir))))
2763 (setq return (spam-check-bsfilter-headers score)))) 2799 (setq return (spam-check-bsfilter-headers score))))
2764 return)) 2800 return))
2765 2801
2766 (defun spam-bsfilter-register-with-bsfilter (articles 2802 (defun spam-bsfilter-register-with-bsfilter (articles
2767 spam 2803 spam
2768 &optional unregister) 2804 &optional unregister)
2769 "Register an article, given as a string, as spam or non-spam." 2805 "Register an article, given as a string, as spam or non-spam."
2770 (dolist (article articles) 2806 (dolist (article articles)
2771 (let ((article-string (spam-get-article-as-string article)) 2807 (let ((article-string (spam-get-article-as-string article))
2772 (switch (if unregister 2808 (switch (if unregister
2773 (if spam 2809 (if spam
2774 spam-bsfilter-spam-strong-switch 2810 spam-bsfilter-spam-strong-switch
2775 spam-bsfilter-ham-strong-switch) 2811 spam-bsfilter-ham-strong-switch)
2776 (if spam 2812 (if spam
2777 spam-bsfilter-spam-switch 2813 spam-bsfilter-spam-switch
2778 spam-bsfilter-ham-switch)))) 2814 spam-bsfilter-ham-switch))))
2779 (when (stringp article-string) 2815 (when (stringp article-string)
2780 (with-temp-buffer 2816 (with-temp-buffer
2781 (insert article-string) 2817 (insert article-string)
2782 (apply 'call-process-region 2818 (apply 'call-process-region
2783 (point-min) (point-max) 2819 (point-min) (point-max)
2784 spam-bsfilter-program 2820 spam-bsfilter-program
2785 nil nil nil switch 2821 nil nil nil switch
2786 "--update" 2822 "--update"
2787 (when spam-bsfilter-database-directory 2823 (when spam-bsfilter-database-directory
2788 (list "--homedir" 2824 (list "--homedir"
2789 spam-bsfilter-database-directory)))))))) 2825 spam-bsfilter-database-directory))))))))
2790 2826
2791 (defun spam-bsfilter-register-spam-routine (articles &optional unregister) 2827 (defun spam-bsfilter-register-spam-routine (articles &optional unregister)
2792 (spam-bsfilter-register-with-bsfilter articles t unregister)) 2828 (spam-bsfilter-register-with-bsfilter articles t unregister))
2793 2829
2794 (defun spam-bsfilter-unregister-spam-routine (articles) 2830 (defun spam-bsfilter-unregister-spam-routine (articles)
2803 ;;}}} 2839 ;;}}}
2804 2840
2805 ;;{{{ CRM114 Mailfilter 2841 ;;{{{ CRM114 Mailfilter
2806 (defun spam-check-crm114-headers (&optional score) 2842 (defun spam-check-crm114-headers (&optional score)
2807 (let ((header (message-fetch-field spam-crm114-header))) 2843 (let ((header (message-fetch-field spam-crm114-header)))
2808 (when header ; return nil when no header 2844 (when header ; return nil when no header
2809 (if score ; scoring mode 2845 (if score ; scoring mode
2810 (if (string-match "( pR: \\([0-9.-]+\\)" header) 2846 (if (string-match "( pR: \\([0-9.-]+\\)" header)
2811 (match-string 1 header) 2847 (match-string 1 header)
2812 "0") 2848 "0")
2813 ;; spam detection mode 2849 ;; spam detection mode
2814 (when (string-match spam-crm114-positive-spam-header 2850 (when (string-match spam-crm114-positive-spam-header
2815 header) 2851 header)
2816 spam-split-group))))) 2852 spam-split-group)))))
2817 2853
2818 ;; return something sensible if the score can't be determined 2854 ;; return something sensible if the score can't be determined
2819 (defun spam-crm114-score () 2855 (defun spam-crm114-score ()
2820 "Get the CRM114 Mailfilter pR." 2856 "Get the CRM114 Mailfilter pR."
2821 (interactive) 2857 (interactive)
2822 (save-window-excursion 2858 (save-window-excursion
2823 (gnus-summary-show-article t) 2859 (gnus-summary-show-article t)
2824 (set-buffer gnus-article-buffer) 2860 (set-buffer gnus-article-buffer)
2825 (let ((score (or (spam-check-crm114-headers t) 2861 (let ((score (or (spam-check-crm114-headers t)
2826 (spam-check-crm114 t)))) 2862 (spam-check-crm114 t))))
2827 (gnus-summary-show-article) 2863 (gnus-summary-show-article)
2828 (message "pR: %s" score) 2864 (message "pR: %s" score)
2829 (or score "0")))) 2865 (or score "0"))))
2830 2866
2831 (defun spam-check-crm114 (&optional score) 2867 (defun spam-check-crm114 (&optional score)
2832 "Check the CRM114 Mailfilter backend for the classification of this message." 2868 "Check the CRM114 Mailfilter backend for the classification of this message."
2833 (let ((article-buffer-name (buffer-name)) 2869 (let ((article-buffer-name (buffer-name))
2834 (db spam-crm114-database-directory) 2870 (db spam-crm114-database-directory)
2835 return) 2871 return)
2836 (with-temp-buffer 2872 (with-temp-buffer
2837 (let ((temp-buffer-name (buffer-name))) 2873 (let ((temp-buffer-name (buffer-name)))
2838 (with-current-buffer article-buffer-name 2874 (with-current-buffer article-buffer-name
2839 (apply 'call-process-region 2875 (apply 'call-process-region
2840 (point-min) (point-max) 2876 (point-min) (point-max)
2841 spam-crm114-program 2877 spam-crm114-program
2842 nil temp-buffer-name nil 2878 nil temp-buffer-name nil
2843 (when db (list (concat "--fileprefix=" db))))) 2879 (when db (list (concat "--fileprefix=" db)))))
2844 (setq return (spam-check-crm114-headers score)))) 2880 (setq return (spam-check-crm114-headers score))))
2845 return)) 2881 return))
2846 2882
2847 (defun spam-crm114-register-with-crm114 (articles 2883 (defun spam-crm114-register-with-crm114 (articles
2848 spam 2884 spam
2849 &optional unregister) 2885 &optional unregister)
2850 "Register an article, given as a string, as spam or non-spam." 2886 "Register an article, given as a string, as spam or non-spam."
2851 (dolist (article articles) 2887 (dolist (article articles)
2852 (let ((article-string (spam-get-article-as-string article)) 2888 (let ((article-string (spam-get-article-as-string article))
2853 (db spam-crm114-database-directory) 2889 (db spam-crm114-database-directory)
2854 (switch (if unregister 2890 (switch (if unregister
2855 (if spam 2891 (if spam
2856 spam-crm114-spam-strong-switch 2892 spam-crm114-spam-strong-switch
2857 spam-crm114-ham-strong-switch) 2893 spam-crm114-ham-strong-switch)
2858 (if spam 2894 (if spam
2859 spam-crm114-spam-switch 2895 spam-crm114-spam-switch
2860 spam-crm114-ham-switch)))) 2896 spam-crm114-ham-switch))))
2861 (when (stringp article-string) 2897 (when (stringp article-string)
2862 (with-temp-buffer 2898 (with-temp-buffer
2863 (insert article-string) 2899 (insert article-string)
2864 2900
2865 (apply 'call-process-region 2901 (apply 'call-process-region
2866 (point-min) (point-max) 2902 (point-min) (point-max)
2867 spam-crm114-program 2903 spam-crm114-program
2868 nil nil nil 2904 nil nil nil
2869 (when db (list switch (concat "--fileprefix=" db))))))))) 2905 (when db (list switch (concat "--fileprefix=" db)))))))))
2870 2906
2871 (defun spam-crm114-register-spam-routine (articles &optional unregister) 2907 (defun spam-crm114-register-spam-routine (articles &optional unregister)
2872 (spam-crm114-register-with-crm114 articles t unregister)) 2908 (spam-crm114-register-with-crm114 articles t unregister))
2873 2909
2903 (add-to-list 'gnus-extra-headers header)) 2939 (add-to-list 'gnus-extra-headers header))
2904 2940
2905 (setq spam-install-hooks t) 2941 (setq spam-install-hooks t)
2906 ;; TODO: How do we redo this every time the `spam' face is customized? 2942 ;; TODO: How do we redo this every time the `spam' face is customized?
2907 (push '((eq mark gnus-spam-mark) . spam) 2943 (push '((eq mark gnus-spam-mark) . spam)
2908 gnus-summary-highlight) 2944 gnus-summary-highlight)
2909 ;; Add hooks for loading and saving the spam stats 2945 ;; Add hooks for loading and saving the spam stats
2910 (add-hook 'gnus-save-newsrc-hook 'spam-maybe-spam-stat-save) 2946 (add-hook 'gnus-save-newsrc-hook 'spam-maybe-spam-stat-save)
2911 (add-hook 'gnus-get-top-new-news-hook 'spam-maybe-spam-stat-load) 2947 (add-hook 'gnus-get-top-new-news-hook 'spam-maybe-spam-stat-load)
2912 (add-hook 'gnus-startup-hook 'spam-maybe-spam-stat-load) 2948 (add-hook 'gnus-startup-hook 'spam-maybe-spam-stat-load)
2913 (add-hook 'gnus-summary-prepare-exit-hook 'spam-summary-prepare-exit) 2949 (add-hook 'gnus-summary-prepare-exit-hook 'spam-summary-prepare-exit)