Mercurial > hg > xemacs-beta

comparison lisp/gnus/nneething.el @ 108:360340f9fd5f r20-1b6

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b6
author cvs
date Mon, 13 Aug 2007 09:18:39 +0200
parents 0d2f883870bc
children fe104dbd9147
comparison
equal deleted inserted replaced
107:523141596bda 108:360340f9fd5f
24 24
25 ;;; Commentary: 25 ;;; Commentary:
26 26
27 ;; Based on nnspool.el by Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>. 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 28 ;; For an overview of what the interface functions do, please see the
29 ;; Gnus sources. 29 ;; Gnus sources.
30 30
31 ;;; Code: 31 ;;; Code:
32 32
33 (require 'nnheader) 33 (require 'nnheader)
34 (require 'nnmail) 34 (require 'nnmail)
48 "*Regexp saying what files to exclude from the group. 48 "*Regexp saying what files to exclude from the group.
49 If this variable is nil, no files will be excluded.") 49 If this variable is nil, no files will be excluded.")
50 50
51 51
52 52
53 ;;; Internal variables. 53 ;;; Internal variables.
54 54
55 (defconst nneething-version "nneething 1.0" 55 (defconst nneething-version "nneething 1.0"
56 "nneething version.") 56 "nneething version.")
57 57
58 (defvoo nneething-current-directory nil 58 (defvoo nneething-current-directory nil
135 (unless dont-check 135 (unless dont-check
136 (nneething-create-mapping) 136 (nneething-create-mapping)
137 (if (> (car nneething-active) (cdr nneething-active)) 137 (if (> (car nneething-active) (cdr nneething-active))
138 (nnheader-insert "211 0 1 0 %s\n" group) 138 (nnheader-insert "211 0 1 0 %s\n" group)
139 (nnheader-insert 139 (nnheader-insert
140 "211 %d %d %d %s\n" 140 "211 %d %d %d %s\n"
141 (- (1+ (cdr nneething-active)) (car nneething-active)) 141 (- (1+ (cdr nneething-active)) (car nneething-active))
142 (car nneething-active) (cdr nneething-active) 142 (car nneething-active) (cdr nneething-active)
143 group))) 143 group)))
144 t) 144 t)
145 145
178 (nneething-create-mapping) 178 (nneething-create-mapping)
179 (push (list group dir nneething-map nneething-active) 179 (push (list group dir nneething-map nneething-active)
180 nneething-group-alist)))))) 180 nneething-group-alist))))))
181 181
182 (defun nneething-map-file () 182 (defun nneething-map-file ()
183 ;; We make sure that the .nneething directory exists. 183 ;; We make sure that the .nneething directory exists.
184 (gnus-make-directory nneething-map-file-directory) 184 (gnus-make-directory nneething-map-file-directory)
185 ;; 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.
186 (concat (file-name-as-directory nneething-map-file-directory) 186 (concat (file-name-as-directory nneething-map-file-directory)
187 nneething-group nneething-map-file)) 187 nneething-group nneething-map-file))
188 188
200 (when (and (cdar nneething-map) 200 (when (and (cdar nneething-map)
201 (atom (cdar nneething-map))) 201 (atom (cdar nneething-map)))
202 (setq nneething-map 202 (setq nneething-map
203 (mapcar (lambda (n) 203 (mapcar (lambda (n)
204 (list (cdr n) (car n) 204 (list (cdr n) (car n)
205 (nth 5 (file-attributes 205 (nth 5 (file-attributes
206 (nneething-file-name (car n)))))) 206 (nneething-file-name (car n))))))
207 nneething-map))) 207 nneething-map)))
208 ;; Remove files matching the exclusion regexp. 208 ;; Remove files matching the exclusion regexp.
209 (when nneething-exclude-files 209 (when nneething-exclude-files
210 (let ((f files) 210 (let ((f files)
241 (push (list (cdr nneething-active) (car files) 241 (push (list (cdr nneething-active) (car files)
242 (nth 5 (file-attributes 242 (nth 5 (file-attributes
243 (nneething-file-name (car files))))) 243 (nneething-file-name (car files)))))
244 nneething-map)) 244 nneething-map))
245 (setq files (cdr files))) 245 (setq files (cdr files)))
246 (when (and touched 246 (when (and touched
247 (not nneething-read-only)) 247 (not nneething-read-only))
248 (nnheader-temp-write map-file 248 (nnheader-temp-write map-file
249 (insert "(setq nneething-map '") 249 (insert "(setq nneething-map '")
250 (gnus-prin1 nneething-map) 250 (gnus-prin1 nneething-map)
251 (insert ")\n(setq nneething-active '") 251 (insert ")\n(setq nneething-active '")
259 (goto-char (point-max)))) 259 (goto-char (point-max))))
260 260
261 (defun nneething-make-head (file &optional buffer) 261 (defun nneething-make-head (file &optional buffer)
262 "Create a head by looking at the file attributes of FILE." 262 "Create a head by looking at the file attributes of FILE."
263 (let ((atts (file-attributes file))) 263 (let ((atts (file-attributes file)))
264 (insert 264 (insert
265 "Subject: " (file-name-nondirectory file) "\n" 265 "Subject: " (file-name-nondirectory file) "\n"
266 "Message-ID: <nneething-" 266 "Message-ID: <nneething-"
267 (int-to-string (incf nneething-message-id-number)) 267 (int-to-string (incf nneething-message-id-number))
268 "@" (system-name) ">\n" 268 "@" (system-name) ">\n"
269 (if (equal '(0 0) (nth 5 atts)) "" 269 (if (equal '(0 0) (nth 5 atts)) ""
270 (concat "Date: " (current-time-string (nth 5 atts)) "\n")) 270 (concat "Date: " (current-time-string (nth 5 atts)) "\n"))
271 (or (when buffer 271 (or (when buffer
272 (save-excursion 272 (save-excursion
273 (set-buffer buffer) 273 (set-buffer buffer)
274 (when (re-search-forward "<[a-zA-Z0-9_]@[-a-zA-Z0-9_]>" 1000 t) 274 (when (re-search-forward "<[a-zA-Z0-9_]@[-a-zA-Z0-9_]>" 1000 t)
275 (concat "From: " (match-string 0) "\n")))) 275 (concat "From: " (match-string 0) "\n"))))
276 (nneething-from-line (nth 2 atts) file)) 276 (nneething-from-line (nth 2 atts) file))
277 (if (> (string-to-int (int-to-string (nth 7 atts))) 0) 277 (if (> (string-to-int (int-to-string (nth 7 atts))) 0)
278 (concat "Chars: " (int-to-string (nth 7 atts)) "\n") 278 (concat "Chars: " (int-to-string (nth 7 atts)) "\n")
279 "") 279 "")
280 (if buffer 280 (if buffer
281 (save-excursion 281 (save-excursion
282 (set-buffer buffer) 282 (set-buffer buffer)
283 (concat "Lines: " (int-to-string 283 (concat "Lines: " (int-to-string
284 (count-lines (point-min) (point-max))) 284 (count-lines (point-min) (point-max)))
285 "\n")) 285 "\n"))
286 "") 286 "")
287 ))) 287 )))
288 288
289 (defun nneething-from-line (uid &optional file) 289 (defun nneething-from-line (uid &optional file)
290 "Return a From header based of UID." 290 "Return a From header based of UID."
291 (let* ((login (condition-case nil 291 (let* ((login (condition-case nil
292 (user-login-name uid) 292 (user-login-name uid)
293 (error 293 (error
294 (cond ((= uid (user-uid)) (user-login-name)) 294 (cond ((= uid (user-uid)) (user-login-name))
295 ((zerop uid) "root") 295 ((zerop uid) "root")
296 (t (int-to-string uid)))))) 296 (t (int-to-string uid))))))
297 (name (condition-case nil 297 (name (condition-case nil
298 (user-full-name uid) 298 (user-full-name uid)
299 (error 299 (error
300 (cond ((= uid (user-uid)) (user-full-name)) 300 (cond ((= uid (user-uid)) (user-full-name))
301 ((zerop uid) "Ms. Root"))))) 301 ((zerop uid) "Ms. Root")))))
302 (host (if (string-match "\\`/[^/@]*@\\([^:/]+\\):" file) 302 (host (if (string-match "\\`/[^/@]*@\\([^:/]+\\):" file)
303 (prog1 303 (prog1
304 (substring file 304 (substring file
305 (match-beginning 1) 305 (match-beginning 1)
306 (match-end 1)) 306 (match-end 1))
307 (when (string-match "/\\(users\\|home\\)/\\([^/]+\\)/" file) 307 (when (string-match "/\\(users\\|home\\)/\\([^/]+\\)/" file)
308 (setq login (substring file 308 (setq login (substring file
309 (match-beginning 2) 309 (match-beginning 2)
310 (match-end 2)) 310 (match-end 2))
311 name nil))) 311 name nil)))
312 (system-name)))) 312 (system-name))))
313 (concat "From: " login "@" host 313 (concat "From: " login "@" host
314 (if name (concat " (" name ")") "") "\n"))) 314 (if name (concat " (" name ")") "") "\n")))
315 315
316 (defun nneething-get-head (file) 316 (defun nneething-get-head (file)
317 "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."
318 (save-excursion 318 (save-excursion
319 (set-buffer (get-buffer-create nneething-work-buffer)) 319 (set-buffer (get-buffer-create nneething-work-buffer))
320 (setq case-fold-search nil) 320 (setq case-fold-search nil)
321 (buffer-disable-undo (current-buffer)) 321 (buffer-disable-undo (current-buffer))
322 (erase-buffer) 322 (erase-buffer)
323 (cond 323 (cond
324 ((not (file-exists-p file)) 324 ((not (file-exists-p file))
325 ;; The file do not exist. 325 ;; The file do not exist.
326 nil) 326 nil)
327 ((or (file-directory-p file) 327 ((or (file-directory-p file)
328 (file-symlink-p file)) 328 (file-symlink-p file))
329 ;; It's a dir, so we fudge a head. 329 ;; It's a dir, so we fudge a head.
330 (nneething-make-head file) t) 330 (nneething-make-head file) t)
331 (t 331 (t
332 ;; We examine the file. 332 ;; We examine the file.
333 (nnheader-insert-head file) 333 (nnheader-insert-head file)
334 (if (nnheader-article-p) 334 (if (nnheader-article-p)
335 (delete-region 335 (delete-region
336 (progn 336 (progn
337 (goto-char (point-min)) 337 (goto-char (point-min))
338 (or (and (search-forward "\n\n" nil t) 338 (or (and (search-forward "\n\n" nil t)
339 (1- (point))) 339 (1- (point)))
340 (point-max))) 340 (point-max)))