Mercurial > hg > xemacs-beta

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

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents ec9a17fef872
children 0d2f883870bc
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
1 ;;; nnsoup.el --- SOUP access for Gnus 1 ;;; nnsoup.el --- SOUP access for Gnus
2 ;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. 2 ;; Copyright (C) 1995,96 Free Software Foundation, Inc.
3 3
4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
5 ;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> 5 ;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
6 ;; Keywords: news, mail 6 ;; Keywords: news, mail
7 7
54 "Active file.") 54 "Active file.")
55 55
56 (defvoo nnsoup-packer "tar cf - %s | gzip > $HOME/Soupin%d.tgz" 56 (defvoo nnsoup-packer "tar cf - %s | gzip > $HOME/Soupin%d.tgz"
57 "Format string command for packing a SOUP packet. 57 "Format string command for packing a SOUP packet.
58 The SOUP files will be inserted where the %s is in the string. 58 The SOUP files will be inserted where the %s is in the string.
59 This string MUST contain both %s and %d. The file number will be 59 This string MUST contain both %s and %d. The file number will be
60 inserted where %d appears.") 60 inserted where %d appears.")
61 61
62 (defvoo nnsoup-unpacker "gunzip -c %s | tar xvf -" 62 (defvoo nnsoup-unpacker "gunzip -c %s | tar xvf -"
63 "*Format string command for unpacking a SOUP packet. 63 "*Format string command for unpacking a SOUP packet.
64 The SOUP packet file name will be inserted at the %s.") 64 The SOUP packet file name will be inserted at the %s.")
79 (defvoo nnsoup-current-prefix 0) 79 (defvoo nnsoup-current-prefix 0)
80 (defvoo nnsoup-replies-list nil) 80 (defvoo nnsoup-replies-list nil)
81 (defvoo nnsoup-buffers nil) 81 (defvoo nnsoup-buffers nil)
82 (defvoo nnsoup-current-group nil) 82 (defvoo nnsoup-current-group nil)
83 (defvoo nnsoup-group-alist-touched nil) 83 (defvoo nnsoup-group-alist-touched nil)
84 (defvoo nnsoup-article-alist nil)
85 84
86 85
87 86
88 ;;; Interface functions. 87 ;;; Interface functions.
89 88
111 ;; This is a useful area. 110 ;; This is a useful area.
112 (push (car areas) useful-areas) 111 (push (car areas) useful-areas)
113 (setq this-area-seq nil) 112 (setq this-area-seq nil)
114 ;; We take note whether this MSG has a corresponding IDX 113 ;; We take note whether this MSG has a corresponding IDX
115 ;; for later use. 114 ;; for later use.
116 (when (or (= (gnus-soup-encoding-index 115 (when (or (= (gnus-soup-encoding-index
117 (gnus-soup-area-encoding (nth 1 (car areas)))) ?n) 116 (gnus-soup-area-encoding (nth 1 (car areas)))) ?n)
118 (not (file-exists-p 117 (not (file-exists-p
119 (nnsoup-file 118 (nnsoup-file
120 (gnus-soup-area-prefix (nth 1 (car areas))))))) 119 (gnus-soup-area-prefix (nth 1 (car areas)))))))
121 (setq use-nov nil)) 120 (setq use-nov nil))
126 (setq sequence (cdr sequence))) 125 (setq sequence (cdr sequence)))
127 (setcar useful-areas (cons (nreverse this-area-seq) 126 (setcar useful-areas (cons (nreverse this-area-seq)
128 (car useful-areas))))) 127 (car useful-areas)))))
129 128
130 ;; We now have a list of article numbers and corresponding 129 ;; We now have a list of article numbers and corresponding
131 ;; areas. 130 ;; areas.
132 (setq useful-areas (nreverse useful-areas)) 131 (setq useful-areas (nreverse useful-areas))
133 132
134 ;; Two different approaches depending on whether all the MSG 133 ;; Two different approaches depending on whether all the MSG
135 ;; files have corresponding IDX files. If they all do, we 134 ;; files have corresponding IDX files. If they all do, we
136 ;; simply return the relevant IDX files and let Gnus sort out 135 ;; simply return the relevant IDX files and let Gnus sort out
161 (while useful-areas 160 (while useful-areas
162 (setq articles (caar useful-areas) 161 (setq articles (caar useful-areas)
163 useful-areas (cdr useful-areas)) 162 useful-areas (cdr useful-areas))
164 (while articles 163 (while articles
165 (when (setq msg-buf 164 (when (setq msg-buf
166 (nnsoup-narrow-to-article 165 (nnsoup-narrow-to-article
167 (car articles) (cdar useful-areas) 'head)) 166 (car articles) (cdar useful-areas) 'head))
168 (goto-char (point-max)) 167 (goto-char (point-max))
169 (insert (format "221 %d Article retrieved.\n" (car articles))) 168 (insert (format "221 %d Article retrieved.\n" (car articles)))
170 (insert-buffer-substring msg-buf) 169 (insert-buffer-substring msg-buf)
171 (goto-char (point-max)) 170 (goto-char (point-max))
179 (nnoo-change-server 'nnsoup server defs) 178 (nnoo-change-server 'nnsoup server defs)
180 (when (not (file-exists-p nnsoup-directory)) 179 (when (not (file-exists-p nnsoup-directory))
181 (condition-case () 180 (condition-case ()
182 (make-directory nnsoup-directory t) 181 (make-directory nnsoup-directory t)
183 (error t))) 182 (error t)))
184 (cond 183 (cond
185 ((not (file-exists-p nnsoup-directory)) 184 ((not (file-exists-p nnsoup-directory))
186 (nnsoup-close-server) 185 (nnsoup-close-server)
187 (nnheader-report 'nnsoup "Couldn't create directory: %s" nnsoup-directory)) 186 (nnheader-report 'nnsoup "Couldn't create directory: %s" nnsoup-directory))
188 ((not (file-directory-p (file-truename nnsoup-directory))) 187 ((not (file-directory-p (file-truename nnsoup-directory)))
189 (nnsoup-close-server) 188 (nnsoup-close-server)
223 (insert-buffer-substring buf) 222 (insert-buffer-substring buf)
224 t)))) 223 t))))
225 224
226 (deffoo nnsoup-request-group (group &optional server dont-check) 225 (deffoo nnsoup-request-group (group &optional server dont-check)
227 (nnsoup-possibly-change-group group) 226 (nnsoup-possibly-change-group group)
228 (if dont-check 227 (if dont-check
229 t 228 t
230 (let ((active (cadr (assoc group nnsoup-group-alist)))) 229 (let ((active (cadr (assoc group nnsoup-group-alist))))
231 (if (not active) 230 (if (not active)
232 (nnheader-report 'nnsoup "No such group: %s" group) 231 (nnheader-report 'nnsoup "No such group: %s" group)
233 (nnheader-insert 232 (nnheader-insert
234 "211 %d %d %d %s\n" 233 "211 %d %d %d %s\n"
235 (max (1+ (- (cdr active) (car active))) 0) 234 (max (1+ (- (cdr active) (car active))) 0)
236 (car active) (cdr active) group))))) 235 (car active) (cdr active) group)))))
237 236
238 (deffoo nnsoup-request-type (group &optional article) 237 (deffoo nnsoup-request-type (group &optional article)
239 (nnsoup-possibly-change-group group) 238 (nnsoup-possibly-change-group group)
240 ;; Try to guess the type based on the first articl ein the group.
241 (when (not article)
242 (setq article
243 (cdaar (cddr (assoc group nnsoup-group-alist)))))
244 (if (not article) 239 (if (not article)
245 'unknown 240 'unknown
246 (let ((kind (gnus-soup-encoding-kind 241 (let ((kind (gnus-soup-encoding-kind
247 (gnus-soup-area-encoding 242 (gnus-soup-area-encoding
248 (nth 1 (nnsoup-article-to-area 243 (nth 1 (nnsoup-article-to-area
249 article nnsoup-current-group)))))) 244 article nnsoup-current-group))))))
250 (cond ((= kind ?m) 'mail) 245 (cond ((= kind ?m) 'mail)
251 ((= kind ?n) 'news) 246 ((= kind ?n) 'news)
310 (and (or (setq mod-time (nth 5 (file-attributes 305 (and (or (setq mod-time (nth 5 (file-attributes
311 (nnsoup-file prefix)))) 306 (nnsoup-file prefix))))
312 (setq mod-time (nth 5 (file-attributes 307 (setq mod-time (nth 5 (file-attributes
313 (nnsoup-file prefix t))))) 308 (nnsoup-file prefix t)))))
314 (gnus-sublist-p articles range-list) 309 (gnus-sublist-p articles range-list)
315 ;; This file is old enough. 310 ;; This file is old enough.
316 (nnmail-expired-article-p group mod-time force)) 311 (nnmail-expired-article-p group mod-time force))
317 ;; Ok, we delete this file. 312 ;; Ok, we delete this file.
318 (when (ignore-errors 313 (when (condition-case nil
319 (nnheader-message 314 (progn
320 5 "Deleting %s in group %s..." (nnsoup-file prefix) 315 (nnheader-message
321 group) 316 5 "Deleting %s in group %s..." (nnsoup-file prefix)
322 (when (file-exists-p (nnsoup-file prefix)) 317 group)
323 (delete-file (nnsoup-file prefix))) 318 (when (file-exists-p (nnsoup-file prefix))
324 (nnheader-message 319 (delete-file (nnsoup-file prefix)))
325 5 "Deleting %s in group %s..." (nnsoup-file prefix t) 320 (nnheader-message
326 group) 321 5 "Deleting %s in group %s..." (nnsoup-file prefix t)
327 (when (file-exists-p (nnsoup-file prefix t)) 322 group)
328 (delete-file (nnsoup-file prefix t))) 323 (when (file-exists-p (nnsoup-file prefix t))
329 t) 324 (delete-file (nnsoup-file prefix t)))
325 t)
326 (error nil))
330 (setcdr (cdr total-infolist) (delq info (cddr total-infolist))) 327 (setcdr (cdr total-infolist) (delq info (cddr total-infolist)))
331 (setq articles (gnus-sorted-complement articles range-list)))) 328 (setq articles (gnus-sorted-complement articles range-list))))
332 (when (not mod-time) 329 (when (not mod-time)
333 (setcdr (cdr total-infolist) (delq info (cddr total-infolist))))) 330 (setcdr (cdr total-infolist) (delq info (cddr total-infolist)))))
334 (if (cddr total-infolist) 331 (if (cddr total-infolist)
340 337
341 338
342 ;;; Internal functions 339 ;;; Internal functions
343 340
344 (defun nnsoup-possibly-change-group (group &optional force) 341 (defun nnsoup-possibly-change-group (group &optional force)
345 (when (and group 342 (if group
346 (not (equal nnsoup-current-group group))) 343 (setq nnsoup-current-group group)
347 (setq nnsoup-article-alist nil) 344 t))
348 (setq nnsoup-current-group group))
349 t)
350 345
351 (defun nnsoup-read-active-file () 346 (defun nnsoup-read-active-file ()
352 (setq nnsoup-group-alist nil) 347 (setq nnsoup-group-alist nil)
353 (when (file-exists-p nnsoup-active-file) 348 (when (file-exists-p nnsoup-active-file)
354 (ignore-errors 349 (condition-case ()
355 (load nnsoup-active-file t t t)) 350 (load nnsoup-active-file t t t)
351 (error nil))
356 ;; Be backwards compatible. 352 ;; Be backwards compatible.
357 (when (and nnsoup-group-alist 353 (when (and nnsoup-group-alist
358 (not (atom (caadar nnsoup-group-alist)))) 354 (not (atom (caadar nnsoup-group-alist))))
359 (let ((alist nnsoup-group-alist) 355 (let ((alist nnsoup-group-alist)
360 entry e min max) 356 entry e min max)
367 (setq nnsoup-group-alist-touched t)) 363 (setq nnsoup-group-alist-touched t))
368 nnsoup-group-alist)) 364 nnsoup-group-alist))
369 365
370 (defun nnsoup-write-active-file (&optional force) 366 (defun nnsoup-write-active-file (&optional force)
371 (when (and nnsoup-group-alist 367 (when (and nnsoup-group-alist
372 (or force 368 (or force
373 nnsoup-group-alist-touched)) 369 nnsoup-group-alist-touched))
374 (setq nnsoup-group-alist-touched nil) 370 (setq nnsoup-group-alist-touched nil)
375 (nnheader-temp-write nnsoup-active-file 371 (nnheader-temp-write nnsoup-active-file
376 (gnus-prin1 `(setq nnsoup-group-alist ',nnsoup-group-alist)) 372 (let ((standard-output (current-buffer)))
377 (insert "\n") 373 (prin1 `(setq nnsoup-group-alist ',nnsoup-group-alist))
378 (gnus-prin1 `(setq nnsoup-current-prefix ,nnsoup-current-prefix)) 374 (insert "\n")
379 (insert "\n")))) 375 (prin1 `(setq nnsoup-current-prefix ,nnsoup-current-prefix))
376 (insert "\n")))))
380 377
381 (defun nnsoup-next-prefix () 378 (defun nnsoup-next-prefix ()
382 "Return the next free prefix." 379 "Return the next free prefix."
383 (let (prefix) 380 (let (prefix)
384 (while (or (file-exists-p 381 (while (or (file-exists-p
385 (nnsoup-file (setq prefix (int-to-string 382 (nnsoup-file (setq prefix (int-to-string
386 nnsoup-current-prefix)))) 383 nnsoup-current-prefix))))
387 (file-exists-p (nnsoup-file prefix t))) 384 (file-exists-p (nnsoup-file prefix t)))
388 (incf nnsoup-current-prefix)) 385 (incf nnsoup-current-prefix))
389 (incf nnsoup-current-prefix) 386 (incf nnsoup-current-prefix)
390 prefix)) 387 prefix))
391 388
392 (defun nnsoup-file-name (dir file)
393 "Return the full path of FILE (in any case) in DIR."
394 (let* ((case-fold-search t)
395 (files (directory-files dir t))
396 (regexp (concat (regexp-quote file) "$")))
397 (car (delq nil
398 (mapcar
399 (lambda (file)
400 (if (string-match regexp file)
401 file
402 nil))
403 files)))))
404
405 (defun nnsoup-read-areas () 389 (defun nnsoup-read-areas ()
406 (let ((areas-file (nnsoup-file-name nnsoup-tmp-directory "areas"))) 390 (save-excursion
407 (when areas-file 391 (set-buffer nntp-server-buffer)
408 (save-excursion 392 (let ((areas (gnus-soup-parse-areas (concat nnsoup-tmp-directory "AREAS")))
409 (set-buffer nntp-server-buffer) 393 entry number area lnum cur-prefix file)
410 (let ((areas (gnus-soup-parse-areas areas-file)) 394 ;; Go through all areas in the new AREAS file.
411 entry number area lnum cur-prefix file) 395 (while (setq area (pop areas))
412 ;; Go through all areas in the new AREAS file. 396 ;; Change the name to the permanent name and move the files.
413 (while (setq area (pop areas)) 397 (setq cur-prefix (nnsoup-next-prefix))
414 ;; Change the name to the permanent name and move the files. 398 (message "Incorporating file %s..." cur-prefix)
415 (setq cur-prefix (nnsoup-next-prefix)) 399 (when (file-exists-p
416 (message "Incorporating file %s..." cur-prefix) 400 (setq file (concat nnsoup-tmp-directory
417 (when (file-exists-p 401 (gnus-soup-area-prefix area) ".IDX")))
418 (setq file (concat nnsoup-tmp-directory 402 (rename-file file (nnsoup-file cur-prefix)))
419 (gnus-soup-area-prefix area) ".IDX"))) 403 (when (file-exists-p
420 (rename-file file (nnsoup-file cur-prefix))) 404 (setq file (concat nnsoup-tmp-directory
421 (when (file-exists-p 405 (gnus-soup-area-prefix area) ".MSG")))
422 (setq file (concat nnsoup-tmp-directory 406 (rename-file file (nnsoup-file cur-prefix t))
423 (gnus-soup-area-prefix area) ".MSG"))) 407 (gnus-soup-set-area-prefix area cur-prefix)
424 (rename-file file (nnsoup-file cur-prefix t)) 408 ;; Find the number of new articles in this area.
425 (gnus-soup-set-area-prefix area cur-prefix) 409 (setq number (nnsoup-number-of-articles area))
426 ;; Find the number of new articles in this area. 410 (if (not (setq entry (assoc (gnus-soup-area-name area)
427 (setq number (nnsoup-number-of-articles area)) 411 nnsoup-group-alist)))
428 (if (not (setq entry (assoc (gnus-soup-area-name area) 412 ;; If this is a new area (group), we just add this info to
429 nnsoup-group-alist))) 413 ;; the group alist.
430 ;; If this is a new area (group), we just add this info to 414 (push (list (gnus-soup-area-name area)
431 ;; the group alist. 415 (cons 1 number)
432 (push (list (gnus-soup-area-name area) 416 (list (cons 1 number) area))
433 (cons 1 number) 417 nnsoup-group-alist)
434 (list (cons 1 number) area)) 418 ;; There are already articles in this group, so we add this
435 nnsoup-group-alist) 419 ;; info to the end of the entry.
436 ;; There are already articles in this group, so we add this 420 (nconc entry (list (list (cons (1+ (setq lnum (cdadr entry)))
437 ;; info to the end of the entry. 421 (+ lnum number))
438 (nconc entry (list (list (cons (1+ (setq lnum (cdadr entry))) 422 area)))
439 (+ lnum number)) 423 (setcdr (cadr entry) (+ lnum number))))))
440 area))) 424 (nnsoup-write-active-file t)
441 (setcdr (cadr entry) (+ lnum number)))))) 425 (delete-file (concat nnsoup-tmp-directory "AREAS"))))
442 (nnsoup-write-active-file t)
443 (delete-file areas-file)))))
444 426
445 (defun nnsoup-number-of-articles (area) 427 (defun nnsoup-number-of-articles (area)
446 (save-excursion 428 (save-excursion
447 (cond 429 (cond
448 ;; If the number is in the area info, we just return it. 430 ;; If the number is in the area info, we just return it.
449 ((gnus-soup-area-number area) 431 ((gnus-soup-area-number area)
450 (gnus-soup-area-number area)) 432 (gnus-soup-area-number area))
451 ;; If there is an index file, we just count the lines. 433 ;; If there is an index file, we just count the lines.
452 ((/= (gnus-soup-encoding-index (gnus-soup-area-encoding area)) ?n) 434 ((/= (gnus-soup-encoding-index (gnus-soup-area-encoding area)) ?n)
453 (set-buffer (nnsoup-index-buffer (gnus-soup-area-prefix area))) 435 (set-buffer (nnsoup-index-buffer (gnus-soup-area-prefix area)))
454 (count-lines (point-min) (point-max))) 436 (count-lines (point-min) (point-max)))
455 ;; We do it the hard way - re-searching through the message 437 ;; We do it the hard way - re-searching through the message
456 ;; buffer. 438 ;; buffer.
457 (t 439 (t
458 (set-buffer (nnsoup-message-buffer (gnus-soup-area-prefix area))) 440 (set-buffer (nnsoup-message-buffer (gnus-soup-area-prefix area)))
459 (unless (assoc (gnus-soup-area-prefix area) nnsoup-article-alist) 441 (goto-char (point-min))
460 (nnsoup-dissect-buffer area)) 442 (let ((regexp (nnsoup-header (gnus-soup-encoding-format
461 (length (cdr (assoc (gnus-soup-area-prefix area) 443 (gnus-soup-area-encoding area))))
462 nnsoup-article-alist))))))) 444 (num 0))
463 445 (while (re-search-forward regexp nil t)
464 (defun nnsoup-dissect-buffer (area) 446 (setq num (1+ num)))
465 (let ((mbox-delim (concat "^" message-unix-mail-delimiter)) 447 num)))))
466 (format (gnus-soup-encoding-format (gnus-soup-area-encoding area)))
467 (i 0)
468 alist len)
469 (goto-char (point-min))
470 (cond
471 ;; rnews batch format
472 ((= format ?n)
473 (while (looking-at "^#! *rnews \\(+[0-9]+\\) *$")
474 (forward-line 1)
475 (push (list
476 (incf i) (point)
477 (progn
478 (forward-char (string-to-number (match-string 1)))
479 (point)))
480 alist)))
481 ;; Unix mbox format
482 ((= format ?m)
483 (while (looking-at mbox-delim)
484 (forward-line 1)
485 (push (list
486 (incf i) (point)
487 (progn
488 (if (re-search-forward mbox-delim nil t)
489 (beginning-of-line)
490 (goto-char (point-max)))
491 (point)))
492 alist)))
493 ;; MMDF format
494 ((= format ?M)
495 (while (looking-at "\^A\^A\^A\^A\n")
496 (forward-line 1)
497 (push (list
498 (incf i) (point)
499 (progn
500 (if (search-forward "\n\^A\^A\^A\^A\n" nil t)
501 (beginning-of-line)
502 (goto-char (point-max)))
503 (point)))
504 alist)))
505 ;; Binary format
506 ((or (= format ?B) (= format ?b))
507 (while (not (eobp))
508 (setq len (+ (* (char-after (point)) (expt 2.0 24))
509 (* (char-after (+ (point) 1)) (expt 2 16))
510 (* (char-after (+ (point) 2)) (expt 2 8))
511 (char-after (+ (point) 3))))
512 (push (list
513 (incf i) (+ (point) 4)
514 (progn
515 (forward-char (floor (+ len 4)))
516 (point)))
517 alist)))
518 (t
519 (error "Unknown format: %c" format)))
520 (push (cons (gnus-soup-area-prefix area) alist) nnsoup-article-alist)))
521 448
522 (defun nnsoup-index-buffer (prefix &optional message) 449 (defun nnsoup-index-buffer (prefix &optional message)
523 (let* ((file (concat prefix (if message ".MSG" ".IDX"))) 450 (let* ((file (concat prefix (if message ".MSG" ".IDX")))
524 (buffer-name (concat " *nnsoup " file "*"))) 451 (buffer-name (concat " *nnsoup " file "*")))
525 (or (get-buffer buffer-name) ; File already loaded. 452 (or (get-buffer buffer-name) ; File aready loaded.
526 (when (file-exists-p (concat nnsoup-directory file)) 453 (when (file-exists-p (concat nnsoup-directory file))
527 (save-excursion ; Load the file. 454 (save-excursion ; Load the file.
528 (set-buffer (get-buffer-create buffer-name)) 455 (set-buffer (get-buffer-create buffer-name))
529 (buffer-disable-undo (current-buffer)) 456 (buffer-disable-undo (current-buffer))
530 (push (cons nnsoup-current-group (current-buffer)) nnsoup-buffers) 457 (push (cons nnsoup-current-group (current-buffer)) nnsoup-buffers)
531 (nnheader-insert-file-contents (concat nnsoup-directory file)) 458 (insert-file-contents (concat nnsoup-directory file))
532 (current-buffer)))))) 459 (current-buffer))))))
533 460
534 (defun nnsoup-file (prefix &optional message) 461 (defun nnsoup-file (prefix &optional message)
535 (expand-file-name 462 (expand-file-name
536 (concat nnsoup-directory prefix (if message ".MSG" ".IDX")))) 463 (concat nnsoup-directory prefix (if message ".MSG" ".IDX"))))
543 (let ((packets (directory-files 470 (let ((packets (directory-files
544 nnsoup-packet-directory t nnsoup-packet-regexp)) 471 nnsoup-packet-directory t nnsoup-packet-regexp))
545 packet) 472 packet)
546 (while (setq packet (pop packets)) 473 (while (setq packet (pop packets))
547 (message "nnsoup: unpacking %s..." packet) 474 (message "nnsoup: unpacking %s..." packet)
548 (if (not (gnus-soup-unpack-packet 475 (if (not (gnus-soup-unpack-packet
549 nnsoup-tmp-directory nnsoup-unpacker packet)) 476 nnsoup-tmp-directory nnsoup-unpacker packet))
550 (message "Couldn't unpack %s" packet) 477 (message "Couldn't unpack %s" packet)
551 (delete-file packet) 478 (delete-file packet)
552 (nnsoup-read-areas) 479 (nnsoup-read-areas)
553 (message "Unpacking...done"))))) 480 (message "Unpacking...done")))))
561 (save-excursion 488 (save-excursion
562 (cond 489 (cond
563 ;; There is no MSG file. 490 ;; There is no MSG file.
564 ((null msg-buf) 491 ((null msg-buf)
565 nil) 492 nil)
566 ;; We use the index file to find out where the article 493
567 ;; begins and ends. 494 ;; We use the index file to find out where the article begins and ends.
568 ((and (= (gnus-soup-encoding-index 495 ((and (= (gnus-soup-encoding-index
569 (gnus-soup-area-encoding (nth 1 area))) 496 (gnus-soup-area-encoding (nth 1 area)))
570 ?c) 497 ?c)
571 (file-exists-p (nnsoup-file prefix))) 498 (file-exists-p (nnsoup-file prefix)))
572 (set-buffer (nnsoup-index-buffer prefix)) 499 (set-buffer (nnsoup-index-buffer prefix))
573 (widen) 500 (widen)
581 (set-buffer msg-buf) 508 (set-buffer msg-buf)
582 (widen) 509 (widen)
583 (let ((format (gnus-soup-encoding-format 510 (let ((format (gnus-soup-encoding-format
584 (gnus-soup-area-encoding (nth 1 area))))) 511 (gnus-soup-area-encoding (nth 1 area)))))
585 (goto-char end) 512 (goto-char end)
586 (when (or (= format ?n) (= format ?m)) 513 (if (or (= format ?n) (= format ?m))
587 (setq end (progn (forward-line -1) (point)))))) 514 (setq end (progn (forward-line -1) (point))))))
588 (set-buffer msg-buf)) 515 (set-buffer msg-buf))
589 (widen) 516 (widen)
590 (narrow-to-region beg (or end (point-max)))) 517 (narrow-to-region beg (or end (point-max))))
591 (t 518 (t
592 (set-buffer msg-buf) 519 (set-buffer msg-buf)
593 (widen) 520 (widen)
594 (unless (assoc (gnus-soup-area-prefix (nth 1 area)) 521 (goto-char (point-min))
595 nnsoup-article-alist) 522 (let ((header (nnsoup-header
596 (nnsoup-dissect-buffer (nth 1 area))) 523 (gnus-soup-encoding-format
597 (let ((entry (assq article (cdr (assoc (gnus-soup-area-prefix 524 (gnus-soup-area-encoding (nth 1 area))))))
598 (nth 1 area)) 525 (re-search-forward header nil t (- article (caar area)))
599 nnsoup-article-alist))))) 526 (narrow-to-region
600 (when entry 527 (match-beginning 0)
601 (narrow-to-region (cadr entry) (caddr entry)))))) 528 (if (re-search-forward header nil t)
529 (match-beginning 0)
530 (point-max))))))
602 (goto-char (point-min)) 531 (goto-char (point-min))
603 (if (not head) 532 (if (not head)
604 () 533 ()
605 (narrow-to-region 534 (narrow-to-region
606 (point-min) 535 (point-min)
607 (if (search-forward "\n\n" nil t) 536 (if (search-forward "\n\n" nil t)
608 (1- (point)) 537 (1- (point))
609 (point-max)))) 538 (point-max))))
610 msg-buf)))) 539 msg-buf))))
611 540
541 (defun nnsoup-header (format)
542 (cond
543 ((= format ?n)
544 "^#! *rnews +[0-9]+ *$")
545 ((= format ?m)
546 (concat "^" message-unix-mail-delimiter))
547 ((= format ?M)
548 "^\^A\^A\^A\^A\n")
549 (t
550 (error "Unknown format: %c" format))))
551
612 ;;;###autoload 552 ;;;###autoload
613 (defun nnsoup-pack-replies () 553 (defun nnsoup-pack-replies ()
614 "Make an outbound package of SOUP replies." 554 "Make an outbound package of SOUP replies."
615 (interactive) 555 (interactive)
616 (unless (file-exists-p nnsoup-replies-directory)
617 (message "No such directory: %s" nnsoup-replies-directory))
618 ;; Write all data buffers. 556 ;; Write all data buffers.
619 (gnus-soup-save-areas) 557 (gnus-soup-save-areas)
620 ;; Write the active file. 558 ;; Write the active file.
621 (nnsoup-write-active-file) 559 (nnsoup-write-active-file)
622 ;; Write the REPLIES file. 560 ;; Write the REPLIES file.
623 (nnsoup-write-replies) 561 (nnsoup-write-replies)
624 ;; Check whether there is anything here.
625 (when (null (directory-files nnsoup-replies-directory nil "\\.MSG$"))
626 (error "No files to pack."))
627 ;; Pack all these files into a SOUP packet. 562 ;; Pack all these files into a SOUP packet.
628 (gnus-soup-pack nnsoup-replies-directory nnsoup-packer)) 563 (gnus-soup-pack nnsoup-replies-directory nnsoup-packer))
629 564
630 (defun nnsoup-write-replies () 565 (defun nnsoup-write-replies ()
631 "Write the REPLIES file." 566 "Write the REPLIES file."
660 (defun nnsoup-store-reply (kind) 595 (defun nnsoup-store-reply (kind)
661 ;; Mostly stolen from `message.el'. 596 ;; Mostly stolen from `message.el'.
662 (require 'mail-utils) 597 (require 'mail-utils)
663 (let ((tembuf (generate-new-buffer " message temp")) 598 (let ((tembuf (generate-new-buffer " message temp"))
664 (case-fold-search nil) 599 (case-fold-search nil)
600 (news (message-news-p))
601 (resend-to-addresses (mail-fetch-field "resent-to"))
665 delimline 602 delimline
666 (mailbuf (current-buffer))) 603 (mailbuf (current-buffer)))
667 (unwind-protect 604 (unwind-protect
668 (save-excursion 605 (save-excursion
669 (save-restriction 606 (save-restriction
681 (message-remove-header message-ignored-mail-headers t)) 618 (message-remove-header message-ignored-mail-headers t))
682 (goto-char (point-max)) 619 (goto-char (point-max))
683 ;; require one newline at the end. 620 ;; require one newline at the end.
684 (or (= (preceding-char) ?\n) 621 (or (= (preceding-char) ?\n)
685 (insert ?\n)) 622 (insert ?\n))
623 (when (and news
624 (equal kind "mail")
625 (or (mail-fetch-field "cc")
626 (mail-fetch-field "to")))
627 (message-insert-courtesy-copy))
686 (let ((case-fold-search t)) 628 (let ((case-fold-search t))
687 ;; Change header-delimiter to be what sendmail expects. 629 ;; Change header-delimiter to be what sendmail expects.
688 (goto-char (point-min)) 630 (goto-char (point-min))
689 (re-search-forward 631 (re-search-forward
690 (concat "^" (regexp-quote mail-header-separator) "\n")) 632 (concat "^" (regexp-quote mail-header-separator) "\n"))
695 ;; Sun's bug that swallows newlines. 637 ;; Sun's bug that swallows newlines.
696 (goto-char (1+ delimline)) 638 (goto-char (1+ delimline))
697 (when (eval message-mailer-swallows-blank-line) 639 (when (eval message-mailer-swallows-blank-line)
698 (newline)) 640 (newline))
699 (let ((msg-buf 641 (let ((msg-buf
700 (gnus-soup-store 642 (gnus-soup-store
701 nnsoup-replies-directory 643 nnsoup-replies-directory
702 (nnsoup-kind-to-prefix kind) nil nnsoup-replies-format-type 644 (nnsoup-kind-to-prefix kind) nil nnsoup-replies-format-type
703 nnsoup-replies-index-type)) 645 nnsoup-replies-index-type))
704 (num 0)) 646 (num 0))
705 (when (and msg-buf (bufferp msg-buf)) 647 (when (and msg-buf (bufferp msg-buf))
706 (save-excursion 648 (save-excursion
713 (kill-buffer tembuf)))))) 655 (kill-buffer tembuf))))))
714 656
715 (defun nnsoup-kind-to-prefix (kind) 657 (defun nnsoup-kind-to-prefix (kind)
716 (unless nnsoup-replies-list 658 (unless nnsoup-replies-list
717 (setq nnsoup-replies-list 659 (setq nnsoup-replies-list
718 (gnus-soup-parse-replies 660 (gnus-soup-parse-replies
719 (concat nnsoup-replies-directory "REPLIES")))) 661 (concat nnsoup-replies-directory "REPLIES"))))
720 (let ((replies nnsoup-replies-list)) 662 (let ((replies nnsoup-replies-list))
721 (while (and replies 663 (while (and replies
722 (not (string= kind (gnus-soup-reply-kind (car replies))))) 664 (not (string= kind (gnus-soup-reply-kind (car replies)))))
723 (setq replies (cdr replies))) 665 (setq replies (cdr replies)))
724 (if replies 666 (if replies
725 (gnus-soup-reply-prefix (car replies)) 667 (gnus-soup-reply-prefix (car replies))
726 (push (vector (gnus-soup-unique-prefix nnsoup-replies-directory) 668 (setq nnsoup-replies-list
727 kind 669 (cons (vector (gnus-soup-unique-prefix nnsoup-replies-directory)
728 (format "%c%c%c" 670 kind
729 nnsoup-replies-format-type 671 (format "%c%c%c"
730 nnsoup-replies-index-type 672 nnsoup-replies-format-type
731 (if (string= kind "news") 673 nnsoup-replies-index-type
732 ?n ?m))) 674 (if (string= kind "news")
733 nnsoup-replies-list) 675 ?n ?m)))
676 nnsoup-replies-list))
734 (gnus-soup-reply-prefix (car nnsoup-replies-list))))) 677 (gnus-soup-reply-prefix (car nnsoup-replies-list)))))
735 678
736 (defun nnsoup-make-active () 679 (defun nnsoup-make-active ()
737 "(Re-)create the SOUP active file." 680 "(Re-)create the SOUP active file."
738 (interactive) 681 (interactive)
746 (set-buffer (get-buffer-create " *nnsoup work*")) 689 (set-buffer (get-buffer-create " *nnsoup work*"))
747 (buffer-disable-undo (current-buffer)) 690 (buffer-disable-undo (current-buffer))
748 (while files 691 (while files
749 (message "Doing %s..." (car files)) 692 (message "Doing %s..." (car files))
750 (erase-buffer) 693 (erase-buffer)
751 (nnheader-insert-file-contents (car files)) 694 (insert-file-contents (car files))
752 (goto-char (point-min)) 695 (goto-char (point-min))
753 (if (not (re-search-forward "^[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t *\\(Xref: \\)? *[^ ]* \\([^ ]+\\):[0-9]" nil t)) 696 (if (not (re-search-forward "^[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t *\\(Xref: \\)? *[^ ]* \\([^ ]+\\):[0-9]" nil t))
754 (setq group "unknown") 697 (setq group "unknown")
755 (setq group (match-string 2))) 698 (setq group (match-string 2)))
756 (setq lines (count-lines (point-min) (point-max))) 699 (setq lines (count-lines (point-min) (point-max)))
757 (setq ident (progn (string-match 700 (setq ident (progn (string-match
758 "/\\([0-9]+\\)\\." (car files)) 701 "/\\([0-9]+\\)\\." (car files))
759 (substring 702 (substring
760 (car files) (match-beginning 1) 703 (car files) (match-beginning 1)
761 (match-end 1)))) 704 (match-end 1))))
762 (if (not (setq elem (assoc group active))) 705 (if (not (setq elem (assoc group active)))
763 (push (list group (cons 1 lines) 706 (push (list group (cons 1 lines)
764 (list (cons 1 lines) 707 (list (cons 1 lines)
765 (vector ident group "ncm" "" lines))) 708 (vector ident group "ncm" "" lines)))
766 active) 709 active)
767 (nconc elem 710 (nconc elem
768 (list 711 (list
769 (list (cons (1+ (setq min (cdadr elem))) 712 (list (cons (1+ (setq min (cdadr elem)))
776 (nnsoup-write-active-file t))) 719 (nnsoup-write-active-file t)))
777 720
778 (defun nnsoup-delete-unreferenced-message-files () 721 (defun nnsoup-delete-unreferenced-message-files ()
779 "Delete any *.MSG and *.IDX files that aren't known by nnsoup." 722 "Delete any *.MSG and *.IDX files that aren't known by nnsoup."
780 (interactive) 723 (interactive)
781 (let* ((known (apply 'nconc (mapcar 724 (let* ((known (apply 'nconc (mapcar
782 (lambda (ga) 725 (lambda (ga)
783 (mapcar 726 (mapcar
784 (lambda (area) 727 (lambda (area)
785 (gnus-soup-area-prefix (cadr area))) 728 (gnus-soup-area-prefix (cadr area)))
786 (cddr ga))) 729 (cddr ga)))