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
  22 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (require 'nnheader)
  29 (require 'nnmail)
  30 (require 'gnus-soup)
  31 (require 'gnus-msg)
  32 (eval-when-compile (require 'cl))
  33
  34 (defvar nnsoup-directory "~/SOUP/"
  35   "*SOUP packet directory.")
  36
  37 (defvar nnsoup-tmp-directory "/tmp/"
  38   "*Where nnsoup will store temporary files.")
  39
  40 (defvar nnsoup-replies-directory (concat nnsoup-directory "replies/")
  41   "*Directory where outgoing packets will be composed.")
  42
  43 (defvar nnsoup-replies-format-type ?n
  44   "*Format of the replies packages.")
  45
  46 (defvar nnsoup-replies-index-type ?n
  47   "*Index type of the replies packages.")
  48
  49 (defvar nnsoup-active-file (concat nnsoup-directory "active")
  50   "Active file.")
  51
  52 (defvar nnsoup-packer "tar cf - %s | gzip > $HOME/Soupin%d.tgz"
  53   "Format string command for packing a SOUP packet.
  54 The SOUP files will be inserted where the %s is in the string.
  55 This string MUST contain both %s and %d. The file number will be
  56 inserted where %d appears.")
  57
  58 (defvar nnsoup-unpacker "gunzip -c %s | tar xvf -"
  59   "*Format string command for unpacking a SOUP packet.
  60 The SOUP packet file name will be inserted at the %s.")
  61
  62 (defvar nnsoup-packet-directory "~/"
  63   "*Where nnsoup will look for incoming packets.")
  64
  65 (defvar nnsoup-packet-regexp "Soupout"
  66   "*Regular expression matching SOUP packets in `nnsoup-packet-directory'.")
  67
  68 \f
  69
  70 (defconst nnsoup-version "nnsoup 0.0"
  71   "nnsoup version.")
  72
  73 (defvar nnsoup-status-string "")
  74 (defvar nnsoup-group-alist nil)
  75 (defvar nnsoup-current-prefix 0)
  76 (defvar nnsoup-replies-list nil)
  77 (defvar nnsoup-buffers nil)
  78 (defvar nnsoup-current-group nil)
  79
  80 \f
  81
  82 ;; Server variables.
  83
  84 (defvar nnsoup-current-server nil)
  85 (defvar nnsoup-server-alist nil)
  86 (defvar nnsoup-server-variables
  87   `((nnsoup-directory ,nnsoup-directory)
  88     (nnsoup-active-file ,nnsoup-active-file)
  89     (nnsoup-status-string "")
  90     (nnsoup-current-prefix 0)
  91     (nnsoup-group-alist nil)))
  92
  93 \f
  94
  95 ;;; Interface functions.
  96
  97 (defun nnsoup-retrieve-headers (sequence &optional group server fetch-old)
  98   (nnsoup-possibly-change-group group)
  99   (save-excursion
 100     (set-buffer nntp-server-buffer)
 101     (erase-buffer)
 102     (let ((areas (cddr (assoc nnsoup-current-group nnsoup-group-alist)))
 103           (articles sequence)
 104           (use-nov t)
 105           useful-areas this-area-seq)
 106       (if (stringp (car sequence))
 107           ;; We don't support fetching by Message-ID.
 108           'headers
 109         ;; We go through all the areas and find which files the
 110         ;; articles in SEQUENCE come from.
 111         (while (and areas sequence)
 112           ;; Peel off areas that are below sequence.
 113           (while (and areas (< (cdr (car (car areas))) (car sequence)))
 114             (setq areas (cdr areas)))
 115           (when areas
 116             ;; This is a useful area.
 117             (push (car areas) useful-areas)
 118             (setq this-area-seq nil)
 119             ;; We take note whether this MSG has a corresponding IDX
 120             ;; for later use.
 121             (when (or (= (gnus-soup-encoding-index
 122                           (gnus-soup-area-encoding (nth 1 (car areas)))) ?n)
 123                       (not (file-exists-p
 124                             (nnsoup-file
 125                              (gnus-soup-area-prefix (nth 1 (car areas)))))))
 126               (setq use-nov nil))
 127             ;; We assign the portion of `sequence' that is relevant to
 128             ;; this MSG packet to this packet.
 129             (while (and sequence (<= (car sequence) (cdr (car (car areas)))))
 130               (push (car sequence) this-area-seq)
 131               (setq sequence (cdr sequence)))
 132             (setcar useful-areas (cons (nreverse this-area-seq)
 133                                        (car useful-areas)))))
 134
 135         ;; We now have a list of article numbers and corresponding
 136         ;; areas.
 137         (setq useful-areas (nreverse useful-areas))
 138
 139         ;; Two different approaches depending on whether all the MSG
 140         ;; files have corresponding IDX files.  If they all do, we
 141         ;; simply return the relevant IDX files and let Gnus sort out
 142         ;; what lines are relevant.  If some of the IDX files are
 143         ;; missing, we must return HEADs for all the articles.
 144         (if use-nov
 145             ;; We have IDX files for all areas.
 146             (progn
 147               (while useful-areas
 148                 (goto-char (point-max))
 149                 (let ((b (point))
 150                       (number (car (nth 1 (car useful-areas)))))
 151                   (insert-buffer-substring
 152                    (nnsoup-index-buffer
 153                     (gnus-soup-area-prefix
 154                      (nth 2 (car useful-areas)))))
 155                   (goto-char b)
 156                   ;; We have to remove the index number entires and
 157                   ;; insert article numbers instead.
 158                   (while (looking-at "[0-9]+")
 159                     (replace-match (int-to-string number) t t)
 160                     (incf number)
 161                     (forward-line 1)))
 162                 (setq useful-areas (cdr useful-areas)))
 163               'nov)
 164           ;; We insert HEADs.
 165           (while useful-areas
 166             (setq articles (car (car useful-areas))
 167                   useful-areas (cdr useful-areas))
 168             (while articles
 169               (goto-char (point-max))
 170               (insert (format "221 %d Article retrieved.\n" (car articles)))
 171               (insert-buffer-substring
 172                (nnsoup-narrow-to-article
 173                 (car articles) (cdr (car useful-areas)) 'head))
 174               (goto-char (point-max))
 175               (insert ".\n")
 176               (setq articles (cdr articles))))
 177
 178           ;; Fold continuation lines.
 179           (goto-char (point-min))
 180           (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
 181             (replace-match " " t t))
 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 (cdr (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         (when (file-exists-p
 409                (setq file (concat nnsoup-tmp-directory
 410                                   (gnus-soup-area-prefix area) ".IDX")))
 411           (rename-file file (nnsoup-file cur-prefix)))
 412         (when (file-exists-p
 413                (setq file (concat nnsoup-tmp-directory
 414                                   (gnus-soup-area-prefix area) ".MSG")))
 415           (rename-file file (nnsoup-file cur-prefix t)))
 416         (gnus-soup-set-area-prefix area cur-prefix)
 417         ;; Find the number of new articles in this area.
 418         (setq number (nnsoup-number-of-articles area))
 419         (if (not (setq entry (assoc (gnus-soup-area-name area)
 420                                     nnsoup-group-alist)))
 421             ;; If this is a new area (group), we just add this info to
 422             ;; the group alist.
 423             (push (list (gnus-soup-area-name area)
 424                         (cons 1 number)
 425                         (list (cons 1 number) area))
 426                   nnsoup-group-alist)
 427           ;; There are already articles in this group, so we add this
 428           ;; info to the end of the entry.
 429           (let ((e (cddr entry)))
 430             (while (cdr e)
 431               (setq e (cdr e)))
 432             (setcdr e (list (list (cons (setq lnum (1+ (cdr (car (car e)))))
 433                                         (+ lnum number))
 434                                   area))))
 435           (setcdr (cadr entry) (+ lnum number)))))
 436     (nnsoup-write-active-file)))
 437
 438 (defun nnsoup-number-of-articles (area)
 439   (save-excursion
 440     (cond
 441      ;; If the number is in the area info, we just return it.
 442      ((gnus-soup-area-number area)
 443       (gnus-soup-area-number area))
 444      ;; If there is an index file, we just count the lines.
 445      ((/= (gnus-soup-encoding-index (gnus-soup-area-encoding area)) ?n)
 446       (set-buffer (nnsoup-index-buffer (gnus-soup-area-prefix area)))
 447       (count-lines (point-min) (point-max)))
 448      ;; We do it the hard way - re-searching through the message
 449      ;; buffer.
 450      (t
 451       (set-buffer (nnsoup-message-buffer (gnus-soup-area-prefix area)))
 452       (goto-char (point-min))
 453       (let ((regexp (nnsoup-header (gnus-soup-encoding-format
 454                                     (gnus-soup-area-encoding area))))
 455             (num 0))
 456         (while (re-search-forward regexp nil t)
 457           (setq num (1+ num)))
 458         num)))))
 459
 460 (defun nnsoup-index-buffer (prefix &optional message)
 461   (let* ((file (concat prefix (if message ".MSG" ".IDX")))
 462          (buffer-name (concat " *nnsoup " file "*")))
 463     (or (get-buffer buffer-name)        ; File aready loaded.
 464         (save-excursion                 ; Load the file.
 465           (set-buffer (get-buffer-create buffer-name))
 466           (buffer-disable-undo (current-buffer))
 467           (push (cons nnsoup-current-group (current-buffer)) nnsoup-buffers)
 468           (insert-file-contents (concat nnsoup-directory file))
 469           (current-buffer)))))
 470
 471 (defun nnsoup-file (prefix &optional message)
 472   (expand-file-name
 473    (concat nnsoup-directory prefix (if message ".MSG" ".IDX"))))
 474
 475 (defun nnsoup-message-buffer (prefix)
 476   (nnsoup-index-buffer prefix 'msg))
 477
 478 (defun nnsoup-unpack-packets ()
 479   "Unpack all packets in `nnsoup-packet-directory'."
 480   (let ((packets (directory-files
 481                   nnsoup-packet-directory t nnsoup-packet-regexp))
 482         packet msg)
 483     (while (setq packet (pop packets))
 484       (message (setq msg (format "nnsoup: unpacking %s..." packet)))
 485       (if (not (gnus-soup-unpack-packet
 486                 nnsoup-tmp-directory nnsoup-unpacker packet))
 487           (message "Couldn't unpack %s" packet)
 488         (delete-file packet)
 489         (nnsoup-read-areas)
 490         (message "%sdone" msg)))))
 491
 492 (defun nnsoup-narrow-to-article (article &optional area head)
 493   (let* ((area (or area (nnsoup-article-to-area article nnsoup-current-group)))
 494          (prefix (gnus-soup-area-prefix (nth 1 area)))
 495          beg end msg-buf)
 496     (setq msg-buf (nnsoup-index-buffer prefix 'msg))
 497     (save-excursion
 498       (cond
 499        ;; We use the index file to find out where the article begins and ends.
 500        ((and (= (gnus-soup-encoding-index
 501                  (gnus-soup-area-encoding (nth 1 area)))
 502                 ?c)
 503              (file-exists-p (nnsoup-file prefix)))
 504         (set-buffer (nnsoup-index-buffer prefix))
 505         (widen)
 506         (goto-char (point-min))
 507         (forward-line (- article (car (car area))))
 508         (setq beg (read (current-buffer)))
 509         (forward-line 1)
 510         (if (looking-at "[0-9]+")
 511             (progn
 512               (setq end (read (current-buffer)))
 513               (set-buffer msg-buf)
 514               (widen)
 515               (let ((format (gnus-soup-encoding-format
 516                              (gnus-soup-area-encoding (nth 1 area)))))
 517                 (goto-char end)
 518                 (if (or (= format ?n) (= format ?m))
 519                     (setq end (progn (forward-line -1) (point))))))
 520           (set-buffer msg-buf))
 521         (widen)
 522         (narrow-to-region beg (or end (point-max))))
 523        (t
 524         (set-buffer msg-buf)
 525         (widen)
 526         (goto-char (point-min))
 527         (let ((header (nnsoup-header
 528                        (gnus-soup-encoding-format
 529                         (gnus-soup-area-encoding (nth 1 area))))))
 530           (re-search-forward header nil t (- article (car (car area))))
 531           (narrow-to-region
 532            (match-beginning 0)
 533            (if (re-search-forward header nil t)
 534                (match-beginning 0)
 535              (point-max))))))
 536       (goto-char (point-min))
 537       (if (not head)
 538           ()
 539         (narrow-to-region
 540          (point-min)
 541          (if (search-forward "\n\n" nil t)
 542              (1- (point))
 543            (point-max))))
 544       msg-buf)))
 545
 546 (defun nnsoup-header (format)
 547   (cond
 548    ((= format ?n)
 549     "^#! *rnews +[0-9]+ *$")
 550    ((= format ?m)
 551     (concat "^" rmail-unix-mail-delimiter))
 552    ((= format ?M)
 553     "^\^A\^A\^A\^A\n")
 554    (t
 555     (error "Unknown format: %c" format))))
 556
 557 ;;;###autoload
 558 (defun nnsoup-pack-replies ()
 559   "Make an outbound package of SOUP replies."
 560   (interactive)
 561   ;; Write all data buffers.
 562   (gnus-soup-save-areas)
 563   ;; Write the active file.
 564   (nnsoup-write-active-file)
 565   ;; Write the REPLIES file.
 566   (nnsoup-write-replies)
 567   ;; Pack all these files into a SOUP packet.
 568   (gnus-soup-pack nnsoup-replies-directory nnsoup-packer))
 569
 570 (defun nnsoup-write-replies ()
 571   "Write the REPLIES file."
 572   (when nnsoup-replies-list
 573     (gnus-soup-write-replies nnsoup-replies-directory nnsoup-replies-list)
 574     (setq nnsoup-replies-list nil)))
 575
 576 (defun nnsoup-article-to-area (article group)
 577   "Return the area that ARTICLE in GROUP is located in."
 578   (let ((areas (cddr (assoc group nnsoup-group-alist))))
 579     (while (and areas (< (cdr (car (car areas))) article))
 580       (setq areas (cdr areas)))
 581     (and areas (car areas))))
 582
 583 ;;;###autoload
 584 (defun nnsoup-set-variables ()
 585   "Use the SOUP methods for posting news and mailing mail."
 586   (interactive)
 587   (setq gnus-inews-article-function 'nnsoup-request-post)
 588   (setq send-mail-function 'nnsoup-request-mail))
 589
 590 (defun nnsoup-store-reply (kind)
 591   ;; Mostly stolen from `sendmail.el'.
 592   (let ((tembuf (generate-new-buffer " sendmail temp"))
 593         (case-fold-search nil)
 594         (mailbuf (current-buffer))
 595         delimline)
 596     (save-excursion
 597       (set-buffer tembuf)
 598       (erase-buffer)
 599       (insert-buffer-substring mailbuf)
 600       (goto-char (point-max))
 601       ;; require one newline at the end.
 602       (or (= (preceding-char) ?\n)
 603           (insert ?\n))
 604       ;; Change header-delimiter to be what sendmail expects.
 605       (goto-char (point-min))
 606       (if (re-search-forward
 607            (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
 608           (replace-match "\n")
 609         (search-forward "\n\n" nil t))
 610       (backward-char 1)
 611       (setq delimline (point-marker))
 612       (if mail-aliases (expand-mail-aliases (point-min) delimline))
 613       (goto-char (point-min))
 614       ;; ignore any blank lines in the header
 615       (while (and (re-search-forward "\n\n\n*" delimline t)
 616                   (< (point) delimline))
 617         (replace-match "\n"))
 618       (let ((case-fold-search t))
 619         (goto-char (point-min))
 620         ;; Find and handle any FCC fields.
 621         (goto-char (point-min))
 622         (if (re-search-forward "^FCC:" delimline t)
 623             (mail-do-fcc delimline))
 624         (goto-char (point-min))
 625         ;; "S:" is an abbreviation for "Subject:".
 626         (goto-char (point-min))
 627         (if (re-search-forward "^S:" delimline t)
 628             (replace-match "Subject:"))
 629         ;; Don't send out a blank subject line
 630         (goto-char (point-min))
 631         (if (re-search-forward "^Subject:[ \t]*\n" delimline t)
 632             (replace-match ""))
 633         ;; Insert an extra newline if we need it to work around
 634         ;; Sun's bug that swallows newlines.
 635         (goto-char (1+ delimline))
 636         (if (eval mail-mailer-swallows-blank-line)
 637             (newline)))
 638       (let ((msg-buf
 639              (gnus-soup-store
 640               nnsoup-replies-directory
 641               (nnsoup-kind-to-prefix kind) nil nnsoup-replies-format-type
 642               nnsoup-replies-index-type))
 643             (num 0))
 644         (when (and msg-buf (bufferp msg-buf))
 645           (save-excursion
 646             (set-buffer msg-buf)
 647             (goto-char (point-min))
 648             (while (re-search-forward "^#! *rnews" nil t)
 649               (incf num)))
 650           (message "Stored %d messages" num)))
 651       (kill-buffer tembuf))))
 652
 653 (defun nnsoup-kind-to-prefix (kind)
 654   (unless nnsoup-replies-list
 655     (setq nnsoup-replies-list
 656           (gnus-soup-parse-replies
 657            (concat nnsoup-replies-directory "REPLIES"))))
 658   (let ((replies nnsoup-replies-list))
 659     (while (and replies
 660                 (not (string= kind (gnus-soup-reply-kind (car replies)))))
 661       (setq replies (cdr replies)))
 662     (if replies
 663         (gnus-soup-reply-prefix (car replies))
 664       (setq nnsoup-replies-list
 665             (cons (vector (gnus-soup-unique-prefix nnsoup-replies-directory)
 666                           kind
 667                           (format "%c%c%c"
 668                                   nnsoup-replies-format-type
 669                                   nnsoup-replies-index-type
 670                                   (if (string= kind "news")
 671                                       ?n ?m)))
 672                   nnsoup-replies-list))
 673       (gnus-soup-reply-prefix (car nnsoup-replies-list)))))
 674
 675 (defun nnsoup-make-active ()
 676   "(Re-)create the SOUP active file."
 677   (interactive)
 678   (let ((files (sort (directory-files nnsoup-directory t "IDX$")
 679                      (lambda (f1 f2)
 680                        (< (progn (string-match "/\\([0-9]+\\)\\." f1)
 681                                  (string-to-int (match-string 1 f1)))
 682                           (progn (string-match "/\\([0-9]+\\)\\." f2)
 683                                  (string-to-int (match-string 1 f2)))))))
 684         active group lines ident elem min)
 685     (set-buffer (get-buffer-create " *nnsoup work*"))
 686     (buffer-disable-undo (current-buffer))
 687     (while files
 688       (message "Doing %s..." (car files))
 689       (erase-buffer)
 690       (insert-file-contents (car files))
 691       (goto-char (point-min))
 692       (end-of-line)
 693       (re-search-backward "[ \t]\\([^ ]+\\):[0-9]")
 694       (setq group (buffer-substring (match-beginning 1) (match-end 1)))
 695       (setq lines (count-lines (point-min) (point-max)))
 696       (setq ident (progn (string-match
 697                           "/\\([0-9]+\\)\\." (car files))
 698                          (substring
 699                           (car files) (match-beginning 1)
 700                           (match-end 1))))
 701       (if (not (setq elem (assoc group active)))
 702           (push (list group (cons 1 lines)
 703                       (list (cons 1 lines)
 704                             (vector ident group "ncm" "" lines)))
 705                 active)
 706         (nconc elem
 707                (list
 708                 (list (cons (setq min (1+ (cdr (car (car
 709                                                      (cdr elem))))))
 710                             (+ min lines))
 711                       (vector ident group "ncm" "" lines))))
 712         (setcdr (cadr elem) (+ min lines)))
 713       (setq files (cdr files)))
 714     (message "")
 715     (setq nnsoup-group-alist active)
 716     (while active
 717       (setcdr (car active) (nreverse (cdr (car active))))
 718       (setq active (cdr active)))
 719     (nnsoup-write-active-file)))
 720
 721 (provide 'nnsoup)
 722
 723 ;;; nnsoup.el ends here