Mercurial > emacs
comparison lisp/gnus/nnmh.el @ 24357:15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
author | Lars Magne Ingebrigtsen <larsi@gnus.org> |
---|---|
date | Sat, 20 Feb 1999 14:05:57 +0000 |
parents | 6182146747a7 |
children | 9968f55ad26e |
comparison
equal
deleted
inserted
replaced
24356:a5a611ef40f6 | 24357:15fc6acbae7a |
---|---|
1 ;;; nnmh.el --- mhspool access for Gnus | 1 ;;; nnmh.el --- mhspool access for Gnus |
2 ;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. | 2 ;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. |
3 | 3 |
4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> | 4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
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 |
8 ;; This file is part of GNU Emacs. | 8 ;; This file is part of GNU Emacs. |
9 | 9 |
58 (defvoo nnmh-current-directory nil | 58 (defvoo nnmh-current-directory nil |
59 "Current news group directory.") | 59 "Current news group directory.") |
60 | 60 |
61 (defvoo nnmh-status-string "") | 61 (defvoo nnmh-status-string "") |
62 (defvoo nnmh-group-alist nil) | 62 (defvoo nnmh-group-alist nil) |
63 (defvoo nnmh-allow-delete-final nil) | |
63 | 64 |
64 | 65 |
65 | 66 |
66 ;;; Interface functions. | 67 ;;; Interface functions. |
67 | 68 |
74 (let* ((file nil) | 75 (let* ((file nil) |
75 (number (length articles)) | 76 (number (length articles)) |
76 (large (and (numberp nnmail-large-newsgroup) | 77 (large (and (numberp nnmail-large-newsgroup) |
77 (> number nnmail-large-newsgroup))) | 78 (> number nnmail-large-newsgroup))) |
78 (count 0) | 79 (count 0) |
79 ;; 1997/8/12 by MORIOKA Tomohiko | 80 (file-name-coding-system 'binary) |
80 (file-name-coding-system 'binary) ; for Emacs 20 | 81 (pathname-coding-system 'binary) |
81 (pathname-coding-system 'binary) ; for XEmacs/mule | |
82 beg article) | 82 beg article) |
83 (nnmh-possibly-change-directory newsgroup server) | 83 (nnmh-possibly-change-directory newsgroup server) |
84 ;; We don't support fetching by Message-ID. | 84 ;; We don't support fetching by Message-ID. |
85 (if (stringp (car articles)) | 85 (if (stringp (car articles)) |
86 'headers | 86 'headers |
103 (delete-region (point) (point-max))) | 103 (delete-region (point) (point-max))) |
104 (setq count (1+ count)) | 104 (setq count (1+ count)) |
105 | 105 |
106 (and large | 106 (and large |
107 (zerop (% count 20)) | 107 (zerop (% count 20)) |
108 (message "nnmh: Receiving headers... %d%%" | 108 (nnheader-message 5 "nnmh: Receiving headers... %d%%" |
109 (/ (* count 100) number)))) | 109 (/ (* count 100) number)))) |
110 | 110 |
111 (when large | 111 (when large |
112 (message "nnmh: Receiving headers...done")) | 112 (nnheader-message 5 "nnmh: Receiving headers...done")) |
113 | 113 |
114 (nnheader-fold-continuation-lines) | 114 (nnheader-fold-continuation-lines) |
115 'headers)))) | 115 'headers)))) |
116 | 116 |
117 (deffoo nnmh-open-server (server &optional defs) | 117 (deffoo nnmh-open-server (server &optional defs) |
135 (deffoo nnmh-request-article (id &optional newsgroup server buffer) | 135 (deffoo nnmh-request-article (id &optional newsgroup server buffer) |
136 (nnmh-possibly-change-directory newsgroup server) | 136 (nnmh-possibly-change-directory newsgroup server) |
137 (let ((file (if (stringp id) | 137 (let ((file (if (stringp id) |
138 nil | 138 nil |
139 (concat nnmh-current-directory (int-to-string id)))) | 139 (concat nnmh-current-directory (int-to-string id)))) |
140 ;; 1997/8/12 by MORIOKA Tomohiko | 140 (pathname-coding-system 'binary) |
141 (file-name-coding-system 'binary) ; for Emacs 20 | 141 (file-name-coding-system 'binary) |
142 (pathname-coding-system 'binary) ; for XEmacs/mule | |
143 (nntp-server-buffer (or buffer nntp-server-buffer))) | 142 (nntp-server-buffer (or buffer nntp-server-buffer))) |
144 (and (stringp file) | 143 (and (stringp file) |
145 (file-exists-p file) | 144 (file-exists-p file) |
146 (not (file-directory-p file)) | 145 (not (file-directory-p file)) |
147 (save-excursion (nnmail-find-file file)) | 146 (save-excursion (nnmail-find-file file)) |
148 (string-to-int (file-name-nondirectory file))))) | 147 (string-to-int (file-name-nondirectory file))))) |
149 | 148 |
150 (deffoo nnmh-request-group (group &optional server dont-check) | 149 (deffoo nnmh-request-group (group &optional server dont-check) |
150 (nnheader-init-server-buffer) | |
151 (nnmh-possibly-change-directory group server) | |
151 (let ((pathname (nnmail-group-pathname group nnmh-directory)) | 152 (let ((pathname (nnmail-group-pathname group nnmh-directory)) |
152 ;; 1997/8/12 by MORIOKA Tomohiko | 153 (pathname-coding-system 'binary) |
153 (file-name-coding-system 'binary) ; for Emacs 20 | 154 (file-name-coding-system 'binary) |
154 (pathname-coding-system 'binary) ; for XEmacs/mule. | |
155 dir) | 155 dir) |
156 (cond | 156 (cond |
157 ((not (file-directory-p pathname)) | 157 ((not (file-directory-p pathname)) |
158 (nnheader-report | 158 (nnheader-report |
159 'nnmh "Can't select group (no such directory): %s" group)) | 159 'nnmh "Can't select group (no such directory): %s" group)) |
188 (deffoo nnmh-request-scan (&optional group server) | 188 (deffoo nnmh-request-scan (&optional group server) |
189 (nnmail-get-new-mail 'nnmh nil nnmh-directory group)) | 189 (nnmail-get-new-mail 'nnmh nil nnmh-directory group)) |
190 | 190 |
191 (deffoo nnmh-request-list (&optional server dir) | 191 (deffoo nnmh-request-list (&optional server dir) |
192 (nnheader-insert "") | 192 (nnheader-insert "") |
193 (let ((file-name-coding-system 'binary) | 193 (nnmh-possibly-change-directory nil server) |
194 (pathname-coding-system 'binary) | 194 (let* ((pathname-coding-system 'binary) |
195 (nnmh-toplev | 195 (file-name-coding-system 'binary) |
196 (file-truename (or dir (file-name-as-directory nnmh-directory))))) | 196 (nnmh-toplev |
197 (file-truename (or dir (file-name-as-directory nnmh-directory))))) | |
197 (nnmh-request-list-1 nnmh-toplev)) | 198 (nnmh-request-list-1 nnmh-toplev)) |
198 (setq nnmh-group-alist (nnmail-get-active)) | 199 (setq nnmh-group-alist (nnmail-get-active)) |
199 t) | 200 t) |
200 | 201 |
201 (defvar nnmh-toplev) | 202 (defvar nnmh-toplev) |
202 (defun nnmh-request-list-1 (dir) | 203 (defun nnmh-request-list-1 (dir) |
203 (setq dir (expand-file-name dir)) | 204 (setq dir (expand-file-name dir)) |
204 ;; Recurse down all directories. | 205 ;; Recurse down all directories. |
205 (let ((dirs (and (file-readable-p dir) | 206 (let ((dirs (and (file-readable-p dir) |
206 (> (nth 1 (file-attributes (file-chase-links dir))) 2) | 207 (> (nth 1 (file-attributes (file-chase-links dir))) 2) |
207 (directory-files dir t nil t))) | 208 (nnheader-directory-files dir t nil t))) |
208 dir) | 209 rdir) |
209 ;; Recurse down directories. | 210 ;; Recurse down directories. |
210 (while (setq dir (pop dirs)) | 211 (while (setq rdir (pop dirs)) |
211 (when (and (not (member (file-name-nondirectory dir) '("." ".."))) | 212 (when (and (file-directory-p rdir) |
212 (file-directory-p dir) | 213 (file-readable-p rdir) |
213 (file-readable-p dir)) | 214 (not (equal (file-truename rdir) |
214 (nnmh-request-list-1 dir)))) | 215 (file-truename dir)))) |
216 (nnmh-request-list-1 rdir)))) | |
215 ;; For each directory, generate an active file line. | 217 ;; For each directory, generate an active file line. |
216 (unless (string= (expand-file-name nnmh-toplev) dir) | 218 (unless (string= (expand-file-name nnmh-toplev) dir) |
217 (let ((files (mapcar | 219 (let ((files (mapcar |
218 (lambda (name) (string-to-int name)) | 220 (lambda (name) (string-to-int name)) |
219 (directory-files dir nil "^[0-9]+$" t)))) | 221 (directory-files dir nil "^[0-9]+$" t)))) |
229 (regexp-quote | 231 (regexp-quote |
230 (file-truename (file-name-as-directory | 232 (file-truename (file-name-as-directory |
231 (expand-file-name nnmh-toplev)))) | 233 (expand-file-name nnmh-toplev)))) |
232 dir) | 234 dir) |
233 (nnheader-replace-chars-in-string | 235 (nnheader-replace-chars-in-string |
234 (decode-coding-string (substring dir (match-end 0)) | 236 (gnus-decode-coding-string (substring dir (match-end 0)) |
235 nnmail-pathname-coding-system) | 237 nnmail-pathname-coding-system) |
236 ?/ ?.)) | 238 ?/ ?.)) |
237 (apply 'max files) | 239 (apply 'max files) |
238 (apply 'min files))))))) | 240 (apply 'min files))))))) |
239 t) | 241 t) |
240 | 242 |
242 (nnmh-request-list server)) | 244 (nnmh-request-list server)) |
243 | 245 |
244 (deffoo nnmh-request-expire-articles (articles newsgroup | 246 (deffoo nnmh-request-expire-articles (articles newsgroup |
245 &optional server force) | 247 &optional server force) |
246 (nnmh-possibly-change-directory newsgroup server) | 248 (nnmh-possibly-change-directory newsgroup server) |
247 (let* ((active-articles | 249 (let* ((is-old t) |
248 (mapcar | |
249 (function | |
250 (lambda (name) | |
251 (string-to-int name))) | |
252 (directory-files nnmh-current-directory nil "^[0-9]+$" t))) | |
253 (is-old t) | |
254 article rest mod-time) | 250 article rest mod-time) |
255 (nnmail-activate 'nnmh) | 251 (nnheader-init-server-buffer) |
256 | 252 |
257 (while (and articles is-old) | 253 (while (and articles is-old) |
258 (setq article (concat nnmh-current-directory | 254 (setq article (concat nnmh-current-directory |
259 (int-to-string (car articles)))) | 255 (int-to-string (car articles)))) |
260 (when (setq mod-time (nth 5 (file-attributes article))) | 256 (when (setq mod-time (nth 5 (file-attributes article))) |
270 (nnheader-message 1 "Couldn't delete article %s in %s" | 266 (nnheader-message 1 "Couldn't delete article %s in %s" |
271 article newsgroup) | 267 article newsgroup) |
272 (push (car articles) rest)))) | 268 (push (car articles) rest)))) |
273 (push (car articles) rest))) | 269 (push (car articles) rest))) |
274 (setq articles (cdr articles))) | 270 (setq articles (cdr articles))) |
275 (message "") | 271 (nnheader-message 5 "") |
276 (nconc rest articles))) | 272 (nconc rest articles))) |
277 | 273 |
278 (deffoo nnmh-close-group (group &optional server) | 274 (deffoo nnmh-close-group (group &optional server) |
279 t) | 275 t) |
280 | 276 |
303 (deffoo nnmh-request-accept-article (group &optional server last noinsert) | 299 (deffoo nnmh-request-accept-article (group &optional server last noinsert) |
304 (nnmh-possibly-change-directory group server) | 300 (nnmh-possibly-change-directory group server) |
305 (nnmail-check-syntax) | 301 (nnmail-check-syntax) |
306 (when nnmail-cache-accepted-message-ids | 302 (when nnmail-cache-accepted-message-ids |
307 (nnmail-cache-insert (nnmail-fetch-field "message-id"))) | 303 (nnmail-cache-insert (nnmail-fetch-field "message-id"))) |
304 (nnheader-init-server-buffer) | |
308 (prog1 | 305 (prog1 |
309 (if (stringp group) | 306 (if (stringp group) |
310 (and | 307 (if noinsert |
311 (nnmail-activate 'nnmh) | 308 (nnmh-active-number group) |
312 (car (nnmh-save-mail | 309 (car (nnmh-save-mail |
313 (list (cons group (nnmh-active-number group))) | 310 (list (cons group (nnmh-active-number group))) |
314 noinsert))) | 311 noinsert))) |
315 (and | 312 (let ((res (nnmail-article-group 'nnmh-active-number))) |
316 (nnmail-activate 'nnmh) | 313 (if (and (null res) |
317 (let ((res (nnmail-article-group 'nnmh-active-number))) | 314 (yes-or-no-p "Moved to `junk' group; delete article? ")) |
318 (if (and (null res) | 315 'junk |
319 (yes-or-no-p "Moved to `junk' group; delete article? ")) | 316 (car (nnmh-save-mail res noinsert))))) |
320 'junk | |
321 (car (nnmh-save-mail res noinsert)))))) | |
322 (when (and last nnmail-cache-accepted-message-ids) | 317 (when (and last nnmail-cache-accepted-message-ids) |
323 (nnmail-cache-close)))) | 318 (nnmail-cache-close)))) |
324 | 319 |
325 (deffoo nnmh-request-replace-article (article group buffer) | 320 (deffoo nnmh-request-replace-article (article group buffer) |
326 (nnmh-possibly-change-directory group) | 321 (nnmh-possibly-change-directory group) |
333 (concat nnmh-current-directory (int-to-string article)) | 328 (concat nnmh-current-directory (int-to-string article)) |
334 nil (if (nnheader-be-verbose 5) nil 'nomesg)) | 329 nil (if (nnheader-be-verbose 5) nil 'nomesg)) |
335 t))) | 330 t))) |
336 | 331 |
337 (deffoo nnmh-request-create-group (group &optional server args) | 332 (deffoo nnmh-request-create-group (group &optional server args) |
338 (nnmail-activate 'nnmh) | 333 (nnheader-init-server-buffer) |
339 (unless (assoc group nnmh-group-alist) | 334 (unless (assoc group nnmh-group-alist) |
340 (let (active) | 335 (let (active) |
341 (push (list group (setq active (cons 1 0))) | 336 (push (list group (setq active (cons 1 0))) |
342 nnmh-group-alist) | 337 nnmh-group-alist) |
343 (nnmh-possibly-create-directory group) | 338 (nnmh-possibly-create-directory group) |
408 (when (and server | 403 (when (and server |
409 (not (nnmh-server-opened server))) | 404 (not (nnmh-server-opened server))) |
410 (nnmh-open-server server)) | 405 (nnmh-open-server server)) |
411 (when newsgroup | 406 (when newsgroup |
412 (let ((pathname (nnmail-group-pathname newsgroup nnmh-directory)) | 407 (let ((pathname (nnmail-group-pathname newsgroup nnmh-directory)) |
413 ;; 1997/8/12 by MORIOKA Tomohiko | 408 (file-name-coding-system 'binary) |
414 (file-name-coding-system 'binary) ; for Emacs 20 | 409 (pathname-coding-system 'binary)) |
415 (pathname-coding-system 'binary)) ; for XEmacs/mule | |
416 (if (file-directory-p pathname) | 410 (if (file-directory-p pathname) |
417 (setq nnmh-current-directory pathname) | 411 (setq nnmh-current-directory pathname) |
418 (error "No such newsgroup: %s" newsgroup))))) | 412 (error "No such newsgroup: %s" newsgroup))))) |
419 | 413 |
420 (defun nnmh-possibly-create-directory (group) | 414 (defun nnmh-possibly-create-directory (group) |
459 | 453 |
460 (defun nnmh-active-number (group) | 454 (defun nnmh-active-number (group) |
461 "Compute the next article number in GROUP." | 455 "Compute the next article number in GROUP." |
462 (let ((active (cadr (assoc group nnmh-group-alist))) | 456 (let ((active (cadr (assoc group nnmh-group-alist))) |
463 (dir (nnmail-group-pathname group nnmh-directory)) | 457 (dir (nnmail-group-pathname group nnmh-directory)) |
464 ;; 1997/8/14 by MORIOKA Tomohiko | 458 (file-name-coding-system 'binary) |
465 (file-name-coding-system 'binary) ; for Emacs 20 | 459 (pathname-coding-system 'binary)) |
466 (pathname-coding-system 'binary)) ; for XEmacs/mule | |
467 (unless active | 460 (unless active |
468 ;; The group wasn't known to nnmh, so we just create an active | 461 ;; The group wasn't known to nnmh, so we just create an active |
469 ;; entry for it. | 462 ;; entry for it. |
470 (setq active (cons 1 0)) | 463 (setq active (cons 1 0)) |
471 (push (list group active) nnmh-group-alist) | 464 (push (list group active) nnmh-group-alist) |
472 (unless (file-exists-p dir) | 465 (unless (file-exists-p dir) |
473 (make-directory dir)) | 466 (gnus-make-directory dir)) |
474 ;; Find the highest number in the group. | 467 ;; Find the highest number in the group. |
475 (let ((files (sort | 468 (let ((files (sort |
476 (mapcar | 469 (mapcar |
477 (lambda (f) | 470 (lambda (f) |
478 (string-to-int f)) | 471 (string-to-int f)) |
555 (defun nnmh-deletable-article-p (group article) | 548 (defun nnmh-deletable-article-p (group article) |
556 "Say whether ARTICLE in GROUP can be deleted." | 549 "Say whether ARTICLE in GROUP can be deleted." |
557 (let ((path (concat nnmh-current-directory (int-to-string article)))) | 550 (let ((path (concat nnmh-current-directory (int-to-string article)))) |
558 ;; Writable. | 551 ;; Writable. |
559 (and (file-writable-p path) | 552 (and (file-writable-p path) |
560 ;; We can never delete the last article in the group. | 553 (or |
561 (not (eq (cdr (nth 1 (assoc group nnmh-group-alist))) | 554 ;; We can never delete the last article in the group. |
562 article))))) | 555 (not (eq (cdr (nth 1 (assoc group nnmh-group-alist))) |
556 article)) | |
557 ;; Well, we can. | |
558 nnmh-allow-delete-final)))) | |
563 | 559 |
564 (provide 'nnmh) | 560 (provide 'nnmh) |
565 | 561 |
566 ;;; nnmh.el ends here | 562 ;;; nnmh.el ends here |