Commit | Line | Data |
---|---|---|
6748645f | 1 | ;;; nneething.el --- arbitrary file access for Gnus |
16409b0b | 2 | |
e84b4b86 | 3 | ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, |
d7a0267c | 4 | ;; 2004, 2005, 2006, 2007 Free Software Foundation, Inc. |
eec82323 | 5 | |
6748645f | 6 | ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
23f87bed | 7 | ;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> |
eec82323 LMI |
8 | ;; Keywords: news, mail |
9 | ||
10 | ;; This file is part of GNU Emacs. | |
11 | ||
12 | ;; GNU Emacs is free software; you can redistribute it and/or modify | |
13 | ;; it under the terms of the GNU General Public License as published by | |
5a9dffec | 14 | ;; the Free Software Foundation; either version 3, or (at your option) |
eec82323 LMI |
15 | ;; any later version. |
16 | ||
17 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
18 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
19 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
20 | ;; GNU General Public License for more details. | |
21 | ||
22 | ;; You should have received a copy of the GNU General Public License | |
23 | ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
3a35cf56 LK |
24 | ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
25 | ;; Boston, MA 02110-1301, USA. | |
eec82323 LMI |
26 | |
27 | ;;; Commentary: | |
28 | ||
29 | ;;; Code: | |
30 | ||
0df953b6 RS |
31 | (eval-when-compile (require 'cl)) |
32 | ||
eec82323 LMI |
33 | (require 'nnheader) |
34 | (require 'nnmail) | |
35 | (require 'nnoo) | |
36 | (require 'gnus-util) | |
eec82323 LMI |
37 | |
38 | (nnoo-declare nneething) | |
39 | ||
fa9a04e1 MB |
40 | (defvoo nneething-map-file-directory |
41 | (nnheader-concat gnus-directory ".nneething/") | |
eec82323 LMI |
42 | "Where nneething stores the map files.") |
43 | ||
44 | (defvoo nneething-map-file ".nneething" | |
45 | "Name of the map files.") | |
46 | ||
47 | (defvoo nneething-exclude-files nil | |
48 | "Regexp saying what files to exclude from the group. | |
49 | If this variable is nil, no files will be excluded.") | |
50 | ||
16409b0b GM |
51 | (defvoo nneething-include-files nil |
52 | "Regexp saying what files to include in the group. | |
53 | If this variable is non-nil, only files matching this regexp will be | |
54 | included.") | |
55 | ||
eec82323 LMI |
56 | \f |
57 | ||
58 | ;;; Internal variables. | |
59 | ||
60 | (defconst nneething-version "nneething 1.0" | |
61 | "nneething version.") | |
62 | ||
63 | (defvoo nneething-current-directory nil | |
64 | "Current news group directory.") | |
65 | ||
66 | (defvoo nneething-status-string "") | |
67 | ||
eec82323 LMI |
68 | (defvoo nneething-work-buffer " *nneething work*") |
69 | ||
70 | (defvoo nneething-group nil) | |
71 | (defvoo nneething-map nil) | |
72 | (defvoo nneething-read-only nil) | |
73 | (defvoo nneething-active nil) | |
6748645f | 74 | (defvoo nneething-address nil) |
eec82323 LMI |
75 | |
76 | \f | |
77 | ||
78 | ;;; Interface functions. | |
79 | ||
80 | (nnoo-define-basics nneething) | |
81 | ||
82 | (deffoo nneething-retrieve-headers (articles &optional group server fetch-old) | |
83 | (nneething-possibly-change-directory group) | |
84 | ||
85 | (save-excursion | |
86 | (set-buffer nntp-server-buffer) | |
87 | (erase-buffer) | |
88 | (let* ((number (length articles)) | |
89 | (count 0) | |
90 | (large (and (numberp nnmail-large-newsgroup) | |
91 | (> number nnmail-large-newsgroup))) | |
92 | article file) | |
93 | ||
94 | (if (stringp (car articles)) | |
95 | 'headers | |
96 | ||
97 | (while (setq article (pop articles)) | |
98 | (setq file (nneething-file-name article)) | |
99 | ||
100 | (when (and (file-exists-p file) | |
101 | (or (file-directory-p file) | |
102 | (not (zerop (nnheader-file-size file))))) | |
103 | (insert (format "221 %d Article retrieved.\n" article)) | |
104 | (nneething-insert-head file) | |
105 | (insert ".\n")) | |
106 | ||
107 | (incf count) | |
108 | ||
109 | (and large | |
110 | (zerop (% count 20)) | |
6748645f | 111 | (nnheader-message 5 "nneething: Receiving headers... %d%%" |
16409b0b | 112 | (/ (* count 100) number)))) |
eec82323 LMI |
113 | |
114 | (when large | |
6748645f | 115 | (nnheader-message 5 "nneething: Receiving headers...done")) |
eec82323 LMI |
116 | |
117 | (nnheader-fold-continuation-lines) | |
118 | 'headers)))) | |
119 | ||
120 | (deffoo nneething-request-article (id &optional group server buffer) | |
121 | (nneething-possibly-change-directory group) | |
122 | (let ((file (unless (stringp id) | |
123 | (nneething-file-name id))) | |
124 | (nntp-server-buffer (or buffer nntp-server-buffer))) | |
23f87bed | 125 | (and (stringp file) ; We did not request by Message-ID. |
eec82323 LMI |
126 | (file-exists-p file) ; The file exists. |
127 | (not (file-directory-p file)) ; It's not a dir. | |
128 | (save-excursion | |
23f87bed MB |
129 | (let ((nnmail-file-coding-system 'binary)) |
130 | (nnmail-find-file file)) ; Insert the file in the nntp buf. | |
eec82323 | 131 | (unless (nnheader-article-p) ; Either it's a real article... |
23f87bed MB |
132 | (let ((type |
133 | (unless (file-directory-p file) | |
134 | (or (cdr (assoc (concat "." (file-name-extension file)) | |
135 | mailcap-mime-extensions)) | |
136 | "text/plain"))) | |
137 | (charset | |
138 | (mm-detect-mime-charset-region (point-min) (point-max))) | |
139 | (encoding)) | |
140 | (unless (string-match "\\`text/" type) | |
141 | (base64-encode-region (point-min) (point-max)) | |
142 | (setq encoding "base64")) | |
143 | (goto-char (point-min)) | |
144 | (nneething-make-head file (current-buffer) | |
145 | nil type charset encoding)) | |
eec82323 LMI |
146 | (insert "\n")) |
147 | t)))) | |
148 | ||
149 | (deffoo nneething-request-group (group &optional server dont-check) | |
150 | (nneething-possibly-change-directory group server) | |
151 | (unless dont-check | |
152 | (nneething-create-mapping) | |
153 | (if (> (car nneething-active) (cdr nneething-active)) | |
154 | (nnheader-insert "211 0 1 0 %s\n" group) | |
155 | (nnheader-insert | |
156 | "211 %d %d %d %s\n" | |
157 | (- (1+ (cdr nneething-active)) (car nneething-active)) | |
158 | (car nneething-active) (cdr nneething-active) | |
159 | group))) | |
160 | t) | |
161 | ||
162 | (deffoo nneething-request-list (&optional server dir) | |
163 | (nnheader-report 'nneething "LIST is not implemented.")) | |
164 | ||
165 | (deffoo nneething-request-newgroups (date &optional server) | |
166 | (nnheader-report 'nneething "NEWSGROUPS is not implemented.")) | |
167 | ||
168 | (deffoo nneething-request-type (group &optional article) | |
169 | 'unknown) | |
170 | ||
171 | (deffoo nneething-close-group (group &optional server) | |
172 | (setq nneething-current-directory nil) | |
173 | t) | |
174 | ||
175 | (deffoo nneething-open-server (server &optional defs) | |
176 | (nnheader-init-server-buffer) | |
177 | (if (nneething-server-opened server) | |
178 | t | |
6748645f LMI |
179 | (unless (assq 'nneething-address defs) |
180 | (setq defs (append defs (list (list 'nneething-address server))))) | |
eec82323 LMI |
181 | (nnoo-change-server 'nneething server defs))) |
182 | ||
183 | \f | |
184 | ;;; Internal functions. | |
185 | ||
186 | (defun nneething-possibly-change-directory (group &optional server) | |
187 | (when (and server | |
188 | (not (nneething-server-opened server))) | |
189 | (nneething-open-server server)) | |
190 | (when (and group | |
191 | (not (equal nneething-group group))) | |
192 | (setq nneething-group group) | |
193 | (setq nneething-map nil) | |
194 | (setq nneething-active (cons 1 0)) | |
195 | (nneething-create-mapping))) | |
196 | ||
197 | (defun nneething-map-file () | |
198 | ;; We make sure that the .nneething directory exists. | |
199 | (gnus-make-directory nneething-map-file-directory) | |
200 | ;; We store it in a special directory under the user's home dir. | |
201 | (concat (file-name-as-directory nneething-map-file-directory) | |
202 | nneething-group nneething-map-file)) | |
203 | ||
204 | (defun nneething-create-mapping () | |
205 | ;; Read nneething-active and nneething-map. | |
6748645f | 206 | (when (file-exists-p nneething-address) |
eec82323 | 207 | (let ((map-file (nneething-map-file)) |
6748645f | 208 | (files (directory-files nneething-address)) |
eec82323 LMI |
209 | touched map-files) |
210 | (when (file-exists-p map-file) | |
211 | (ignore-errors | |
212 | (load map-file nil t t))) | |
213 | (unless nneething-active | |
214 | (setq nneething-active (cons 1 0))) | |
215 | ;; Old nneething had a different map format. | |
216 | (when (and (cdar nneething-map) | |
217 | (atom (cdar nneething-map))) | |
218 | (setq nneething-map | |
219 | (mapcar (lambda (n) | |
220 | (list (cdr n) (car n) | |
221 | (nth 5 (file-attributes | |
222 | (nneething-file-name (car n)))))) | |
223 | nneething-map))) | |
224 | ;; Remove files matching the exclusion regexp. | |
225 | (when nneething-exclude-files | |
226 | (let ((f files) | |
227 | prev) | |
228 | (while f | |
229 | (if (string-match nneething-exclude-files (car f)) | |
230 | (if prev (setcdr prev (cdr f)) | |
231 | (setq files (cdr files))) | |
232 | (setq prev f)) | |
233 | (setq f (cdr f))))) | |
16409b0b GM |
234 | ;; Remove files not matching the inclusion regexp. |
235 | (when nneething-include-files | |
236 | (let ((f files) | |
237 | prev) | |
238 | (while f | |
239 | (if (not (string-match nneething-include-files (car f))) | |
240 | (if prev (setcdr prev (cdr f)) | |
241 | (setq files (cdr files))) | |
242 | (setq prev f)) | |
243 | (setq f (cdr f))))) | |
eec82323 LMI |
244 | ;; Remove deleted files from the map. |
245 | (let ((map nneething-map) | |
246 | prev) | |
247 | (while map | |
16409b0b | 248 | (if (and (member (cadr (car map)) files) |
23f87bed | 249 | ;; We also remove files that have changed mod times. |
eec82323 | 250 | (equal (nth 5 (file-attributes |
16409b0b GM |
251 | (nneething-file-name (cadr (car map))))) |
252 | (cadr (cdar map)))) | |
eec82323 | 253 | (progn |
16409b0b | 254 | (push (cadr (car map)) map-files) |
eec82323 LMI |
255 | (setq prev map)) |
256 | (setq touched t) | |
257 | (if prev | |
258 | (setcdr prev (cdr map)) | |
259 | (setq nneething-map (cdr nneething-map)))) | |
260 | (setq map (cdr map)))) | |
261 | ;; Find all new files and enter them into the map. | |
262 | (while files | |
263 | (unless (member (car files) map-files) | |
264 | ;; This file is not in the map, so we enter it. | |
265 | (setq touched t) | |
266 | (setcdr nneething-active (1+ (cdr nneething-active))) | |
267 | (push (list (cdr nneething-active) (car files) | |
268 | (nth 5 (file-attributes | |
269 | (nneething-file-name (car files))))) | |
270 | nneething-map)) | |
271 | (setq files (cdr files))) | |
272 | (when (and touched | |
273 | (not nneething-read-only)) | |
16409b0b | 274 | (with-temp-file map-file |
eec82323 LMI |
275 | (insert "(setq nneething-map '") |
276 | (gnus-prin1 nneething-map) | |
277 | (insert ")\n(setq nneething-active '") | |
278 | (gnus-prin1 nneething-active) | |
279 | (insert ")\n")))))) | |
280 | ||
281 | (defun nneething-insert-head (file) | |
282 | "Insert the head of FILE." | |
283 | (when (nneething-get-head file) | |
284 | (insert-buffer-substring nneething-work-buffer) | |
285 | (goto-char (point-max)))) | |
286 | ||
23f87bed MB |
287 | (defun nneething-encode-file-name (file &optional coding-system) |
288 | "Encode the name of the FILE in CODING-SYSTEM." | |
289 | (let ((pos 0) buf) | |
290 | (setq file (mm-encode-coding-string | |
291 | file (or coding-system nnmail-pathname-coding-system))) | |
292 | (while (string-match "[^-0-9a-zA-Z_:/.]" file pos) | |
293 | (setq buf (cons (format "%%%02x" (aref file (match-beginning 0))) | |
294 | (cons (substring file pos (match-beginning 0)) buf)) | |
295 | pos (match-end 0))) | |
296 | (apply (function concat) | |
297 | (nreverse (cons (substring file pos) buf))))) | |
298 | ||
299 | (defun nneething-decode-file-name (file &optional coding-system) | |
300 | "Decode the name of the FILE is encoded in CODING-SYSTEM." | |
301 | (let ((pos 0) buf) | |
302 | (while (string-match "%\\([0-9a-fA-F][0-9a-fA-F]\\)" file pos) | |
303 | (setq buf (cons (string (string-to-number (match-string 1 file) 16)) | |
304 | (cons (substring file pos (match-beginning 0)) buf)) | |
305 | pos (match-end 0))) | |
5538c331 | 306 | (mm-decode-coding-string |
23f87bed MB |
307 | (apply (function concat) |
308 | (nreverse (cons (substring file pos) buf))) | |
309 | (or coding-system nnmail-pathname-coding-system)))) | |
310 | ||
311 | (defun nneething-get-file-name (id) | |
312 | "Extract the file name from the message ID string." | |
313 | (when (string-match "\\`<nneething-\\([^@]+\\)@.*>\\'" id) | |
314 | (nneething-decode-file-name (match-string 1 id)))) | |
315 | ||
316 | (defun nneething-make-head (file &optional buffer extra-msg | |
317 | mime-type mime-charset mime-encoding) | |
eec82323 LMI |
318 | "Create a head by looking at the file attributes of FILE." |
319 | (let ((atts (file-attributes file))) | |
320 | (insert | |
23f87bed MB |
321 | "Subject: " (file-name-nondirectory file) (or extra-msg "") "\n" |
322 | "Message-ID: <nneething-" (nneething-encode-file-name file) | |
eec82323 LMI |
323 | "@" (system-name) ">\n" |
324 | (if (equal '(0 0) (nth 5 atts)) "" | |
325 | (concat "Date: " (current-time-string (nth 5 atts)) "\n")) | |
326 | (or (when buffer | |
327 | (save-excursion | |
328 | (set-buffer buffer) | |
329 | (when (re-search-forward "<[a-zA-Z0-9_]@[-a-zA-Z0-9_]>" 1000 t) | |
330 | (concat "From: " (match-string 0) "\n")))) | |
331 | (nneething-from-line (nth 2 atts) file)) | |
e9bd5782 | 332 | (if (> (string-to-number (int-to-string (nth 7 atts))) 0) |
eec82323 LMI |
333 | (concat "Chars: " (int-to-string (nth 7 atts)) "\n") |
334 | "") | |
335 | (if buffer | |
336 | (save-excursion | |
337 | (set-buffer buffer) | |
338 | (concat "Lines: " (int-to-string | |
339 | (count-lines (point-min) (point-max))) | |
340 | "\n")) | |
23f87bed MB |
341 | "") |
342 | (if mime-type | |
343 | (concat "Content-Type: " mime-type | |
344 | (if mime-charset | |
345 | (concat "; charset=" | |
346 | (if (stringp mime-charset) | |
347 | mime-charset | |
348 | (symbol-name mime-charset))) | |
349 | "") | |
350 | (if mime-encoding | |
351 | (concat "\nContent-Transfer-Encoding: " mime-encoding) | |
352 | "") | |
353 | "\nMIME-Version: 1.0\n") | |
16409b0b | 354 | "")))) |
eec82323 LMI |
355 | |
356 | (defun nneething-from-line (uid &optional file) | |
357 | "Return a From header based of UID." | |
358 | (let* ((login (condition-case nil | |
359 | (user-login-name uid) | |
360 | (error | |
361 | (cond ((= uid (user-uid)) (user-login-name)) | |
362 | ((zerop uid) "root") | |
363 | (t (int-to-string uid)))))) | |
364 | (name (condition-case nil | |
365 | (user-full-name uid) | |
366 | (error | |
367 | (cond ((= uid (user-uid)) (user-full-name)) | |
368 | ((zerop uid) "Ms. Root"))))) | |
369 | (host (if (string-match "\\`/[^/@]*@\\([^:/]+\\):" file) | |
370 | (prog1 | |
371 | (substring file | |
372 | (match-beginning 1) | |
373 | (match-end 1)) | |
16409b0b GM |
374 | (when (string-match |
375 | "/\\(users\\|home\\)/\\([^/]+\\)/" file) | |
eec82323 LMI |
376 | (setq login (substring file |
377 | (match-beginning 2) | |
378 | (match-end 2)) | |
379 | name nil))) | |
380 | (system-name)))) | |
381 | (concat "From: " login "@" host | |
382 | (if name (concat " (" name ")") "") "\n"))) | |
383 | ||
384 | (defun nneething-get-head (file) | |
385 | "Either find the head in FILE or make a head for FILE." | |
386 | (save-excursion | |
387 | (set-buffer (get-buffer-create nneething-work-buffer)) | |
388 | (setq case-fold-search nil) | |
16409b0b | 389 | (buffer-disable-undo) |
eec82323 LMI |
390 | (erase-buffer) |
391 | (cond | |
392 | ((not (file-exists-p file)) | |
393 | ;; The file do not exist. | |
394 | nil) | |
395 | ((or (file-directory-p file) | |
396 | (file-symlink-p file)) | |
397 | ;; It's a dir, so we fudge a head. | |
398 | (nneething-make-head file) t) | |
399 | (t | |
400 | ;; We examine the file. | |
23f87bed MB |
401 | (condition-case () |
402 | (progn | |
403 | (nnheader-insert-head file) | |
404 | (if (nnheader-article-p) | |
405 | (delete-region | |
406 | (progn | |
407 | (goto-char (point-min)) | |
408 | (or (and (search-forward "\n\n" nil t) | |
409 | (1- (point))) | |
410 | (point-max))) | |
411 | (point-max)) | |
412 | (goto-char (point-min)) | |
413 | (nneething-make-head file (current-buffer)) | |
414 | (delete-region (point) (point-max)))) | |
415 | (file-error | |
416 | (nneething-make-head file (current-buffer) " (unreadable)"))) | |
eec82323 LMI |
417 | t)))) |
418 | ||
419 | (defun nneething-file-name (article) | |
420 | "Return the file name of ARTICLE." | |
16409b0b | 421 | (let ((dir (file-name-as-directory nneething-address)) |
23f87bed | 422 | fname) |
16409b0b GM |
423 | (if (numberp article) |
424 | (if (setq fname (cadr (assq article nneething-map))) | |
425 | (expand-file-name fname dir) | |
3efe5554 | 426 | (mm-make-temp-file (expand-file-name "nneething" dir))) |
16409b0b | 427 | (expand-file-name article dir)))) |
eec82323 LMI |
428 | |
429 | (provide 'nneething) | |
430 | ||
ab5796a9 | 431 | ;;; arch-tag: 1277f386-88f2-4459-bb24-f3f45962a6c5 |
eec82323 | 432 | ;;; nneething.el ends here |