Mercurial > emacs
annotate lisp/gnus/nneething.el @ 30669:616d7d67e133
(Fstring_width): Doc fix.
author | Gerd Moellmann <gerd@gnu.org> |
---|---|
date | Tue, 08 Aug 2000 12:38:01 +0000 |
parents | 15fc6acbae7a |
children | 9968f55ad26e |
rev | line source |
---|---|
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19522
diff
changeset
|
1 ;;; nneething.el --- arbitrary file access for Gnus |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19522
diff
changeset
|
2 ;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. |
17493 | 3 |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19522
diff
changeset
|
4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
17493 | 5 ;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> |
6 ;; Keywords: news, mail | |
7 | |
8 ;; This file is part of GNU Emacs. | |
9 | |
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 2, or (at your option) | |
13 ;; any later version. | |
14 | |
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. | |
19 | |
20 ;; You should have received a copy of the GNU General Public License | |
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
23 ;; Boston, MA 02111-1307, USA. | |
24 | |
25 ;;; Commentary: | |
26 | |
27 ;;; Code: | |
28 | |
19522
681265352f07
Require cl only at compile time.
Richard M. Stallman <rms@gnu.org>
parents:
17493
diff
changeset
|
29 (eval-when-compile (require 'cl)) |
681265352f07
Require cl only at compile time.
Richard M. Stallman <rms@gnu.org>
parents:
17493
diff
changeset
|
30 |
17493 | 31 (require 'nnheader) |
32 (require 'nnmail) | |
33 (require 'nnoo) | |
34 (require 'gnus-util) | |
35 | |
36 (nnoo-declare nneething) | |
37 | |
38 (defvoo nneething-map-file-directory "~/.nneething/" | |
39 "Where nneething stores the map files.") | |
40 | |
41 (defvoo nneething-map-file ".nneething" | |
42 "Name of the map files.") | |
43 | |
44 (defvoo nneething-exclude-files nil | |
45 "Regexp saying what files to exclude from the group. | |
46 If this variable is nil, no files will be excluded.") | |
47 | |
48 | |
49 | |
50 ;;; Internal variables. | |
51 | |
52 (defconst nneething-version "nneething 1.0" | |
53 "nneething version.") | |
54 | |
55 (defvoo nneething-current-directory nil | |
56 "Current news group directory.") | |
57 | |
58 (defvoo nneething-status-string "") | |
59 | |
60 (defvoo nneething-message-id-number 0) | |
61 (defvoo nneething-work-buffer " *nneething work*") | |
62 | |
63 (defvoo nneething-group nil) | |
64 (defvoo nneething-map nil) | |
65 (defvoo nneething-read-only nil) | |
66 (defvoo nneething-active nil) | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19522
diff
changeset
|
67 (defvoo nneething-address nil) |
17493 | 68 |
69 | |
70 | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19522
diff
changeset
|
71 (autoload 'gnus-encode-coding-string "gnus-ems") |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19522
diff
changeset
|
72 |
17493 | 73 ;;; Interface functions. |
74 | |
75 (nnoo-define-basics nneething) | |
76 | |
77 (deffoo nneething-retrieve-headers (articles &optional group server fetch-old) | |
78 (nneething-possibly-change-directory group) | |
79 | |
80 (save-excursion | |
81 (set-buffer nntp-server-buffer) | |
82 (erase-buffer) | |
83 (let* ((number (length articles)) | |
84 (count 0) | |
85 (large (and (numberp nnmail-large-newsgroup) | |
86 (> number nnmail-large-newsgroup))) | |
87 article file) | |
88 | |
89 (if (stringp (car articles)) | |
90 'headers | |
91 | |
92 (while (setq article (pop articles)) | |
93 (setq file (nneething-file-name article)) | |
94 | |
95 (when (and (file-exists-p file) | |
96 (or (file-directory-p file) | |
97 (not (zerop (nnheader-file-size file))))) | |
98 (insert (format "221 %d Article retrieved.\n" article)) | |
99 (nneething-insert-head file) | |
100 (insert ".\n")) | |
101 | |
102 (incf count) | |
103 | |
104 (and large | |
105 (zerop (% count 20)) | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19522
diff
changeset
|
106 (nnheader-message 5 "nneething: Receiving headers... %d%%" |
17493 | 107 (/ (* count 100) number)))) |
108 | |
109 (when large | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19522
diff
changeset
|
110 (nnheader-message 5 "nneething: Receiving headers...done")) |
17493 | 111 |
112 (nnheader-fold-continuation-lines) | |
113 'headers)))) | |
114 | |
115 (deffoo nneething-request-article (id &optional group server buffer) | |
116 (nneething-possibly-change-directory group) | |
117 (let ((file (unless (stringp id) | |
118 (nneething-file-name id))) | |
119 (nntp-server-buffer (or buffer nntp-server-buffer))) | |
120 (and (stringp file) ; We did not request by Message-ID. | |
121 (file-exists-p file) ; The file exists. | |
122 (not (file-directory-p file)) ; It's not a dir. | |
123 (save-excursion | |
124 (nnmail-find-file file) ; Insert the file in the nntp buf. | |
125 (unless (nnheader-article-p) ; Either it's a real article... | |
126 (goto-char (point-min)) | |
127 (nneething-make-head file (current-buffer)) ; ... or we fake some headers. | |
128 (insert "\n")) | |
129 t)))) | |
130 | |
131 (deffoo nneething-request-group (group &optional server dont-check) | |
132 (nneething-possibly-change-directory group server) | |
133 (unless dont-check | |
134 (nneething-create-mapping) | |
135 (if (> (car nneething-active) (cdr nneething-active)) | |
136 (nnheader-insert "211 0 1 0 %s\n" group) | |
137 (nnheader-insert | |
138 "211 %d %d %d %s\n" | |
139 (- (1+ (cdr nneething-active)) (car nneething-active)) | |
140 (car nneething-active) (cdr nneething-active) | |
141 group))) | |
142 t) | |
143 | |
144 (deffoo nneething-request-list (&optional server dir) | |
145 (nnheader-report 'nneething "LIST is not implemented.")) | |
146 | |
147 (deffoo nneething-request-newgroups (date &optional server) | |
148 (nnheader-report 'nneething "NEWSGROUPS is not implemented.")) | |
149 | |
150 (deffoo nneething-request-type (group &optional article) | |
151 'unknown) | |
152 | |
153 (deffoo nneething-close-group (group &optional server) | |
154 (setq nneething-current-directory nil) | |
155 t) | |
156 | |
157 (deffoo nneething-open-server (server &optional defs) | |
158 (nnheader-init-server-buffer) | |
159 (if (nneething-server-opened server) | |
160 t | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19522
diff
changeset
|
161 (unless (assq 'nneething-address defs) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19522
diff
changeset
|
162 (setq defs (append defs (list (list 'nneething-address server))))) |
17493 | 163 (nnoo-change-server 'nneething server defs))) |
164 | |
165 | |
166 ;;; Internal functions. | |
167 | |
168 (defun nneething-possibly-change-directory (group &optional server) | |
169 (when (and server | |
170 (not (nneething-server-opened server))) | |
171 (nneething-open-server server)) | |
172 (when (and group | |
173 (not (equal nneething-group group))) | |
174 (setq nneething-group group) | |
175 (setq nneething-map nil) | |
176 (setq nneething-active (cons 1 0)) | |
177 (nneething-create-mapping))) | |
178 | |
179 (defun nneething-map-file () | |
180 ;; We make sure that the .nneething directory exists. | |
181 (gnus-make-directory nneething-map-file-directory) | |
182 ;; We store it in a special directory under the user's home dir. | |
183 (concat (file-name-as-directory nneething-map-file-directory) | |
184 nneething-group nneething-map-file)) | |
185 | |
186 (defun nneething-create-mapping () | |
187 ;; Read nneething-active and nneething-map. | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19522
diff
changeset
|
188 (when (file-exists-p nneething-address) |
17493 | 189 (let ((map-file (nneething-map-file)) |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19522
diff
changeset
|
190 (files (directory-files nneething-address)) |
17493 | 191 touched map-files) |
192 (when (file-exists-p map-file) | |
193 (ignore-errors | |
194 (load map-file nil t t))) | |
195 (unless nneething-active | |
196 (setq nneething-active (cons 1 0))) | |
197 ;; Old nneething had a different map format. | |
198 (when (and (cdar nneething-map) | |
199 (atom (cdar nneething-map))) | |
200 (setq nneething-map | |
201 (mapcar (lambda (n) | |
202 (list (cdr n) (car n) | |
203 (nth 5 (file-attributes | |
204 (nneething-file-name (car n)))))) | |
205 nneething-map))) | |
206 ;; Remove files matching the exclusion regexp. | |
207 (when nneething-exclude-files | |
208 (let ((f files) | |
209 prev) | |
210 (while f | |
211 (if (string-match nneething-exclude-files (car f)) | |
212 (if prev (setcdr prev (cdr f)) | |
213 (setq files (cdr files))) | |
214 (setq prev f)) | |
215 (setq f (cdr f))))) | |
216 ;; Remove deleted files from the map. | |
217 (let ((map nneething-map) | |
218 prev) | |
219 (while map | |
220 (if (and (member (cadar map) files) | |
221 ;; We also remove files that have changed mod times. | |
222 (equal (nth 5 (file-attributes | |
223 (nneething-file-name (cadar map)))) | |
224 (caddar map))) | |
225 (progn | |
226 (push (cadar map) map-files) | |
227 (setq prev map)) | |
228 (setq touched t) | |
229 (if prev | |
230 (setcdr prev (cdr map)) | |
231 (setq nneething-map (cdr nneething-map)))) | |
232 (setq map (cdr map)))) | |
233 ;; Find all new files and enter them into the map. | |
234 (while files | |
235 (unless (member (car files) map-files) | |
236 ;; This file is not in the map, so we enter it. | |
237 (setq touched t) | |
238 (setcdr nneething-active (1+ (cdr nneething-active))) | |
239 (push (list (cdr nneething-active) (car files) | |
240 (nth 5 (file-attributes | |
241 (nneething-file-name (car files))))) | |
242 nneething-map)) | |
243 (setq files (cdr files))) | |
244 (when (and touched | |
245 (not nneething-read-only)) | |
246 (nnheader-temp-write map-file | |
247 (insert "(setq nneething-map '") | |
248 (gnus-prin1 nneething-map) | |
249 (insert ")\n(setq nneething-active '") | |
250 (gnus-prin1 nneething-active) | |
251 (insert ")\n")))))) | |
252 | |
253 (defun nneething-insert-head (file) | |
254 "Insert the head of FILE." | |
255 (when (nneething-get-head file) | |
256 (insert-buffer-substring nneething-work-buffer) | |
257 (goto-char (point-max)))) | |
258 | |
259 (defun nneething-make-head (file &optional buffer) | |
260 "Create a head by looking at the file attributes of FILE." | |
261 (let ((atts (file-attributes file))) | |
262 (insert | |
263 "Subject: " (file-name-nondirectory file) "\n" | |
264 "Message-ID: <nneething-" | |
265 (int-to-string (incf nneething-message-id-number)) | |
266 "@" (system-name) ">\n" | |
267 (if (equal '(0 0) (nth 5 atts)) "" | |
268 (concat "Date: " (current-time-string (nth 5 atts)) "\n")) | |
269 (or (when buffer | |
270 (save-excursion | |
271 (set-buffer buffer) | |
272 (when (re-search-forward "<[a-zA-Z0-9_]@[-a-zA-Z0-9_]>" 1000 t) | |
273 (concat "From: " (match-string 0) "\n")))) | |
274 (nneething-from-line (nth 2 atts) file)) | |
275 (if (> (string-to-int (int-to-string (nth 7 atts))) 0) | |
276 (concat "Chars: " (int-to-string (nth 7 atts)) "\n") | |
277 "") | |
278 (if buffer | |
279 (save-excursion | |
280 (set-buffer buffer) | |
281 (concat "Lines: " (int-to-string | |
282 (count-lines (point-min) (point-max))) | |
283 "\n")) | |
284 "") | |
285 ))) | |
286 | |
287 (defun nneething-from-line (uid &optional file) | |
288 "Return a From header based of UID." | |
289 (let* ((login (condition-case nil | |
290 (user-login-name uid) | |
291 (error | |
292 (cond ((= uid (user-uid)) (user-login-name)) | |
293 ((zerop uid) "root") | |
294 (t (int-to-string uid)))))) | |
295 (name (condition-case nil | |
296 (user-full-name uid) | |
297 (error | |
298 (cond ((= uid (user-uid)) (user-full-name)) | |
299 ((zerop uid) "Ms. Root"))))) | |
300 (host (if (string-match "\\`/[^/@]*@\\([^:/]+\\):" file) | |
301 (prog1 | |
302 (substring file | |
303 (match-beginning 1) | |
304 (match-end 1)) | |
305 (when (string-match "/\\(users\\|home\\)/\\([^/]+\\)/" file) | |
306 (setq login (substring file | |
307 (match-beginning 2) | |
308 (match-end 2)) | |
309 name nil))) | |
310 (system-name)))) | |
311 (concat "From: " login "@" host | |
312 (if name (concat " (" name ")") "") "\n"))) | |
313 | |
314 (defun nneething-get-head (file) | |
315 "Either find the head in FILE or make a head for FILE." | |
316 (save-excursion | |
317 (set-buffer (get-buffer-create nneething-work-buffer)) | |
318 (setq case-fold-search nil) | |
319 (buffer-disable-undo (current-buffer)) | |
320 (erase-buffer) | |
321 (cond | |
322 ((not (file-exists-p file)) | |
323 ;; The file do not exist. | |
324 nil) | |
325 ((or (file-directory-p file) | |
326 (file-symlink-p file)) | |
327 ;; It's a dir, so we fudge a head. | |
328 (nneething-make-head file) t) | |
329 (t | |
330 ;; We examine the file. | |
331 (nnheader-insert-head file) | |
332 (if (nnheader-article-p) | |
333 (delete-region | |
334 (progn | |
335 (goto-char (point-min)) | |
336 (or (and (search-forward "\n\n" nil t) | |
337 (1- (point))) | |
338 (point-max))) | |
339 (point-max)) | |
340 (goto-char (point-min)) | |
341 (nneething-make-head file (current-buffer)) | |
342 (delete-region (point) (point-max))) | |
343 t)))) | |
344 | |
345 (defun nneething-file-name (article) | |
346 "Return the file name of ARTICLE." | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19522
diff
changeset
|
347 (concat (file-name-as-directory nneething-address) |
17493 | 348 (if (numberp article) |
349 (cadr (assq article nneething-map)) | |
350 article))) | |
351 | |
352 (provide 'nneething) | |
353 | |
354 ;;; nneething.el ends here |