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-init-server-buffer)
 186   (if (equal server nnsoup-current-server)
 187       t
 188     (if nnsoup-current-server
 189         (setq nnsoup-server-alist
 190               (cons (list nnsoup-current-server
 191                           (nnheader-save-variables nnsoup-server-variables))
 192                     nnsoup-server-alist)))
 193     (let ((state (assoc server nnsoup-server-alist)))
 194       (if state
 195           (progn
 196             (nnheader-restore-variables (nth 1 state))
 197             (setq nnsoup-server-alist (delq state nnsoup-server-alist)))
 198         (nnheader-set-init-variables nnsoup-server-variables defs)))
 199     (setq nnsoup-current-server server))
 200   (nnsoup-read-active-file))
 201
 202 (defun nnsoup-request-close ()
 203   (nnsoup-write-active-file)
 204   (nnsoup-write-replies)
 205   (gnus-soup-save-areas)
 206   ;; Kill all nnsoup buffers.
 207   (let (buffer)
 208     (while nnsoup-buffers
 209       (setq buffer (cdr (pop nnsoup-buffers)))
 210       (and buffer
 211            (buffer-name buffer)
 212            (kill-buffer buffer))))
 213   (setq nnsoup-group-alist nil
 214         nnsoup-current-group nil
 215         nnsoup-current-server nil
 216         nnsoup-server-alist nil
 217         nnsoup-replies-list nil)
 218   t)
 219
 220 (defun nnsoup-close-server (&optional server)
 221   t)
 222
 223 (defun nnsoup-server-opened (&optional server)
 224   (and (equal server nnsoup-current-server)
 225        nntp-server-buffer
 226        (buffer-name nntp-server-buffer)))
 227
 228 (defun nnsoup-status-message (&optional server)
 229   nnsoup-status-string)
 230
 231 (defun nnsoup-request-article (id &optional newsgroup server buffer)
 232   (nnsoup-possibly-change-group newsgroup)
 233   (let ((buffer (or buffer nntp-server-buffer)))
 234     (save-excursion
 235       (set-buffer buffer)
 236       (erase-buffer)
 237       (if (stringp id)
 238           ()
 239         (insert-buffer-substring
 240          (nnsoup-narrow-to-article id))
 241         t))))
 242
 243 (defun nnsoup-request-group (group &optional server dont-check)
 244   (nnsoup-possibly-change-group group)
 245   (if dont-check
 246       t
 247     (let ((active (cadr (assoc group nnsoup-group-alist))))
 248       (if (not active)
 249           (nnheader-report 'nnsoup "No such group: %s" group)
 250         (nnheader-insert
 251          "211 %d %d %d %s\n"
 252          (max (1+ (- (cdr active) (car active))) 0)
 253          (car active) (cdr active) group)))))
 254
 255 (defun nnsoup-request-type (group &optional article)
 256   (nnsoup-possibly-change-group group)
 257   (if (not article)
 258       'unknown
 259     (let ((kind (gnus-soup-encoding-kind
 260                  (gnus-soup-area-encoding
 261                   (nth 1 (nnsoup-article-to-area
 262                           article nnsoup-current-group))))))
 263       (cond ((= kind ?m) 'mail)
 264             ((= kind ?n) 'news)
 265             (t 'unknown)))))
 266
 267 (defun nnsoup-close-group (group &optional server)
 268   ;; Kill all nnsoup buffers.
 269   (let ((buffers nnsoup-buffers)
 270         elem)
 271     (while buffers
 272       (when (equal (car (setq elem (pop buffers))) group)
 273         (setq nnsoup-buffers (delq elem nnsoup-buffers))
 274         (and (cdr elem) (buffer-name (cdr elem))
 275              (kill-buffer (cdr elem))))))
 276   t)
 277
 278 (defun nnsoup-request-list (&optional server)
 279   (save-excursion
 280     (set-buffer nntp-server-buffer)
 281     (erase-buffer)
 282     (let ((alist nnsoup-group-alist)
 283           entry)
 284       (while (setq entry (pop alist))
 285         (insert (format "%s %d %d y\n" (car entry)
 286                         (cdadr entry) (caadr entry))))
 287       t)))
 288
 289 (defun nnsoup-request-scan (group &optional server)
 290   (nnsoup-unpack-packets))
 291
 292 (defun nnsoup-request-newgroups (date &optional server)
 293   (nnsoup-request-list))
 294
 295 (defun nnsoup-request-list-newsgroups (&optional server)
 296   nil)
 297
 298 (defun nnsoup-request-post (&optional server)
 299   (nnsoup-store-reply "news")
 300   t)
 301
 302 (defun nnsoup-request-mail ()
 303   (nnsoup-store-reply "mail")
 304   t)
 305
 306 (defun nnsoup-request-expire-articles (articles group &optional server force)
 307   (nnsoup-possibly-change-group group)
 308   (let* ((total-infolist (assoc group nnsoup-group-alist))
 309          (active (cadr total-infolist))
 310          (infolist (cddr total-infolist))
 311          info range-list mod-time prefix)
 312     (while infolist
 313       (setq info (pop infolist)
 314             range-list (gnus-uncompress-range (car info))
 315             prefix (gnus-soup-area-prefix (nth 1 info)))
 316       (when ;; All the articles in this file are marked for expiry.
 317           (and (or (setq mod-time (nth 5 (file-attributes
 318                                           (nnsoup-file prefix))))
 319                    (setq mod-time (nth 5 (file-attributes
 320                                           (nnsoup-file prefix t)))))
 321                (gnus-sublist-p articles range-list)
 322                ;; This file is old enough.
 323                (nnmail-expired-article-p group mod-time force))
 324         ;; Ok, we delete this file.
 325         (when (condition-case nil
 326                   (progn
 327                     (nnheader-message
 328                      5 "Deleting %s..." (nnsoup-file prefix))
 329                     (when (file-exists-p (nnsoup-file prefix))
 330                       (delete-file (nnsoup-file prefix)))
 331                     (nnheader-message
 332                      5 "Deleting %s..." (nnsoup-file prefix t))
 333                     (when (file-exists-p (nnsoup-file prefix t))
 334                       (delete-file (nnsoup-file prefix t)))
 335                     t)
 336                 (error nil))
 337           (setcdr (cdr total-infolist) (delq info (cddr total-infolist)))
 338           (setq articles (gnus-sorted-complement articles range-list))))
 339       (when (not mod-time)
 340         (setcdr (cdr total-infolist) (delq info (cddr total-infolist)))))
 341     (if (cddr total-infolist)
 342         (setcar active (car (car (car (cdr (cdr total-infolist))))))
 343       (setcar active (1+ (cdr active))))
 344     (nnsoup-write-active-file)
 345     ;; Return the articles that weren't expired.
 346     articles))
 347
 348 \f
 349 ;;; Internal functions
 350
 351 (defun nnsoup-possibly-change-group (group &optional force)
 352   (if group
 353       (setq nnsoup-current-group group)
 354     t))
 355
 356 (defun nnsoup-read-active-file ()
 357   (setq nnsoup-group-alist)
 358   (when (file-exists-p nnsoup-active-file)
 359     (condition-case ()
 360         (load nnsoup-active-file)
 361       (error nil))
 362     ;; Be backwards compatible.
 363     (when (and nnsoup-group-alist
 364                (not (atom (caadar nnsoup-group-alist))))
 365       (let ((alist nnsoup-group-alist)
 366             entry e min max)
 367         (while (setq e (cdr (setq entry (pop alist))))
 368           (setq min (caaar e))
 369           (while (cdr e)
 370             (setq e (cdr e)))
 371           (setq max (cdaar e))
 372           (setcdr entry (cons (cons min max) (cdr entry))))))
 373     nnsoup-group-alist))
 374
 375 (defun nnsoup-write-active-file ()
 376   (when nnsoup-group-alist
 377     (save-excursion
 378       (set-buffer (get-buffer-create " *nnsoup work*"))
 379       (buffer-disable-undo (current-buffer))
 380       (erase-buffer)
 381       (insert (format "(setq nnsoup-group-alist '%S)\n" nnsoup-group-alist))
 382       (insert (format "(setq nnsoup-current-prefix %d)\n"
 383                       nnsoup-current-prefix))
 384       (write-region (point-min) (point-max) nnsoup-active-file
 385                     nil 'silent)
 386       (kill-buffer (current-buffer)))))
 387
 388 (defun nnsoup-next-prefix ()
 389   "Return the next free prefix."
 390   (let (prefix)
 391     (while (or (file-exists-p
 392                 (nnsoup-file (setq prefix (int-to-string
 393                                            nnsoup-current-prefix))))
 394                (file-exists-p (nnsoup-file prefix t)))
 395       (incf nnsoup-current-prefix))
 396     (incf nnsoup-current-prefix)
 397     prefix))
 398
 399 (defun nnsoup-read-areas ()
 400   (save-excursion
 401     (set-buffer nntp-server-buffer)
 402     (let ((areas (gnus-soup-parse-areas (concat nnsoup-tmp-directory "AREAS")))
 403           entry number area lnum cur-prefix file)
 404       ;; Go through all areas in the new AREAS file.
 405       (while (setq area (pop areas))
 406         ;; Change the name to the permanent name and move the files.
 407         (setq cur-prefix (nnsoup-next-prefix))
 408         (message "Incorporating file %s..." cur-prefix)
 409         (when (file-exists-p
 410                (setq file (concat nnsoup-tmp-directory
 411                                   (gnus-soup-area-prefix area) ".IDX")))
 412           (rename-file file (nnsoup-file cur-prefix)))
 413         (when (file-exists-p
 414                (setq file (concat nnsoup-tmp-directory
 415                                   (gnus-soup-area-prefix area) ".MSG")))
 416           (rename-file file (nnsoup-file cur-prefix t)))
 417         (gnus-soup-set-area-prefix area cur-prefix)
 418         ;; Find the number of new articles in this area.
 419         (setq number (nnsoup-number-of-articles area))
 420         (if (not (setq entry (assoc (gnus-soup-area-name area)
 421                                     nnsoup-group-alist)))
 422             ;; If this is a new area (group), we just add this info to
 423             ;; the group alist.
 424             (push (list (gnus-soup-area-name area)
 425                         (cons 1 number)
 426                         (list (cons 1 number) area))
 427                   nnsoup-group-alist)
 428           ;; There are already articles in this group, so we add this
 429           ;; info to the end of the entry.
 430           (nconc entry (list (list (cons (1+ (setq lnum (cdadr entry)))
 431                                          (+ lnum number))
 432                                    area)))
 433           (setcdr (cadr entry) (+ lnum number)))))
 434     (nnsoup-write-active-file)))
 435
 436 (defun nnsoup-number-of-articles (area)
 437   (save-excursion
 438     (cond
 439      ;; If the number is in the area info, we just return it.
 440      ((gnus-soup-area-number area)
 441       (gnus-soup-area-number area))
 442      ;; If there is an index file, we just count the lines.
 443      ((/= (gnus-soup-encoding-index (gnus-soup-area-encoding area)) ?n)
 444       (set-buffer (nnsoup-index-buffer (gnus-soup-area-prefix area)))
 445       (count-lines (point-min) (point-max)))
 446      ;; We do it the hard way - re-searching through the message
 447      ;; buffer.
 448      (t
 449       (set-buffer (nnsoup-message-buffer (gnus-soup-area-prefix area)))
 450       (goto-char (point-min))
 451       (let ((regexp (nnsoup-header (gnus-soup-encoding-format
 452                                     (gnus-soup-area-encoding area))))
 453             (num 0))
 454         (while (re-search-forward regexp nil t)
 455           (setq num (1+ num)))
 456         num)))))
 457
 458 (defun nnsoup-index-buffer (prefix &optional message)
 459   (let* ((file (concat prefix (if message ".MSG" ".IDX")))
 460          (buffer-name (concat " *nnsoup " file "*")))
 461     (or (get-buffer buffer-name)        ; File aready loaded.
 462         (when (file-exists-p (concat nnsoup-directory file))
 463           (save-excursion                       ; Load the file.
 464             (set-buffer (get-buffer-create buffer-name))
 465             (buffer-disable-undo (current-buffer))
 466             (push (cons nnsoup-current-group (current-buffer)) nnsoup-buffers)
 467             (insert-file-contents (concat nnsoup-directory file))
 468             (current-buffer))))))
 469
 470 (defun nnsoup-file (prefix &optional message)
 471   (expand-file-name
 472    (concat nnsoup-directory prefix (if message ".MSG" ".IDX"))))
 473
 474 (defun nnsoup-message-buffer (prefix)
 475   (nnsoup-index-buffer prefix 'msg))
 476
 477 (defun nnsoup-unpack-packets ()
 478   "Unpack all packets in `nnsoup-packet-directory'."
 479   (let ((packets (directory-files
 480                   nnsoup-packet-directory t nnsoup-packet-regexp))
 481         packet msg)
 482     (while (setq packet (pop packets))
 483       (message (setq msg (format "nnsoup: unpacking %s..." packet)))
 484       (if (not (gnus-soup-unpack-packet
 485                 nnsoup-tmp-directory nnsoup-unpacker packet))
 486           (message "Couldn't unpack %s" packet)
 487         (delete-file packet)
 488         (nnsoup-read-areas)
 489         (message "%sdone" msg)))))
 490
 491 (defun nnsoup-narrow-to-article (article &optional area head)
 492   (let* ((area (or area (nnsoup-article-to-area article nnsoup-current-group)))
 493          (prefix (gnus-soup-area-prefix (nth 1 area)))
 494          (msg-buf (nnsoup-index-buffer prefix 'msg))
 495          beg end)
 496     (save-excursion
 497       (cond
 498        ;; There is no MSG file.
 499        ((null msg-buf)
 500         nil)
 501
 502        ;; We use the index file to find out where the article begins and ends.
 503        ((and (= (gnus-soup-encoding-index
 504                  (gnus-soup-area-encoding (nth 1 area)))
 505                 ?c)
 506              (file-exists-p (nnsoup-file prefix)))
 507         (set-buffer (nnsoup-index-buffer prefix))
 508         (widen)
 509         (goto-char (point-min))
 510         (forward-line (- article (car (car area))))
 511         (setq beg (read (current-buffer)))
 512         (forward-line 1)
 513         (if (looking-at "[0-9]+")
 514             (progn
 515               (setq end (read (current-buffer)))
 516               (set-buffer msg-buf)
 517               (widen)
 518               (let ((format (gnus-soup-encoding-format
 519                              (gnus-soup-area-encoding (nth 1 area)))))
 520                 (goto-char end)
 521                 (if (or (= format ?n) (= format ?m))
 522                     (setq end (progn (forward-line -1) (point))))))
 523           (set-buffer msg-buf))
 524         (widen)
 525         (narrow-to-region beg (or end (point-max))))
 526        (t
 527         (set-buffer msg-buf)
 528         (widen)
 529         (goto-char (point-min))
 530         (let ((header (nnsoup-header
 531                        (gnus-soup-encoding-format
 532                         (gnus-soup-area-encoding (nth 1 area))))))
 533           (re-search-forward header nil t (- article (car (car area))))
 534           (narrow-to-region
 535            (match-beginning 0)
 536            (if (re-search-forward header nil t)
 537                (match-beginning 0)
 538              (point-max))))))
 539       (goto-char (point-min))
 540       (if (not head)
 541           ()
 542         (narrow-to-region
 543          (point-min)
 544          (if (search-forward "\n\n" nil t)
 545              (1- (point))
 546            (point-max))))
 547       msg-buf)))
 548
 549 (defun nnsoup-header (format)
 550   (cond
 551    ((= format ?n)
 552     "^#! *rnews +[0-9]+ *$")
 553    ((= format ?m)
 554     (concat "^" rmail-unix-mail-delimiter))
 555    ((= format ?M)
 556     "^\^A\^A\^A\^A\n")
 557    (t
 558     (error "Unknown format: %c" format))))
 559
 560 ;;;###autoload
 561 (defun nnsoup-pack-replies ()
 562   "Make an outbound package of SOUP replies."
 563   (interactive)
 564   ;; Write all data buffers.
 565   (gnus-soup-save-areas)
 566   ;; Write the active file.
 567   (nnsoup-write-active-file)
 568   ;; Write the REPLIES file.
 569   (nnsoup-write-replies)
 570   ;; Pack all these files into a SOUP packet.
 571   (gnus-soup-pack nnsoup-replies-directory nnsoup-packer))
 572
 573 (defun nnsoup-write-replies ()
 574   "Write the REPLIES file."
 575   (when nnsoup-replies-list
 576     (gnus-soup-write-replies nnsoup-replies-directory nnsoup-replies-list)
 577     (setq nnsoup-replies-list nil)))
 578
 579 (defun nnsoup-article-to-area (article group)
 580   "Return the area that ARTICLE in GROUP is located in."
 581   (let ((areas (cddr (assoc group nnsoup-group-alist))))
 582     (while (and areas (< (cdr (car (car areas))) article))
 583       (setq areas (cdr areas)))
 584     (and areas (car areas))))
 585
 586 (defvar nnsoup-old-functions
 587   (list gnus-inews-article-function send-mail-function))
 588
 589 ;;;###autoload
 590 (defun nnsoup-set-variables ()
 591   "Use the SOUP methods for posting news and mailing mail."
 592   (interactive)
 593   (setq gnus-inews-article-function 'nnsoup-request-post)
 594   (setq send-mail-function 'nnsoup-request-mail))
 595
 596 ;;;###autoload
 597 (defun nnsoup-revert-variables ()
 598   "Revert posting and mailing methods to the standard Emacs methods."
 599   (interactive)
 600   (setq gnus-inews-article-function (car nnsoup-old-functions))
 601   (setq send-mail-function (cadr nnsoup-old-functions)))
 602
 603 (defun nnsoup-store-reply (kind)
 604   ;; Mostly stolen from `sendmail.el'.
 605   (let ((tembuf (generate-new-buffer " sendmail temp"))
 606         (case-fold-search nil)
 607         (mailbuf (current-buffer))
 608         delimline)
 609     (save-excursion
 610       (set-buffer tembuf)
 611       (erase-buffer)
 612       (insert-buffer-substring mailbuf)
 613       (goto-char (point-max))
 614       ;; require one newline at the end.
 615       (or (= (preceding-char) ?\n)
 616           (insert ?\n))
 617       ;; Change header-delimiter to be what sendmail expects.
 618       (goto-char (point-min))
 619       (if (re-search-forward
 620            (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
 621           (replace-match "\n")
 622         (search-forward "\n\n" nil t))
 623       (backward-char 1)
 624       (setq delimline (point-marker))
 625       (if mail-aliases (expand-mail-aliases (point-min) delimline))
 626       (goto-char (point-min))
 627       ;; ignore any blank lines in the header
 628       (while (and (re-search-forward "\n\n\n*" delimline t)
 629                   (< (point) delimline))
 630         (replace-match "\n"))
 631       (let ((case-fold-search t))
 632         (goto-char (point-min))
 633         ;; Find and handle any FCC fields.
 634         (goto-char (point-min))
 635         (if (re-search-forward "^FCC:" delimline t)
 636             (mail-do-fcc delimline))
 637         (goto-char (point-min))
 638         ;; "S:" is an abbreviation for "Subject:".
 639         (goto-char (point-min))
 640         (if (re-search-forward "^S:" delimline t)
 641             (replace-match "Subject:"))
 642         ;; Don't send out a blank subject line
 643         (goto-char (point-min))
 644         (if (re-search-forward "^Subject:[ \t]*\n" delimline t)
 645             (replace-match ""))
 646         ;; Insert an extra newline if we need it to work around
 647         ;; Sun's bug that swallows newlines.
 648         (goto-char (1+ delimline))
 649         (if (eval mail-mailer-swallows-blank-line)
 650             (newline)))
 651       (let ((msg-buf
 652              (gnus-soup-store
 653               nnsoup-replies-directory
 654               (nnsoup-kind-to-prefix kind) nil nnsoup-replies-format-type
 655               nnsoup-replies-index-type))
 656             (num 0))
 657         (when (and msg-buf (bufferp msg-buf))
 658           (save-excursion
 659             (set-buffer msg-buf)
 660             (goto-char (point-min))
 661             (while (re-search-forward "^#! *rnews" nil t)
 662               (incf num)))
 663           (message "Stored %d messages" num)))
 664       (nnsoup-write-replies)
 665       (kill-buffer tembuf))))
 666
 667 (defun nnsoup-kind-to-prefix (kind)
 668   (unless nnsoup-replies-list
 669     (setq nnsoup-replies-list
 670           (gnus-soup-parse-replies
 671            (concat nnsoup-replies-directory "REPLIES"))))
 672   (let ((replies nnsoup-replies-list))
 673     (while (and replies
 674                 (not (string= kind (gnus-soup-reply-kind (car replies)))))
 675       (setq replies (cdr replies)))
 676     (if replies
 677         (gnus-soup-reply-prefix (car replies))
 678       (setq nnsoup-replies-list
 679             (cons (vector (gnus-soup-unique-prefix nnsoup-replies-directory)
 680                           kind
 681                           (format "%c%c%c"
 682                                   nnsoup-replies-format-type
 683                                   nnsoup-replies-index-type
 684                                   (if (string= kind "news")
 685                                       ?n ?m)))
 686                   nnsoup-replies-list))
 687       (gnus-soup-reply-prefix (car nnsoup-replies-list)))))
 688
 689 (defun nnsoup-make-active ()
 690   "(Re-)create the SOUP active file."
 691   (interactive)
 692   (let ((files (sort (directory-files nnsoup-directory t "IDX$")
 693                      (lambda (f1 f2)
 694                        (< (progn (string-match "/\\([0-9]+\\)\\." f1)
 695                                  (string-to-int (match-string 1 f1)))
 696                           (progn (string-match "/\\([0-9]+\\)\\." f2)
 697                                  (string-to-int (match-string 1 f2)))))))
 698         active group lines ident elem min)
 699     (set-buffer (get-buffer-create " *nnsoup work*"))
 700     (buffer-disable-undo (current-buffer))
 701     (while files
 702       (message "Doing %s..." (car files))
 703       (erase-buffer)
 704       (insert-file-contents (car files))
 705       (goto-char (point-min))
 706       (end-of-line)
 707       (re-search-backward "[ \t]\\([^ ]+\\):[0-9]")
 708       (setq group (buffer-substring (match-beginning 1) (match-end 1)))
 709       (setq lines (count-lines (point-min) (point-max)))
 710       (setq ident (progn (string-match
 711                           "/\\([0-9]+\\)\\." (car files))
 712                          (substring
 713                           (car files) (match-beginning 1)
 714                           (match-end 1))))
 715       (if (not (setq elem (assoc group active)))
 716           (push (list group (cons 1 lines)
 717                       (list (cons 1 lines)
 718                             (vector ident group "ncm" "" lines)))
 719                 active)
 720         (nconc elem
 721                (list
 722                 (list (cons (setq min (1+ (cdr (car (car
 723                                                      (cdr elem))))))
 724                             (+ min lines))
 725                       (vector ident group "ncm" "" lines))))
 726         (setcdr (cadr elem) (+ min lines)))
 727       (setq files (cdr files)))
 728     (message "")
 729     (setq nnsoup-group-alist active)
 730     (while active
 731       (setcdr (car active) (nreverse (cdr (car active))))
 732       (setq active (cdr active)))
 733     (nnsoup-write-active-file)))
 734
 735 (defun nnsoup-delete-unreferenced-message-files ()
 736   "Delete any *.MSG and *.IDX files that aren't known by nnsoup."
 737   (interactive)
 738   (let* ((known (apply 'nconc (mapcar
 739                                (lambda (ga)
 740                                  (mapcar
 741                                   (lambda (area)
 742                                     (gnus-soup-area-prefix (cadr area)))
 743                                   (cddr ga)))
 744                                nnsoup-group-alist)))
 745          (regexp "\\.MSG$\\|\\.IDX$")
 746          (files (directory-files nnsoup-directory nil regexp))
 747          non-files file)
 748     ;; Find all files that aren't known by nnsoup.
 749     (while (setq file (pop files))
 750       (string-match regexp file)
 751       (unless (member (substring file 0 (match-beginning 0)) known)
 752         (push file non-files)))
 753     ;; Sort and delete the files.
 754     (setq non-files (sort non-files 'string<))
 755     (map-y-or-n-p "Delete file %s? "
 756                   (lambda (file) (delete-file (concat nnsoup-directory file)))
 757                   non-files)))
 758
 759 (provide 'nnsoup)
 760
 761 ;;; nnsoup.el ends here