| 1 | ;;; gnus-mlspl.el --- a group params-based mail splitting mechanism |
| 2 | |
| 3 | ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, |
| 4 | ;; 2005, 2006, 2007 Free Software Foundation, Inc. |
| 5 | |
| 6 | ;; Author: Alexandre Oliva <oliva@lsd.ic.unicamp.br> |
| 7 | ;; Keywords: news, mail |
| 8 | |
| 9 | ;; This file is part of GNU Emacs. |
| 10 | |
| 11 | ;; GNU Emacs is free software; you can redistribute it and/or modify |
| 12 | ;; it under the terms of the GNU General Public License as published |
| 13 | ;; by the Free Software Foundation; either version 3, or (at your |
| 14 | ;; option) any later version. |
| 15 | |
| 16 | ;; GNU Emacs is distributed in the hope that it will be useful, but |
| 17 | ;; WITHOUT ANY WARRANTY; without even the implied warranty of |
| 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
| 19 | ;; General Public License for more details. |
| 20 | |
| 21 | ;; You should have received a copy of the GNU General Public License |
| 22 | ;; along with this program; see the file COPYING. If not, write to |
| 23 | ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
| 24 | ;; Boston, MA 02110-1301, USA. |
| 25 | |
| 26 | ;;; Commentary: |
| 27 | |
| 28 | ;;; Code: |
| 29 | |
| 30 | (eval-when-compile (require 'cl)) |
| 31 | (require 'gnus) |
| 32 | (require 'gnus-sum) |
| 33 | (require 'gnus-group) |
| 34 | (require 'nnmail) |
| 35 | |
| 36 | (defvar gnus-group-split-updated-hook nil |
| 37 | "Hook called just after nnmail-split-fancy is updated by |
| 38 | gnus-group-split-update.") |
| 39 | |
| 40 | (defvar gnus-group-split-default-catch-all-group "mail.misc" |
| 41 | "Group name (or arbitrary fancy split) with default splitting rules. |
| 42 | Used by gnus-group-split and gnus-group-split-update as a fallback |
| 43 | split, in case none of the group-based splits matches.") |
| 44 | |
| 45 | ;;;###autoload |
| 46 | (defun gnus-group-split-setup (&optional auto-update catch-all) |
| 47 | "Set up the split for nnmail-split-fancy. |
| 48 | Sets things up so that nnmail-split-fancy is used for mail |
| 49 | splitting, and defines the variable nnmail-split-fancy according with |
| 50 | group parameters. |
| 51 | |
| 52 | If AUTO-UPDATE is non-nil (prefix argument accepted, if called |
| 53 | interactively), it makes sure nnmail-split-fancy is re-computed before |
| 54 | getting new mail, by adding gnus-group-split-update to |
| 55 | nnmail-pre-get-new-mail-hook. |
| 56 | |
| 57 | A non-nil CATCH-ALL replaces the current value of |
| 58 | gnus-group-split-default-catch-all-group. This variable is only used |
| 59 | by gnus-group-split-update, and only when its CATCH-ALL argument is |
| 60 | nil. This argument may contain any fancy split, that will be added as |
| 61 | the last split in a `|' split produced by gnus-group-split-fancy, |
| 62 | unless overridden by any group marked as a catch-all group. Typical |
| 63 | uses are as simple as the name of a default mail group, but more |
| 64 | elaborate fancy splits may also be useful to split mail that doesn't |
| 65 | match any of the group-specified splitting rules. See |
| 66 | `gnus-group-split-fancy' for details." |
| 67 | (interactive "P") |
| 68 | (setq nnmail-split-methods 'nnmail-split-fancy) |
| 69 | (when catch-all |
| 70 | (setq gnus-group-split-default-catch-all-group catch-all)) |
| 71 | (gnus-group-split-update) |
| 72 | (when auto-update |
| 73 | (add-hook 'nnmail-pre-get-new-mail-hook 'gnus-group-split-update))) |
| 74 | |
| 75 | ;;;###autoload |
| 76 | (defun gnus-group-split-update (&optional catch-all) |
| 77 | "Computes nnmail-split-fancy from group params and CATCH-ALL. |
| 78 | It does this by calling by calling (gnus-group-split-fancy nil |
| 79 | nil CATCH-ALL). |
| 80 | |
| 81 | If CATCH-ALL is nil, gnus-group-split-default-catch-all-group is used |
| 82 | instead. This variable is set by gnus-group-split-setup." |
| 83 | (interactive) |
| 84 | (setq nnmail-split-fancy |
| 85 | (gnus-group-split-fancy |
| 86 | nil (null nnmail-crosspost) |
| 87 | (or catch-all gnus-group-split-default-catch-all-group))) |
| 88 | (run-hooks 'gnus-group-split-updated-hook)) |
| 89 | |
| 90 | ;;;###autoload |
| 91 | (defun gnus-group-split () |
| 92 | "Uses information from group parameters in order to split mail. |
| 93 | See `gnus-group-split-fancy' for more information. |
| 94 | |
| 95 | gnus-group-split is a valid value for nnmail-split-methods." |
| 96 | (let (nnmail-split-fancy) |
| 97 | (gnus-group-split-update) |
| 98 | (nnmail-split-fancy))) |
| 99 | |
| 100 | ;;;###autoload |
| 101 | (defun gnus-group-split-fancy |
| 102 | (&optional groups no-crosspost catch-all) |
| 103 | "Uses information from group parameters in order to split mail. |
| 104 | It can be embedded into `nnmail-split-fancy' lists with the SPLIT |
| 105 | |
| 106 | \(: gnus-group-split-fancy GROUPS NO-CROSSPOST CATCH-ALL\) |
| 107 | |
| 108 | GROUPS may be a regular expression or a list of group names, that will |
| 109 | be used to select candidate groups. If it is omitted or nil, all |
| 110 | existing groups are considered. |
| 111 | |
| 112 | if NO-CROSSPOST is omitted or nil, a & split will be returned, |
| 113 | otherwise, a | split, that does not allow crossposting, will be |
| 114 | returned. |
| 115 | |
| 116 | For each selected group, a SPLIT is composed like this: if SPLIT-SPEC |
| 117 | is specified, this split is returned as-is (unless it is nil: in this |
| 118 | case, the group is ignored). Otherwise, if TO-ADDRESS, TO-LIST and/or |
| 119 | EXTRA-ALIASES are specified, a regexp that matches any of them is |
| 120 | constructed (extra-aliases may be a list). Additionally, if |
| 121 | SPLIT-REGEXP is specified, the regexp will be extended so that it |
| 122 | matches this regexp too, and if SPLIT-EXCLUDE is specified, RESTRICT |
| 123 | clauses will be generated. |
| 124 | |
| 125 | If CATCH-ALL is nil, no catch-all handling is performed, regardless of |
| 126 | catch-all marks in group parameters. Otherwise, if there is no |
| 127 | selected group whose SPLIT-REGEXP matches the empty string, nor is |
| 128 | there a selected group whose SPLIT-SPEC is 'catch-all, this fancy |
| 129 | split (say, a group name) will be appended to the returned SPLIT list, |
| 130 | as the last element of a '| SPLIT. |
| 131 | |
| 132 | For example, given the following group parameters: |
| 133 | |
| 134 | nnml:mail.bar: |
| 135 | \((to-address . \"bar@femail.com\") |
| 136 | (split-regexp . \".*@femail\\\\.com\")) |
| 137 | nnml:mail.foo: |
| 138 | \((to-list . \"foo@nowhere.gov\") |
| 139 | (extra-aliases \"foo@localhost\" \"foo-redist@home\") |
| 140 | (split-exclude \"bugs-foo\" \"rambling-foo\") |
| 141 | (admin-address . \"foo-request@nowhere.gov\")) |
| 142 | nnml:mail.others: |
| 143 | \((split-spec . catch-all)) |
| 144 | |
| 145 | Calling (gnus-group-split-fancy nil nil \"mail.others\") returns: |
| 146 | |
| 147 | \(| (& (any \"\\\\(bar@femail\\\\.com\\\\|.*@femail\\\\.com\\\\)\" |
| 148 | \"mail.bar\") |
| 149 | (any \"\\\\(foo@nowhere\\\\.gov\\\\|foo@localhost\\\\|foo-redist@home\\\\)\" |
| 150 | - \"bugs-foo\" - \"rambling-foo\" \"mail.foo\")) |
| 151 | \"mail.others\")" |
| 152 | (let* ((newsrc (cdr gnus-newsrc-alist)) |
| 153 | split) |
| 154 | (dolist (info newsrc) |
| 155 | (let ((group (gnus-info-group info)) |
| 156 | (params (gnus-info-params info))) |
| 157 | ;; For all GROUPs that match the specified GROUPS |
| 158 | (when (or (not groups) |
| 159 | (and (listp groups) |
| 160 | (memq group groups)) |
| 161 | (and (stringp groups) |
| 162 | (string-match groups group))) |
| 163 | (let ((split-spec (assoc 'split-spec params)) group-clean) |
| 164 | ;; Remove backend from group name |
| 165 | (setq group-clean (string-match ":" group)) |
| 166 | (setq group-clean |
| 167 | (if group-clean |
| 168 | (substring group (1+ group-clean)) |
| 169 | group)) |
| 170 | (if split-spec |
| 171 | (when (setq split-spec (cdr split-spec)) |
| 172 | (if (eq split-spec 'catch-all) |
| 173 | ;; Emit catch-all only when requested |
| 174 | (when catch-all |
| 175 | (setq catch-all group-clean)) |
| 176 | ;; Append split-spec to the main split |
| 177 | (push split-spec split))) |
| 178 | ;; Let's deduce split-spec from other params |
| 179 | (let ((to-address (cdr (assoc 'to-address params))) |
| 180 | (to-list (cdr (assoc 'to-list params))) |
| 181 | (extra-aliases (cdr (assoc 'extra-aliases params))) |
| 182 | (split-regexp (cdr (assoc 'split-regexp params))) |
| 183 | (split-exclude (cdr (assoc 'split-exclude params)))) |
| 184 | (when (or to-address to-list extra-aliases split-regexp) |
| 185 | ;; regexp-quote to-address, to-list and extra-aliases |
| 186 | ;; and add them all to split-regexp |
| 187 | (setq split-regexp |
| 188 | (concat |
| 189 | "\\(" |
| 190 | (mapconcat |
| 191 | 'identity |
| 192 | (append |
| 193 | (and to-address (list (regexp-quote to-address))) |
| 194 | (and to-list (list (regexp-quote to-list))) |
| 195 | (and extra-aliases |
| 196 | (if (listp extra-aliases) |
| 197 | (mapcar 'regexp-quote extra-aliases) |
| 198 | (list extra-aliases))) |
| 199 | (and split-regexp (list split-regexp))) |
| 200 | "\\|") |
| 201 | "\\)")) |
| 202 | ;; Now create the new SPLIT |
| 203 | (push (append |
| 204 | (list 'any split-regexp) |
| 205 | ;; Generate RESTRICTs for SPLIT-EXCLUDEs. |
| 206 | (if (listp split-exclude) |
| 207 | (apply #'append |
| 208 | (mapcar (lambda (arg) (list '- arg)) |
| 209 | split-exclude)) |
| 210 | (list '- split-exclude)) |
| 211 | (list group-clean)) |
| 212 | split) |
| 213 | ;; If it matches the empty string, it is a catch-all |
| 214 | (when (string-match split-regexp "") |
| 215 | (setq catch-all nil))))))))) |
| 216 | ;; Add catch-all if not crossposting |
| 217 | (if (and catch-all no-crosspost) |
| 218 | (push catch-all split)) |
| 219 | ;; Move it to the tail, while arranging that SPLITs appear in the |
| 220 | ;; same order as groups. |
| 221 | (setq split (reverse split)) |
| 222 | ;; Decide whether to accept cross-postings or not. |
| 223 | (push (if no-crosspost '| '&) split) |
| 224 | ;; Even if we can cross-post, catch-all should not get |
| 225 | ;; cross-posts. |
| 226 | (if (and catch-all (not no-crosspost)) |
| 227 | (setq split (list '| split catch-all))) |
| 228 | split)) |
| 229 | |
| 230 | (provide 'gnus-mlspl) |
| 231 | |
| 232 | ;;; arch-tag: 62b3381f-1e45-4b61-be1a-29fb27703322 |
| 233 | ;;; gnus-mlspl.el ends here |