;;; imap-respool.el --- Respool IMAP groups using a different backend.
;;
;; Author: Mark Triggs <mst@dishevelled.net>
;;
;; This file 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.
;;
;; This file 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:
;;
;; To use this code, you will need to define a list of imap groups to respool
;; by setting the variable `imap-respool-groups-to-respool'.
;;
;; After defining which imap groups should be respooled, you will just need to
;; call `gnus-respool-respool-groups` to perform the respooling.  I use:
;;
;;   (define-key gnus-group-mode-map (kbd "g")
;;     (lambda ()
;;       (interactive)
;;       (imap-respool-respool-groups)
;;       (gnus-group-get-new-news)))
;;

;;; Code:

(defvar imap-respool-groups-to-respool '()
  "Defines the IMAP groups that should be respooled.  This is of the form:

  '((<group name 1> <predicate> <backend>)
    (<group name 2> <predicate> <backend>)
    ...
    (<group name N> <predicate> <backend>))

The group name should be a string representing the group to be respooled,
such as \"nnimap+myserver:MYMAILBOX\".

The predicate function, if given, is used to decide whether a particular
message should be respooled or left alone.  It is called with no arguments
in a buffer containing a message's headers, and should return non-nil if,
based on those headers, the message should be respooled.  If no predicate is
given, all messages will be respooled.

The backend should be the backend to use when respooling messages (such as
'(nnml \"\")).  If this is not given, the value of `gnus-select-method' is
used.")

(defun imap-respool-respool-groups ()
  (interactive)
  (unless (boundp 'respooling)
    (let ((respooling t))
      (dolist (respool-rule imap-respool-groups-to-respool)
        (apply 'imap-respool-group respool-rule)))))


(defun imap-respool-article-matches (predicate)
  "Call PREDICATE on the current article's headers."
  (if predicate
      (let ((article (gnus-summary-article-number)))
        (nnimap-request-body (gnus-summary-article-number))
        (with-current-buffer nntp-server-buffer
          (article-narrow-to-head)
          (goto-char (point-min))
          (unwind-protect
              (funcall predicate)
            (widen))))
    t))


(defun imap-respool-group (group &optional predicate backend)
  (let ((backend (or backend gnus-select-method)))
    (dotimes (i 2)
      (save-excursion
        (goto-char (gnus-group-jump-to-group group))
        (gnus-group-get-new-news-this-group)))
    (let ((buffer (let ((gnus-visual nil)
                        (gnus-score-find-score-files-function nil)
                        (gnus-home-score-file nil)
                        (gnus-apply-kill-hook nil)
                        (gnus-summary-expunge-below nil))
                    (save-excursion
                      (if (gnus-group-read-group t t group)
                          (current-buffer)
                        nil)))))
      (when buffer
        (with-current-buffer buffer
          (goto-char (point-min))
          (while (and (not (eobp))
                      (gnus-summary-article-number))
            (when (imap-respool-article-matches predicate)
              (gnus-summary-mark-article nil gnus-unread-mark)
              (gnus-summary-respool-article nil backend)
              (let ((gnus-novice-user nil))
                (gnus-summary-delete-article)))
            (next-line 1))
          (ignore-errors (gnus-summary-quit t)))))))


(provide 'imap-respool)
;;; imap-respool.el ends here