Update copyright year to 2015
[emacs.git] / lisp / gnus / nnagent.el
blob9c828a3f073e943f6ef485dbf12b25b0876187fa
1 ;;; nnagent.el --- offline backend for Gnus
3 ;; Copyright (C) 1997-2015 Free Software Foundation, Inc.
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
6 ;; Keywords: news, mail
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
23 ;;; Commentary:
25 ;;; Code:
27 (require 'nnheader)
28 (require 'nnoo)
29 (eval-when-compile (require 'cl))
30 (require 'gnus-agent)
31 (require 'nnml)
33 (nnoo-declare nnagent
34 nnml)
38 (defconst nnagent-version "nnagent 1.0")
40 (defvoo nnagent-directory nil
41 "Internal variable."
42 nnml-directory)
44 (defvoo nnagent-active-file nil
45 "Internal variable."
46 nnml-active-file)
48 (defvoo nnagent-newsgroups-file nil
49 "Internal variable."
50 nnml-newsgroups-file)
52 (defvoo nnagent-get-new-mail nil
53 "Internal variable."
54 nnml-get-new-mail)
56 ;;; Interface functions.
58 (nnoo-define-basics nnagent)
60 (defun nnagent-server (server)
61 (and server (format "%s+%s" (car gnus-command-method) server)))
63 (deffoo nnagent-open-server (server &optional defs)
64 (setq defs
65 `((nnagent-directory ,(gnus-agent-directory))
66 (nnagent-active-file ,(gnus-agent-lib-file "active"))
67 (nnagent-newsgroups-file ,(gnus-agent-lib-file "newsgroups"))
68 (nnagent-get-new-mail nil)))
69 (nnoo-change-server 'nnagent
70 (nnagent-server server)
71 defs)
72 (let ((dir (gnus-agent-directory))
73 err)
74 (cond
75 ((not (condition-case arg
76 (file-exists-p dir)
77 (ftp-error (setq err (format "%s" arg)))))
78 (nnagent-close-server)
79 (nnheader-report
80 'nnagent (or err
81 (format "No such file or directory: %s" dir))))
82 ((not (file-directory-p (file-truename dir)))
83 (nnagent-close-server)
84 (nnheader-report 'nnagent "Not a directory: %s" dir))
86 (nnheader-report 'nnagent "Opened server %s using directory %s"
87 server dir)
88 t))))
90 (deffoo nnagent-retrieve-groups (groups &optional server)
91 (save-excursion
92 (cond
93 ((file-exists-p (gnus-agent-lib-file "groups"))
94 (nnmail-find-file (gnus-agent-lib-file "groups"))
95 'groups)
96 ((file-exists-p (gnus-agent-lib-file "active"))
97 (nnmail-find-file (gnus-agent-lib-file "active"))
98 'active)
99 (t nil))))
101 (defun nnagent-request-type (group article)
102 (unless (stringp article)
103 (let ((gnus-agent nil))
104 (if (not (gnus-check-backend-function
105 'request-type (car gnus-command-method)))
106 'unknown
107 (funcall (gnus-get-function gnus-command-method 'request-type)
108 (gnus-group-real-name group) article)))))
110 (deffoo nnagent-request-newgroups (date server)
111 nil)
113 (deffoo nnagent-request-update-info (group info &optional server)
114 nil)
116 (deffoo nnagent-request-post (&optional server)
117 (gnus-agent-insert-meta-information 'news gnus-command-method)
118 (gnus-request-accept-article "nndraft:queue" nil t t))
120 (deffoo nnagent-request-set-mark (group action server)
121 (mm-with-unibyte-buffer
122 (insert "(gnus-agent-synchronize-group-flags \""
123 group
124 "\" '")
125 (gnus-pp action)
126 (insert " \""
127 (gnus-method-to-server gnus-command-method)
128 "\"")
129 (insert ")\n")
130 (let ((coding-system-for-write nnheader-file-coding-system))
131 (write-region (point-min) (point-max) (gnus-agent-lib-file "flags")
132 t 'silent)))
133 ;; Also set the marks for the original back end that keeps marks in
134 ;; the local system.
135 (let ((gnus-agent nil))
136 (when (and (memq (car gnus-command-method) '(nntp))
137 (gnus-check-backend-function 'request-set-mark
138 (car gnus-command-method)))
139 (funcall (gnus-get-function gnus-command-method 'request-set-mark)
140 group action server)))
141 nil)
143 (deffoo nnagent-retrieve-headers (articles &optional group server fetch-old)
144 (let ((file (gnus-agent-article-name ".overview" group))
145 arts n first)
146 (save-excursion
147 (gnus-agent-load-alist group)
148 (setq arts (gnus-sorted-difference
149 articles (mapcar 'car gnus-agent-article-alist)))
150 ;; Assume that articles with smaller numbers than the first one
151 ;; Agent knows are gone.
152 (setq first (caar gnus-agent-article-alist))
153 (when first
154 (while (and arts (< (car arts) first))
155 (pop arts)))
156 (set-buffer nntp-server-buffer)
157 (erase-buffer)
158 (let ((file-name-coding-system nnmail-pathname-coding-system))
159 (nnheader-insert-nov-file file (car articles)))
160 (goto-char (point-min))
161 (gnus-parse-without-error
162 (while (and arts (not (eobp)))
163 (setq n (read (current-buffer)))
164 (when (> n (car arts))
165 (beginning-of-line))
166 (while (and arts (> n (car arts)))
167 (insert (format
168 "%d\t[Undownloaded article %d]\tGnus Agent\t\t\t\n"
169 (car arts) (car arts)))
170 (pop arts))
171 (when (and arts (= n (car arts)))
172 (pop arts))
173 (forward-line 1)))
174 (while arts
175 (insert (format
176 "%d\t[Undownloaded article %d]\tGnus Agent\t\t\t\n"
177 (car arts) (car arts)))
178 (pop arts))
179 (if (and fetch-old
180 (not (numberp fetch-old)))
181 t ; Don't remove anything.
182 (nnheader-nov-delete-outside-range
183 (if fetch-old (max 1 (- (car articles) fetch-old))
184 (car articles))
185 (car (last articles)))
187 'nov)))
189 (deffoo nnagent-request-expire-articles (articles group &optional server force)
190 articles)
192 (deffoo nnagent-request-group (group &optional server dont-check info)
193 (nnoo-parent-function 'nnagent 'nnml-request-group
194 (list group (nnagent-server server) dont-check info)))
196 (deffoo nnagent-close-group (group &optional server)
197 (nnoo-parent-function 'nnagent 'nnml-close-group
198 (list group (nnagent-server server))))
200 (deffoo nnagent-request-accept-article (group &optional server last)
201 (nnoo-parent-function 'nnagent 'nnml-request-accept-article
202 (list group (nnagent-server server) last)))
204 (deffoo nnagent-request-article (id &optional group server buffer)
205 (nnoo-parent-function 'nnagent 'nnml-request-article
206 (list id group (nnagent-server server) buffer)))
208 (deffoo nnagent-request-create-group (group &optional server args)
209 (nnoo-parent-function 'nnagent 'nnml-request-create-group
210 (list group (nnagent-server server) args)))
212 (deffoo nnagent-request-delete-group (group &optional force server)
213 (nnoo-parent-function 'nnagent 'nnml-request-delete-group
214 (list group force (nnagent-server server))))
216 (deffoo nnagent-request-list (&optional server)
217 (nnoo-parent-function 'nnagent 'nnml-request-list
218 (list (nnagent-server server))))
220 (deffoo nnagent-request-list-newsgroups (&optional server)
221 (nnoo-parent-function 'nnagent 'nnml-request-list-newsgroups
222 (list (nnagent-server server))))
224 (deffoo nnagent-request-move-article
225 (article group server accept-form &optional last move-is-internal)
226 (nnoo-parent-function 'nnagent 'nnml-request-move-article
227 (list article group (nnagent-server server)
228 accept-form last move-is-internal)))
230 (deffoo nnagent-request-rename-group (group new-name &optional server)
231 (nnoo-parent-function 'nnagent 'nnml-request-rename-group
232 (list group new-name (nnagent-server server))))
234 (deffoo nnagent-request-scan (&optional group server)
235 (nnoo-parent-function 'nnagent 'nnml-request-scan
236 (list group (nnagent-server server))))
238 (deffoo nnagent-set-status (article name value &optional group server)
239 (nnoo-parent-function 'nnagent 'nnml-set-status
240 (list article name value group (nnagent-server server))))
242 (deffoo nnagent-server-opened (&optional server)
243 (nnoo-parent-function 'nnagent 'nnml-server-opened
244 (list (nnagent-server server))))
246 (deffoo nnagent-status-message (&optional server)
247 (nnoo-parent-function 'nnagent 'nnml-status-message
248 (list (nnagent-server server))))
250 (deffoo nnagent-request-regenerate (server)
251 (nnoo-parent-function 'nnagent 'nnml-request-regenerate
252 (list (nnagent-server server))))
254 (deffoo nnagent-retrieve-group-data-early (server infos)
255 nil)
257 ;; Use nnml functions for just about everything.
258 (nnoo-import nnagent
259 (nnml))
262 ;;; Internal functions.
264 (provide 'nnagent)
266 ;;; nnagent.el ends here