Mercurial > emacs
comparison lisp/gnus/nnml.el @ 91085:880960b70474
Merge from emacs--devo--0
Revision: emacs@sv.gnu.org/emacs--unicode--0--patch-283
author | Miles Bader <miles@gnu.org> |
---|---|
date | Sun, 11 Nov 2007 00:56:44 +0000 |
parents | f55f9811f5d7 403aa95593fa |
children | 53108e6cea98 |
comparison
equal
deleted
inserted
replaced
91084:a4347a111894 | 91085:880960b70474 |
---|---|
1 ;;; nnml.el --- mail spool access for Gnus | 1 ;;; nnml.el --- mail spool access for Gnus |
2 | 2 |
3 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, | 3 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, |
4 ;; 2004, 2005, 2006, 2007 Free Software Foundation, Inc. | 4 ;; 2004, 2005, 2006, 2007 Free Software Foundation, Inc. |
5 | 5 |
6 ;; Author: Simon Josefsson <simon@josefsson.org> (adding MARKS) | 6 ;; Authors: Didier Verna <didier@xemacs.org> (adding compaction) |
7 ;; Lars Magne Ingebrigtsen <larsi@gnus.org> | 7 ;; Simon Josefsson <simon@josefsson.org> (adding MARKS) |
8 ;; Lars Magne Ingebrigtsen <larsi@gnus.org> | |
8 ;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> | 9 ;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> |
9 ;; Keywords: news, mail | 10 ;; Keywords: news, mail |
10 | 11 |
11 ;; This file is part of GNU Emacs. | 12 ;; This file is part of GNU Emacs. |
12 | 13 |
38 (require 'nnmail) | 39 (require 'nnmail) |
39 (require 'nnoo) | 40 (require 'nnoo) |
40 (eval-when-compile (require 'cl)) | 41 (eval-when-compile (require 'cl)) |
41 | 42 |
42 (eval-and-compile | 43 (eval-and-compile |
43 (autoload 'gnus-article-unpropagatable-p "gnus-sum")) | 44 (autoload 'gnus-article-unpropagatable-p "gnus-sum") |
45 (autoload 'gnus-backlog-remove-article "gnus-bcklg")) | |
44 | 46 |
45 (nnoo-declare nnml) | 47 (nnoo-declare nnml) |
46 | 48 |
47 (defvoo nnml-directory message-directory | 49 (defvoo nnml-directory message-directory |
48 "Spool directory for the nnml mail backend.") | 50 "Spool directory for the nnml mail backend.") |
81 | 83 |
82 (defvoo nnml-inhibit-expiry nil | 84 (defvoo nnml-inhibit-expiry nil |
83 "If non-nil, inhibit expiry.") | 85 "If non-nil, inhibit expiry.") |
84 | 86 |
85 (defvoo nnml-use-compressed-files nil | 87 (defvoo nnml-use-compressed-files nil |
86 "If non-nil, allow using compressed message files.") | 88 "If non-nil, allow using compressed message files. |
89 | |
90 If it is a string, use it as the file extension which specifies | |
91 the compression program. You can set it to \".bz2\" if your Emacs | |
92 supports auto-compression using the bzip2 program. A value of t | |
93 is equivalent to \".gz\".") | |
94 | |
95 (defvoo nnml-compressed-files-size-threshold 1000 | |
96 "Default size threshold for compressed message files. | |
97 Message files with bodies larger than that many characters will | |
98 be automatically compressed if `nnml-use-compressed-files' is | |
99 non-nil.") | |
87 | 100 |
88 | 101 |
89 | 102 |
90 (defconst nnml-version "nnml 1.0" | 103 (defconst nnml-version "nnml 1.0" |
91 "nnml version.") | 104 "nnml version.") |
113 | 126 |
114 | 127 |
115 ;;; Interface functions. | 128 ;;; Interface functions. |
116 | 129 |
117 (nnoo-define-basics nnml) | 130 (nnoo-define-basics nnml) |
131 | |
132 (eval-when-compile | |
133 (defsubst nnml-group-name-charset (group server-or-method) | |
134 (gnus-group-name-charset | |
135 (if (stringp server-or-method) | |
136 (gnus-server-to-method | |
137 (if (string-match "\\+" server-or-method) | |
138 (concat (substring server-or-method 0 (match-beginning 0)) | |
139 ":" (substring server-or-method (match-end 0))) | |
140 (concat "nnml:" server-or-method))) | |
141 (or server-or-method gnus-command-method '(nnml ""))) | |
142 group))) | |
143 | |
144 (defun nnml-decoded-group-name (group &optional server-or-method) | |
145 "Return a decoded group name of GROUP on SERVER-OR-METHOD." | |
146 (if nnmail-group-names-not-encoded-p | |
147 group | |
148 (mm-decode-coding-string | |
149 group | |
150 (nnml-group-name-charset group server-or-method)))) | |
151 | |
152 (defun nnml-encoded-group-name (group &optional server-or-method) | |
153 "Return an encoded group name of GROUP on SERVER-OR-METHOD." | |
154 (mm-encode-coding-string | |
155 group | |
156 (nnml-group-name-charset group server-or-method))) | |
157 | |
158 (defun nnml-group-pathname (group &optional file server) | |
159 "Return an absolute file name of FILE for GROUP on SERVER." | |
160 (nnmail-group-pathname (inline (nnml-decoded-group-name group server)) | |
161 nnml-directory file)) | |
118 | 162 |
119 (deffoo nnml-retrieve-headers (sequence &optional group server fetch-old) | 163 (deffoo nnml-retrieve-headers (sequence &optional group server fetch-old) |
120 (when (nnml-possibly-change-directory group server) | 164 (when (nnml-possibly-change-directory group server) |
121 (save-excursion | 165 (save-excursion |
122 (set-buffer nntp-server-buffer) | 166 (set-buffer nntp-server-buffer) |
186 (nnml-possibly-change-directory group server) | 230 (nnml-possibly-change-directory group server) |
187 (let* ((nntp-server-buffer (or buffer nntp-server-buffer)) | 231 (let* ((nntp-server-buffer (or buffer nntp-server-buffer)) |
188 (file-name-coding-system nnmail-pathname-coding-system) | 232 (file-name-coding-system nnmail-pathname-coding-system) |
189 path gpath group-num) | 233 path gpath group-num) |
190 (if (stringp id) | 234 (if (stringp id) |
191 (when (and (setq group-num (nnml-find-group-number id)) | 235 (when (and (setq group-num (nnml-find-group-number id server)) |
192 (cdr | 236 (cdr |
193 (assq (cdr group-num) | 237 (assq (cdr group-num) |
194 (nnheader-article-to-file-alist | 238 (nnheader-article-to-file-alist |
195 (setq gpath | 239 (setq gpath (nnml-group-pathname (car group-num) |
196 (nnmail-group-pathname | 240 nil server)))))) |
197 (car group-num) | |
198 nnml-directory)))))) | |
199 (setq path (concat gpath (int-to-string (cdr group-num))))) | 241 (setq path (concat gpath (int-to-string (cdr group-num))))) |
200 (setq path (nnml-article-to-file id))) | 242 (setq path (nnml-article-to-file id))) |
201 (cond | 243 (cond |
202 ((not path) | 244 ((not path) |
203 (nnheader-report 'nnml "No such article: %s" id)) | 245 (nnheader-report 'nnml "No such article: %s" id)) |
250 | 292 |
251 (deffoo nnml-request-create-group (group &optional server args) | 293 (deffoo nnml-request-create-group (group &optional server args) |
252 (nnml-possibly-change-directory nil server) | 294 (nnml-possibly-change-directory nil server) |
253 (nnmail-activate 'nnml) | 295 (nnmail-activate 'nnml) |
254 (cond | 296 (cond |
297 ((let ((file (directory-file-name (nnml-group-pathname group nil server))) | |
298 (file-name-coding-system nnmail-pathname-coding-system)) | |
299 (and (file-exists-p file) | |
300 (not (file-directory-p file)))) | |
301 (nnheader-report 'nnml "%s is a file" | |
302 (directory-file-name (nnml-group-pathname group | |
303 nil server)))) | |
255 ((assoc group nnml-group-alist) | 304 ((assoc group nnml-group-alist) |
256 t) | 305 t) |
257 ((and (file-exists-p (nnmail-group-pathname group nnml-directory)) | |
258 (not (file-directory-p (nnmail-group-pathname group nnml-directory)))) | |
259 (nnheader-report 'nnml "%s is a file" | |
260 (nnmail-group-pathname group nnml-directory))) | |
261 (t | 306 (t |
262 (let (active) | 307 (let (active) |
263 (push (list group (setq active (cons 1 0))) | 308 (push (list group (setq active (cons 1 0))) |
264 nnml-group-alist) | 309 nnml-group-alist) |
265 (nnml-possibly-create-directory group) | 310 (nnml-possibly-create-directory group server) |
266 (nnml-possibly-change-directory group server) | 311 (nnml-possibly-change-directory group server) |
267 (let ((articles (nnml-directory-articles nnml-current-directory))) | 312 (let* ((file-name-coding-system nnmail-pathname-coding-system) |
313 (articles (nnml-directory-articles nnml-current-directory))) | |
268 (when articles | 314 (when articles |
269 (setcar active (apply 'min articles)) | 315 (setcar active (apply 'min articles)) |
270 (setcdr active (apply 'max articles)))) | 316 (setcdr active (apply 'max articles)))) |
271 (nnmail-save-active nnml-group-alist nnml-active-file) | 317 (nnmail-save-active nnml-group-alist nnml-active-file) |
272 t)))) | 318 t)))) |
286 (save-excursion | 332 (save-excursion |
287 (nnmail-find-file nnml-newsgroups-file))) | 333 (nnmail-find-file nnml-newsgroups-file))) |
288 | 334 |
289 (deffoo nnml-request-expire-articles (articles group &optional server force) | 335 (deffoo nnml-request-expire-articles (articles group &optional server force) |
290 (nnml-possibly-change-directory group server) | 336 (nnml-possibly-change-directory group server) |
291 (let ((active-articles | 337 (let* ((file-name-coding-system nnmail-pathname-coding-system) |
292 (nnml-directory-articles nnml-current-directory)) | 338 (active-articles |
293 (is-old t) | 339 (nnml-directory-articles nnml-current-directory)) |
294 article rest mod-time number) | 340 (is-old t) |
341 (decoded (nnml-decoded-group-name group server)) | |
342 article rest mod-time number target) | |
295 (nnmail-activate 'nnml) | 343 (nnmail-activate 'nnml) |
296 | 344 |
297 (setq active-articles (sort active-articles '<)) | 345 (setq active-articles (sort active-articles '<)) |
298 ;; Articles not listed in active-articles are already gone, | 346 ;; Articles not listed in active-articles are already gone, |
299 ;; so don't try to expire them. | 347 ;; so don't try to expire them. |
306 (nnml-deletable-article-p group number) | 354 (nnml-deletable-article-p group number) |
307 (setq is-old (nnmail-expired-article-p group mod-time force | 355 (setq is-old (nnmail-expired-article-p group mod-time force |
308 nnml-inhibit-expiry))) | 356 nnml-inhibit-expiry))) |
309 (progn | 357 (progn |
310 ;; Allow a special target group. | 358 ;; Allow a special target group. |
311 (unless (eq nnmail-expiry-target 'delete) | 359 (setq target nnmail-expiry-target) |
360 (unless (eq target 'delete) | |
312 (with-temp-buffer | 361 (with-temp-buffer |
313 (nnml-request-article number group server (current-buffer)) | 362 (nnml-request-article number group server (current-buffer)) |
314 (let (nnml-current-directory | 363 (let (nnml-current-directory |
315 nnml-current-group | 364 nnml-current-group |
316 nnml-article-file-alist) | 365 nnml-article-file-alist) |
317 (nnmail-expiry-target-group nnmail-expiry-target group))) | 366 (when (functionp target) |
367 (setq target (funcall target group))) | |
368 (if (and target | |
369 (or (gnus-request-group target) | |
370 (gnus-request-create-group target))) | |
371 (nnmail-expiry-target-group target group) | |
372 (setq target nil)))) | |
318 ;; Maybe directory is changed during nnmail-expiry-target-group. | 373 ;; Maybe directory is changed during nnmail-expiry-target-group. |
319 (nnml-possibly-change-directory group server)) | 374 (nnml-possibly-change-directory group server)) |
320 (nnheader-message 5 "Deleting article %s in %s" | 375 (if target |
321 number group) | 376 (progn |
322 (condition-case () | 377 (nnheader-message 5 "Deleting article %s in %s" |
323 (funcall nnmail-delete-file-function article) | 378 number decoded) |
324 (file-error | 379 (condition-case () |
325 (push number rest))) | 380 (funcall nnmail-delete-file-function article) |
326 (setq active-articles (delq number active-articles)) | 381 (file-error |
327 (nnml-nov-delete-article group number)) | 382 (push number rest))) |
383 (setq active-articles (delq number active-articles)) | |
384 (nnml-nov-delete-article group number)) | |
385 (push number rest))) | |
328 (push number rest))) | 386 (push number rest))) |
329 (let ((active (nth 1 (assoc group nnml-group-alist)))) | 387 (let ((active (nth 1 (assoc group nnml-group-alist)))) |
330 (when active | 388 (when active |
331 (setcar active (or (and active-articles | 389 (setcar active (or (and active-articles |
332 (apply 'min active-articles)) | 390 (apply 'min active-articles)) |
334 (nnmail-save-active nnml-group-alist nnml-active-file)) | 392 (nnmail-save-active nnml-group-alist nnml-active-file)) |
335 (nnml-save-nov) | 393 (nnml-save-nov) |
336 (nconc rest articles))) | 394 (nconc rest articles))) |
337 | 395 |
338 (deffoo nnml-request-move-article | 396 (deffoo nnml-request-move-article |
339 (article group server accept-form &optional last) | 397 (article group server accept-form &optional last move-is-internal) |
340 (let ((buf (get-buffer-create " *nnml move*")) | 398 (let ((buf (get-buffer-create " *nnml move*")) |
399 (file-name-coding-system nnmail-pathname-coding-system) | |
341 result) | 400 result) |
342 (nnml-possibly-change-directory group server) | 401 (nnml-possibly-change-directory group server) |
343 (nnml-update-file-alist) | 402 (nnml-update-file-alist) |
344 (and | 403 (and |
345 (nnml-deletable-article-p group article) | 404 (nnml-deletable-article-p group article) |
368 (deffoo nnml-request-accept-article (group &optional server last) | 427 (deffoo nnml-request-accept-article (group &optional server last) |
369 (nnml-possibly-change-directory group server) | 428 (nnml-possibly-change-directory group server) |
370 (nnmail-check-syntax) | 429 (nnmail-check-syntax) |
371 (let (result) | 430 (let (result) |
372 (when nnmail-cache-accepted-message-ids | 431 (when nnmail-cache-accepted-message-ids |
373 (nnmail-cache-insert (nnmail-fetch-field "message-id") | 432 (nnmail-cache-insert (nnmail-fetch-field "message-id") |
374 group | 433 group |
375 (nnmail-fetch-field "subject") | 434 (nnmail-fetch-field "subject") |
376 (nnmail-fetch-field "from"))) | 435 (nnmail-fetch-field "from"))) |
377 (if (stringp group) | 436 (if (stringp group) |
378 (and | 437 (and |
379 (nnmail-activate 'nnml) | 438 (nnmail-activate 'nnml) |
380 (setq result (car (nnml-save-mail | 439 (setq result (car (nnml-save-mail |
381 (list (cons group (nnml-active-number group)))))) | 440 (list (cons group (nnml-active-number group |
441 server))) | |
442 server))) | |
382 (progn | 443 (progn |
383 (nnmail-save-active nnml-group-alist nnml-active-file) | 444 (nnmail-save-active nnml-group-alist nnml-active-file) |
384 (and last (nnml-save-nov)))) | 445 (and last (nnml-save-nov)))) |
385 (and | 446 (and |
386 (nnmail-activate 'nnml) | 447 (nnmail-activate 'nnml) |
387 (if (and (not (setq result (nnmail-article-group 'nnml-active-number))) | 448 (if (and (not (setq result (nnmail-article-group |
449 `(lambda (group) | |
450 (nnml-active-number group ,server))))) | |
388 (yes-or-no-p "Moved to `junk' group; delete article? ")) | 451 (yes-or-no-p "Moved to `junk' group; delete article? ")) |
389 (setq result 'junk) | 452 (setq result 'junk) |
390 (setq result (car (nnml-save-mail result)))) | 453 (setq result (car (nnml-save-mail result server)))) |
391 (when last | 454 (when last |
392 (nnmail-save-active nnml-group-alist nnml-active-file) | 455 (nnmail-save-active nnml-group-alist nnml-active-file) |
393 (when nnmail-cache-accepted-message-ids | 456 (when nnmail-cache-accepted-message-ids |
394 (nnmail-cache-close)) | 457 (nnmail-cache-close)) |
395 (nnml-save-nov)))) | 458 (nnml-save-nov)))) |
437 (nnml-save-nov) | 500 (nnml-save-nov) |
438 t))))) | 501 t))))) |
439 | 502 |
440 (deffoo nnml-request-delete-group (group &optional force server) | 503 (deffoo nnml-request-delete-group (group &optional force server) |
441 (nnml-possibly-change-directory group server) | 504 (nnml-possibly-change-directory group server) |
442 (when force | 505 (let ((file (directory-file-name nnml-current-directory)) |
443 ;; Delete all articles in GROUP. | 506 (file-name-coding-system nnmail-pathname-coding-system)) |
444 (let ((articles | 507 (if (file-exists-p file) |
445 (directory-files | 508 (if (file-directory-p file) |
446 nnml-current-directory t | 509 (progn |
447 (concat nnheader-numerical-short-files | 510 (when force |
448 "\\|" (regexp-quote nnml-nov-file-name) "$" | 511 ;; Delete all articles in GROUP. |
449 "\\|" (regexp-quote nnml-marks-file-name) "$"))) | 512 (let ((articles |
450 article) | 513 (directory-files |
451 (while articles | 514 nnml-current-directory t |
452 (setq article (pop articles)) | 515 (concat |
453 (when (file-writable-p article) | 516 nnheader-numerical-short-files |
454 (nnheader-message 5 "Deleting article %s in %s..." article group) | 517 "\\|" (regexp-quote nnml-nov-file-name) "$" |
455 (funcall nnmail-delete-file-function article)))) | 518 "\\|" (regexp-quote nnml-marks-file-name) "$"))) |
456 ;; Try to delete the directory itself. | 519 (decoded (nnml-decoded-group-name group server))) |
457 (ignore-errors (delete-directory nnml-current-directory))) | 520 (dolist (article articles) |
458 ;; Remove the group from all structures. | 521 (when (file-writable-p article) |
459 (setq nnml-group-alist | 522 (nnheader-message 5 "Deleting article %s in %s..." |
460 (delq (assoc group nnml-group-alist) nnml-group-alist) | 523 (file-name-nondirectory article) |
461 nnml-current-group nil | 524 decoded) |
462 nnml-current-directory nil) | 525 (funcall nnmail-delete-file-function article)))) |
463 ;; Save the active file. | 526 ;; Try to delete the directory itself. |
464 (nnmail-save-active nnml-group-alist nnml-active-file) | 527 (ignore-errors (delete-directory nnml-current-directory)))) |
528 (nnheader-report 'nnml "%s is not a directory" file)) | |
529 (nnheader-report 'nnml "No such directory: %s/" file)) | |
530 ;; Remove the group from all structures. | |
531 (setq nnml-group-alist | |
532 (delq (assoc group nnml-group-alist) nnml-group-alist) | |
533 nnml-current-group nil | |
534 nnml-current-directory nil) | |
535 ;; Save the active file. | |
536 (nnmail-save-active nnml-group-alist nnml-active-file)) | |
465 t) | 537 t) |
466 | 538 |
467 (deffoo nnml-request-rename-group (group new-name &optional server) | 539 (deffoo nnml-request-rename-group (group new-name &optional server) |
468 (nnml-possibly-change-directory group server) | 540 (nnml-possibly-change-directory group server) |
469 (let ((new-dir (nnmail-group-pathname new-name nnml-directory)) | 541 (let ((new-dir (nnml-group-pathname new-name nil server)) |
470 (old-dir (nnmail-group-pathname group nnml-directory))) | 542 (old-dir (nnml-group-pathname group nil server)) |
543 (file-name-coding-system nnmail-pathname-coding-system)) | |
471 (when (ignore-errors | 544 (when (ignore-errors |
472 (make-directory new-dir t) | 545 (make-directory new-dir t) |
473 t) | 546 t) |
474 ;; We move the articles file by file instead of renaming | 547 ;; We move the articles file by file instead of renaming |
475 ;; the directory -- there may be subgroups in this group. | 548 ;; the directory -- there may be subgroups in this group. |
476 ;; One might be more clever, I guess. | 549 ;; One might be more clever, I guess. |
477 (let ((files (nnheader-article-to-file-alist old-dir))) | 550 (dolist (file (nnheader-article-to-file-alist old-dir)) |
478 (while files | 551 (rename-file |
479 (rename-file | 552 (concat old-dir (cdr file)) |
480 (concat old-dir (cdar files)) | 553 (concat new-dir (cdr file)))) |
481 (concat new-dir (cdar files))) | |
482 (pop files))) | |
483 ;; Move .overview file. | 554 ;; Move .overview file. |
484 (let ((overview (concat old-dir nnml-nov-file-name))) | 555 (let ((overview (concat old-dir nnml-nov-file-name))) |
485 (when (file-exists-p overview) | 556 (when (file-exists-p overview) |
486 (rename-file overview (concat new-dir nnml-nov-file-name)))) | 557 (rename-file overview (concat new-dir nnml-nov-file-name)))) |
487 ;; Move .marks file. | 558 ;; Move .marks file. |
532 (nnml-update-file-alist t) | 603 (nnml-update-file-alist t) |
533 file))))) | 604 file))))) |
534 | 605 |
535 (defun nnml-deletable-article-p (group article) | 606 (defun nnml-deletable-article-p (group article) |
536 "Say whether ARTICLE in GROUP can be deleted." | 607 "Say whether ARTICLE in GROUP can be deleted." |
537 (let (path) | 608 (let ((file-name-coding-system nnmail-pathname-coding-system) |
609 path) | |
538 (when (setq path (nnml-article-to-file article)) | 610 (when (setq path (nnml-article-to-file article)) |
539 (when (file-writable-p path) | 611 (when (file-writable-p path) |
540 (or (not nnmail-keep-last-article) | 612 (or (not nnmail-keep-last-article) |
541 (not (eq (cdr (nth 1 (assoc group nnml-group-alist))) | 613 (not (eq (cdr (nth 1 (assoc group nnml-group-alist))) |
542 article))))))) | 614 article))))))) |
543 | 615 |
544 ;; Find an article number in the current group given the Message-ID. | 616 ;; Find an article number in the current group given the Message-ID. |
545 (defun nnml-find-group-number (id) | 617 (defun nnml-find-group-number (id server) |
546 (save-excursion | 618 (save-excursion |
547 (set-buffer (get-buffer-create " *nnml id*")) | 619 (set-buffer (get-buffer-create " *nnml id*")) |
548 (let ((alist nnml-group-alist) | 620 (let ((alist nnml-group-alist) |
549 number) | 621 number) |
550 ;; We want to look through all .overview files, but we want to | 622 ;; We want to look through all .overview files, but we want to |
551 ;; start with the one in the current directory. It seems most | 623 ;; start with the one in the current directory. It seems most |
552 ;; likely that the article we are looking for is in that group. | 624 ;; likely that the article we are looking for is in that group. |
553 (if (setq number (nnml-find-id nnml-current-group id)) | 625 (if (setq number (nnml-find-id nnml-current-group id server)) |
554 (cons nnml-current-group number) | 626 (cons nnml-current-group number) |
555 ;; It wasn't there, so we look through the other groups as well. | 627 ;; It wasn't there, so we look through the other groups as well. |
556 (while (and (not number) | 628 (while (and (not number) |
557 alist) | 629 alist) |
558 (or (string= (caar alist) nnml-current-group) | 630 (or (string= (caar alist) nnml-current-group) |
559 (setq number (nnml-find-id (caar alist) id))) | 631 (setq number (nnml-find-id (caar alist) id server))) |
560 (or number | 632 (or number |
561 (setq alist (cdr alist)))) | 633 (setq alist (cdr alist)))) |
562 (and number | 634 (and number |
563 (cons (caar alist) number)))))) | 635 (cons (caar alist) number)))))) |
564 | 636 |
565 (defun nnml-find-id (group id) | 637 (defun nnml-find-id (group id server) |
566 (erase-buffer) | 638 (erase-buffer) |
567 (let ((nov (expand-file-name nnml-nov-file-name | 639 (let ((nov (nnml-group-pathname group nnml-nov-file-name server)) |
568 (nnmail-group-pathname group nnml-directory))) | |
569 number found) | 640 number found) |
570 (when (file-exists-p nov) | 641 (when (file-exists-p nov) |
571 (nnheader-insert-file-contents nov) | 642 (nnheader-insert-file-contents nov) |
572 (while (and (not found) | 643 (while (and (not found) |
573 (search-forward id nil t)) ; We find the ID. | 644 (search-forward id nil t)) ; We find the ID. |
574 ;; And the id is in the fourth field. | 645 ;; And the id is in the fourth field. |
575 (if (not (and (search-backward "\t" nil t 4) | 646 (if (not (and (search-backward "\t" nil t 4) |
576 (not (search-backward"\t" (gnus-point-at-bol) t)))) | 647 (not (search-backward "\t" (point-at-bol) t)))) |
577 (forward-line 1) | 648 (forward-line 1) |
578 (beginning-of-line) | 649 (beginning-of-line) |
579 (setq found t) | 650 (setq found t) |
580 ;; We return the article number. | 651 ;; We return the article number. |
581 (setq number | 652 (setq number |
604 (when (and server | 675 (when (and server |
605 (not (nnml-server-opened server))) | 676 (not (nnml-server-opened server))) |
606 (nnml-open-server server)) | 677 (nnml-open-server server)) |
607 (if (not group) | 678 (if (not group) |
608 t | 679 t |
609 (let ((pathname (nnmail-group-pathname group nnml-directory)) | 680 (let ((pathname (nnml-group-pathname group nil server)) |
610 (file-name-coding-system nnmail-pathname-coding-system)) | 681 (file-name-coding-system nnmail-pathname-coding-system)) |
611 (when (not (equal pathname nnml-current-directory)) | 682 (when (not (equal pathname nnml-current-directory)) |
612 (setq nnml-current-directory pathname | 683 (setq nnml-current-directory pathname |
613 nnml-current-group group | 684 nnml-current-group group |
614 nnml-article-file-alist nil)) | 685 nnml-article-file-alist nil)) |
615 (file-exists-p nnml-current-directory)))) | 686 (file-exists-p nnml-current-directory)))) |
616 | 687 |
617 (defun nnml-possibly-create-directory (group) | 688 (defun nnml-possibly-create-directory (group &optional server) |
618 (let ((dir (nnmail-group-pathname group nnml-directory))) | 689 (let ((dir (nnml-group-pathname group nil server)) |
690 (file-name-coding-system nnmail-pathname-coding-system)) | |
619 (unless (file-exists-p dir) | 691 (unless (file-exists-p dir) |
620 (make-directory (directory-file-name dir) t) | 692 (make-directory (directory-file-name dir) t) |
621 (nnheader-message 5 "Creating mail directory %s" dir)))) | 693 (nnheader-message 5 "Creating mail directory %s" dir)))) |
622 | 694 |
623 (defun nnml-save-mail (group-art) | 695 (defun nnml-save-mail (group-art &optional server) |
624 "Called narrowed to an article." | 696 "Save a mail into the groups GROUP-ART in the nnml server SERVER. |
625 (let (chars headers extension) | 697 GROUP-ART is a list that each element is a cons of a group name and an |
626 (setq chars (nnmail-insert-lines)) | 698 article number. This function is called narrowed to an article." |
627 (setq extension | 699 (let* ((chars (nnmail-insert-lines)) |
628 (and nnml-use-compressed-files | 700 (extension (and nnml-use-compressed-files |
629 (> chars 1000) | 701 (> chars nnml-compressed-files-size-threshold) |
630 ".gz")) | 702 (if (stringp nnml-use-compressed-files) |
703 nnml-use-compressed-files | |
704 ".gz"))) | |
705 decoded dec file first headers) | |
706 (when nnmail-group-names-not-encoded-p | |
707 (dolist (ga (prog1 group-art (setq group-art nil))) | |
708 (setq group-art (nconc group-art | |
709 (list (cons (nnml-encoded-group-name (car ga) | |
710 server) | |
711 (cdr ga)))) | |
712 decoded (nconc decoded (list (car ga))))) | |
713 (setq dec decoded)) | |
631 (nnmail-insert-xref group-art) | 714 (nnmail-insert-xref group-art) |
632 (run-hooks 'nnmail-prepare-save-mail-hook) | 715 (run-hooks 'nnmail-prepare-save-mail-hook) |
633 (run-hooks 'nnml-prepare-save-mail-hook) | 716 (run-hooks 'nnml-prepare-save-mail-hook) |
634 (goto-char (point-min)) | 717 (goto-char (point-min)) |
635 (while (looking-at "From ") | 718 (while (looking-at "From ") |
636 (replace-match "X-From-Line: ") | 719 (replace-match "X-From-Line: ") |
637 (forward-line 1)) | 720 (forward-line 1)) |
638 ;; We save the article in all the groups it belongs in. | 721 ;; We save the article in all the groups it belongs in. |
639 (let ((ga group-art) | 722 (dolist (ga group-art) |
640 first) | 723 (if nnmail-group-names-not-encoded-p |
641 (while ga | 724 (progn |
642 (nnml-possibly-create-directory (caar ga)) | 725 (nnml-possibly-create-directory (car decoded) server) |
643 (let ((file (concat (nnmail-group-pathname | 726 (setq file (nnmail-group-pathname |
644 (caar ga) nnml-directory) | 727 (pop decoded) nnml-directory |
645 (int-to-string (cdar ga)) | 728 (concat (number-to-string (cdr ga)) extension)))) |
646 extension))) | 729 (nnml-possibly-create-directory (car ga) server) |
647 (if first | 730 (setq file (nnml-group-pathname |
648 ;; It was already saved, so we just make a hard link. | 731 (car ga) (concat (number-to-string (cdr ga)) extension) |
649 (funcall nnmail-crosspost-link-function first file t) | 732 server))) |
650 ;; Save the article. | 733 (if first |
651 (nnmail-write-region (point-min) (point-max) file nil | 734 ;; It was already saved, so we just make a hard link. |
652 (if (nnheader-be-verbose 5) nil 'nomesg)) | 735 (let ((file-name-coding-system nnmail-pathname-coding-system)) |
653 (setq first file))) | 736 (funcall nnmail-crosspost-link-function first file t)) |
654 (setq ga (cdr ga)))) | 737 ;; Save the article. |
738 (nnmail-write-region (point-min) (point-max) file nil | |
739 (if (nnheader-be-verbose 5) nil 'nomesg)) | |
740 (setq first file))) | |
655 ;; Generate a nov line for this article. We generate the nov | 741 ;; Generate a nov line for this article. We generate the nov |
656 ;; line after saving, because nov generation destroys the | 742 ;; line after saving, because nov generation destroys the |
657 ;; header. | 743 ;; header. |
658 (setq headers (nnml-parse-head chars)) | 744 (setq headers (nnml-parse-head chars)) |
659 ;; Output the nov line to all nov databases that should have it. | 745 ;; Output the nov line to all nov databases that should have it. |
660 (let ((ga group-art)) | 746 (if nnmail-group-names-not-encoded-p |
661 (while ga | 747 (dolist (ga group-art) |
662 (nnml-add-nov (caar ga) (cdar ga) headers) | 748 (nnml-add-nov (pop dec) (cdr ga) headers)) |
663 (setq ga (cdr ga)))) | 749 (dolist (ga group-art) |
664 group-art)) | 750 (nnml-add-nov (car ga) (cdr ga) headers)))) |
665 | 751 group-art) |
666 (defun nnml-active-number (group) | 752 |
667 "Compute the next article number in GROUP." | 753 (defun nnml-active-number (group &optional server) |
668 (let ((active (cadr (assoc group nnml-group-alist)))) | 754 "Compute the next article number in GROUP on SERVER." |
755 (let ((active (cadr (assoc (if nnmail-group-names-not-encoded-p | |
756 (nnml-encoded-group-name group server) | |
757 group) | |
758 nnml-group-alist)))) | |
669 ;; The group wasn't known to nnml, so we just create an active | 759 ;; The group wasn't known to nnml, so we just create an active |
670 ;; entry for it. | 760 ;; entry for it. |
671 (unless active | 761 (unless active |
672 ;; Perhaps the active file was corrupt? See whether | 762 ;; Perhaps the active file was corrupt? See whether |
673 ;; there are any articles in this group. | 763 ;; there are any articles in this group. |
674 (nnml-possibly-create-directory group) | 764 (nnml-possibly-create-directory group server) |
675 (nnml-possibly-change-directory group) | 765 (nnml-possibly-change-directory group server) |
676 (unless nnml-article-file-alist | 766 (unless nnml-article-file-alist |
677 (setq nnml-article-file-alist | 767 (setq nnml-article-file-alist |
678 (sort | 768 (sort |
679 (nnml-current-group-article-to-file-alist) | 769 (nnml-current-group-article-to-file-alist) |
680 'car-less-than-car))) | 770 'car-less-than-car))) |
684 (caar (last nnml-article-file-alist))) | 774 (caar (last nnml-article-file-alist))) |
685 (cons 1 0))) | 775 (cons 1 0))) |
686 (push (list group active) nnml-group-alist)) | 776 (push (list group active) nnml-group-alist)) |
687 (setcdr active (1+ (cdr active))) | 777 (setcdr active (1+ (cdr active))) |
688 (while (file-exists-p | 778 (while (file-exists-p |
689 (expand-file-name (int-to-string (cdr active)) | 779 (nnml-group-pathname group (int-to-string (cdr active)) server)) |
690 (nnmail-group-pathname group nnml-directory))) | |
691 (setcdr active (1+ (cdr active)))) | 780 (setcdr active (1+ (cdr active)))) |
692 (cdr active))) | 781 (cdr active))) |
693 | 782 |
694 (defun nnml-add-nov (group article headers) | 783 (defun nnml-add-nov (group article headers) |
695 "Add a nov line for the GROUP base." | 784 "Add a nov line for the GROUP base." |
698 (goto-char (point-max)) | 787 (goto-char (point-max)) |
699 (mail-header-set-number headers article) | 788 (mail-header-set-number headers article) |
700 (nnheader-insert-nov headers))) | 789 (nnheader-insert-nov headers))) |
701 | 790 |
702 (defsubst nnml-header-value () | 791 (defsubst nnml-header-value () |
703 (buffer-substring (match-end 0) (gnus-point-at-eol))) | 792 (buffer-substring (match-end 0) (point-at-eol))) |
704 | 793 |
705 (defun nnml-parse-head (chars &optional number) | 794 (defun nnml-parse-head (chars &optional number) |
706 "Parse the head of the current buffer." | 795 "Parse the head of the current buffer." |
707 (save-excursion | 796 (save-excursion |
708 (save-restriction | 797 (save-restriction |
716 (mail-header-set-chars headers chars) | 805 (mail-header-set-chars headers chars) |
717 (mail-header-set-number headers number) | 806 (mail-header-set-number headers number) |
718 headers)))) | 807 headers)))) |
719 | 808 |
720 (defun nnml-get-nov-buffer (group) | 809 (defun nnml-get-nov-buffer (group) |
721 (let ((buffer (get-buffer-create (format " *nnml overview %s*" group)))) | 810 (let* ((decoded (nnml-decoded-group-name group)) |
811 (buffer (get-buffer-create (format " *nnml overview %s*" decoded))) | |
812 (file-name-coding-system nnmail-pathname-coding-system)) | |
722 (save-excursion | 813 (save-excursion |
723 (set-buffer buffer) | 814 (set-buffer buffer) |
724 (set (make-local-variable 'nnml-nov-buffer-file-name) | 815 (set (make-local-variable 'nnml-nov-buffer-file-name) |
725 (expand-file-name | 816 (nnmail-group-pathname decoded nnml-directory nnml-nov-file-name)) |
726 nnml-nov-file-name | |
727 (nnmail-group-pathname group nnml-directory))) | |
728 (erase-buffer) | 817 (erase-buffer) |
729 (when (file-exists-p nnml-nov-buffer-file-name) | 818 (when (file-exists-p nnml-nov-buffer-file-name) |
730 (nnheader-insert-file-contents nnml-nov-buffer-file-name))) | 819 (nnheader-insert-file-contents nnml-nov-buffer-file-name))) |
731 buffer)) | 820 buffer)) |
732 | 821 |
757 (nnmail-activate 'nnml) | 846 (nnmail-activate 'nnml) |
758 (unless (nnml-server-opened server) | 847 (unless (nnml-server-opened server) |
759 (nnml-open-server server)) | 848 (nnml-open-server server)) |
760 (setq nnml-directory (expand-file-name nnml-directory)) | 849 (setq nnml-directory (expand-file-name nnml-directory)) |
761 ;; Recurse down the directories. | 850 ;; Recurse down the directories. |
762 (nnml-generate-nov-databases-1 nnml-directory nil t) | 851 (nnml-generate-nov-databases-directory nnml-directory nil t) |
763 ;; Save the active file. | 852 ;; Save the active file. |
764 (nnmail-save-active nnml-group-alist nnml-active-file)) | 853 (nnmail-save-active nnml-group-alist nnml-active-file)) |
765 | 854 |
766 (defun nnml-generate-nov-databases-1 (dir &optional seen no-active) | 855 (defun nnml-generate-nov-databases-directory (dir &optional seen no-active) |
767 "Regenerate the NOV database in DIR." | 856 "Regenerate the NOV database in DIR. |
768 (interactive "DRegenerate NOV in: ") | 857 |
858 Unless no-active is non-nil, update the active file too." | |
859 (interactive (list (let ((file-name-coding-system | |
860 nnmail-pathname-coding-system)) | |
861 (read-directory-name "Regenerate NOV in: " | |
862 nnml-directory nil t)))) | |
769 (setq dir (file-name-as-directory dir)) | 863 (setq dir (file-name-as-directory dir)) |
770 ;; Only scan this sub-tree if we haven't been here yet. | 864 (let ((file-name-coding-system nnmail-pathname-coding-system)) |
771 (unless (member (file-truename dir) seen) | 865 ;; Only scan this sub-tree if we haven't been here yet. |
772 (push (file-truename dir) seen) | 866 (unless (member (file-truename dir) seen) |
773 ;; We descend recursively | 867 (push (file-truename dir) seen) |
774 (let ((dirs (directory-files dir t nil t)) | 868 ;; We descend recursively |
775 dir) | 869 (dolist (dir (directory-files dir t nil t)) |
776 (while (setq dir (pop dirs)) | |
777 (when (and (not (string-match "^\\." (file-name-nondirectory dir))) | 870 (when (and (not (string-match "^\\." (file-name-nondirectory dir))) |
778 (file-directory-p dir)) | 871 (file-directory-p dir)) |
779 (nnml-generate-nov-databases-1 dir seen)))) | 872 (nnml-generate-nov-databases-directory dir seen))) |
780 ;; Do this directory. | 873 ;; Do this directory. |
781 (let ((files (sort (nnheader-article-to-file-alist dir) | 874 (let ((files (sort (nnheader-article-to-file-alist dir) |
782 'car-less-than-car))) | 875 'car-less-than-car))) |
783 (if (not files) | 876 (if (not files) |
784 (let* ((group (nnheader-file-to-group | 877 (let* ((group (nnheader-file-to-group |
785 (directory-file-name dir) nnml-directory)) | 878 (directory-file-name dir) nnml-directory)) |
786 (info (cadr (assoc group nnml-group-alist)))) | 879 (info (cadr (assoc group nnml-group-alist)))) |
787 (when info | 880 (when info |
788 (setcar info (1+ (cdr info))))) | 881 (setcar info (1+ (cdr info))))) |
789 (funcall nnml-generate-active-function dir) | 882 (funcall nnml-generate-active-function dir) |
790 ;; Generate the nov file. | 883 ;; Generate the nov file. |
791 (nnml-generate-nov-file dir files) | 884 (nnml-generate-nov-file dir files) |
792 (unless no-active | 885 (unless no-active |
793 (nnmail-save-active nnml-group-alist nnml-active-file)))))) | 886 (nnmail-save-active nnml-group-alist nnml-active-file))))))) |
794 | 887 |
795 (eval-when-compile (defvar files)) | 888 (eval-when-compile (defvar files)) |
796 (defun nnml-generate-active-info (dir) | 889 (defun nnml-generate-active-info (dir) |
797 ;; Update the active info for this group. | 890 ;; Update the active info for this group. |
798 (let* ((group (nnheader-file-to-group | 891 (let ((group (directory-file-name dir)) |
799 (directory-file-name dir) nnml-directory)) | 892 entry last) |
800 (entry (assoc group nnml-group-alist)) | 893 (setq group (nnheader-file-to-group (nnml-encoded-group-name group) |
801 (last (or (caadr entry) 0))) | 894 nnml-directory) |
802 (setq nnml-group-alist (delq entry nnml-group-alist)) | 895 entry (assoc group nnml-group-alist) |
896 last (or (caadr entry) 0) | |
897 nnml-group-alist (delq entry nnml-group-alist)) | |
803 (push (list group | 898 (push (list group |
804 (cons (or (caar files) (1+ last)) | 899 (cons (or (caar files) (1+ last)) |
805 (max last | 900 (max last |
806 (or (let ((f files)) | 901 (or (caar (last files)) |
807 (while (cdr f) (setq f (cdr f))) | |
808 (caar f)) | |
809 0)))) | 902 0)))) |
810 nnml-group-alist))) | 903 nnml-group-alist))) |
811 | 904 |
812 (defun nnml-generate-nov-file (dir files) | 905 (defun nnml-generate-nov-file (dir files) |
813 (let* ((dir (file-name-as-directory dir)) | 906 (let* ((dir (file-name-as-directory dir)) |
936 (nnml-save-marks group server)) | 1029 (nnml-save-marks group server)) |
937 nil) | 1030 nil) |
938 | 1031 |
939 (deffoo nnml-request-update-info (group info &optional server) | 1032 (deffoo nnml-request-update-info (group info &optional server) |
940 (nnml-possibly-change-directory group server) | 1033 (nnml-possibly-change-directory group server) |
941 (when (and (not nnml-marks-is-evil) (nnml-marks-changed-p group)) | 1034 (when (and (not nnml-marks-is-evil) (nnml-marks-changed-p group server)) |
942 (nnheader-message 8 "Updating marks for %s..." group) | 1035 (nnheader-message 8 "Updating marks for %s..." group) |
943 (nnml-open-marks group server) | 1036 (nnml-open-marks group server) |
944 ;; Update info using `nnml-marks'. | 1037 ;; Update info using `nnml-marks'. |
945 (mapcar (lambda (pred) | 1038 (mapc (lambda (pred) |
946 (unless (memq (cdr pred) gnus-article-unpropagated-mark-lists) | 1039 (unless (memq (cdr pred) gnus-article-unpropagated-mark-lists) |
947 (gnus-info-set-marks | 1040 (gnus-info-set-marks |
948 info | 1041 info |
949 (gnus-update-alist-soft | 1042 (gnus-update-alist-soft |
950 (cdr pred) | 1043 (cdr pred) |
951 (cdr (assq (cdr pred) nnml-marks)) | 1044 (cdr (assq (cdr pred) nnml-marks)) |
952 (gnus-info-marks info)) | 1045 (gnus-info-marks info)) |
953 t))) | 1046 t))) |
954 gnus-article-mark-lists) | 1047 gnus-article-mark-lists) |
955 (let ((seen (cdr (assq 'read nnml-marks)))) | 1048 (let ((seen (cdr (assq 'read nnml-marks)))) |
956 (gnus-info-set-read info | 1049 (gnus-info-set-read info |
957 (if (and (integerp (car seen)) | 1050 (if (and (integerp (car seen)) |
958 (null (cdr seen))) | 1051 (null (cdr seen))) |
959 (list (cons (car seen) (car seen))) | 1052 (list (cons (car seen) (car seen))) |
960 seen))) | 1053 seen))) |
961 (nnheader-message 8 "Updating marks for %s...done" group)) | 1054 (nnheader-message 8 "Updating marks for %s...done" group)) |
962 info) | 1055 info) |
963 | 1056 |
964 (defun nnml-marks-changed-p (group) | 1057 (defun nnml-marks-changed-p (group server) |
965 (let ((file (expand-file-name nnml-marks-file-name | 1058 (let ((file (nnml-group-pathname group nnml-marks-file-name server))) |
966 (nnmail-group-pathname group nnml-directory)))) | |
967 (if (null (gnus-gethash file nnml-marks-modtime)) | 1059 (if (null (gnus-gethash file nnml-marks-modtime)) |
968 t ;; never looked at marks file, assume it has changed | 1060 t ;; never looked at marks file, assume it has changed |
969 (not (equal (gnus-gethash file nnml-marks-modtime) | 1061 (not (equal (gnus-gethash file nnml-marks-modtime) |
970 (nth 5 (file-attributes file))))))) | 1062 (nth 5 (file-attributes file))))))) |
971 | 1063 |
972 (defun nnml-save-marks (group server) | 1064 (defun nnml-save-marks (group server) |
973 (let ((file-name-coding-system nnmail-pathname-coding-system) | 1065 (let ((file-name-coding-system nnmail-pathname-coding-system) |
974 (file (expand-file-name nnml-marks-file-name | 1066 (file (nnml-group-pathname group nnml-marks-file-name server))) |
975 (nnmail-group-pathname group nnml-directory)))) | |
976 (condition-case err | 1067 (condition-case err |
977 (progn | 1068 (progn |
978 (nnml-possibly-create-directory group) | 1069 (nnml-possibly-create-directory group server) |
979 (with-temp-file file | 1070 (with-temp-file file |
980 (erase-buffer) | 1071 (erase-buffer) |
981 (gnus-prin1 nnml-marks) | 1072 (gnus-prin1 nnml-marks) |
982 (insert "\n")) | 1073 (insert "\n")) |
983 (gnus-sethash file | 1074 (gnus-sethash file |
986 (error (or (gnus-yes-or-no-p | 1077 (error (or (gnus-yes-or-no-p |
987 (format "Could not write to %s (%s). Continue? " file err)) | 1078 (format "Could not write to %s (%s). Continue? " file err)) |
988 (error "Cannot write to %s (%s)" file err)))))) | 1079 (error "Cannot write to %s (%s)" file err)))))) |
989 | 1080 |
990 (defun nnml-open-marks (group server) | 1081 (defun nnml-open-marks (group server) |
991 (let ((file (expand-file-name | 1082 (let* ((decoded (nnml-decoded-group-name group server)) |
992 nnml-marks-file-name | 1083 (file (nnmail-group-pathname decoded nnml-directory |
993 (nnmail-group-pathname group nnml-directory)))) | 1084 nnml-marks-file-name)) |
1085 (file-name-coding-system nnmail-pathname-coding-system)) | |
994 (if (file-exists-p file) | 1086 (if (file-exists-p file) |
995 (condition-case err | 1087 (condition-case err |
996 (with-temp-buffer | 1088 (with-temp-buffer |
997 (gnus-sethash file (nth 5 (file-attributes file)) | 1089 (gnus-sethash file (nth 5 (file-attributes file)) |
998 nnml-marks-modtime) | 1090 nnml-marks-modtime) |
1006 ;; User didn't have a .marks file. Probably first time | 1098 ;; User didn't have a .marks file. Probably first time |
1007 ;; user of the .marks stuff. Bootstrap it from .newsrc.eld. | 1099 ;; user of the .marks stuff. Bootstrap it from .newsrc.eld. |
1008 (let ((info (gnus-get-info | 1100 (let ((info (gnus-get-info |
1009 (gnus-group-prefixed-name | 1101 (gnus-group-prefixed-name |
1010 group | 1102 group |
1011 (gnus-server-to-method (format "nnml:%s" server)))))) | 1103 (gnus-server-to-method |
1012 (nnheader-message 7 "Bootstrapping marks for %s..." group) | 1104 (format "nnml:%s" (or server ""))))))) |
1105 (setq decoded (if (member server '(nil "")) | |
1106 (concat "nnml:" decoded) | |
1107 (format "nnml+%s:%s" server decoded))) | |
1108 (nnheader-message 7 "Bootstrapping marks for %s..." decoded) | |
1013 (setq nnml-marks (gnus-info-marks info)) | 1109 (setq nnml-marks (gnus-info-marks info)) |
1014 (push (cons 'read (gnus-info-read info)) nnml-marks) | 1110 (push (cons 'read (gnus-info-read info)) nnml-marks) |
1015 (dolist (el gnus-article-unpropagated-mark-lists) | 1111 (dolist (el gnus-article-unpropagated-mark-lists) |
1016 (setq nnml-marks (gnus-remassoc el nnml-marks))) | 1112 (setq nnml-marks (gnus-remassoc el nnml-marks))) |
1017 (nnml-save-marks group server) | 1113 (nnml-save-marks group server) |
1018 (nnheader-message 7 "Bootstrapping marks for %s...done" group))))) | 1114 (nnheader-message 7 "Bootstrapping marks for %s...done" decoded))))) |
1115 | |
1116 | |
1117 ;;; | |
1118 ;;; Group and server compaction. -- dvl | |
1119 ;;; | |
1120 | |
1121 ;; #### FIXME: this function handles self Xref: entry correctly, but I don't | |
1122 ;; #### know how to handle external cross-references. I actually don't know if | |
1123 ;; #### this is handled correctly elsewhere. For instance, what happens if you | |
1124 ;; #### move all articles to a new group (that's what people do for manual | |
1125 ;; #### compaction) ? | |
1126 | |
1127 ;; #### NOTE: the function below handles the article backlog. This is | |
1128 ;; #### conceptually the wrong place to do it because the backend is at a | |
1129 ;; #### lower level. However, this is the only place where we have the needed | |
1130 ;; #### information to do the job. Ideally, this function should not handle | |
1131 ;; #### the backlog by itself, but return a list of moved groups / articles to | |
1132 ;; #### the caller. This will become important to avoid code duplication when | |
1133 ;; #### other backends get a compaction feature. Also, note that invalidating | |
1134 ;; #### the "original article buffer" is already done at an upper level. | |
1135 | |
1136 ;; Shouldn't `nnml-request-compact-group' be interactive? --rsteib | |
1137 | |
1138 (defun nnml-request-compact-group (group &optional server save) | |
1139 (nnml-possibly-change-directory group server) | |
1140 (unless nnml-article-file-alist | |
1141 (setq nnml-article-file-alist | |
1142 (sort (nnml-current-group-article-to-file-alist) | |
1143 'car-less-than-car))) | |
1144 (if (not nnml-article-file-alist) | |
1145 ;; The group is empty: do nothing but return t | |
1146 t | |
1147 ;; The group is not empty: | |
1148 (let* ((group-full-name | |
1149 (gnus-group-prefixed-name | |
1150 group | |
1151 (gnus-server-to-method (format "nnml:%s" server)))) | |
1152 (info (gnus-get-info group-full-name)) | |
1153 (new-number 1) | |
1154 compacted) | |
1155 (let ((articles nnml-article-file-alist) | |
1156 article) | |
1157 (while (setq article (pop articles)) | |
1158 (let ((old-number (car article))) | |
1159 (when (> old-number new-number) | |
1160 ;; There is a gap here: | |
1161 (let ((old-number-string (int-to-string old-number)) | |
1162 (new-number-string (int-to-string new-number))) | |
1163 (setq compacted t) | |
1164 ;; #### NOTE: `nnml-article-to-file' calls | |
1165 ;; #### `nnml-update-file-alist' (which in turn calls | |
1166 ;; #### `nnml-current-group-article-to-file-alist', which | |
1167 ;; #### might use the NOV database). This might turn out to be | |
1168 ;; #### inefficient. In that case, we will do the work | |
1169 ;; #### manually. | |
1170 ;; 1/ Move the article to a new file: | |
1171 (let* ((oldfile (nnml-article-to-file old-number)) | |
1172 (newfile | |
1173 (gnus-replace-in-string | |
1174 oldfile | |
1175 ;; nnml-use-compressed-files might be any string, but | |
1176 ;; probably it's sufficient to take into account only | |
1177 ;; "\\.[a-z0-9]+". Note that we can't only use the | |
1178 ;; value of nnml-use-compressed-files because old | |
1179 ;; articles might have been saved with a different | |
1180 ;; value. | |
1181 (concat | |
1182 "\\(" old-number-string "\\)\\(\\(\\.[a-z0-9]+\\)?\\)$") | |
1183 (concat new-number-string "\\2")))) | |
1184 (with-current-buffer nntp-server-buffer | |
1185 (nnmail-find-file oldfile) | |
1186 ;; Update the Xref header in the article itself: | |
1187 (when (and (re-search-forward "^Xref: [^ ]+ " nil t) | |
1188 (re-search-forward | |
1189 (concat "\\<" | |
1190 (regexp-quote | |
1191 (concat group ":" old-number-string)) | |
1192 "\\>") | |
1193 (point-at-eol) t)) | |
1194 (replace-match | |
1195 (concat group ":" new-number-string))) | |
1196 ;; Save to the new file: | |
1197 (nnmail-write-region (point-min) (point-max) newfile)) | |
1198 (funcall nnmail-delete-file-function oldfile)) | |
1199 ;; 2/ Update all marks for this article: | |
1200 ;; #### NOTE: it is possible that the new article number | |
1201 ;; #### already belongs to a range, whereas the corresponding | |
1202 ;; #### article doesn't exist (for example, if you delete an | |
1203 ;; #### article). For that reason, it is important to update | |
1204 ;; #### the ranges (meaning remove inexistant articles) before | |
1205 ;; #### doing anything on them. | |
1206 ;; 2 a/ read articles: | |
1207 (let ((read (gnus-info-read info))) | |
1208 (setq read (gnus-remove-from-range read (list new-number))) | |
1209 (when (gnus-member-of-range old-number read) | |
1210 (setq read (gnus-remove-from-range read (list old-number))) | |
1211 (setq read (gnus-add-to-range read (list new-number)))) | |
1212 (gnus-info-set-read info read)) | |
1213 ;; 2 b/ marked articles: | |
1214 (let ((oldmarks (gnus-info-marks info)) | |
1215 mark newmarks) | |
1216 (while (setq mark (pop oldmarks)) | |
1217 (setcdr mark (gnus-remove-from-range (cdr mark) | |
1218 (list new-number))) | |
1219 (when (gnus-member-of-range old-number (cdr mark)) | |
1220 (setcdr mark (gnus-remove-from-range (cdr mark) | |
1221 (list old-number))) | |
1222 (setcdr mark (gnus-add-to-range (cdr mark) | |
1223 (list new-number)))) | |
1224 (push mark newmarks)) | |
1225 (gnus-info-set-marks info newmarks)) | |
1226 ;; 3/ Update the NOV entry for this article: | |
1227 (unless nnml-nov-is-evil | |
1228 (save-excursion | |
1229 (set-buffer (nnml-open-nov group)) | |
1230 (when (nnheader-find-nov-line old-number) | |
1231 ;; Replace the article number: | |
1232 (looking-at old-number-string) | |
1233 (replace-match new-number-string nil t) | |
1234 ;; Update the Xref header: | |
1235 (when (re-search-forward | |
1236 (concat "\\(Xref:[^\t\n]* \\)\\<" | |
1237 (regexp-quote | |
1238 (concat group ":" old-number-string)) | |
1239 "\\>") | |
1240 (point-at-eol) t) | |
1241 (replace-match | |
1242 (concat "\\1" group ":" new-number-string)))))) | |
1243 ;; 4/ Possibly remove the article from the backlog: | |
1244 (when gnus-keep-backlog | |
1245 ;; #### NOTE: instead of removing the article, we could | |
1246 ;; #### modify the backlog to reflect the numbering change, | |
1247 ;; #### but I don't think it's worth it. | |
1248 (gnus-backlog-remove-article group-full-name old-number) | |
1249 (gnus-backlog-remove-article group-full-name new-number)))) | |
1250 (setq new-number (1+ new-number))))) | |
1251 (if (not compacted) | |
1252 ;; No compaction had to be done: | |
1253 t | |
1254 ;; Some articles have actually been renamed: | |
1255 ;; 1/ Rebuild active information: | |
1256 (let ((entry (assoc group nnml-group-alist)) | |
1257 (active (cons 1 (1- new-number)))) | |
1258 (setq nnml-group-alist (delq entry nnml-group-alist)) | |
1259 (push (list group active) nnml-group-alist) | |
1260 ;; Update the active hashtable to let the *Group* buffer display | |
1261 ;; up-to-date lines. I don't think that either gnus-newsrc-hashtb or | |
1262 ;; gnus-newwrc-alist are out of date, since all we did is to modify | |
1263 ;; the info of the group internally. | |
1264 (gnus-set-active group-full-name active)) | |
1265 ;; 1 bis/ | |
1266 ;; #### NOTE: normally, we should save the overview (NOV) file | |
1267 ;; #### here, just like we save the marks file. However, there is no | |
1268 ;; #### such function as nnml-save-nov for a single group. Only for | |
1269 ;; #### all groups. Gnus inconsistency is getting worse every day... | |
1270 ;; 2/ Rebuild marks file: | |
1271 (unless nnml-marks-is-evil | |
1272 ;; #### NOTE: this constant use of global variables everywhere is | |
1273 ;; #### truly disgusting. Gnus really needs a *major* cleanup. | |
1274 (setq nnml-marks (gnus-info-marks info)) | |
1275 (push (cons 'read (gnus-info-read info)) nnml-marks) | |
1276 (dolist (el gnus-article-unpropagated-mark-lists) | |
1277 (setq nnml-marks (gnus-remassoc el nnml-marks))) | |
1278 (nnml-save-marks group server)) | |
1279 ;; 3/ Save everything if this was not part of a bigger operation: | |
1280 (if (not save) | |
1281 ;; Nothing to save (yet): | |
1282 t | |
1283 ;; Something to save: | |
1284 ;; a/ Save the NOV databases: | |
1285 ;; #### NOTE: this should be done directory per directory in 1bis | |
1286 ;; #### above. See comment there. | |
1287 (nnml-save-nov) | |
1288 ;; b/ Save the active file: | |
1289 (nnmail-save-active nnml-group-alist nnml-active-file) | |
1290 t))))) | |
1291 | |
1292 (defun nnml-request-compact (&optional server) | |
1293 "Request compaction of all SERVER nnml groups." | |
1294 (interactive (list (or (nnoo-current-server 'nnml) ""))) | |
1295 (nnmail-activate 'nnml) | |
1296 (unless (nnml-server-opened server) | |
1297 (nnml-open-server server)) | |
1298 (setq nnml-directory (expand-file-name nnml-directory)) | |
1299 (let* ((groups (gnus-groups-from-server | |
1300 (gnus-server-to-method (format "nnml:%s" server)))) | |
1301 (first (pop groups)) | |
1302 group) | |
1303 (when first | |
1304 (while (setq group (pop groups)) | |
1305 (nnml-request-compact-group (gnus-group-real-name group) server)) | |
1306 (nnml-request-compact-group (gnus-group-real-name first) server t)))) | |
1307 | |
1019 | 1308 |
1020 (provide 'nnml) | 1309 (provide 'nnml) |
1021 | 1310 |
1022 ;;; arch-tag: 52c97dc3-9735-45de-b439-9e4d23b52004 | 1311 ;;; arch-tag: 52c97dc3-9735-45de-b439-9e4d23b52004 |
1023 ;;; nnml.el ends here | 1312 ;;; nnml.el ends here |