1;;; nnsoup.el --- SOUP access for Gnus 2 3;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 4;; 2004, 2005, 2006, 2007 Free Software Foundation, Inc. 5 6;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> 7;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> 8;; Keywords: news, mail 9 10;; This file is part of GNU Emacs. 11 12;; GNU Emacs is free software; you can redistribute it and/or modify 13;; it under the terms of the GNU General Public License as published by 14;; the Free Software Foundation; either version 2, or (at your option) 15;; any later version. 16 17;; GNU Emacs is distributed in the hope that it will be useful, 18;; but WITHOUT ANY WARRANTY; without even the implied warranty of 19;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 20;; GNU General Public License for more details. 21 22;; You should have received a copy of the GNU General Public License 23;; along with GNU Emacs; see the file COPYING. If not, write to the 24;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 25;; Boston, MA 02110-1301, USA. 26 27;;; Commentary: 28 29;;; Code: 30 31(require 'nnheader) 32(require 'nnmail) 33(require 'gnus-soup) 34(require 'gnus-msg) 35(require 'nnoo) 36(eval-when-compile (require 'cl)) 37 38(nnoo-declare nnsoup) 39 40(defvoo nnsoup-directory (nnheader-concat gnus-home-directory "SOUP/") 41 "*SOUP packet directory.") 42 43(defvoo nnsoup-tmp-directory 44 (cond ((fboundp 'temp-directory) (temp-directory)) 45 ((boundp 'temporary-file-directory) temporary-file-directory) 46 ("/tmp/")) 47 "*Where nnsoup will store temporary files.") 48 49(defvoo nnsoup-replies-directory (expand-file-name "replies/" nnsoup-directory) 50 "*Directory where outgoing packets will be composed.") 51 52(defvoo nnsoup-replies-format-type ?u ;; u is USENET news format. 53 "*Format of the replies packages.") 54 55(defvoo nnsoup-replies-index-type ?n 56 "*Index type of the replies packages.") 57 58(defvoo nnsoup-active-file (expand-file-name "active" nnsoup-directory) 59 "Active file.") 60 61(defvoo nnsoup-packer (concat "tar cf - %s | gzip > " 62 (expand-file-name gnus-home-directory) 63 "Soupin%d.tgz") 64 "Format string command for packing a SOUP packet. 65The SOUP files will be inserted where the %s is in the string. 66This string MUST contain both %s and %d. The file number will be 67inserted where %d appears.") 68 69(defvoo nnsoup-unpacker "gunzip -c %s | tar xvf -" 70 "*Format string command for unpacking a SOUP packet. 71The SOUP packet file name will be inserted at the %s.") 72 73(defvoo nnsoup-packet-directory gnus-home-directory 74 "*Where nnsoup will look for incoming packets.") 75 76(defvoo nnsoup-packet-regexp "Soupout" 77 "*Regular expression matching SOUP packets in `nnsoup-packet-directory'.") 78 79(defvoo nnsoup-always-save t 80 "If non-nil commit the reply buffer on each message send. 81This is necessary if using message mode outside Gnus with nnsoup as a 82backend for the messages.") 83 84 85 86(defconst nnsoup-version "nnsoup 0.0" 87 "nnsoup version.") 88 89(defvoo nnsoup-status-string "") 90(defvoo nnsoup-group-alist nil) 91(defvoo nnsoup-current-prefix 0) 92(defvoo nnsoup-replies-list nil) 93(defvoo nnsoup-buffers nil) 94(defvoo nnsoup-current-group nil) 95(defvoo nnsoup-group-alist-touched nil) 96(defvoo nnsoup-article-alist nil) 97 98 99;;; Interface functions. 100 101(nnoo-define-basics nnsoup) 102 103(deffoo nnsoup-retrieve-headers (sequence &optional group server fetch-old) 104 (nnsoup-possibly-change-group group) 105 (save-excursion 106 (set-buffer nntp-server-buffer) 107 (erase-buffer) 108 (let ((areas (cddr (assoc nnsoup-current-group nnsoup-group-alist))) 109 (articles sequence) 110 (use-nov t) 111 useful-areas this-area-seq msg-buf) 112 (if (stringp (car sequence)) 113 ;; We don't support fetching by Message-ID. 114 'headers 115 ;; We go through all the areas and find which files the 116 ;; articles in SEQUENCE come from. 117 (while (and areas sequence) 118 ;; Peel off areas that are below sequence. 119 (while (and areas (< (cdar (car areas)) (car sequence))) 120 (setq areas (cdr areas))) 121 (when areas 122 ;; This is a useful area. 123 (push (car areas) useful-areas) 124 (setq this-area-seq nil) 125 ;; We take note whether this MSG has a corresponding IDX 126 ;; for later use. 127 (when (or (= (gnus-soup-encoding-index 128 (gnus-soup-area-encoding (nth 1 (car areas)))) ?n) 129 (not (file-exists-p 130 (nnsoup-file 131 (gnus-soup-area-prefix (nth 1 (car areas))))))) 132 (setq use-nov nil)) 133 ;; We assign the portion of `sequence' that is relevant to 134 ;; this MSG packet to this packet. 135 (while (and sequence (<= (car sequence) (cdar (car areas)))) 136 (push (car sequence) this-area-seq) 137 (setq sequence (cdr sequence))) 138 (setcar useful-areas (cons (nreverse this-area-seq) 139 (car useful-areas))))) 140 141 ;; We now have a list of article numbers and corresponding 142 ;; areas. 143 (setq useful-areas (nreverse useful-areas)) 144 145 ;; Two different approaches depending on whether all the MSG 146 ;; files have corresponding IDX files. If they all do, we 147 ;; simply return the relevant IDX files and let Gnus sort out 148 ;; what lines are relevant. If some of the IDX files are 149 ;; missing, we must return HEADs for all the articles. 150 (if use-nov 151 ;; We have IDX files for all areas. 152 (progn 153 (while useful-areas 154 (goto-char (point-max)) 155 (let ((b (point)) 156 (number (car (nth 1 (car useful-areas)))) 157 (index-buffer (nnsoup-index-buffer 158 (gnus-soup-area-prefix 159 (nth 2 (car useful-areas)))))) 160 (when index-buffer 161 (insert-buffer-substring index-buffer) 162 (goto-char b) 163 ;; We have to remove the index number entries and 164 ;; insert article numbers instead. 165 (while (looking-at "[0-9]+") 166 (replace-match (int-to-string number) t t) 167 (incf number) 168 (forward-line 1)))) 169 (setq useful-areas (cdr useful-areas))) 170 'nov) 171 ;; We insert HEADs. 172 (while useful-areas 173 (setq articles (caar useful-areas) 174 useful-areas (cdr useful-areas)) 175 (while articles 176 (when (setq msg-buf 177 (nnsoup-narrow-to-article 178 (car articles) (cdar useful-areas) 'head)) 179 (goto-char (point-max)) 180 (insert (format "221 %d Article retrieved.\n" (car articles))) 181 (insert-buffer-substring msg-buf) 182 (goto-char (point-max)) 183 (insert ".\n")) 184 (setq articles (cdr articles)))) 185 186 (nnheader-fold-continuation-lines) 187 'headers))))) 188 189(deffoo nnsoup-open-server (server &optional defs) 190 (nnoo-change-server 'nnsoup server defs) 191 (when (not (file-exists-p nnsoup-directory)) 192 (condition-case () 193 (make-directory nnsoup-directory t) 194 (error t))) 195 (cond 196 ((not (file-exists-p nnsoup-directory)) 197 (nnsoup-close-server) 198 (nnheader-report 'nnsoup "Couldn't create directory: %s" nnsoup-directory)) 199 ((not (file-directory-p (file-truename nnsoup-directory))) 200 (nnsoup-close-server) 201 (nnheader-report 'nnsoup "Not a directory: %s" nnsoup-directory)) 202 (t 203 (nnsoup-read-active-file) 204 (nnheader-report 'nnsoup "Opened server %s using directory %s" 205 server nnsoup-directory) 206 t))) 207 208(deffoo nnsoup-request-close () 209 (nnsoup-write-active-file) 210 (nnsoup-write-replies) 211 (gnus-soup-save-areas) 212 ;; Kill all nnsoup buffers. 213 (let (buffer) 214 (while nnsoup-buffers 215 (setq buffer (cdr (pop nnsoup-buffers))) 216 (and buffer 217 (buffer-name buffer) 218 (kill-buffer buffer)))) 219 (setq nnsoup-group-alist nil 220 nnsoup-group-alist-touched nil 221 nnsoup-current-group nil 222 nnsoup-replies-list nil) 223 (nnoo-close-server 'nnoo) 224 t) 225 226(deffoo nnsoup-request-article (id &optional newsgroup server buffer) 227 (nnsoup-possibly-change-group newsgroup) 228 (let (buf) 229 (save-excursion 230 (set-buffer (or buffer nntp-server-buffer)) 231 (erase-buffer) 232 (when (and (not (stringp id)) 233 (setq buf (nnsoup-narrow-to-article id))) 234 (insert-buffer-substring buf) 235 t)))) 236 237(deffoo nnsoup-request-group (group &optional server dont-check) 238 (nnsoup-possibly-change-group group) 239 (if dont-check 240 t 241 (let ((active (cadr (assoc group nnsoup-group-alist)))) 242 (if (not active) 243 (nnheader-report 'nnsoup "No such group: %s" group) 244 (nnheader-insert 245 "211 %d %d %d %s\n" 246 (max (1+ (- (cdr active) (car active))) 0) 247 (car active) (cdr active) group))))) 248 249(deffoo nnsoup-request-type (group &optional article) 250 (nnsoup-possibly-change-group group) 251 ;; Try to guess the type based on the first article in the group. 252 (when (not article) 253 (setq article 254 (cdar (car (cddr (assoc group nnsoup-group-alist)))))) 255 (if (not article) 256 'unknown 257 (let ((kind (gnus-soup-encoding-kind 258 (gnus-soup-area-encoding 259 (nth 1 (nnsoup-article-to-area 260 article nnsoup-current-group)))))) 261 (cond ((= kind ?m) 'mail) 262 ((= kind ?n) 'news) 263 (t 'unknown))))) 264 265(deffoo nnsoup-close-group (group &optional server) 266 ;; Kill all nnsoup buffers. 267 (let ((buffers nnsoup-buffers) 268 elem) 269 (while buffers 270 (when (equal (car (setq elem (pop buffers))) group) 271 (setq nnsoup-buffers (delq elem nnsoup-buffers)) 272 (and (cdr elem) (buffer-name (cdr elem)) 273 (kill-buffer (cdr elem)))))) 274 t) 275 276(deffoo nnsoup-request-list (&optional server) 277 (save-excursion 278 (set-buffer nntp-server-buffer) 279 (erase-buffer) 280 (unless nnsoup-group-alist 281 (nnsoup-read-active-file)) 282 (let ((alist nnsoup-group-alist) 283 (standard-output (current-buffer)) 284 entry) 285 (while (setq entry (pop alist)) 286 (insert (car entry) " ") 287 (princ (cdadr entry)) 288 (insert " ") 289 (princ (caadr entry)) 290 (insert " y\n")) 291 t))) 292 293(deffoo nnsoup-request-scan (group &optional server) 294 (nnsoup-unpack-packets)) 295 296(deffoo nnsoup-request-newgroups (date &optional server) 297 (nnsoup-request-list)) 298 299(deffoo nnsoup-request-list-newsgroups (&optional server) 300 nil) 301 302(deffoo nnsoup-request-post (&optional server) 303 (nnsoup-store-reply "news") 304 t) 305 306(deffoo nnsoup-request-mail (&optional server) 307 (nnsoup-store-reply "mail") 308 t) 309 310(deffoo nnsoup-request-expire-articles (articles group &optional server force) 311 (nnsoup-possibly-change-group group) 312 (let* ((total-infolist (assoc group nnsoup-group-alist)) 313 (active (cadr total-infolist)) 314 (infolist (cddr total-infolist)) 315 info range-list mod-time prefix) 316 (while infolist 317 (setq info (pop infolist) 318 range-list (gnus-uncompress-range (car info)) 319 prefix (gnus-soup-area-prefix (nth 1 info))) 320 (when;; All the articles in this file are marked for expiry. 321 (and (or (setq mod-time (nth 5 (file-attributes 322 (nnsoup-file prefix)))) 323 (setq mod-time (nth 5 (file-attributes 324 (nnsoup-file prefix t))))) 325 (gnus-sublist-p articles range-list) 326 ;; This file is old enough. 327 (nnmail-expired-article-p group mod-time force)) 328 ;; Ok, we delete this file. 329 (when (ignore-errors 330 (nnheader-message 331 5 "Deleting %s in group %s..." (nnsoup-file prefix) 332 group) 333 (when (file-exists-p (nnsoup-file prefix)) 334 (delete-file (nnsoup-file prefix))) 335 (nnheader-message 336 5 "Deleting %s in group %s..." (nnsoup-file prefix t) 337 group) 338 (when (file-exists-p (nnsoup-file prefix t)) 339 (delete-file (nnsoup-file prefix t))) 340 t) 341 (setcdr (cdr total-infolist) (delq info (cddr total-infolist))) 342 (setq articles (gnus-sorted-difference articles range-list)))) 343 (when (not mod-time) 344 (setcdr (cdr total-infolist) (delq info (cddr total-infolist))))) 345 (if (cddr total-infolist) 346 (setcar active (caaadr (cdr total-infolist))) 347 (setcar active (1+ (cdr active)))) 348 (nnsoup-write-active-file t) 349 ;; Return the articles that weren't expired. 350 articles)) 351 352 353;;; Internal functions 354 355(defun nnsoup-possibly-change-group (group &optional force) 356 (when (and group 357 (not (equal nnsoup-current-group group))) 358 (setq nnsoup-article-alist nil) 359 (setq nnsoup-current-group group)) 360 t) 361 362(defun nnsoup-read-active-file () 363 (setq nnsoup-group-alist nil) 364 (when (file-exists-p nnsoup-active-file) 365 (ignore-errors 366 (load nnsoup-active-file t t t)) 367 ;; Be backwards compatible. 368 (when (and nnsoup-group-alist 369 (not (atom (caadar nnsoup-group-alist)))) 370 (let ((alist nnsoup-group-alist) 371 entry e min max) 372 (while (setq e (cdr (setq entry (pop alist)))) 373 (setq min (caaar e)) 374 (while (cdr e) 375 (setq e (cdr e))) 376 (setq max (cdar (car e))) 377 (setcdr entry (cons (cons min max) (cdr entry))))) 378 (setq nnsoup-group-alist-touched t)) 379 nnsoup-group-alist)) 380 381(defun nnsoup-write-active-file (&optional force) 382 (when (and nnsoup-group-alist 383 (or force 384 nnsoup-group-alist-touched)) 385 (setq nnsoup-group-alist-touched nil) 386 (with-temp-file nnsoup-active-file 387 (gnus-prin1 `(setq nnsoup-group-alist ',nnsoup-group-alist)) 388 (insert "\n") 389 (gnus-prin1 `(setq nnsoup-current-prefix ,nnsoup-current-prefix)) 390 (insert "\n")))) 391 392(defun nnsoup-next-prefix () 393 "Return the next free prefix." 394 (let (prefix) 395 (while (or (file-exists-p 396 (nnsoup-file (setq prefix (int-to-string 397 nnsoup-current-prefix)))) 398 (file-exists-p (nnsoup-file prefix t))) 399 (incf nnsoup-current-prefix)) 400 (incf nnsoup-current-prefix) 401 prefix)) 402 403(defun nnsoup-file-name (dir file) 404 "Return the full name of FILE (in any case) in DIR." 405 (let* ((case-fold-search t) 406 (files (directory-files dir t)) 407 (regexp (concat (regexp-quote file) "$"))) 408 (car (delq nil 409 (mapcar 410 (lambda (file) 411 (if (string-match regexp file) 412 file 413 nil)) 414 files))))) 415 416(defun nnsoup-read-areas () 417 (let ((areas-file (nnsoup-file-name nnsoup-tmp-directory "areas"))) 418 (when areas-file 419 (save-excursion 420 (set-buffer nntp-server-buffer) 421 (let ((areas (gnus-soup-parse-areas areas-file)) 422 entry number area lnum cur-prefix file) 423 ;; Go through all areas in the new AREAS file. 424 (while (setq area (pop areas)) 425 ;; Change the name to the permanent name and move the files. 426 (setq cur-prefix (nnsoup-next-prefix)) 427 (nnheader-message 5 "Incorporating file %s..." cur-prefix) 428 (when (file-exists-p 429 (setq file 430 (expand-file-name 431 (concat (gnus-soup-area-prefix area) ".IDX") 432 nnsoup-tmp-directory))) 433 (rename-file file (nnsoup-file cur-prefix))) 434 (when (file-exists-p 435 (setq file (expand-file-name 436 (concat (gnus-soup-area-prefix area) ".MSG") 437 nnsoup-tmp-directory))) 438 (rename-file file (nnsoup-file cur-prefix t)) 439 (gnus-soup-set-area-prefix area cur-prefix) 440 ;; Find the number of new articles in this area. 441 (setq number (nnsoup-number-of-articles area)) 442 (if (not (setq entry (assoc (gnus-soup-area-name area) 443 nnsoup-group-alist))) 444 ;; If this is a new area (group), we just add this info to 445 ;; the group alist. 446 (push (list (gnus-soup-area-name area) 447 (cons 1 number) 448 (list (cons 1 number) area)) 449 nnsoup-group-alist) 450 ;; There are already articles in this group, so we add this 451 ;; info to the end of the entry. 452 (nconc entry (list (list (cons (1+ (setq lnum (cdadr entry))) 453 (+ lnum number)) 454 area))) 455 (setcdr (cadr entry) (+ lnum number)))))) 456 (nnsoup-write-active-file t) 457 (delete-file areas-file))))) 458 459(defun nnsoup-number-of-articles (area) 460 (save-excursion 461 (cond 462 ;; If the number is in the area info, we just return it. 463 ((gnus-soup-area-number area) 464 (gnus-soup-area-number area)) 465 ;; If there is an index file, we just count the lines. 466 ((/= (gnus-soup-encoding-index (gnus-soup-area-encoding area)) ?n) 467 (set-buffer (nnsoup-index-buffer (gnus-soup-area-prefix area))) 468 (count-lines (point-min) (point-max))) 469 ;; We do it the hard way - re-searching through the message 470 ;; buffer. 471 (t 472 (set-buffer (nnsoup-message-buffer (gnus-soup-area-prefix area))) 473 (unless (assoc (gnus-soup-area-prefix area) nnsoup-article-alist) 474 (nnsoup-dissect-buffer area)) 475 (length (cdr (assoc (gnus-soup-area-prefix area) 476 nnsoup-article-alist))))))) 477 478(defun nnsoup-dissect-buffer (area) 479 (let ((mbox-delim (concat "^" message-unix-mail-delimiter)) 480 (format (gnus-soup-encoding-format (gnus-soup-area-encoding area))) 481 (i 0) 482 alist len) 483 (goto-char (point-min)) 484 (cond 485 ;; rnews batch format 486 ((or (= format ?u) 487 (= format ?n)) ;; Gnus back compatibility. 488 (while (looking-at "^#! *rnews \\(+[0-9]+\\) *$") 489 (forward-line 1) 490 (push (list 491 (incf i) (point) 492 (progn 493 (forward-char (string-to-number (match-string 1))) 494 (point))) 495 alist))) 496 ;; Unix mbox format 497 ((= format ?m) 498 (while (looking-at mbox-delim) 499 (forward-line 1) 500 (push (list 501 (incf i) (point) 502 (progn 503 (if (re-search-forward mbox-delim nil t) 504 (beginning-of-line) 505 (goto-char (point-max))) 506 (point))) 507 alist))) 508 ;; MMDF format 509 ((= format ?M) 510 (while (looking-at "\^A\^A\^A\^A\n") 511 (forward-line 1) 512 (push (list 513 (incf i) (point) 514 (progn 515 (if (search-forward "\n\^A\^A\^A\^A\n" nil t) 516 (beginning-of-line) 517 (goto-char (point-max))) 518 (point))) 519 alist))) 520 ;; Binary format 521 ((or (= format ?B) (= format ?b)) 522 (while (not (eobp)) 523 (setq len (+ (* (char-after (point)) (expt 2.0 24)) 524 (* (char-after (+ (point) 1)) (expt 2 16)) 525 (* (char-after (+ (point) 2)) (expt 2 8)) 526 (char-after (+ (point) 3)))) 527 (push (list 528 (incf i) (+ (point) 4) 529 (progn 530 (forward-char (floor (+ len 4))) 531 (point))) 532 alist))) 533 (t 534 (error "Unknown format: %c" format))) 535 (push (cons (gnus-soup-area-prefix area) alist) nnsoup-article-alist))) 536 537(defun nnsoup-index-buffer (prefix &optional message) 538 (let* ((file (concat prefix (if message ".MSG" ".IDX"))) 539 (buffer-name (concat " *nnsoup " file "*"))) 540 (or (get-buffer buffer-name) ; File already loaded. 541 (when (file-exists-p (expand-file-name file nnsoup-directory)) 542 (save-excursion ; Load the file. 543 (set-buffer (get-buffer-create buffer-name)) 544 (buffer-disable-undo) 545 (push (cons nnsoup-current-group (current-buffer)) nnsoup-buffers) 546 (nnheader-insert-file-contents 547 (expand-file-name file nnsoup-directory)) 548 (current-buffer)))))) 549 550(defun nnsoup-file (prefix &optional message) 551 (expand-file-name 552 (concat prefix (if message ".MSG" ".IDX")) 553 nnsoup-directory)) 554 555(defun nnsoup-message-buffer (prefix) 556 (nnsoup-index-buffer prefix 'msg)) 557 558(defun nnsoup-unpack-packets () 559 "Unpack all packets in `nnsoup-packet-directory'." 560 (let ((packets (directory-files 561 nnsoup-packet-directory t nnsoup-packet-regexp)) 562 packet) 563 (while (setq packet (pop packets)) 564 (nnheader-message 5 "nnsoup: unpacking %s..." packet) 565 (if (not (gnus-soup-unpack-packet 566 nnsoup-tmp-directory nnsoup-unpacker packet)) 567 (nnheader-message 5 "Couldn't unpack %s" packet) 568 (delete-file packet) 569 (nnsoup-read-areas) 570 (nnheader-message 5 "Unpacking...done"))))) 571 572(defun nnsoup-narrow-to-article (article &optional area head) 573 (let* ((area (or area (nnsoup-article-to-area article nnsoup-current-group))) 574 (prefix (and area (gnus-soup-area-prefix (nth 1 area)))) 575 (msg-buf (and prefix (nnsoup-index-buffer prefix 'msg))) 576 beg end) 577 (when area 578 (save-excursion 579 (cond 580 ;; There is no MSG file. 581 ((null msg-buf) 582 nil) 583 ;; We use the index file to find out where the article 584 ;; begins and ends. 585 ((and (= (gnus-soup-encoding-index 586 (gnus-soup-area-encoding (nth 1 area))) 587 ?c) 588 (file-exists-p (nnsoup-file prefix))) 589 (set-buffer (nnsoup-index-buffer prefix)) 590 (widen) 591 (goto-char (point-min)) 592 (forward-line (- article (caar area))) 593 (setq beg (read (current-buffer))) 594 (forward-line 1) 595 (if (looking-at "[0-9]+") 596 (progn 597 (setq end (read (current-buffer))) 598 (set-buffer msg-buf) 599 (widen) 600 (let ((format (gnus-soup-encoding-format 601 (gnus-soup-area-encoding (nth 1 area))))) 602 (goto-char end) 603 (when (or (= format ?u) (= format ?n) (= format ?m)) 604 (setq end (progn (forward-line -1) (point)))))) 605 (set-buffer msg-buf)) 606 (widen) 607 (narrow-to-region beg (or end (point-max)))) 608 (t 609 (set-buffer msg-buf) 610 (widen) 611 (unless (assoc (gnus-soup-area-prefix (nth 1 area)) 612 nnsoup-article-alist) 613 (nnsoup-dissect-buffer (nth 1 area))) 614 (let ((entry (assq article (cdr (assoc (gnus-soup-area-prefix 615 (nth 1 area)) 616 nnsoup-article-alist))))) 617 (when entry 618 (narrow-to-region (cadr entry) (caddr entry)))))) 619 (goto-char (point-min)) 620 (if (not head) 621 () 622 (narrow-to-region 623 (point-min) 624 (if (search-forward "\n\n" nil t) 625 (1- (point)) 626 (point-max)))) 627 msg-buf)))) 628 629;;;###autoload 630(defun nnsoup-pack-replies () 631 "Make an outbound package of SOUP replies." 632 (interactive) 633 (unless (file-exists-p nnsoup-replies-directory) 634 (nnheader-message 5 "No such directory: %s" nnsoup-replies-directory)) 635 ;; Write all data buffers. 636 (gnus-soup-save-areas) 637 ;; Write the active file. 638 (nnsoup-write-active-file) 639 ;; Write the REPLIES file. 640 (nnsoup-write-replies) 641 ;; Check whether there is anything here. 642 (when (null (directory-files nnsoup-replies-directory nil "\\.MSG$")) 643 (error "No files to pack")) 644 ;; Pack all these files into a SOUP packet. 645 (gnus-soup-pack nnsoup-replies-directory nnsoup-packer)) 646 647(defun nnsoup-write-replies () 648 "Write the REPLIES file." 649 (when nnsoup-replies-list 650 (gnus-soup-write-replies nnsoup-replies-directory nnsoup-replies-list) 651 (setq nnsoup-replies-list nil))) 652 653(defun nnsoup-article-to-area (article group) 654 "Return the area that ARTICLE in GROUP is located in." 655 (let ((areas (cddr (assoc group nnsoup-group-alist)))) 656 (while (and areas (< (cdar (car areas)) article)) 657 (setq areas (cdr areas))) 658 (and areas (car areas)))) 659 660(defvar nnsoup-old-functions 661 (list message-send-mail-real-function message-send-news-function)) 662 663;;;###autoload 664(defun nnsoup-set-variables () 665 "Use the SOUP methods for posting news and mailing mail." 666 (interactive) 667 (setq message-send-news-function 'nnsoup-request-post) 668 (setq message-send-mail-real-function 'nnsoup-request-mail)) 669 670;;;###autoload 671(defun nnsoup-revert-variables () 672 "Revert posting and mailing methods to the standard Emacs methods." 673 (interactive) 674 (setq message-send-mail-real-function (car nnsoup-old-functions)) 675 (setq message-send-news-function (cadr nnsoup-old-functions))) 676 677(defun nnsoup-store-reply (kind) 678 ;; Mostly stolen from `message.el'. 679 (require 'mail-utils) 680 (let ((tembuf (generate-new-buffer " message temp")) 681 (case-fold-search nil) 682 delimline 683 (mailbuf (current-buffer))) 684 (unwind-protect 685 (save-excursion 686 (save-restriction 687 (message-narrow-to-headers) 688 (if (equal kind "mail") 689 (message-generate-headers message-required-mail-headers) 690 (message-generate-headers message-required-news-headers))) 691 (set-buffer tembuf) 692 (erase-buffer) 693 (insert-buffer-substring mailbuf) 694 ;; Remove some headers. 695 (save-restriction 696 (message-narrow-to-headers) 697 ;; Remove some headers. 698 (message-remove-header message-ignored-mail-headers t)) 699 (goto-char (point-max)) 700 ;; require one newline at the end. 701 (or (= (preceding-char) ?\n) 702 (insert ?\n)) 703 (let ((case-fold-search t)) 704 ;; Change header-delimiter to be what sendmail expects. 705 (goto-char (point-min)) 706 (re-search-forward 707 (concat "^" (regexp-quote mail-header-separator) "\n")) 708 (replace-match "\n") 709 (backward-char 1) 710 (setq delimline (point-marker)) 711 (goto-char (1+ delimline)) 712 (let ((msg-buf 713 (gnus-soup-store 714 nnsoup-replies-directory 715 (nnsoup-kind-to-prefix kind) nil nnsoup-replies-format-type 716 nnsoup-replies-index-type)) 717 (num 0)) 718 (when (and msg-buf (bufferp msg-buf)) 719 (save-excursion 720 (set-buffer msg-buf) 721 (goto-char (point-min)) 722 (while (re-search-forward "^#! *rnews" nil t) 723 (incf num)) 724 (when nnsoup-always-save 725 (save-buffer))) 726 (nnheader-message 5 "Stored %d messages" num))) 727 (nnsoup-write-replies) 728 (kill-buffer tembuf)))))) 729 730(defun nnsoup-kind-to-prefix (kind) 731 (unless nnsoup-replies-list 732 (setq nnsoup-replies-list 733 (gnus-soup-parse-replies 734 (expand-file-name "REPLIES" nnsoup-replies-directory)))) 735 (let ((replies nnsoup-replies-list)) 736 (while (and replies 737 (not (string= kind (gnus-soup-reply-kind (car replies))))) 738 (setq replies (cdr replies))) 739 (if replies 740 (gnus-soup-reply-prefix (car replies)) 741 (push (vector (gnus-soup-unique-prefix nnsoup-replies-directory) 742 kind 743 (format "%c%c%c" 744 nnsoup-replies-format-type 745 nnsoup-replies-index-type 746 (if (string= kind "news") 747 ?n ?m))) 748 nnsoup-replies-list) 749 (gnus-soup-reply-prefix (car nnsoup-replies-list))))) 750 751(defun nnsoup-make-active () 752 "(Re-)create the SOUP active file." 753 (interactive) 754 (let ((files (sort (directory-files nnsoup-directory t "IDX$") 755 (lambda (f1 f2) 756 (< (progn (string-match "/\\([0-9]+\\)\\." f1) 757 (string-to-number (match-string 1 f1))) 758 (progn (string-match "/\\([0-9]+\\)\\." f2) 759 (string-to-number (match-string 1 f2))))))) 760 active group lines ident elem min) 761 (set-buffer (get-buffer-create " *nnsoup work*")) 762 (while files 763 (nnheader-message 5 "Doing %s..." (car files)) 764 (erase-buffer) 765 (nnheader-insert-file-contents (car files)) 766 (goto-char (point-min)) 767 (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)) 768 (setq group "unknown") 769 (setq group (match-string 2))) 770 (setq lines (count-lines (point-min) (point-max))) 771 (setq ident (progn (string-match 772 "/\\([0-9]+\\)\\." (car files)) 773 (substring 774 (car files) (match-beginning 1) 775 (match-end 1)))) 776 (if (not (setq elem (assoc group active))) 777 (push (list group (cons 1 lines) 778 (list (cons 1 lines) 779 (vector ident group "ucm" "" lines))) 780 active) 781 (nconc elem 782 (list 783 (list (cons (1+ (setq min (cdadr elem))) 784 (+ min lines)) 785 (vector ident group "ucm" "" lines)))) 786 (setcdr (cadr elem) (+ min lines))) 787 (setq files (cdr files))) 788 (nnheader-message 5 "") 789 (setq nnsoup-group-alist active) 790 (nnsoup-write-active-file t))) 791 792(defun nnsoup-delete-unreferenced-message-files () 793 "Delete any *.MSG and *.IDX files that aren't known by nnsoup." 794 (interactive) 795 (let* ((known (apply 'nconc (mapcar 796 (lambda (ga) 797 (mapcar 798 (lambda (area) 799 (gnus-soup-area-prefix (cadr area))) 800 (cddr ga))) 801 nnsoup-group-alist))) 802 (regexp "\\.MSG$\\|\\.IDX$") 803 (files (directory-files nnsoup-directory nil regexp)) 804 non-files file) 805 ;; Find all files that aren't known by nnsoup. 806 (while (setq file (pop files)) 807 (string-match regexp file) 808 (unless (member (substring file 0 (match-beginning 0)) known) 809 (push file non-files))) 810 ;; Sort and delete the files. 811 (setq non-files (sort non-files 'string<)) 812 (map-y-or-n-p "Delete file %s? " 813 (lambda (file) (delete-file 814 (expand-file-name file nnsoup-directory))) 815 non-files))) 816 817(provide 'nnsoup) 818 819;;; arch-tag: b0451389-5703-4450-9425-f66f6b38c828 820;;; nnsoup.el ends here 821