Uwe Brauer wrote:
> I would like to use nnimap-split-fancy together with bbdb in the
> following way:
> For each record that has a 'imap attribute split the mail into this
> imap folder
When I used gnus for mail, I had something from Soren Dayton that did
this called csd-gnus-split. I would add the following to
nnmail-split-fancy:
(: cor-csd-gnus-split-method)
I wrote the following function to call Soren's method:
(defun cor-csd-gnus-split-method ()
(let ((result (csd-gnus-split-method)))
(and result (cons '& result))))
These were my settings (you would want 'imap rather than 'gnus-group):
(setq csd-gnus-split-default-group nil)
(setq csd-gnus-split-mail-group 'gnus-group)
(setq csd-gnus-split-headers '("from" "resent-from" "to" "cc"))
For some reason, I modified Soren's version of csd-gnus-split-method.
I cannot remember why. I did this all in 1999.
(defun csd-gnus-split-split-to-group (addr)
"This function is called from csd-gnus-split-split-method in order to
determine the group and spooling priority for a single address."
(condition-case tmp
(progn
(setq tmp (mail-extract-address-components addr))
(let* ((nam (car tmp))
(net (if (not bbdb-canonicalize-net-hook) (car (cdr tmp))
(bbdb-canonicalize-address (car (cdr tmp)))))
(rec (bbdb-search-simple nam net))
prv)
(if (not rec) nil
(setq prv (bbdb-record-getprop rec csd-gnus-split-mail-group)))
(if (and prv (eq (aref prv 0) ?\())
(setq prv (let ((nnmail-split-fancy (car (read-from-string
prv))))
(nnmail-split-fancy))))
(if (not (listp prv)) (setq prv (list prv)))
(cond
(prv prv)
(t nil))))
(error nil)))
Here is the version of Soren's code that I've been using. I googled,
but cannot find it.
--[[application/x-emacs-lisp; type=emacs-lisp
Content-Disposition: inline; filename="csd-gnus-split.el"][7bit]]
;; csd-gnus-split.el: Front end to gnus splitting
;; Copyright (C) 1998 Soren Dayton <[EMAIL PROTECTED]>
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2 of
;; the License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; csd-gnus-split.el - gnus functions which utilize bbdb data
;;; $Id: csd-gnus-split.el,v 1.6 1997/08/17 19:31:40 csdayton Exp csdayton $
;;; We require rfc822.el here as it handles comma-separated lists of
;;; addresses, which is needed for csd-gnus-split-split-method. If someone
;;; knows of a better way to handle this, let me know.
(require 'bbdb)
(require 'rfc822)
(require 'custom)
(defgroup csd-gnus-split nil
"A front end to Gnus splitting that uses procmail `+' syntax."
:group 'news
:group 'csd)
(defcustom csd-gnus-split-default-group "personal.inbox"
"If the BBDB doesn't indicate any group to spool a message to, it will
be spooled to this group. If csd-gnus-split-split-crosspost-default is not
nil, and if the BBDB did not indicate a specific group for one or more
addresses, messages will be crossposted to this group in addition to any
group(s) which the BBDB indicated."
:group 'csd-gnus-split
:type '(string :tag "Default group name"))
(defcustom csd-gnus-split-mail-group 'mail
"This variable is used to determine the field to reference to find the
associated group when saving private mail for a network address known to
the BBDB. The value of the field should be the name of a mail group."
:tag "BBDB group field"
:group 'csd-gnus-split
:type '(symbol :tag "BBDB field"))
(defcustom csd-gnus-split-mailing-list-alist
nil
"An alist that maps `plus' addresses to mail groups."
:tag "Map from `+' data to lists."
:group 'csd-gnus-split
:type '(repeat (cons :tag "Plus/name pair"
(string :tag "Plus name")
(repeat :tag "List names"
(string :tag "List")))))
(defcustom csd-gnus-split-mailing-list-data-header "X-Data"
"The header that contains the `plus' data for the message."
:tag "Plus Header"
:type '(string :tag "Header in which `+' information is")
:group 'csd-gnus-split)
(defcustom csd-gnus-split-method-list
'(csd-gnus-split-mailing-lists csd-gnus-split-personal-mail)
"*Functions used by `csd-gnus-split-method'.
These functions return a list of groups on success or nil. If all of
the functions return nil, `csd-gnus-split-default-group' is used"
:tag "Split Methods"
:type '(repeat :tag "Splitting Functions"
(function :tag "Splitting Function"))
:group 'csd-gnus-split)
(defcustom csd-gnus-split-headers
'("from" "resent-from" "to")
"*Headers used to generate the list of addresses for a message."
:type '(repeat :tag "Headers" (string :tag "Header"))
:group 'csd-gnus-split)
(defcustom csd-gnus-split-spam-data-value "usenet"
"*Value of the `+' data such that the mail might be spam."
:type '(string :tag "Data value")
:group 'csd-gnus-split)
(defcustom csd-gnus-split-spam-not-regex "^[Rr]e:"
"*Regex to match mail that is probably not spam."
:type '(string :tag "Regex")
:group 'csd-gnus-split)
(defcustom csd-gnus-split-spam-group nil
"*Mail group to send possible spam off to."
:type '(string :tag "Mail group")
:group 'csd-gnus-split)
(defun csd-gnus-split-mailing-lists ()
"This splits mailing lists based on procmail `+' data.
This is done with the alist `csd-gnus-split-mailing-list-alist'. This
information is extracted from the
`csd-gnus-split-mailing-list-data-header' header."
(let ((data (mail-fetch-field csd-gnus-split-mailing-list-data-header
nil t)))
(if data
(cdr (assoc data csd-gnus-split-mailing-list-alist)))))
(defun csd-gnus-split-spam ()
"This splits out spam by sending it to `csd-gnus-split-spam-group'.
This is done by comparing the value of the
`csd-gnus-split-mailing-list-data-header' header with
`csd-gnus-split-spam-data-value'. If these are the same then if the
Subject: header matches `csd-gnus-split-spam-not-regex', the message
is filed in `csd-gnus-split-spam-group'."
(let ((data (mail-fetch-field csd-gnus-split-mailing-list-data-header
nil t))
(subject (mail-fetch-field "subject" nil t)))
(if (and (string-equal (downcase data)
(downcase csd-gnus-split-spam-data-value))
(string-match csd-gnus-split-spam-not-regex subject))
csd-gnus-split-spam-group
nil)))
(defun csd-gnus-split-personal-mail ()
"This function expects to be called in a buffer which contains a mail
message to be spooled, and the buffer should be narrowed to the message
headers. It returns a list of groups to which the message should be
spooled, using the addresses in the headers and information from the
BBDB."
;; do the rest of the headers
(apply 'append
(mapcar 'csd-gnus-split-split-to-group
(rfc822-addresses
(or (apply 'concat
(mapcar
(lambda (header)
(let ((data (mail-fetch-field header nil t)))
(if data
(concat data ","))))
csd-gnus-split-headers))
"")))))
(defun csd-gnus-split-split-to-group (addr)
"This function is called from csd-gnus-split-split-method in order to
determine the group and spooling priority for a single address."
(condition-case tmp
(progn
(setq tmp (mail-extract-address-components addr))
(let* ((nam (car tmp))
(net (if (not bbdb-canonicalize-net-hook) (car (cdr tmp))
(bbdb-canonicalize-address (car (cdr tmp)))))
(rec (bbdb-search-simple nam net))
prv)
(if (not rec) nil
(setq prv (bbdb-record-getprop rec csd-gnus-split-mail-group)))
(if prv (setq prv (list prv)))
(cond
(prv prv)
(t nil))))
(error nil)))
(defun csd-gnus-split-method ()
"Splits mail based on `csd-gnus-split-method-list'."
(csd-gnus-split-method-internal csd-gnus-split-method-list))
;; oh well. If only Emacs was tail recursive
(defun csd-gnus-split-method-internal (list)
"Splits mail based on `list'.
This just calls each element of list until one returns non-nil. If none
return non-nil, return `csd-gnus-split-default-group'."
(if list
(let ((first (car list))
(rest (cdr list)))
(or (funcall first)
(csd-gnus-split-method-internal rest)))
(list csd-gnus-split-default-group)))
(provide 'csd-gnus-split)
;;; EOF
-------------------------------------------------------
The SF.Net email is sponsored by: Beat the post-holiday blues
Get a FREE limited edition SourceForge.net t-shirt from ThinkGeek.
It's fun and FREE -- well, almost....http://www.thinkgeek.com/sfshirt
_______________________________________________
bbdb-info@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/bbdb-info
BBDB Home Page: http://bbdb.sourceforge.net/
