1;;; nneething.el --- arbitrary file access for Gnus
2
3;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
4;;   2004, 2005, 2006, 2007 Free Software Foundation, Inc.
5
6;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
7;;	Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
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
14;; the Free Software Foundation; either version 2, or (at your option)
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
24;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
25;; Boston, MA 02110-1301, USA.
26
27;;; Commentary:
28
29;;; Code:
30
31(eval-when-compile (require 'cl))
32
33(require 'nnheader)
34(require 'nnmail)
35(require 'nnoo)
36(require 'gnus-util)
37
38(nnoo-declare nneething)
39
40(defvoo nneething-map-file-directory
41  (nnheader-concat gnus-directory ".nneething/")
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.
49If this variable is nil, no files will be excluded.")
50
51(defvoo nneething-include-files nil
52  "Regexp saying what files to include in the group.
53If this variable is non-nil, only files matching this regexp will be
54included.")
55
56
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
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)
74(defvoo nneething-address nil)
75
76
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))
111	       (nnheader-message 5 "nneething: Receiving headers... %d%%"
112				 (/ (* count 100) number))))
113
114	(when large
115	  (nnheader-message 5 "nneething: Receiving headers...done"))
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)))
125    (and (stringp file)		   ; We did not request by Message-ID.
126	 (file-exists-p file)		; The file exists.
127	 (not (file-directory-p file))	; It's not a dir.
128	 (save-excursion
129	   (let ((nnmail-file-coding-system 'binary))
130	     (nnmail-find-file file))	; Insert the file in the nntp buf.
131	   (unless (nnheader-article-p)	; Either it's a real article...
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))
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
179    (unless (assq 'nneething-address defs)
180      (setq defs (append defs (list (list 'nneething-address server)))))
181    (nnoo-change-server 'nneething server defs)))
182
183
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.
206  (when (file-exists-p nneething-address)
207    (let ((map-file (nneething-map-file))
208	  (files (directory-files nneething-address))
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)))))
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)))))
244      ;; Remove deleted files from the map.
245      (let ((map nneething-map)
246	    prev)
247	(while map
248	  (if (and (member (cadr (car map)) files)
249		  ;; We also remove files that have changed mod times.
250		   (equal (nth 5 (file-attributes
251				  (nneething-file-name (cadr (car map)))))
252			  (cadr (cdar map))))
253	      (progn
254		(push (cadr (car map)) map-files)
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))
274	(with-temp-file map-file
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
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)))
306    (mm-decode-coding-string
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)
318  "Create a head by looking at the file attributes of FILE."
319  (let ((atts (file-attributes file)))
320    (insert
321     "Subject: " (file-name-nondirectory file) (or extra-msg "") "\n"
322     "Message-ID: <nneething-" (nneething-encode-file-name file)
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))
332     (if (> (string-to-number (int-to-string (nth 7 atts))) 0)
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"))
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")
354       ""))))
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))
374		     (when (string-match
375			    "/\\(users\\|home\\)/\\([^/]+\\)/" file)
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)
389    (buffer-disable-undo)
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.
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)")))
417      t))))
418
419(defun nneething-file-name (article)
420  "Return the file name of ARTICLE."
421  (let ((dir (file-name-as-directory nneething-address))
422	fname)
423    (if (numberp article)
424	(if (setq fname (cadr (assq article nneething-map)))
425	    (expand-file-name fname dir)
426	  (mm-make-temp-file (expand-file-name "nneething" dir)))
427      (expand-file-name article dir))))
428
429(provide 'nneething)
430
431;;; arch-tag: 1277f386-88f2-4459-bb24-f3f45962a6c5
432;;; nneething.el ends here
433