cgit.sxemacs.org Git - gnus/blob - lisp/nnsoup.el

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