wl/wl-spam.el

   1 ;;; wl-spam.el --- Spam filtering interface for Wanderlust.
   2
   3 ;; Copyright (C) 2003 Hiroya Murata <lapis-lazuli@pop06.odn.ne.jp>
   4 ;; Copyright (C) 2003 Yuuichi Teranishi <teranisi@gohome.org>
   5
   6 ;; Author: Hiroya Murata <lapis-lazuli@pop06.odn.ne.jp>
   7 ;; Keywords: mail, net news, spam
   8
   9 ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
  10
  11 ;; This program is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15 ;;
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20 ;;
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25 ;;
  26
  27 ;;; Commentary:
  28 ;;
  29
  30 ;;; Code:
  31 ;;
  32
  33 (eval-when-compile (require 'cl))
  34
  35 (require 'elmo-spam)
  36 (require 'wl-summary)
  37 (require 'wl-action)
  38 (require 'wl-highlight)
  39
  40 (defgroup wl-spam nil
  41   "Spam configuration for wanderlust."
  42   :group 'wl)
  43
  44 (defcustom wl-spam-folder "+spam"
  45   "*Spam folder."
  46   :type 'string
  47   :group 'wl-spam)
  48
  49 (defcustom wl-spam-undecided-folder-list nil
  50   "*List of folder name which is contained undecided domain.
  51 If an element is symbol, use symbol-value instead."
  52   :type '(repeat (choice (string :tag "Folder name")
  53                          (variable :tag "Variable")))
  54   :group 'wl-spam)
  55
  56 (defcustom wl-spam-undecided-folder-regexp-list '("inbox")
  57   "*List of folder regexp which is contained undecided domain."
  58   :type '(repeat (regexp :tag "Folder Regexp"))
  59   :group 'wl-spam)
  60
  61 (defcustom wl-spam-ignored-folder-list '(wl-draft-folder
  62                                          wl-trash-folder
  63                                          wl-queue-folder)
  64   "*List of folder name which is contained ignored domain.
  65 If an element is symbol, use symbol-value instead."
  66   :type '(repeat (choice (string :tag "Folder name")
  67                          (variable :tag "Variable")))
  68   :group 'wl-spam)
  69
  70 (defcustom wl-spam-ignored-folder-regexp-list nil
  71   "*List of folder regexp which is contained ignored domain."
  72   :type '(repeat (regexp :tag "Folder Regexp"))
  73   :group 'wl-spam)
  74
  75 (defcustom wl-spam-auto-check-folder-regexp-list nil
  76   "*List of Folder regexp which check spam automatically."
  77   :type '(repeat (regexp :tag "Folder Regexp"))
  78   :group 'wl-spam)
  79
  80 (defcustom wl-spam-auto-check-marks
  81   (list wl-summary-new-uncached-mark
  82         wl-summary-new-cached-mark)
  83   "Persistent marks to check spam automatically."
  84   :type '(choice (const :tag "All marks" all)
  85                  (repeat (string :tag "Mark")))
  86   :group 'wl-spam)
  87
  88 (wl-defface wl-highlight-summary-spam-face
  89   '((((type tty)
  90       (background dark))
  91      (:foreground "blue"))
  92     (((class color))
  93      (:foreground "LightSlateGray")))
  94   "Face used for displaying messages mark as spam."
  95   :group 'wl-summary-faces
  96   :group 'wl-faces)
  97
  98 (defcustom wl-spam-mark-action-list
  99   '(("s"
 100      spam
 101      nil
 102      wl-summary-register-temp-mark
 103      wl-summary-exec-action-spam
 104      wl-highlight-summary-spam-face
 105      "Mark messages as spam."))
 106   "A variable to define Mark & Action for spam.
 107 Append this value to `wl-summary-mark-action-list' by `wl-spam-setup'.
 108
 109 See `wl-summary-mark-action-list' for the detail of element."
 110   :type '(repeat (list
 111                   (string :tag "Temporary mark")
 112                   (symbol :tag "Action name")
 113                   (symbol :tag "Argument function")
 114                   (symbol :tag "Set mark function")
 115                   (symbol :tag "Exec function")
 116                   (symbol :tag "Face symbol")
 117                   (string :tag "Document string")))
 118   :group 'wl-spam)
 119
 120 (defsubst wl-spam-string-member-p (string list regexp-list)
 121   (or (wl-string-member string list)
 122       (wl-string-match-member string regexp-list)))
 123
 124 (defun wl-spam-domain (folder-name)
 125   (cond ((string= folder-name wl-spam-folder)
 126          'spam)
 127         ((wl-spam-string-member-p folder-name
 128                                   wl-spam-undecided-folder-list
 129                                   wl-spam-undecided-folder-regexp-list)
 130          'undecided)
 131         ((wl-spam-string-member-p folder-name
 132                                   wl-spam-ignored-folder-list
 133                                   wl-spam-ignored-folder-regexp-list)
 134          'ignore)
 135         (t
 136          'good)))
 137
 138 (defun wl-spam-split-numbers (folder numbers)
 139   (let (alist)
 140     (dolist (number numbers)
 141       (let* ((domain (wl-spam-domain
 142                       (elmo-folder-name-internal
 143                        (elmo-message-folder folder number))))
 144              (cell (assq domain alist)))
 145         (if cell
 146             (setcdr cell (cons number (cdr cell)))
 147           (setq alist (cons (list domain number) alist)))))
 148     alist))
 149
 150 (defsubst wl-spam-auto-check-message-p (folder number)
 151   (or (eq wl-spam-auto-check-marks 'all)
 152       (member (wl-summary-message-mark folder number)
 153               wl-spam-auto-check-marks)))
 154
 155 (defsubst wl-spam-map-spam-messages (folder numbers function &rest args)
 156   (elmo-with-progress-display (elmo-spam-check-spam (length numbers))
 157       "Checking spam"
 158     (dolist (number (elmo-spam-list-spam-messages (elmo-spam-processor)
 159                                                   folder
 160                                                   numbers))
 161       (apply function number args))))
 162
 163 (defun wl-spam-apply-partitions (folder partitions function msg)
 164   (when partitions
 165     (let ((total 0))
 166       (dolist (partition partitions)
 167         (setq total (+ total (length (cdr partition)))))
 168       (elmo-with-progress-display (elmo-spam-register total) msg
 169         (dolist (partition partitions)
 170           (funcall function folder (cdr partition) (car partition)))))))
 171
 172 (defun wl-spam-register-spam-messages (folder numbers)
 173   (elmo-with-progress-display (elmo-spam-register (length numbers))
 174       "Registering spam"
 175     (elmo-spam-register-spam-messages (elmo-spam-processor)
 176                                       folder
 177                                       numbers)))
 178
 179 (defun wl-spam-register-good-messages (folder numbers)
 180   (elmo-with-progress-display (elmo-spam-register (length numbers))
 181       "Registering good"
 182     (elmo-spam-register-good-messages (elmo-spam-processor)
 183                                       folder
 184                                       numbers)))
 185
 186 (defun wl-spam-save-status (&optional force)
 187   (interactive "P")
 188   (let ((processor (elmo-spam-processor (not force))))
 189     (when (or force
 190               (and processor (elmo-spam-modified-p processor)))
 191       (elmo-spam-save-status processor))))
 192
 193 ;; insinuate into summary mode
 194 (defvar wl-summary-spam-map nil)
 195
 196 (unless wl-summary-spam-map
 197   (let ((map (make-sparse-keymap)))
 198     (define-key map "m" 'wl-summary-spam)
 199     (define-key map "c" 'wl-summary-test-spam)
 200     (define-key map "C" 'wl-summary-mark-spam)
 201     (define-key map "s" 'wl-summary-register-as-spam)
 202     (define-key map "S" 'wl-summary-register-as-spam-all)
 203     (define-key map "n" 'wl-summary-register-as-good)
 204     (define-key map "N" 'wl-summary-register-as-good-all)
 205     (setq wl-summary-spam-map map)))
 206
 207 (eval-when-compile
 208   ;; Avoid compile warnings
 209   (defalias-maybe 'wl-summary-spam 'ignore)
 210   (defalias-maybe 'wl-summary-unmark-spam 'ignore))
 211
 212 (defun wl-summary-test-spam (&optional folder number)
 213   (interactive)
 214   (let ((folder (or folder wl-summary-buffer-elmo-folder))
 215         (number (or number (wl-summary-message-number)))
 216         spam)
 217     (message "Checking spam...")
 218     (if (setq spam (elmo-spam-message-spam-p (elmo-spam-processor)
 219                                              folder number))
 220         (wl-summary-spam number)
 221       (wl-summary-unmark-spam number))
 222     (message "Checking spam...done")
 223     (when (interactive-p)
 224       (message "No: %d is %sa spam message." number (if spam "" "not ")))))
 225
 226 (defun wl-summary-test-spam-messages (folder numbers &rest args)
 227   (elmo-with-progress-display (elmo-spam-check-spam (length numbers))
 228       "Checking spam"
 229     (let* ((spams (elmo-spam-list-spam-messages (elmo-spam-processor)
 230                                                 folder
 231                                                 numbers))
 232            (goods (car (elmo-list-diff numbers spams))))
 233       (dolist (number spams)
 234         (wl-summary-spam number args))
 235       (dolist (number goods)
 236         (wl-summary-unmark-spam number)))))
 237
 238 (defun wl-summary-test-spam-region (beg end)
 239   (interactive "r")
 240   (let ((numbers (wl-summary-collect-numbers-region beg end)))
 241     (cond (numbers
 242            (wl-summary-test-spam-messages wl-summary-buffer-elmo-folder
 243                                           numbers))
 244           ((interactive-p)
 245            (message "No message to test.")))))
 246
 247 (defun wl-thread-test-spam (&optional arg)
 248   (interactive "P")
 249   (wl-thread-call-region-func 'wl-summary-test-spam-region arg))
 250
 251 (defun wl-summary-mark-spam (&optional all)
 252   "Set spam mark to messages which is spam classification."
 253   (interactive "P")
 254   (let (numbers)
 255     (if all
 256         (setq numbers wl-summary-buffer-number-list)
 257       (dolist (number wl-summary-buffer-number-list)
 258         (when (wl-spam-auto-check-message-p wl-summary-buffer-elmo-folder
 259                                             number)
 260           (setq numbers (cons number numbers)))))
 261     (cond (numbers
 262            (wl-spam-map-spam-messages wl-summary-buffer-elmo-folder
 263                                       numbers
 264                                       #'wl-summary-spam))
 265           ((interactive-p)
 266            (message "No message to test.")))))
 267
 268 (defun wl-summary-register-as-spam ()
 269   (interactive)
 270   (let ((number (wl-summary-message-number)))
 271     (when number
 272       (wl-spam-register-spam-messages wl-summary-buffer-elmo-folder
 273                                       (list number)))))
 274
 275 (defun wl-summary-register-as-spam-region (beg end)
 276   (interactive "r")
 277   (let ((numbers (wl-summary-collect-numbers-region beg end)))
 278     (cond (numbers
 279            (wl-spam-register-spam-messages wl-summary-buffer-elmo-folder
 280                                            numbers))
 281           ((interactive-p)
 282            (message "No message to register as spam.")))))
 283
 284 (defun wl-thread-register-as-spam (&optional arg)
 285   (interactive "P")
 286   (wl-thread-call-region-func 'wl-summary-register-as-spam-region arg))
 287
 288 (defun wl-summary-register-as-spam-all ()
 289   (interactive)
 290   (wl-spam-register-spam-messages wl-summary-buffer-elmo-folder
 291                                   wl-summary-buffer-number-list))
 292
 293 (defun wl-summary-target-mark-register-as-spam ()
 294   (interactive)
 295   (save-excursion
 296     (goto-char (point-min))
 297     (let ((inhibit-read-only t)
 298           (buffer-read-only nil)
 299           wl-summary-buffer-disp-msg)
 300       (wl-spam-register-spam-messages wl-summary-buffer-elmo-folder
 301                                       wl-summary-buffer-target-mark-list)
 302       (dolist (number wl-summary-buffer-target-mark-list)
 303         (wl-summary-unset-mark number)))))
 304
 305 (defun wl-summary-register-as-good ()
 306   (interactive)
 307   (let ((number (wl-summary-message-number)))
 308     (when number
 309       (wl-spam-register-good-messages wl-summary-buffer-elmo-folder
 310                                       (list number)))))
 311
 312 (defun wl-summary-register-as-good-region (beg end)
 313   (interactive "r")
 314   (let ((numbers (wl-summary-collect-numbers-region beg end)))
 315     (cond (numbers
 316            (wl-spam-register-good-messages wl-summary-buffer-elmo-folder
 317                                            numbers))
 318           ((interactive-p)
 319            (message "No message to register as good.")))))
 320
 321 (defun wl-thread-register-as-good (&optional arg)
 322   (interactive "P")
 323   (wl-thread-call-region-func 'wl-summary-register-as-good-region arg))
 324
 325 (defun wl-summary-register-as-good-all ()
 326   (interactive)
 327   (wl-spam-register-good-messages wl-summary-buffer-elmo-folder
 328                                   wl-summary-buffer-number-list))
 329
 330 (defun wl-summary-target-mark-register-as-good ()
 331   (interactive)
 332   (save-excursion
 333     (goto-char (point-min))
 334     (let ((inhibit-read-only t)
 335           (buffer-read-only nil)
 336           wl-summary-buffer-disp-msg)
 337       (wl-spam-register-good-messages wl-summary-buffer-elmo-folder
 338                                       wl-summary-buffer-target-mark-list)
 339       (dolist (number wl-summary-buffer-target-mark-list)
 340         (wl-summary-unset-mark number)))))
 341
 342 ;; hook functions and other
 343 (defun wl-summary-auto-check-spam ()
 344   (when (elmo-string-match-member (wl-summary-buffer-folder-name)
 345                                   wl-spam-auto-check-folder-regexp-list)
 346     (wl-summary-mark-spam)))
 347
 348 (defun wl-summary-exec-action-spam (mark-list)
 349   (let ((folder wl-summary-buffer-elmo-folder))
 350     (wl-folder-confirm-existence (wl-folder-get-elmo-folder wl-spam-folder))
 351     (wl-spam-apply-partitions
 352      folder
 353      (wl-filter-associations
 354       '(undecided good)
 355       (wl-spam-split-numbers folder (mapcar #'car mark-list)))
 356      (lambda (folder numbers domain)
 357        (elmo-spam-register-spam-messages (elmo-spam-processor)
 358                                          folder numbers
 359                                          (eq domain 'good)))
 360      "Registering spam")
 361     (wl-summary-move-mark-list-messages mark-list
 362                                         wl-spam-folder
 363                                         "Refiling spam")))
 364
 365 (defun wl-summary-exec-action-refile-with-register (mark-list)
 366   (let ((folder wl-summary-buffer-elmo-folder)
 367         spam-list good-list)
 368     (dolist (info mark-list)
 369       (case (wl-spam-domain (nth 2 info))
 370         (spam
 371          (setq spam-list (cons (car info) spam-list)))
 372         (good
 373          (setq good-list (cons (car info) good-list)))))
 374     (wl-spam-apply-partitions
 375      folder
 376      (wl-filter-associations '(undecided good)
 377                              (wl-spam-split-numbers folder spam-list))
 378      (lambda (folder numbers domain)
 379        (elmo-spam-register-spam-messages (elmo-spam-processor)
 380                                          folder numbers
 381                                          (eq domain 'good)))
 382      "Registering spam")
 383     (wl-spam-apply-partitions
 384      folder
 385      (wl-filter-associations '(undecided spam)
 386                              (wl-spam-split-numbers folder good-list))
 387      (lambda (folder numbers domain)
 388        (elmo-spam-register-good-messages (elmo-spam-processor)
 389                                          folder numbers
 390                                          (eq domain 'spam)))
 391      "Registering good")
 392     ;; execute refile messages
 393     (wl-summary-exec-action-refile mark-list)))
 394
 395 (defun wl-message-check-spam ()
 396   (let ((original (wl-message-get-original-buffer))
 397         (number wl-message-buffer-cur-number)
 398         spam)
 399     (message "Checking spam...")
 400     (when (setq spam (elmo-spam-buffer-spam-p (elmo-spam-processor) original))
 401       (with-current-buffer wl-message-buffer-cur-summary-buffer
 402         (wl-summary-spam number)))
 403     (message "Checking spam...done")
 404     (message "No: %d is %sa spam message." number (if spam "" "not "))))
 405
 406 (defun wl-refile-guess-by-spam (entity)
 407   (when (elmo-spam-message-spam-p (elmo-spam-processor)
 408                                   wl-summary-buffer-elmo-folder
 409                                   (elmo-message-entity-number entity))
 410     wl-spam-folder))
 411
 412 (defun wl-spam-setup ()
 413   (add-hook 'wl-summary-sync-updated-hook #'wl-summary-auto-check-spam)
 414   (let ((actions wl-summary-mark-action-list)
 415         action)
 416     (while actions
 417       (setq action  (car actions)
 418             actions (cdr actions))
 419       (when (eq (wl-summary-action-symbol action) 'refile)
 420         (setcar (nthcdr 4 action) 'wl-summary-exec-action-refile-with-register)
 421         (setq actions nil))))
 422   (when wl-spam-mark-action-list
 423     (setq wl-summary-mark-action-list (append
 424                                        wl-summary-mark-action-list
 425                                        wl-spam-mark-action-list))
 426     (dolist (action wl-spam-mark-action-list)
 427       (setq wl-summary-reserve-mark-list
 428             (cons (wl-summary-action-mark action)
 429                   wl-summary-reserve-mark-list))
 430       (setq wl-summary-skip-mark-list
 431             (cons (wl-summary-action-mark action)
 432                   wl-summary-skip-mark-list))))
 433   (define-key wl-summary-mode-map "k" wl-summary-spam-map)
 434   (define-key
 435     wl-summary-mode-map "rkm" 'wl-summary-spam-region)
 436   (define-key
 437     wl-summary-mode-map "rkc" 'wl-summary-test-spam-region)
 438   (define-key
 439     wl-summary-mode-map "rks" 'wl-summary-register-as-spam-region)
 440   (define-key
 441     wl-summary-mode-map "rkn" 'wl-summary-register-as-good-region)
 442   (define-key
 443     wl-summary-mode-map "tkm" 'wl-thread-spam)
 444   (define-key
 445     wl-summary-mode-map "tkc" 'wl-thread-test-spam)
 446   (define-key
 447     wl-summary-mode-map "tks" 'wl-thread-register-as-spam)
 448   (define-key
 449     wl-summary-mode-map "tkn" 'wl-thread-register-as-good)
 450   (define-key
 451     wl-summary-mode-map "mk" 'wl-summary-target-mark-spam)
 452   (define-key
 453     wl-summary-mode-map "ms" 'wl-summary-target-mark-register-as-spam)
 454   (define-key
 455     wl-summary-mode-map "mn" 'wl-summary-target-mark-register-as-good))
 456
 457 (require 'product)
 458 (product-provide (provide 'wl-spam) (require 'wl-version))
 459
 460 (unless noninteractive
 461   (wl-spam-setup))
 462
 463 ;;; wl-spam.el ends here