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