gnus-prcml.el

;;; gnus-prcml.el --- Utilities to manage procmail recipes for Gnus
;; Copyright (C) 2001, 2003, 2005, 2006 Free Software Foundation, Inc.

;; Author: NAGY Andras <nagya@inf.elte.hu>,
;;	Simon Josefsson <simon@josefsson.org>,
;;	Arne J,Ax(Brgensen <arne@arnested.dk>
;; Maintainer: Arne J,Ax(Brgensen <arne@arnested.dk>

;; This file is part of GNU Emacs.

;; GNU Emacs 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, or (at your option)
;; any later version.

;; GNU Emacs 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 GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;; Gnus glue to generate Procmail recipes from Gnus Group Parameters.

;; It is inspired by and heavily based on gnus-sieve.el

;;; Code:

(require 'gnus)
(require 'gnus-sum)
(require 'gnus-util)
(require 'format-spec)

;; Variables

(defgroup gnus-procmail nil
  "Manage Procmail recipes in Gnus."
  :group 'gnus)

(defcustom gnus-procmail-file "~/.procmailrc"
  "Path to your Procmail script."
  :type 'file
  :group 'gnus-procmail)

(defcustom gnus-procmail-region-start "\n## Begin Gnus Procmail Recipes\n"
  "Line indicating the start of the autogenerated region in
your Procmail script."
  :type 'string
  :group 'gnus-procmail)

(defcustom gnus-procmail-region-end "\n## End Gnus Procmail Recipes\n"
  "Line indicating the end of the autogenerated region in
your Procmail script."
  :type 'string
  :group 'gnus-procmail)

(defcustom gnus-procmail-select-method nil
  "Which select method we generate the Procmail script for.

For example: \"nnimap:mailbox\""
  :group 'gnus-procmail)

(defcustom gnus-procmail-crosspost t
  "Whether the generated Procmail script should do crossposting."
  :type 'boolean
  :group 'gnus-procmail)

(defcustom gnus-procmail-action "%s.spool"
  "How the group name is turned into a Procmail action line.

Is either a format string where %s is substituted with the group
name, i.e.

  \"~/Mail/spool/%s.spool\"

or

  \"~/Maildir/%s/\"

or

  \"| /usr/bin/dmail +%s\"

Another possibility is to let it be a function (of your choice
and probably also definition) taking the group name as an
argument and returning the action line as a string."
  :type '(choice (string :tag "Format string" :value "%s.spool")
		 (function :tag "Function"))
  :group 'gnus-procmail)

;;;###autoload
(defun gnus-procmail-update ()
  "Update the Procmail script in gnus-procmail-file, by replacing
the region between gnus-procmail-region-start and
gnus-procmail-region-end with \(gnus-procmail-script
gnus-procmail-select-method gnus-procmail-crosspost\). See the
documentation for these variables and functions for details."
  (interactive)
  (save-window-excursion
    (gnus-procmail-generate)
    (save-buffer)
    (bury-buffer)))

;;;###autoload
(defun gnus-procmail-generate ()
  "Generate the Procmail script in gnus-procmail-file, by
replacing the region between gnus-procmail-region-start and
gnus-procmail-region-end with \(gnus-procmail-script
gnus-procmail-select-method gnus-procmail-crosspost\). See the
documentation for these variables and functions for details."
  (interactive)
  (find-file gnus-procmail-file)
  (goto-char (point-min))
  (if (re-search-forward (regexp-quote gnus-procmail-region-start) nil t)
      (delete-region (match-beginning 0)
		     (or (re-search-forward (regexp-quote
					     gnus-procmail-region-end) nil t)
			 (point))))
  (insert gnus-procmail-region-start
	  (gnus-procmail-script gnus-procmail-select-method gnus-procmail-crosspost)
	  gnus-procmail-region-end))

(defun gnus-procmail-quote (string)
  "Return a Procmail regexp string  which matches exactly STRING and nothing else."
  (dolist (elem '(("\\^" . "\\^")
		  ("\\$" . "\\$")
		  ("\\." . "\\.")
		  ("\\*" . "\\*")
		  ("\\+" . "\\+")
		  ("\\?" . "\\?")))
    (setq string (gnus-replace-in-string string (car elem) (cdr elem) t)))
  string)

(defun gnus-procmail-guess-rule-for-article ()
  "Guess a procmail recipe based on RFC822 article in buffer.
Return nil if no recipe could be guessed."
  (let ((list-id (message-fetch-field "list-id"))
	(sender (message-fetch-field "sender")))
    ;; RFC 2919-style List-Id
    (if (and list-id
	     (string-match ".*<\\(.+\\)>" list-id))
	`(procmail . ,(concat "^List-Id:.*"
			      (gnus-procmail-quote 
			       (match-string 1 list-id))))
      ;; Sender
      (when sender
	`(procmail . ,(concat "^Sender:.*"
			      (gnus-procmail-quote sender)))))))

;;;###autoload
(defun gnus-procmail-article-add-rule ()
  "Guess and add a procmail recipe to the group parameters."
  (interactive)
  (gnus-summary-select-article nil 'force)
  (with-current-buffer gnus-original-article-buffer
    (let ((rule (gnus-procmail-guess-rule-for-article))
	  (info (gnus-get-info gnus-newsgroup-name)))
      (if (null rule)
	  (error "Could not guess recipe for article.")
	(gnus-info-set-params info (cons rule (gnus-info-params info)))
	(message "Added recipe in group %s for article: %s" gnus-newsgroup-name
		 rule)))))

;; Internals

(defun gnus-procmail-test (test)
  "Convert an elisp test to a Procmail condition.

For example:
\(procmail . \"^TO_my@address.com\"\) =>
* ^TO_my@address.com

\(procmail \"^From:.*larsi\" \"^Subject:.*gnus\"\) => 
* ^From:.*larsi
* ^Subject:.*gnus"
  (if (listp test)
      (mapconcat 'gnus-procmail-test test "\n")
    (concat "* " test)))

(defun gnus-procmail-script (&optional method crosspost)
  "Generate a Procmail script based on groups with select method
METHOD \(or all groups if nil\). Only groups having a `procmail'
parameter are considered. This parameter should contain an elisp
test \(see the documentation of gnus-procmail-test for details\).
For each such group, a Procmail recipe is generated, having the
test(s) as the condition(s) and an action line based on the group
name (see `gnus-procmail-action').

If CROSSPOST is t (default), each recipe will have a \"c\"
flag (:0 c) at the beginning of the recipe.

For example: If the INBOX.list.procmail group has the

  (procmail \"^Sender:.*procmail-admin@extundo.com\")

group parameter, (gnus-procmail-script) results in:

:0
* ^Sender:.*procmail-admin@extundo.com
INBOX.list.procmail

This is returned as a string."
  (let* ((newsrc (cdr gnus-newsrc-alist))
	 script)
    (dolist (info newsrc)
      (when (or (not method)
		(gnus-server-equal method (gnus-info-method info)))
	(let* ((group (gnus-info-group info))
	       (spec (gnus-group-find-parameter group 'procmail t)))
	  (when spec
	    (push (concat ":0" (if crosspost
				   " c\n"
				 "\n")
			  (gnus-procmail-test spec) "\n"
			  (if (stringp gnus-procmail-action)
			      (format gnus-procmail-action (gnus-group-real-name group))
			    (if (functionp gnus-procmail-action)
				(funcall gnus-procmail-action (gnus-group-real-name group))
			      (gnus-group-real-name group)))
			  "\n")
		  script)))))
    (mapconcat 'identity script "\n")))


(provide 'gnus-prcml)

;;; gnus-prcml.el ends here