;; Retrieval Status Value (score).
;; When looking at the retrieval result (in the Summary buffer) you
-;; can type `G T' (aka M-x gnus-summary-nnir-goto-thread RET) on an
-;; article. You will be teleported into the group this article came
-;; from, showing the thread this article is part of.
+;; can type `A W' (aka M-x gnus-warp-to-article RET) on an article. You
+;; will be warped into the group this article came from. Typing `A W'
+;; (aka M-x gnus-summary-refer-thread RET) will warp to the group and
+;; also show the thread this article is part of.
;; The Lisp setup may involve setting a few variables and setting up the
;; search engine. You can define the variables in the server definition
;;; Setup Code:
+;; For Emacs <22.2 and XEmacs.
+(eval-and-compile
+ (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
+
(require 'nnoo)
(require 'gnus-group)
(require 'gnus-sum)
:type '(string)
:group 'nnir)
-(defcustom nnir-wais-program "waissearch"
- "*Name of waissearch executable."
- :type '(string)
- :group 'nnir)
-
-(defcustom nnir-wais-database (expand-file-name "~/.wais/mail")
- "*Name of Wais database containing the mail.
-
-Note that this should be a file name without extension. For example,
-if you have a file /home/john/.wais/mail.fmt, use this:
- (setq nnir-wais-database \"/home/john/.wais/mail\")
-The string given here is passed to `waissearch -d' as-is."
- :type '(file)
- :group 'nnir)
-
-(defcustom nnir-wais-remove-prefix (concat (getenv "HOME") "/Mail/")
- "*The prefix to remove from each directory name returned by waissearch
-in order to get a group name (albeit with / instead of .). This is a
-regular expression.
-
-For example, suppose that Wais returns file names such as
-\"/home/john/Mail/mail/misc/42\". For this example, use the following
-setting: (setq nnir-wais-remove-prefix \"/home/john/Mail/\")
-Note the trailing slash. Removing this prefix gives \"mail/misc/42\".
-`nnir' knows to remove the \"/42\" and to replace \"/\" with \".\" to
-arrive at the correct group name, \"mail.misc\"."
- :type '(regexp)
- :group 'nnir)
-
(defcustom nnir-swish++-configuration-file
(expand-file-name "~/Mail/swish++.conf")
"*Configuration file for swish++."
;;; Developer Extension Variable:
(defvar nnir-engines
- `((wais nnir-run-waissearch
- ())
- (imap nnir-run-imap
+ `((imap nnir-run-imap
((criteria
"Imap Search in" ; Prompt
,(mapcar 'car nnir-imap-search-arguments) ; alist for completing
nnir-current-group-marked nil
nnir-artlist nil)
(let* ((query (read-string "Query: " nil 'nnir-search-history))
- (parms (list (cons 'query query))))
+ (parms (list (cons 'query query)))
+ (srv (if (gnus-server-server-name)
+ "all" "")))
(add-to-list 'parms (cons 'unique-id (message-unique-id)) t)
(gnus-group-read-ephemeral-group
- (concat "nnir:" (prin1-to-string parms)) '(nnir "") t
+ (concat "nnir:" (prin1-to-string parms)) (list 'nnir srv) t
(cons (current-buffer) gnus-current-window-configuration)
nil)))
-;; Summary mode commands.
-
-(defun gnus-summary-nnir-goto-thread ()
- "Only applies to nnir groups. Go to group this article came from
-and show thread that contains this article."
- (interactive)
- (unless (eq 'nnir (car (gnus-find-method-for-group gnus-newsgroup-name)))
- (error "Can't execute this command unless in nnir group"))
- (let* ((cur (gnus-summary-article-number))
- (group (nnir-artlist-artitem-group nnir-artlist cur))
- (backend-number (nnir-artlist-artitem-number nnir-artlist cur))
- (id (mail-header-id (gnus-summary-article-header)))
- (refs (split-string
- (mail-header-references (gnus-summary-article-header)))))
- (if (eq (car (gnus-find-method-for-group group)) 'nnimap)
- (progn
- (nnimap-possibly-change-group (gnus-group-short-name group) nil)
- (with-current-buffer (nnimap-buffer)
- (let* ((cmd
- (let ((value
- (format
- "(OR HEADER REFERENCES %s HEADER Message-Id %s)"
- id id)))
- (dolist (refid refs value)
- (setq value
- (format
- "(OR (OR HEADER Message-Id %s HEADER REFERENCES %s) %s)"
- refid refid value)))))
- (result (nnimap-command "UID SEARCH %s" cmd)))
- (gnus-summary-read-group-1
- group t t gnus-summary-buffer nil
- (and (car result)
- (delete 0 (mapcar
- #'string-to-number
- (cdr (assoc "SEARCH" (cdr result))))))))))
- (gnus-summary-read-group-1 group t t gnus-summary-buffer
- nil (list backend-number))
- (gnus-summary-limit (list backend-number))
- (gnus-summary-refer-thread))))
-
-
-(if (fboundp 'eval-after-load)
- (eval-after-load "gnus-sum"
- '(define-key gnus-summary-goto-map
- "T" 'gnus-summary-nnir-goto-thread))
- (add-hook 'gnus-summary-mode-hook
- (function (lambda ()
- (define-key gnus-summary-goto-map
- "T" 'gnus-summary-nnir-goto-thread)))))
-
-
;; Gnus backend interface functions.
(equal server nnir-current-server)))
nnir-artlist
;; Cache miss.
- (setq nnir-artlist (nnir-run-query group)))
+ (setq nnir-artlist (nnir-run-query group server)))
(with-current-buffer nntp-server-buffer
(setq nnir-current-query group)
(when server (setq nnir-current-server server))
;; in nnir group
(when novitem
(mail-header-set-number novitem art)
- (mail-header-set-from novitem
- (mail-header-from novitem))
(mail-header-set-subject
novitem
(format "[%d: %s/%d] %s"
(gnus-request-article artno artfullgroup nntp-server-buffer)
(cons artfullgroup artno)))))
+(deffoo nnir-request-move-article (article group server accept-form
+ &optional last internal-move-group)
+ (let* ((artitem (nnir-artlist-article nnir-artlist
+ article))
+ (artfullgroup (nnir-artitem-group artitem))
+ (artno (nnir-artitem-number artitem))
+ (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))))))
+ (setq gnus-newsgroup-original-name artfullgroup)
+ (string-match "^\\[[0-9]+:.+/[0-9]+\\] " artsubject)
+ (setq gnus-article-original-subject (substring artsubject (match-end 0)))
+ (gnus-request-move-article
+ artno
+ artfullgroup
+ (nth 1 from-method)
+ accept-form
+ last
+ (and move-is-internal
+ to-newsgroup ; Not respooling
+ (gnus-group-real-name to-newsgroup)))))
+
+(deffoo nnir-warp-to-article ()
+ (let* ((cur (if (> (gnus-summary-article-number) 0)
+ (gnus-summary-article-number)
+ (error "This is not a real article.")))
+ (gnus-newsgroup-name (nnir-artlist-artitem-group nnir-artlist cur))
+ (backend-number (nnir-artlist-artitem-number nnir-artlist cur)))
+ (gnus-summary-read-group-1 gnus-newsgroup-name t t gnus-summary-buffer
+ nil (list backend-number))))
(nnoo-define-skeleton nnir)
;;; Search Engine Interfaces:
-;; freeWAIS-sf interface.
-(defun nnir-run-waissearch (query server &optional group)
- "Run given query agains waissearch. Returns vector of (group name, file name)
-pairs (also vectors, actually)."
- ;; (when group
- ;; (error "The freeWAIS-sf backend cannot search specific groups"))
- (save-excursion
- (let ((qstring (cdr (assq 'query query)))
- (prefix (nnir-read-server-parm 'nnir-wais-remove-prefix server))
- artlist score artno dirnam)
- (set-buffer (get-buffer-create nnir-tmp-buffer))
- (erase-buffer)
- (message "Doing WAIS query %s..." query)
- (call-process nnir-wais-program
- nil ; input from /dev/null
- t ; output to current buffer
- nil ; don't redisplay
- "-d" (nnir-read-server-parm 'nnir-wais-database server) ; database to search
- qstring)
- (message "Massaging waissearch output...")
- ;; remove superfluous lines
- (keep-lines "Score:")
- ;; extract data from result lines
- (goto-char (point-min))
- (while (re-search-forward
- "Score: +\\([0-9]+\\).*'\\([0-9]+\\) +\\([^']+\\)/'" nil t)
- (setq score (match-string 1)
- artno (match-string 2)
- dirnam (match-string 3))
- (unless (string-match prefix dirnam)
- (nnheader-report 'nnir "Dir name %s doesn't contain prefix %s"
- dirnam prefix))
- (setq group (gnus-replace-in-string
- (replace-match "" t t dirnam) "/" "."))
- (push (vector (nnir-group-full-name group server)
- (string-to-number artno)
- (string-to-number score))
- artlist))
- (message "Massaging waissearch output...done")
- (apply 'vector
- (sort artlist
- (function (lambda (x y)
- (> (nnir-artitem-rsv x)
- (nnir-artitem-rsv y)))))))))
-
;; imap interface
(defun nnir-run-imap (query srv &optional groups)
"Run a search against an IMAP back-end server.
(cdr (assoc nnir-imap-default-search-key
nnir-imap-search-arguments))))
(gnus-inhibit-demon t)
- artlist)
+ (groups (or groups (nnir-get-active srv))))
(message "Opening server %s" server)
(apply
'vconcat
(mapcar
- (lambda (x)
- (let ((group x))
+ (lambda (group)
+ (let (artlist)
(condition-case ()
(when (nnimap-possibly-change-group
(gnus-group-short-name group) server)
(message "Searching %s... %d matches" group arts)))
(message "Searching %s...done" group))
(quit nil))
- (reverse artlist)))
+ artlist))
groups)))))
(defun nnir-imap-make-query (criteria qstring)
artlist)))
grouplist))))
+(declare-function mm-url-insert "mm-url" (url &optional follow-refresh))
+(declare-function mm-url-encode-www-form-urlencoded "mm-url" (pairs))
+
;; gmane interface
(defun nnir-run-gmane (query srv &optional groups)
"Run a search against a gmane back-end server."
- (if (string-match-p "gmane" srv)
+ (if (gnus-string-match-p "gmane" srv)
(let* ((case-fold-search t)
(qstring (cdr (assq 'query query)))
(server (cadr (gnus-server-to-method srv)))
(format "author:%s" (cdr (assq 'author query))) ""))
(search (format "%s %s %s"
qstring groupspec authorspec))
+ (gnus-inhibit-demon t)
artlist)
- (with-current-buffer nntp-server-buffer
+ (require 'mm-url)
+ (with-current-buffer (get-buffer-create nnir-tmp-buffer)
(erase-buffer)
(mm-url-insert
(concat
(while (not (eobp))
(unless (or (eolp) (looking-at "\x0d"))
(let ((header (nnheader-parse-nov)))
- (let ((xref (mail-header-xref header)))
+ (let ((xref (mail-header-xref header))
+ (xscore (string-to-number (cdr (assoc 'X-Score
+ (mail-header-extra header))))))
(when (string-match " \\([^:]+\\)[:/]\\([0-9]+\\)" xref)
(push
(vector
(gnus-group-prefixed-name (match-string 1 xref) srv)
- (string-to-number (match-string 2 xref)) 1)
+ (string-to-number (match-string 2 xref)) xscore)
artlist)))))
(forward-line 1)))
- (reverse artlist))
- (message "Can't search non-gmane nntp groups")))
+ ;; Sort by score
+ (apply 'vector
+ (sort artlist
+ (function (lambda (x y)
+ (> (nnir-artitem-rsv x)
+ (nnir-artitem-rsv y)))))))
+ (message "Can't search non-gmane nntp groups")
+ nil))
;;; Util Code:
(defun nnir-read-parms (query nnir-search-engine)
"Reads additional search parameters according to `nnir-engines'."
(let ((parmspec (caddr (assoc nnir-search-engine nnir-engines))))
- (nconc query
+ (append query
(mapcar 'nnir-read-parm parmspec))))
(defun nnir-read-parm (parmspec)
(cons sym (format (cdr mapping) result)))
(cons sym (read-string prompt)))))
-(defun nnir-run-query (query)
+(autoload 'gnus-group-topic-name "gnus-topic")
+
+(defun nnir-run-query (query nserver)
"Invoke appropriate search engine function (see `nnir-engines').
If some groups were process-marked, run the query for each of the groups
and concat the results."
(let ((q (car (read-from-string query)))
- (groups (nnir-sort-groups-by-server
- (or gnus-group-marked (list (gnus-group-group-name))))))
+ (groups (if (string= "all-ephemeral" nserver)
+ (with-current-buffer gnus-server-buffer
+ (list (list (gnus-server-server-name))))
+ (nnir-sort-groups-by-server
+ (or gnus-group-marked
+ (if (gnus-group-group-name)
+ (list (gnus-group-group-name))
+ (cdr (assoc (gnus-group-topic-name)
+ gnus-topic-alist))))))))
(apply 'vconcat
(mapcar (lambda (x)
(let* ((server (car x))
(let ((server (gnus-group-server var)))
(if (assoc server value)
(nconc (cdr (assoc server value)) (list var))
- (push (cons (gnus-group-server var) (list var)) value))))
+ (push (cons server (list var)) value))))
value)
nil))
+(defun nnir-get-active (srv)
+ (let ((method (gnus-server-to-method srv))
+ groups)
+ (gnus-request-list method)
+ (with-current-buffer nntp-server-buffer
+ (let ((cur (current-buffer))
+ name)
+ (goto-char (point-min))
+ (unless (string= gnus-ignored-newsgroups "")
+ (delete-matching-lines gnus-ignored-newsgroups))
+ (while (not (eobp))
+ (ignore-errors
+ (push (mm-string-as-unibyte
+ (let ((p (point)))
+ (skip-chars-forward "^ \t\\\\")
+ (setq name (buffer-substring (+ p 1) (- (point) 1)))
+ (gnus-group-full-name name method)))
+ groups))
+ (forward-line))))
+ groups))
+
;; The end.
(provide 'nnir)
projects / gnus / blobdiff