Mercurial > hg > xemacs-beta

comparison lisp/gnus/nneething.el @ 70:131b0175ea99 r20-0b30

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents 1a767b41a199
children 0d2f883870bc
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
1 ;;; nneething.el --- random file access for Gnus 1 ;;; nneething.el --- random file access for Gnus
2 ;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. 2 ;; Copyright (C) 1995,96 Free Software Foundation, Inc.
3 3
4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
5 ;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> 5 ;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
6 ;; Keywords: news, mail 6 ;; Keywords: news, mail
7 7
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA. 23 ;; Boston, MA 02111-1307, USA.
24 24
25 ;;; Commentary: 25 ;;; Commentary:
26 26
27 ;; Based on nnspool.el by Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>.
28 ;; For an overview of what the interface functions do, please see the
29 ;; Gnus sources.
30
27 ;;; Code: 31 ;;; Code:
28 32
29 (require 'nnheader) 33 (require 'nnheader)
30 (require 'nnmail) 34 (require 'nnmail)
31 (require 'nnoo) 35 (require 'nnoo)
32 (require 'gnus-util) 36 (eval-when-compile (require 'cl))
33 (require 'cl)
34 37
35 (nnoo-declare nneething) 38 (nnoo-declare nneething)
36 39
37 (defvoo nneething-map-file-directory "~/.nneething/" 40 (defvoo nneething-map-file-directory "~/.nneething/"
38 "Where nneething stores the map files.") 41 "*Where nneething stores the map files.")
39 42
40 (defvoo nneething-map-file ".nneething" 43 (defvoo nneething-map-file ".nneething"
41 "Name of the map files.") 44 "*Name of the map files.")
42 45
43 (defvoo nneething-exclude-files nil 46 (defvoo nneething-exclude-files nil
44 "Regexp saying what files to exclude from the group. 47 "*Regexp saying what files to exclude from the group.
45 If this variable is nil, no files will be excluded.") 48 If this variable is nil, no files will be excluded.")
46 49
47 50
48 51
49 ;;; Internal variables. 52 ;;; Internal variables.
50 53
51 (defconst nneething-version "nneething 1.0" 54 (defconst nneething-version "nneething 1.0"
52 "nneething version.") 55 "nneething version.")
53 56
54 (defvoo nneething-current-directory nil 57 (defvoo nneething-current-directory nil
55 "Current news group directory.") 58 "Current news group directory.")
56 59
57 (defvoo nneething-status-string "") 60 (defvoo nneething-status-string "")
61 (defvoo nneething-group-alist nil)
58 62
59 (defvoo nneething-message-id-number 0) 63 (defvoo nneething-message-id-number 0)
60 (defvoo nneething-work-buffer " *nneething work*") 64 (defvoo nneething-work-buffer " *nneething work*")
61 65
66 (defvoo nneething-directory nil)
62 (defvoo nneething-group nil) 67 (defvoo nneething-group nil)
63 (defvoo nneething-map nil) 68 (defvoo nneething-map nil)
64 (defvoo nneething-read-only nil) 69 (defvoo nneething-read-only nil)
65 (defvoo nneething-active nil) 70 (defvoo nneething-active nil)
66 71
108 (nnheader-fold-continuation-lines) 113 (nnheader-fold-continuation-lines)
109 'headers)))) 114 'headers))))
110 115
111 (deffoo nneething-request-article (id &optional group server buffer) 116 (deffoo nneething-request-article (id &optional group server buffer)
112 (nneething-possibly-change-directory group) 117 (nneething-possibly-change-directory group)
113 (let ((file (unless (stringp id) 118 (let ((file (unless (stringp id) (nneething-file-name id)))
114 (nneething-file-name id)))
115 (nntp-server-buffer (or buffer nntp-server-buffer))) 119 (nntp-server-buffer (or buffer nntp-server-buffer)))
116 (and (stringp file) ; We did not request by Message-ID. 120 (and (stringp file) ; We did not request by Message-ID.
117 (file-exists-p file) ; The file exists. 121 (file-exists-p file) ; The file exists.
118 (not (file-directory-p file)) ; It's not a dir. 122 (not (file-directory-p file)) ; It's not a dir.
119 (save-excursion 123 (save-excursion
120 (nnmail-find-file file) ; Insert the file in the nntp buf. 124 (nnmail-find-file file) ; Insert the file in the nntp buf.
121 (unless (nnheader-article-p) ; Either it's a real article... 125 (or (nnheader-article-p) ; Either it's a real article...
122 (goto-char (point-min)) 126 (progn
123 (nneething-make-head file (current-buffer)) ; ... or we fake some headers. 127 (goto-char (point-min))
124 (insert "\n")) 128 (nneething-make-head file (current-buffer)) ; ... or we fake some headers.
129 (insert "\n")))
125 t)))) 130 t))))
126 131
127 (deffoo nneething-request-group (group &optional server dont-check) 132 (deffoo nneething-request-group (group &optional dir dont-check)
128 (nneething-possibly-change-directory group server) 133 (nneething-possibly-change-directory group dir)
129 (unless dont-check 134 (unless dont-check
130 (nneething-create-mapping) 135 (nneething-create-mapping)
131 (if (> (car nneething-active) (cdr nneething-active)) 136 (if (> (car nneething-active) (cdr nneething-active))
132 (nnheader-insert "211 0 1 0 %s\n" group) 137 (nnheader-insert "211 0 1 0 %s\n" group)
133 (nnheader-insert 138 (nnheader-insert
134 "211 %d %d %d %s\n" 139 "211 %d %d %d %s\n"
135 (- (1+ (cdr nneething-active)) (car nneething-active)) 140 (- (1+ (cdr nneething-active)) (car nneething-active))
136 (car nneething-active) (cdr nneething-active) 141 (car nneething-active) (cdr nneething-active)
137 group))) 142 group)))
138 t) 143 t)
139 144
148 153
149 (deffoo nneething-close-group (group &optional server) 154 (deffoo nneething-close-group (group &optional server)
150 (setq nneething-current-directory nil) 155 (setq nneething-current-directory nil)
151 t) 156 t)
152 157
153 (deffoo nneething-open-server (server &optional defs)
154 (nnheader-init-server-buffer)
155 (if (nneething-server-opened server)
156 t
157 (unless (assq 'nneething-directory defs)
158 (setq defs (append defs (list (list 'nneething-directory server)))))
159 (nnoo-change-server 'nneething server defs)))
160
161 158
162 ;;; Internal functions. 159 ;;; Internal functions.
163 160
164 (defun nneething-possibly-change-directory (group &optional server) 161 (defun nneething-possibly-change-directory (group &optional dir)
165 (when (and server 162 (when group
166 (not (nneething-server-opened server))) 163 (if (and nneething-group
167 (nneething-open-server server)) 164 (string= group nneething-group))
168 (when (and group 165 t
169 (not (equal nneething-group group))) 166 (let (entry)
170 (setq nneething-group group) 167 (if (setq entry (assoc group nneething-group-alist))
171 (setq nneething-map nil) 168 (progn
172 (setq nneething-active (cons 1 0)) 169 (setq nneething-group group)
173 (nneething-create-mapping))) 170 (setq nneething-directory (nth 1 entry))
171 (setq nneething-map (nth 2 entry))
172 (setq nneething-active (nth 3 entry)))
173 (setq nneething-group group)
174 (setq nneething-directory dir)
175 (setq nneething-map nil)
176 (setq nneething-active (cons 1 0))
177 (nneething-create-mapping)
178 (push (list group dir nneething-map nneething-active)
179 nneething-group-alist))))))
174 180
175 (defun nneething-map-file () 181 (defun nneething-map-file ()
176 ;; We make sure that the .nneething directory exists. 182 ;; We make sure that the .nneething directory exists.
177 (gnus-make-directory nneething-map-file-directory) 183 (unless (file-exists-p nneething-map-file-directory)
184 (make-directory nneething-map-file-directory 'parents))
178 ;; We store it in a special directory under the user's home dir. 185 ;; We store it in a special directory under the user's home dir.
179 (concat (file-name-as-directory nneething-map-file-directory) 186 (concat (file-name-as-directory nneething-map-file-directory)
180 nneething-group nneething-map-file)) 187 nneething-group nneething-map-file))
181 188
182 (defun nneething-create-mapping () 189 (defun nneething-create-mapping ()
183 ;; Read nneething-active and nneething-map. 190 ;; Read nneething-active and nneething-map.
184 (when (file-exists-p nneething-directory) 191 (let ((map-file (nneething-map-file))
185 (let ((map-file (nneething-map-file)) 192 (files (directory-files nneething-directory))
186 (files (directory-files nneething-directory)) 193 touched map-files)
187 touched map-files) 194 (if (file-exists-p map-file)
188 (when (file-exists-p map-file) 195 (condition-case nil
189 (ignore-errors 196 (load map-file nil t t)
190 (load map-file nil t t))) 197 (error nil)))
191 (unless nneething-active 198 (or nneething-active (setq nneething-active (cons 1 0)))
192 (setq nneething-active (cons 1 0))) 199 ;; Old nneething had a different map format.
193 ;; Old nneething had a different map format. 200 (when (and (cdar nneething-map)
194 (when (and (cdar nneething-map) 201 (atom (cdar nneething-map)))
195 (atom (cdar nneething-map))) 202 (setq nneething-map
196 (setq nneething-map 203 (mapcar (lambda (n)
197 (mapcar (lambda (n) 204 (list (cdr n) (car n)
198 (list (cdr n) (car n) 205 (nth 5 (file-attributes
199 (nth 5 (file-attributes 206 (nneething-file-name (car n))))))
200 (nneething-file-name (car n)))))) 207 nneething-map)))
201 nneething-map))) 208 ;; Remove files matching the exclusion regexp.
202 ;; Remove files matching the exclusion regexp. 209 (when nneething-exclude-files
203 (when nneething-exclude-files 210 (let ((f files)
204 (let ((f files)
205 prev)
206 (while f
207 (if (string-match nneething-exclude-files (car f))
208 (if prev (setcdr prev (cdr f))
209 (setq files (cdr files)))
210 (setq prev f))
211 (setq f (cdr f)))))
212 ;; Remove deleted files from the map.
213 (let ((map nneething-map)
214 prev) 211 prev)
215 (while map 212 (while f
216 (if (and (member (cadar map) files) 213 (if (string-match nneething-exclude-files (car f))
217 ;; We also remove files that have changed mod times. 214 (if prev (setcdr prev (cdr f))
218 (equal (nth 5 (file-attributes 215 (setq files (cdr files)))
219 (nneething-file-name (cadar map)))) 216 (setq prev f))
220 (caddar map))) 217 (setq f (cdr f)))))
221 (progn 218 ;; Remove deleted files from the map.
222 (push (cadar map) map-files) 219 (let ((map nneething-map)
223 (setq prev map)) 220 prev)
224 (setq touched t) 221 (while map
225 (if prev 222 (if (and (member (cadar map) files)
226 (setcdr prev (cdr map)) 223 ;; We also remove files that have changed mod times.
227 (setq nneething-map (cdr nneething-map)))) 224 (equal (nth 5 (file-attributes
228 (setq map (cdr map)))) 225 (nneething-file-name (cadar map))))
229 ;; Find all new files and enter them into the map. 226 (caddar map)))
230 (while files 227 (progn
231 (unless (member (car files) map-files) 228 (push (cadar map) map-files)
232 ;; This file is not in the map, so we enter it. 229 (setq prev map))
233 (setq touched t) 230 (setq touched t)
234 (setcdr nneething-active (1+ (cdr nneething-active))) 231 (if prev
235 (push (list (cdr nneething-active) (car files) 232 (setcdr prev (cdr map))
236 (nth 5 (file-attributes 233 (setq nneething-map (cdr nneething-map))))
237 (nneething-file-name (car files))))) 234 (setq map (cdr map))))
238 nneething-map)) 235 ;; Find all new files and enter them into the map.
239 (setq files (cdr files))) 236 (while files
240 (when (and touched 237 (unless (member (car files) map-files)
241 (not nneething-read-only)) 238 ;; This file is not in the map, so we enter it.
242 (nnheader-temp-write map-file 239 (setq touched t)
243 (insert "(setq nneething-map '") 240 (setcdr nneething-active (1+ (cdr nneething-active)))
244 (gnus-prin1 nneething-map) 241 (push (list (cdr nneething-active) (car files)
245 (insert ")\n(setq nneething-active '") 242 (nth 5 (file-attributes
246 (gnus-prin1 nneething-active) 243 (nneething-file-name (car files)))))
247 (insert ")\n")))))) 244 nneething-map))
245 (setq files (cdr files)))
246 (when (and touched
247 (not nneething-read-only))
248 (save-excursion
249 (nnheader-set-temp-buffer " *nneething map*")
250 (insert "(setq nneething-map '" (prin1-to-string nneething-map) ")\n"
251 "(setq nneething-active '" (prin1-to-string nneething-active)
252 ")\n")
253 (write-region (point-min) (point-max) map-file nil 'nomesg)
254 (kill-buffer (current-buffer))))))
248 255
249 (defun nneething-insert-head (file) 256 (defun nneething-insert-head (file)
250 "Insert the head of FILE." 257 "Insert the head of FILE."
251 (when (nneething-get-head file) 258 (when (nneething-get-head file)
252 (insert-buffer-substring nneething-work-buffer) 259 (insert-buffer-substring nneething-work-buffer)
253 (goto-char (point-max)))) 260 (goto-char (point-max))))
254 261
255 (defun nneething-make-head (file &optional buffer) 262 (defun nneething-make-head (file &optional buffer)
256 "Create a head by looking at the file attributes of FILE." 263 "Create a head by looking at the file attributes of FILE."
257 (let ((atts (file-attributes file))) 264 (let ((atts (file-attributes file)))
258 (insert 265 (insert
259 "Subject: " (file-name-nondirectory file) "\n" 266 "Subject: " (file-name-nondirectory file) "\n"
260 "Message-ID: <nneething-" 267 "Message-ID: <nneething-"
261 (int-to-string (incf nneething-message-id-number)) 268 (int-to-string (incf nneething-message-id-number))
262 "@" (system-name) ">\n" 269 "@" (system-name) ">\n"
263 (if (equal '(0 0) (nth 5 atts)) "" 270 (if (equal '(0 0) (nth 5 atts)) ""
264 (concat "Date: " (current-time-string (nth 5 atts)) "\n")) 271 (concat "Date: " (current-time-string (nth 5 atts)) "\n"))
265 (or (when buffer 272 (or (if buffer
266 (save-excursion 273 (save-excursion
267 (set-buffer buffer) 274 (set-buffer buffer)
268 (when (re-search-forward "<[a-zA-Z0-9_]@[-a-zA-Z0-9_]>" 1000 t) 275 (if (re-search-forward "<[a-zA-Z0-9_]@[-a-zA-Z0-9_]>" 1000 t)
269 (concat "From: " (match-string 0) "\n")))) 276 (concat "From: " (match-string 0) "\n"))))
270 (nneething-from-line (nth 2 atts) file)) 277 (nneething-from-line (nth 2 atts) file))
271 (if (> (string-to-int (int-to-string (nth 7 atts))) 0) 278 (if (> (string-to-int (int-to-string (nth 7 atts))) 0)
272 (concat "Chars: " (int-to-string (nth 7 atts)) "\n") 279 (concat "Chars: " (int-to-string (nth 7 atts)) "\n")
273 "") 280 "")
274 (if buffer 281 (if buffer
275 (save-excursion 282 (save-excursion
276 (set-buffer buffer) 283 (set-buffer buffer)
277 (concat "Lines: " (int-to-string 284 (concat "Lines: " (int-to-string
278 (count-lines (point-min) (point-max))) 285 (count-lines (point-min) (point-max))) "\n"))
279 "\n"))
280 "") 286 "")
281 ))) 287 )))
282 288
283 (defun nneething-from-line (uid &optional file) 289 (defun nneething-from-line (uid &optional file)
284 "Return a From header based of UID." 290 "Return a From header based of UID."
285 (let* ((login (condition-case nil 291 (let* ((login (condition-case nil
286 (user-login-name uid) 292 (user-login-name uid)
287 (error 293 (error
288 (cond ((= uid (user-uid)) (user-login-name)) 294 (cond ((= uid (user-uid)) (user-login-name))
289 ((zerop uid) "root") 295 ((zerop uid) "root")
290 (t (int-to-string uid)))))) 296 (t (int-to-string uid))))))
291 (name (condition-case nil 297 (name (condition-case nil
292 (user-full-name uid) 298 (user-full-name uid)
293 (error 299 (error
294 (cond ((= uid (user-uid)) (user-full-name)) 300 (cond ((= uid (user-uid)) (user-full-name))
295 ((zerop uid) "Ms. Root"))))) 301 ((zerop uid) "Ms. Root")))))
296 (host (if (string-match "\\`/[^/@]*@\\([^:/]+\\):" file) 302 (host (if (string-match "\\`/[^/@]*@\\([^:/]+\\):" file)
297 (prog1 303 (prog1
298 (substring file 304 (substring file
299 (match-beginning 1) 305 (match-beginning 1)
300 (match-end 1)) 306 (match-end 1))
301 (when (string-match "/\\(users\\|home\\)/\\([^/]+\\)/" file) 307 (if (string-match "/\\(users\\|home\\)/\\([^/]+\\)/" file)
302 (setq login (substring file 308 (setq login (substring file
303 (match-beginning 2) 309 (match-beginning 2)
304 (match-end 2)) 310 (match-end 2))
305 name nil))) 311 name nil)))
306 (system-name)))) 312 (system-name))))
307 (concat "From: " login "@" host 313 (concat "From: " login "@" host
308 (if name (concat " (" name ")") "") "\n"))) 314 (if name (concat " (" name ")") "") "\n")))
309 315
310 (defun nneething-get-head (file) 316 (defun nneething-get-head (file)
311 "Either find the head in FILE or make a head for FILE." 317 "Either find the head in FILE or make a head for FILE."
312 (save-excursion 318 (save-excursion
313 (set-buffer (get-buffer-create nneething-work-buffer)) 319 (set-buffer (get-buffer-create nneething-work-buffer))
314 (setq case-fold-search nil) 320 (setq case-fold-search nil)
315 (buffer-disable-undo (current-buffer)) 321 (buffer-disable-undo (current-buffer))
316 (erase-buffer) 322 (erase-buffer)
317 (cond 323 (cond
318 ((not (file-exists-p file)) 324 ((not (file-exists-p file))
319 ;; The file do not exist. 325 ;; The file do not exist.
320 nil) 326 nil)
321 ((or (file-directory-p file) 327 ((or (file-directory-p file)
322 (file-symlink-p file)) 328 (file-symlink-p file))
323 ;; It's a dir, so we fudge a head. 329 ;; It's a dir, so we fudge a head.
324 (nneething-make-head file) t) 330 (nneething-make-head file) t)
325 (t 331 (t
326 ;; We examine the file. 332 ;; We examine the file.
327 (nnheader-insert-head file) 333 (nnheader-insert-head file)
328 (if (nnheader-article-p) 334 (if (nnheader-article-p)
329 (delete-region 335 (delete-region
330 (progn 336 (progn
331 (goto-char (point-min)) 337 (goto-char (point-min))
332 (or (and (search-forward "\n\n" nil t) 338 (or (and (search-forward "\n\n" nil t)
333 (1- (point))) 339 (1- (point)))
334 (point-max))) 340 (point-max)))