nnir.el (nnir-run-gmane): Better check for gmane groups.

[gnus] / lisp / nnir.el

diff --git a/lisp/nnir.el b/lisp/nnir.el
index 7e1bd30..6c97f72 100644 (file)
--- a/lisp/nnir.el
+++ b/lisp/nnir.el
@@ -269,7 +269,7 @@ as `(keyfunc member)' and the corresponding element is just
 is `(valuefunc member)'."
   `(unless (null ,sequence)
      (let (value)
-       (mapcar
+       (mapc
        (lambda (member)
          (let ((y (,keyfunc member))
                (x ,(if valuefunc
@@ -635,7 +635,7 @@ Add an entry here when adding a new search engine.")
          (while (not (eobp))
            (let* ((novitem (funcall parsefunc))
                   (artno (mail-header-number novitem))
-                  (art (car (rassoc artno articleids))))
+                  (art (car (rassq artno articleids))))
              (when art
                (mail-header-set-number novitem art)
                (push novitem headers))
@@ -656,17 +656,14 @@ Add an entry here when adding a new search engine.")
        article)
     (save-excursion
       (let ((artfullgroup (nnir-article-group article))
-           (artno (nnir-article-number article))
-           ;; Bug?
-           ;; Why must we bind nntp-server-buffer here?  It won't
-           ;; work if `buf' is used, say.  (Of course, the set-buffer
-           ;; line below must then be updated, too.)
-           (nntp-server-buffer (or to-buffer nntp-server-buffer)))
-       (set-buffer nntp-server-buffer)
-       (erase-buffer)
+           (artno (nnir-article-number article)))
        (message "Requesting article %d from group %s"
                 artno artfullgroup)
-       (gnus-request-article artno artfullgroup nntp-server-buffer)
+       (if to-buffer
+           (with-current-buffer to-buffer
+             (let ((gnus-article-decode-hook nil))
+               (gnus-request-article-this-buffer artno artfullgroup)))
+         (gnus-request-article artno artfullgroup))
        (cons artfullgroup artno)))))
 
 (deffoo nnir-request-move-article (article group server accept-form
@@ -676,10 +673,7 @@ Add an entry here when adding a new search engine.")
         (to-newsgroup (nth 1 accept-form))
         (to-method (gnus-find-method-for-group to-newsgroup))
         (from-method (gnus-find-method-for-group artfullgroup))
-        (move-is-internal (gnus-server-equal from-method to-method))
-        (artsubject (mail-header-subject
-                     (gnus-data-header
-                      (assoc article (gnus-data-list nil))))))
+        (move-is-internal (gnus-server-equal from-method to-method)))
     (unless (gnus-check-backend-function
             'request-move-article artfullgroup)
       (error "The group %s does not support article moving" artfullgroup))
@@ -693,6 +687,27 @@ Add an entry here when adding a new search engine.")
          to-newsgroup          ; Not respooling
          (gnus-group-real-name to-newsgroup)))))
 
+(deffoo nnir-request-expire-articles (articles group &optional server force)
+  (if force
+    (let ((articles-by-group (nnir-categorize
+                             articles nnir-article-group nnir-article-ids))
+         not-deleted)
+      (while (not (null articles-by-group))
+       (let* ((group-articles (pop articles-by-group))
+              (artgroup (car group-articles))
+              (articleids (cadr group-articles))
+              (artlist (sort (mapcar 'cdr articleids) '<)))
+         (unless (gnus-check-backend-function 'request-expire-articles
+                                              artgroup)
+           (error "The group %s does not support article deletion" artgroup))
+         (unless (gnus-check-server (gnus-find-method-for-group artgroup))
+           (error "Couldn't open server for group %s" artgroup))
+         (push (gnus-request-expire-articles
+                artlist artgroup force)
+               not-deleted)))
+      (sort (delq nil not-deleted) '<))
+    articles))
+
 (deffoo nnir-warp-to-article ()
   (let* ((cur (if (> (gnus-summary-article-number) 0)
                  (gnus-summary-article-number)
@@ -779,16 +794,17 @@ details on the language and supported extensions"
                                                    (nnir-imap-make-query
                                                     criteria qstring)))))
                      (mapc
-                      (lambda (artnum) (push (vector group artnum 100) artlist)
-                        (setq arts (1+ arts)))
-                      (and (car result)
-                           (delete 0 (mapcar #'string-to-number
-                                             (cdr (assoc "SEARCH"
-                                                         (cdr result)))))))
+                      (lambda (artnum)
+                        (let ((artn (string-to-number artnum)))
+                          (when (> artn 0)
+                            (push (vector group artn 100)
+                                  artlist)
+                            (setq arts (1+ arts)))))
+                      (and (car result) (cdr (assoc "SEARCH" (cdr result)))))
                      (message "Searching %s... %d matches" group arts)))
                  (message "Searching %s...done" group))
              (quit nil))
-           artlist))
+           (nreverse artlist)))
        groups)))))
 
 (defun nnir-imap-make-query (criteria qstring)
@@ -1381,15 +1397,15 @@ Tested with Namazu 2.0.6 on a GNU/Linux system."
 ;; gmane interface
 (defun nnir-run-gmane (query srv &optional groups)
   "Run a search against a gmane back-end server."
-  (if (gnus-string-match-p "gmane.org$" srv)
       (let* ((case-fold-search t)
             (qstring (cdr (assq 'query query)))
             (server (cadr (gnus-server-to-method srv)))
-            (groupspec (if groups
-                           (mapconcat
-                            (lambda (x)
-                              (format "group:%s" (gnus-group-short-name x)))
-                            groups " ") ""))
+            (groupspec (mapconcat
+                        (lambda (x)
+                          (if (gnus-string-match-p "gmane" x)
+                              (format "group:%s" (gnus-group-short-name x))
+                            (error "Can't search non-gmane groups: %s" x)))
+                          groups " "))
             (authorspec
              (if (assq 'author query)
                  (format "author:%s" (cdr (assq 'author query))) ""))
@@ -1424,9 +1440,7 @@ Tested with Namazu 2.0.6 on a GNU/Linux system."
                      (string-to-number (match-string 2 xref)) xscore)
                     artlist)))))
            (forward-line 1)))
-       (apply 'vector (nreverse (mm-delete-duplicates artlist))))
-    (message "Can't search non-gmane nntp groups")
-    nil))
+       (apply 'vector (nreverse (mm-delete-duplicates artlist)))))
 
 ;;; Util Code:
 
@@ -1569,8 +1583,10 @@ server is of form 'backend:name'."
          (or nnir-summary-line-format gnus-summary-line-format))
     (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action t)
     (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action t)
+    (remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action t)
     (add-hook 'gnus-summary-article-delete-hook 'nnir-registry-action t t)
-    (add-hook 'gnus-summary-article-move-hook 'nnir-registry-action t t)))
+    (add-hook 'gnus-summary-article-move-hook 'nnir-registry-action t t)
+    (add-hook 'gnus-summary-article-expire-hook 'nnir-registry-action t t)))