Mercurial > hg > xemacs-beta

comparison lisp/gnus/nnsoup.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 15872534500d
comparison
equal deleted inserted replaced
107:523141596bda 108:360340f9fd5f
111 ;; This is a useful area. 111 ;; This is a useful area.
112 (push (car areas) useful-areas) 112 (push (car areas) useful-areas)
113 (setq this-area-seq nil) 113 (setq this-area-seq nil)
114 ;; We take note whether this MSG has a corresponding IDX 114 ;; We take note whether this MSG has a corresponding IDX
115 ;; for later use. 115 ;; for later use.
116 (when (or (= (gnus-soup-encoding-index 116 (when (or (= (gnus-soup-encoding-index
117 (gnus-soup-area-encoding (nth 1 (car areas)))) ?n) 117 (gnus-soup-area-encoding (nth 1 (car areas)))) ?n)
118 (not (file-exists-p 118 (not (file-exists-p
119 (nnsoup-file 119 (nnsoup-file
120 (gnus-soup-area-prefix (nth 1 (car areas))))))) 120 (gnus-soup-area-prefix (nth 1 (car areas)))))))
121 (setq use-nov nil)) 121 (setq use-nov nil))
126 (setq sequence (cdr sequence))) 126 (setq sequence (cdr sequence)))
127 (setcar useful-areas (cons (nreverse this-area-seq) 127 (setcar useful-areas (cons (nreverse this-area-seq)
128 (car useful-areas))))) 128 (car useful-areas)))))
129 129
130 ;; We now have a list of article numbers and corresponding 130 ;; We now have a list of article numbers and corresponding
131 ;; areas. 131 ;; areas.
132 (setq useful-areas (nreverse useful-areas)) 132 (setq useful-areas (nreverse useful-areas))
133 133
134 ;; Two different approaches depending on whether all the MSG 134 ;; Two different approaches depending on whether all the MSG
135 ;; files have corresponding IDX files. If they all do, we 135 ;; files have corresponding IDX files. If they all do, we
136 ;; simply return the relevant IDX files and let Gnus sort out 136 ;; simply return the relevant IDX files and let Gnus sort out
161 (while useful-areas 161 (while useful-areas
162 (setq articles (caar useful-areas) 162 (setq articles (caar useful-areas)
163 useful-areas (cdr useful-areas)) 163 useful-areas (cdr useful-areas))
164 (while articles 164 (while articles
165 (when (setq msg-buf 165 (when (setq msg-buf
166 (nnsoup-narrow-to-article 166 (nnsoup-narrow-to-article
167 (car articles) (cdar useful-areas) 'head)) 167 (car articles) (cdar useful-areas) 'head))
168 (goto-char (point-max)) 168 (goto-char (point-max))
169 (insert (format "221 %d Article retrieved.\n" (car articles))) 169 (insert (format "221 %d Article retrieved.\n" (car articles)))
170 (insert-buffer-substring msg-buf) 170 (insert-buffer-substring msg-buf)
171 (goto-char (point-max)) 171 (goto-char (point-max))
179 (nnoo-change-server 'nnsoup server defs) 179 (nnoo-change-server 'nnsoup server defs)
180 (when (not (file-exists-p nnsoup-directory)) 180 (when (not (file-exists-p nnsoup-directory))
181 (condition-case () 181 (condition-case ()
182 (make-directory nnsoup-directory t) 182 (make-directory nnsoup-directory t)
183 (error t))) 183 (error t)))
184 (cond 184 (cond
185 ((not (file-exists-p nnsoup-directory)) 185 ((not (file-exists-p nnsoup-directory))
186 (nnsoup-close-server) 186 (nnsoup-close-server)
187 (nnheader-report 'nnsoup "Couldn't create directory: %s" nnsoup-directory)) 187 (nnheader-report 'nnsoup "Couldn't create directory: %s" nnsoup-directory))
188 ((not (file-directory-p (file-truename nnsoup-directory))) 188 ((not (file-directory-p (file-truename nnsoup-directory)))
189 (nnsoup-close-server) 189 (nnsoup-close-server)
223 (insert-buffer-substring buf) 223 (insert-buffer-substring buf)
224 t)))) 224 t))))
225 225
226 (deffoo nnsoup-request-group (group &optional server dont-check) 226 (deffoo nnsoup-request-group (group &optional server dont-check)
227 (nnsoup-possibly-change-group group) 227 (nnsoup-possibly-change-group group)
228 (if dont-check 228 (if dont-check
229 t 229 t
230 (let ((active (cadr (assoc group nnsoup-group-alist)))) 230 (let ((active (cadr (assoc group nnsoup-group-alist))))
231 (if (not active) 231 (if (not active)
232 (nnheader-report 'nnsoup "No such group: %s" group) 232 (nnheader-report 'nnsoup "No such group: %s" group)
233 (nnheader-insert 233 (nnheader-insert
234 "211 %d %d %d %s\n" 234 "211 %d %d %d %s\n"
235 (max (1+ (- (cdr active) (car active))) 0) 235 (max (1+ (- (cdr active) (car active))) 0)
236 (car active) (cdr active) group))))) 236 (car active) (cdr active) group)))))
237 237
238 (deffoo nnsoup-request-type (group &optional article) 238 (deffoo nnsoup-request-type (group &optional article)
239 (nnsoup-possibly-change-group group) 239 (nnsoup-possibly-change-group group)
241 (when (not article) 241 (when (not article)
242 (setq article 242 (setq article
243 (cdaar (cddr (assoc group nnsoup-group-alist))))) 243 (cdaar (cddr (assoc group nnsoup-group-alist)))))
244 (if (not article) 244 (if (not article)
245 'unknown 245 'unknown
246 (let ((kind (gnus-soup-encoding-kind 246 (let ((kind (gnus-soup-encoding-kind
247 (gnus-soup-area-encoding 247 (gnus-soup-area-encoding
248 (nth 1 (nnsoup-article-to-area 248 (nth 1 (nnsoup-article-to-area
249 article nnsoup-current-group)))))) 249 article nnsoup-current-group))))))
250 (cond ((= kind ?m) 'mail) 250 (cond ((= kind ?m) 'mail)
251 ((= kind ?n) 'news) 251 ((= kind ?n) 'news)
310 (and (or (setq mod-time (nth 5 (file-attributes 310 (and (or (setq mod-time (nth 5 (file-attributes
311 (nnsoup-file prefix)))) 311 (nnsoup-file prefix))))
312 (setq mod-time (nth 5 (file-attributes 312 (setq mod-time (nth 5 (file-attributes
313 (nnsoup-file prefix t))))) 313 (nnsoup-file prefix t)))))
314 (gnus-sublist-p articles range-list) 314 (gnus-sublist-p articles range-list)
315 ;; This file is old enough. 315 ;; This file is old enough.
316 (nnmail-expired-article-p group mod-time force)) 316 (nnmail-expired-article-p group mod-time force))
317 ;; Ok, we delete this file. 317 ;; Ok, we delete this file.
318 (when (ignore-errors 318 (when (ignore-errors
319 (nnheader-message 319 (nnheader-message
320 5 "Deleting %s in group %s..." (nnsoup-file prefix) 320 5 "Deleting %s in group %s..." (nnsoup-file prefix)
321 group) 321 group)
322 (when (file-exists-p (nnsoup-file prefix)) 322 (when (file-exists-p (nnsoup-file prefix))
323 (delete-file (nnsoup-file prefix))) 323 (delete-file (nnsoup-file prefix)))
324 (nnheader-message 324 (nnheader-message
325 5 "Deleting %s in group %s..." (nnsoup-file prefix t) 325 5 "Deleting %s in group %s..." (nnsoup-file prefix t)
326 group) 326 group)
327 (when (file-exists-p (nnsoup-file prefix t)) 327 (when (file-exists-p (nnsoup-file prefix t))
328 (delete-file (nnsoup-file prefix t))) 328 (delete-file (nnsoup-file prefix t)))
329 t) 329 t)
367 (setq nnsoup-group-alist-touched t)) 367 (setq nnsoup-group-alist-touched t))
368 nnsoup-group-alist)) 368 nnsoup-group-alist))
369 369
370 (defun nnsoup-write-active-file (&optional force) 370 (defun nnsoup-write-active-file (&optional force)
371 (when (and nnsoup-group-alist 371 (when (and nnsoup-group-alist
372 (or force 372 (or force
373 nnsoup-group-alist-touched)) 373 nnsoup-group-alist-touched))
374 (setq nnsoup-group-alist-touched nil) 374 (setq nnsoup-group-alist-touched nil)
375 (nnheader-temp-write nnsoup-active-file 375 (nnheader-temp-write nnsoup-active-file
376 (gnus-prin1 `(setq nnsoup-group-alist ',nnsoup-group-alist)) 376 (gnus-prin1 `(setq nnsoup-group-alist ',nnsoup-group-alist))
377 (insert "\n") 377 (insert "\n")
379 (insert "\n")))) 379 (insert "\n"))))
380 380
381 (defun nnsoup-next-prefix () 381 (defun nnsoup-next-prefix ()
382 "Return the next free prefix." 382 "Return the next free prefix."
383 (let (prefix) 383 (let (prefix)
384 (while (or (file-exists-p 384 (while (or (file-exists-p
385 (nnsoup-file (setq prefix (int-to-string 385 (nnsoup-file (setq prefix (int-to-string
386 nnsoup-current-prefix)))) 386 nnsoup-current-prefix))))
387 (file-exists-p (nnsoup-file prefix t))) 387 (file-exists-p (nnsoup-file prefix t)))
388 (incf nnsoup-current-prefix)) 388 (incf nnsoup-current-prefix))
389 (incf nnsoup-current-prefix) 389 (incf nnsoup-current-prefix)
412 ;; Go through all areas in the new AREAS file. 412 ;; Go through all areas in the new AREAS file.
413 (while (setq area (pop areas)) 413 (while (setq area (pop areas))
414 ;; Change the name to the permanent name and move the files. 414 ;; Change the name to the permanent name and move the files.
415 (setq cur-prefix (nnsoup-next-prefix)) 415 (setq cur-prefix (nnsoup-next-prefix))
416 (message "Incorporating file %s..." cur-prefix) 416 (message "Incorporating file %s..." cur-prefix)
417 (when (file-exists-p 417 (when (file-exists-p
418 (setq file (concat nnsoup-tmp-directory 418 (setq file (concat nnsoup-tmp-directory
419 (gnus-soup-area-prefix area) ".IDX"))) 419 (gnus-soup-area-prefix area) ".IDX")))
420 (rename-file file (nnsoup-file cur-prefix))) 420 (rename-file file (nnsoup-file cur-prefix)))
421 (when (file-exists-p 421 (when (file-exists-p
422 (setq file (concat nnsoup-tmp-directory 422 (setq file (concat nnsoup-tmp-directory
423 (gnus-soup-area-prefix area) ".MSG"))) 423 (gnus-soup-area-prefix area) ".MSG")))
424 (rename-file file (nnsoup-file cur-prefix t)) 424 (rename-file file (nnsoup-file cur-prefix t))
425 (gnus-soup-set-area-prefix area cur-prefix) 425 (gnus-soup-set-area-prefix area cur-prefix)
426 ;; Find the number of new articles in this area. 426 ;; Find the number of new articles in this area.
427 (setq number (nnsoup-number-of-articles area)) 427 (setq number (nnsoup-number-of-articles area))
428 (if (not (setq entry (assoc (gnus-soup-area-name area) 428 (if (not (setq entry (assoc (gnus-soup-area-name area)
429 nnsoup-group-alist))) 429 nnsoup-group-alist)))
430 ;; If this is a new area (group), we just add this info to 430 ;; If this is a new area (group), we just add this info to
431 ;; the group alist. 431 ;; the group alist.
432 (push (list (gnus-soup-area-name area) 432 (push (list (gnus-soup-area-name area)
433 (cons 1 number) 433 (cons 1 number)
434 (list (cons 1 number) area)) 434 (list (cons 1 number) area))
435 nnsoup-group-alist) 435 nnsoup-group-alist)
436 ;; There are already articles in this group, so we add this 436 ;; There are already articles in this group, so we add this
442 (nnsoup-write-active-file t) 442 (nnsoup-write-active-file t)
443 (delete-file areas-file))))) 443 (delete-file areas-file)))))
444 444
445 (defun nnsoup-number-of-articles (area) 445 (defun nnsoup-number-of-articles (area)
446 (save-excursion 446 (save-excursion
447 (cond 447 (cond
448 ;; If the number is in the area info, we just return it. 448 ;; If the number is in the area info, we just return it.
449 ((gnus-soup-area-number area) 449 ((gnus-soup-area-number area)
450 (gnus-soup-area-number area)) 450 (gnus-soup-area-number area))
451 ;; If there is an index file, we just count the lines. 451 ;; If there is an index file, we just count the lines.
452 ((/= (gnus-soup-encoding-index (gnus-soup-area-encoding area)) ?n) 452 ((/= (gnus-soup-encoding-index (gnus-soup-area-encoding area)) ?n)
453 (set-buffer (nnsoup-index-buffer (gnus-soup-area-prefix area))) 453 (set-buffer (nnsoup-index-buffer (gnus-soup-area-prefix area)))
454 (count-lines (point-min) (point-max))) 454 (count-lines (point-min) (point-max)))
455 ;; We do it the hard way - re-searching through the message 455 ;; We do it the hard way - re-searching through the message
456 ;; buffer. 456 ;; buffer.
457 (t 457 (t
458 (set-buffer (nnsoup-message-buffer (gnus-soup-area-prefix area))) 458 (set-buffer (nnsoup-message-buffer (gnus-soup-area-prefix area)))
459 (unless (assoc (gnus-soup-area-prefix area) nnsoup-article-alist) 459 (unless (assoc (gnus-soup-area-prefix area) nnsoup-article-alist)
460 (nnsoup-dissect-buffer area)) 460 (nnsoup-dissect-buffer area))
461 (length (cdr (assoc (gnus-soup-area-prefix area) 461 (length (cdr (assoc (gnus-soup-area-prefix area)
462 nnsoup-article-alist))))))) 462 nnsoup-article-alist)))))))
463 463
464 (defun nnsoup-dissect-buffer (area) 464 (defun nnsoup-dissect-buffer (area)
465 (let ((mbox-delim (concat "^" message-unix-mail-delimiter)) 465 (let ((mbox-delim (concat "^" message-unix-mail-delimiter))
466 (format (gnus-soup-encoding-format (gnus-soup-area-encoding area))) 466 (format (gnus-soup-encoding-format (gnus-soup-area-encoding area)))
467 (i 0) 467 (i 0)
468 alist len) 468 alist len)
469 (goto-char (point-min)) 469 (goto-char (point-min))
470 (cond 470 (cond
471 ;; rnews batch format 471 ;; rnews batch format
472 ((= format ?n) 472 ((= format ?n)
473 (while (looking-at "^#! *rnews \\(+[0-9]+\\) *$") 473 (while (looking-at "^#! *rnews \\(+[0-9]+\\) *$")
474 (forward-line 1) 474 (forward-line 1)
475 (push (list 475 (push (list
480 alist))) 480 alist)))
481 ;; Unix mbox format 481 ;; Unix mbox format
482 ((= format ?m) 482 ((= format ?m)
483 (while (looking-at mbox-delim) 483 (while (looking-at mbox-delim)
484 (forward-line 1) 484 (forward-line 1)
485 (push (list 485 (push (list
486 (incf i) (point) 486 (incf i) (point)
487 (progn 487 (progn
488 (if (re-search-forward mbox-delim nil t) 488 (if (re-search-forward mbox-delim nil t)
489 (beginning-of-line) 489 (beginning-of-line)
490 (goto-char (point-max))) 490 (goto-char (point-max)))
492 alist))) 492 alist)))
493 ;; MMDF format 493 ;; MMDF format
494 ((= format ?M) 494 ((= format ?M)
495 (while (looking-at "\^A\^A\^A\^A\n") 495 (while (looking-at "\^A\^A\^A\^A\n")
496 (forward-line 1) 496 (forward-line 1)
497 (push (list 497 (push (list
498 (incf i) (point) 498 (incf i) (point)
499 (progn 499 (progn
500 (if (search-forward "\n\^A\^A\^A\^A\n" nil t) 500 (if (search-forward "\n\^A\^A\^A\^A\n" nil t)
501 (beginning-of-line) 501 (beginning-of-line)
502 (goto-char (point-max))) 502 (goto-char (point-max)))
543 (let ((packets (directory-files 543 (let ((packets (directory-files
544 nnsoup-packet-directory t nnsoup-packet-regexp)) 544 nnsoup-packet-directory t nnsoup-packet-regexp))
545 packet) 545 packet)
546 (while (setq packet (pop packets)) 546 (while (setq packet (pop packets))
547 (message "nnsoup: unpacking %s..." packet) 547 (message "nnsoup: unpacking %s..." packet)
548 (if (not (gnus-soup-unpack-packet 548 (if (not (gnus-soup-unpack-packet
549 nnsoup-tmp-directory nnsoup-unpacker packet)) 549 nnsoup-tmp-directory nnsoup-unpacker packet))
550 (message "Couldn't unpack %s" packet) 550 (message "Couldn't unpack %s" packet)
551 (delete-file packet) 551 (delete-file packet)
552 (nnsoup-read-areas) 552 (nnsoup-read-areas)
553 (message "Unpacking...done"))))) 553 (message "Unpacking...done")))))
561 (save-excursion 561 (save-excursion
562 (cond 562 (cond
563 ;; There is no MSG file. 563 ;; There is no MSG file.
564 ((null msg-buf) 564 ((null msg-buf)
565 nil) 565 nil)
566 ;; We use the index file to find out where the article 566 ;; We use the index file to find out where the article
567 ;; begins and ends. 567 ;; begins and ends.
568 ((and (= (gnus-soup-encoding-index 568 ((and (= (gnus-soup-encoding-index
569 (gnus-soup-area-encoding (nth 1 area))) 569 (gnus-soup-area-encoding (nth 1 area)))
570 ?c) 570 ?c)
571 (file-exists-p (nnsoup-file prefix))) 571 (file-exists-p (nnsoup-file prefix)))
572 (set-buffer (nnsoup-index-buffer prefix)) 572 (set-buffer (nnsoup-index-buffer prefix))
573 (widen) 573 (widen)
695 ;; Sun's bug that swallows newlines. 695 ;; Sun's bug that swallows newlines.
696 (goto-char (1+ delimline)) 696 (goto-char (1+ delimline))
697 (when (eval message-mailer-swallows-blank-line) 697 (when (eval message-mailer-swallows-blank-line)
698 (newline)) 698 (newline))
699 (let ((msg-buf 699 (let ((msg-buf
700 (gnus-soup-store 700 (gnus-soup-store
701 nnsoup-replies-directory 701 nnsoup-replies-directory
702 (nnsoup-kind-to-prefix kind) nil nnsoup-replies-format-type 702 (nnsoup-kind-to-prefix kind) nil nnsoup-replies-format-type
703 nnsoup-replies-index-type)) 703 nnsoup-replies-index-type))
704 (num 0)) 704 (num 0))
705 (when (and msg-buf (bufferp msg-buf)) 705 (when (and msg-buf (bufferp msg-buf))
706 (save-excursion 706 (save-excursion
713 (kill-buffer tembuf)))))) 713 (kill-buffer tembuf))))))
714 714
715 (defun nnsoup-kind-to-prefix (kind) 715 (defun nnsoup-kind-to-prefix (kind)
716 (unless nnsoup-replies-list 716 (unless nnsoup-replies-list
717 (setq nnsoup-replies-list 717 (setq nnsoup-replies-list
718 (gnus-soup-parse-replies 718 (gnus-soup-parse-replies
719 (concat nnsoup-replies-directory "REPLIES")))) 719 (concat nnsoup-replies-directory "REPLIES"))))
720 (let ((replies nnsoup-replies-list)) 720 (let ((replies nnsoup-replies-list))
721 (while (and replies 721 (while (and replies
722 (not (string= kind (gnus-soup-reply-kind (car replies))))) 722 (not (string= kind (gnus-soup-reply-kind (car replies)))))
723 (setq replies (cdr replies))) 723 (setq replies (cdr replies)))
724 (if replies 724 (if replies
725 (gnus-soup-reply-prefix (car replies)) 725 (gnus-soup-reply-prefix (car replies))
726 (push (vector (gnus-soup-unique-prefix nnsoup-replies-directory) 726 (push (vector (gnus-soup-unique-prefix nnsoup-replies-directory)
727 kind 727 kind
728 (format "%c%c%c" 728 (format "%c%c%c"
729 nnsoup-replies-format-type 729 nnsoup-replies-format-type
730 nnsoup-replies-index-type 730 nnsoup-replies-index-type
731 (if (string= kind "news") 731 (if (string= kind "news")
732 ?n ?m))) 732 ?n ?m)))
754 (setq group "unknown") 754 (setq group "unknown")
755 (setq group (match-string 2))) 755 (setq group (match-string 2)))
756 (setq lines (count-lines (point-min) (point-max))) 756 (setq lines (count-lines (point-min) (point-max)))
757 (setq ident (progn (string-match 757 (setq ident (progn (string-match
758 "/\\([0-9]+\\)\\." (car files)) 758 "/\\([0-9]+\\)\\." (car files))
759 (substring 759 (substring
760 (car files) (match-beginning 1) 760 (car files) (match-beginning 1)
761 (match-end 1)))) 761 (match-end 1))))
762 (if (not (setq elem (assoc group active))) 762 (if (not (setq elem (assoc group active)))
763 (push (list group (cons 1 lines) 763 (push (list group (cons 1 lines)
764 (list (cons 1 lines) 764 (list (cons 1 lines)
776 (nnsoup-write-active-file t))) 776 (nnsoup-write-active-file t)))
777 777
778 (defun nnsoup-delete-unreferenced-message-files () 778 (defun nnsoup-delete-unreferenced-message-files ()
779 "Delete any *.MSG and *.IDX files that aren't known by nnsoup." 779 "Delete any *.MSG and *.IDX files that aren't known by nnsoup."
780 (interactive) 780 (interactive)
781 (let* ((known (apply 'nconc (mapcar 781 (let* ((known (apply 'nconc (mapcar
782 (lambda (ga) 782 (lambda (ga)
783 (mapcar 783 (mapcar
784 (lambda (area) 784 (lambda (area)
785 (gnus-soup-area-prefix (cadr area))) 785 (gnus-soup-area-prefix (cadr area)))
786 (cddr ga))) 786 (cddr ga)))