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

   1 ;;; nnsoup.el --- SOUP access for Gnus
   2 ;; Copyright (C) 1995 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
  33 (defvar nnsoup-directory "~/SOUP/"
  34   "*SOUP packet directory directory.")
  35
  36 (defvar nnsoup-replies-directory (concat nnsoup-directory "replies/")
  37   "*Directory where outgoing packets will be composed.")
  38
  39 (defvar nnsoup-replies-format-type ?n
  40   "*Format of the replies packages.")
  41
  42 (defvar nnsoup-replies-index-type ?n
  43   "*Index type of the replies packages.")
  44
  45 (defvar nnsoup-active-file (concat nnsoup-directory "active")
  46   "Active file.")
  47
  48 (defvar nnsoup-packer "tar cf - %s | gzip > $HOME/Soupin%d.tgz"
  49   "Format string command for packing a SOUP packet.
  50 The SOUP files will be inserted where the %s is in the string.
  51 This string MUST contain both %s and %d. The file number will be
  52 inserted where %d appears.")
  53
  54 (defvar nnsoup-unpacker "gunzip -c %s | tar xvf -"
  55   "*Format string command for unpacking a SOUP packet.
  56 The SOUP packet file name will be inserted at the %s.")
  57
  58 (defvar nnsoup-packet-directory "~/"
  59   "*Where nnsoup will look for incoming packets.")
  60
  61 (defvar nnsoup-packet-regexp "Soupout"
  62   "*Regular expression matching SOUP packets in `nnsoup-packet-directory'.")
  63
  64 \f
  65
  66 (defconst nnsoup-version "nnsoup 0.0"
  67   "nnsoup version.")
  68
  69 (defvar nnsoup-status-string "")
  70 (defvar nnsoup-group-alist nil)
  71 (defvar nnsoup-replies-list nil)
  72 (defvar nnsoup-buffers nil)
  73 (defvar nnsoup-current-group nil)
  74
  75 \f
  76
  77 ;; Server variables.
  78
  79 (defvar nnsoup-current-server nil)
  80 (defvar nnsoup-server-alist nil)
  81 (defvar nnsoup-server-variables
  82   (list
  83    (list 'nnsoup-directory nnsoup-directory)
  84    (list 'nnsoup-active-file nnsoup-active-file)
  85    '(nnsoup-status-string "")
  86    '(nnsoup-group-alist nil)))
  87
  88 \f
  89
  90 ;;; Interface functions.
  91
  92 (defun nnsoup-retrieve-headers (sequence &optional group server fetch-old)
  93   (nnsoup-possibly-change-group group)
  94   (save-excursion
  95     (set-buffer nntp-server-buffer)
  96     (erase-buffer)
  97     (let ((areas (cdr (assoc nnsoup-current-group nnsoup-group-alist)))
  98           (articles sequence)
  99           (use-nov t)
 100           useful-areas this-area-seq)
 101       (if (stringp (car sequence))
 102           'headers
 103         ;; We go through all the areas and find which files the
 104         ;; articles in SEQUENCE come from.
 105         (while (and areas sequence)
 106           ;; Peel off areas that are below sequence.
 107           (while (and areas (< (cdr (car (car areas))) (car sequence)))
 108             (setq areas (cdr areas)))
 109           (if (not areas)
 110               ()
 111             ;; This is a useful area.
 112             (setq useful-areas (cons (car areas) useful-areas)
 113                   this-area-seq nil)
 114             ;; We take note whether this MSG has a corresponding IDX
 115             ;; for later use.
 116             (if (or (= (gnus-soup-encoding-index
 117                         (gnus-soup-area-encoding (nth 1 (car areas)))) ?n)
 118                     (not (file-exists-p
 119                           (nnsoup-file
 120                            (gnus-soup-area-prefix (nth 1 (car areas)))))))
 121                 (setq use-nov nil))
 122             ;; We assing the portion of `sequence' that is relevant to
 123             ;; this MSG packet to this packet.
 124             (while (and sequence (<= (car sequence) (cdr (car (car areas)))))
 125               (setq this-area-seq (cons (car sequence) this-area-seq)
 126                     sequence (cdr sequence)))
 127             (setcar useful-areas (cons (nreverse this-area-seq)
 128                                        (car useful-areas)))))
 129
 130         ;; We now have a list of article numbers and corresponding
 131         ;; areas.
 132         (setq useful-areas (nreverse useful-areas))
 133
 134         ;; Two different approaches depending on whether all the MSG
 135         ;; files have corresponding IDX files.  If they all do, we
 136         ;; simply return the relevant IDX files and let Gnus sort out
 137         ;; what lines are relevant.  If some of the IDX files are
 138         ;; missing, we must return HEADs for all the articles.
 139         (if use-nov
 140             (while useful-areas
 141               (goto-char (point-max))
 142               (let ((b (point))
 143                     (number (car (nth 1 (car useful-areas)))))
 144                 (insert-buffer-substring
 145                  (nnsoup-index-buffer
 146                   (gnus-soup-area-prefix
 147                    (nth 2 (car useful-areas)))))
 148                 (goto-char b)
 149                 ;; We have to remove the index number entires and
 150                 ;; insert article numbers instead.
 151                 (while (looking-at "[0-9]+")
 152                   (replace-match (int-to-string number) t t)
 153                   (setq number (1+ number))
 154                   (forward-line 1)))
 155               (setq useful-areas (cdr useful-areas)))
 156           ;; We insert HEADs.
 157           (while useful-areas
 158             (setq articles (car (car useful-areas))
 159                   useful-areas (cdr useful-areas))
 160             (while articles
 161               (goto-char (point-max))
 162               (insert (format "221 %d Article retrieved.\n" (car articles)))
 163               (insert-buffer-substring
 164                (nnsoup-narrow-to-article
 165                 (car articles) (cdr (car useful-areas)) 'head))
 166               (goto-char (point-max))
 167               (insert ".\n")
 168               (setq articles (cdr articles))))
 169
 170           ;; Fold continuation lines.
 171           (goto-char (point-min))
 172           (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
 173             (replace-match " " t t)))
 174         (if use-nov 'nov 'headers)))))
 175
 176 (defun nnsoup-open-server (server &optional defs)
 177   (nnsoup-set-variables)
 178   (nnheader-init-server-buffer)
 179   (if (equal server nnsoup-current-server)
 180       t
 181     (if nnsoup-current-server
 182         (setq nnsoup-server-alist
 183               (cons (list nnsoup-current-server
 184                           (nnheader-save-variables nnsoup-server-variables))
 185                     nnsoup-server-alist)))
 186     (let ((state (assoc server nnsoup-server-alist)))
 187       (if state
 188           (progn
 189             (nnheader-restore-variables (nth 1 state))
 190             (setq nnsoup-server-alist (delq state nnsoup-server-alist)))
 191         (nnheader-set-init-variables nnsoup-server-variables defs)))
 192     (setq nnsoup-current-server server))
 193   (nnsoup-read-active-file))
 194
 195 (defun nnsoup-request-close ()
 196   (nnsoup-write-active-file)
 197   (nnsoup-write-replies)
 198   (while nnsoup-buffers
 199     (and (car nnsoup-buffers)
 200          (buffer-name (car nnsoup-buffers))
 201          (kill-buffer (car nnsoup-buffers)))
 202     (setq nnsoup-buffers (cdr nnsoup-buffers)))
 203   (setq nnsoup-group-alist nil
 204         nnsoup-current-group nil
 205         nnsoup-current-server nil
 206         nnsoup-server-alist nil
 207         nnsoup-replies-list nil)
 208   t)
 209
 210 (defun nnsoup-close-server (&optional server)
 211   t)
 212
 213 (defun nnsoup-server-opened (&optional server)
 214   (and (equal server nnsoup-current-server)
 215        nntp-server-buffer
 216        (buffer-name nntp-server-buffer)))
 217
 218 (defun nnsoup-status-message (&optional server)
 219   nnsoup-status-string)
 220
 221 (defun nnsoup-request-article (id &optional newsgroup server buffer)
 222   (nnsoup-possibly-change-group newsgroup)
 223   (let ((buffer (or buffer nntp-server-buffer)))
 224     (save-excursion
 225       (set-buffer buffer)
 226       (erase-buffer)
 227       (if (stringp id)
 228           ()
 229         (insert-buffer-substring
 230          (nnsoup-narrow-to-article id))
 231         t))))
 232
 233 (defun nnsoup-request-group (group &optional server dont-check)
 234   (nnsoup-possibly-change-group group)
 235   (if dont-check
 236       ()
 237     (let ((area (cdr (assoc group nnsoup-group-alist)))
 238           min max)
 239       (save-excursion
 240         (set-buffer nntp-server-buffer)
 241         (erase-buffer)
 242         (setq min (car (car (car area))))
 243         (while (cdr area)
 244           (setq area (cdr area)))
 245         (setq max (cdr (car (car area))))
 246         (insert (format "211 %d %d %d %s\n"
 247                         (max (1+ (- max min)) 0) min max group)))))
 248   t)
 249
 250 (defun nnsoup-close-group (group &optional server)
 251   t)
 252
 253 (defun nnsoup-request-list (&optional server)
 254   (save-excursion
 255     (set-buffer nntp-server-buffer)
 256     (erase-buffer)
 257     (let ((alist nnsoup-group-alist)
 258           min)
 259       (while alist
 260         (setq min (car (car (nth 1 (car alist)))))
 261         (insert (format "%s %d %d y\n" (car (car alist))
 262                         (let ((areas (car alist)))
 263                           (while (cdr areas)
 264                             (setq areas (cdr areas)))
 265                           (cdr (car (car areas)))) min))
 266         (setq alist (cdr alist)))
 267       t)))
 268
 269 (defun nnsoup-request-scan (group &optional server)
 270   (or nnsoup-group-alist (nnsoup-read-areas))
 271   (nnsoup-unpack-packets))
 272
 273 (defun nnsoup-request-newgroups (date &optional server)
 274   (nnsoup-request-list))
 275
 276 (defun nnsoup-request-list-newsgroups (&optional server)
 277   nil)
 278
 279 (defun nnsoup-request-post (&optional server)
 280   (nnsoup-store-reply "news")
 281   t)
 282
 283 (defun nnsoup-request-mail ()
 284   (nnsoup-store-reply "mail")
 285   t)
 286
 287 \f
 288 ;;; Internal functions
 289
 290 (defun nnsoup-possibly-change-group (group &optional force)
 291   (if group
 292       (setq nnsoup-current-group group)
 293     t))
 294
 295 (defun nnsoup-read-active-file ()
 296   (if (file-exists-p nnsoup-active-file)
 297       (condition-case ()
 298           (load nnsoup-active-file)
 299         (error nil))))
 300
 301 (defun nnsoup-write-active-file ()
 302   (save-excursion
 303     (set-buffer (get-buffer-create " *nnsoup work*"))
 304     (buffer-disable-undo (current-buffer))
 305     (erase-buffer)
 306     (insert (format "(setq nnsoup-group-alist '%S)\n" nnsoup-group-alist))
 307     (write-region (point-min) (point-max) nnsoup-active-file
 308                   nil 'silent)
 309     (kill-buffer (current-buffer))))
 310
 311 (defun nnsoup-read-areas ()
 312   (save-excursion
 313     (set-buffer nntp-server-buffer)
 314     (let ((areas (gnus-soup-parse-areas (concat nnsoup-directory "AREAS")))
 315           entry number area lnum)
 316       ;; Go through all areas in the new AREAS file.
 317       (while areas
 318         (setq area (car areas)
 319               areas (cdr areas))
 320         ;; Find the number of new articles in this area.
 321         (setq number (nnsoup-number-of-articles area))
 322         (if (not (setq entry (assoc (gnus-soup-area-name area)
 323                                     nnsoup-group-alist)))
 324             ;; If this is a new area (group), we just add this info to
 325             ;; the group alist.
 326             (setq nnsoup-group-alist
 327                   (cons (list (gnus-soup-area-name area)
 328                               (list (cons 1 number) area))
 329                         nnsoup-group-alist))
 330           ;; There are already articles in this group, so we add this
 331           ;; info to the end of the entry.
 332           (let ((e (cdr entry)))
 333             (while (cdr e)
 334               (setq e (cdr e)))
 335             (setcdr e (list (list (cons (setq lnum (1+ (cdr (car (car e)))))
 336                                         (+ lnum number))
 337                                   area)))))))
 338     (nnsoup-write-active-file)))
 339
 340 (defun nnsoup-number-of-articles (area)
 341   (save-excursion
 342     (cond
 343      ;; If the number is in the area info, we just return it.
 344      ((gnus-soup-area-number area)
 345       (gnus-soup-area-number area))
 346      ;; If there is an index file, we just count the lines.
 347      ((/= (gnus-soup-encoding-index (gnus-soup-area-encoding area)) ?n)
 348       (set-buffer (nnsoup-index-buffer (gnus-soup-area-prefix area)))
 349       (count-lines (point-min) (point-max)))
 350      ;; We do it the hard way - re-searching through the message
 351      ;; buffer.
 352      (t
 353       (set-buffer (nnsoup-message-buffer (gnus-soup-area-prefix area)))
 354       (goto-char (point-min))
 355       (let ((regexp (nnsoup-header (gnus-soup-encoding-format
 356                                     (gnus-soup-area-encoding area))))
 357             (num 0))
 358         (while (re-search-forward regexp nil t)
 359           (setq num (1+ num)))
 360         num)))))
 361
 362 (defun nnsoup-index-buffer (prefix &optional message)
 363   (let* ((file (concat prefix (if message ".MSG" ".IDX")))
 364          (buffer-name (concat " *nnsoup " file "*")))
 365     (or (get-buffer buffer-name)        ; File aready loaded.
 366         (save-excursion                 ; Load the file.
 367           (set-buffer (get-buffer-create buffer-name))
 368           (setq nnsoup-buffers (cons (current-buffer) nnsoup-buffers))
 369           (insert-file-contents (concat nnsoup-directory file))
 370           (current-buffer)))))
 371
 372 (defun nnsoup-file (prefix &optional message)
 373   (concat nnsoup-directory prefix (if message ".MSG" ".IDX")))
 374
 375 (defun nnsoup-message-buffer (prefix)
 376   (nnsoup-index-buffer prefix 'msg))
 377
 378 (defun nnsoup-unpack-packets ()
 379   (let ((packets (directory-files
 380                   nnsoup-packet-directory t nnsoup-packet-regexp))
 381         msg)
 382     (while packets
 383       (message (setq msg (format "nnsoup: unpacking %s..." (car packets))))
 384       (gnus-soup-unpack-packet nnsoup-directory nnsoup-unpacker (car packets))
 385       (delete-file (car packets))
 386       (nnsoup-read-areas)
 387       (message "%sdone" msg)
 388       (setq packets (cdr packets)))))
 389
 390 (defun nnsoup-narrow-to-article (article &optional area head)
 391   (let* ((area (or area (nnsoup-article-to-area article nnsoup-current-group)))
 392          (prefix (gnus-soup-area-prefix (nth 1 area)))
 393          beg end msg-buf)
 394     (setq msg-buf (nnsoup-index-buffer prefix 'msg))
 395     (save-excursion
 396       (cond
 397        ;; We use the index file to find out where the article begins and ends.
 398        ((and (= (gnus-soup-encoding-index
 399                  (gnus-soup-area-encoding (nth 1 area)))
 400                 ?c)
 401              (file-exists-p (nnsoup-file prefix)))
 402         (set-buffer (nnsoup-index-buffer prefix))
 403         (widen)
 404         (goto-char (point-min))
 405         (forward-line (- article (car (car area))))
 406         (setq beg (read (current-buffer)))
 407         (forward-line 1)
 408         (if (looking-at "[0-9]+")
 409             (progn
 410               (setq end (read (current-buffer)))
 411               (set-buffer msg-buf)
 412               (widen)
 413               (let ((format (gnus-soup-encoding-format
 414                              (gnus-soup-area-encoding (nth 1 area)))))
 415                 (goto-char end)
 416                 (if (or (= format ?n) (= format ?m))
 417                     (setq end (progn (forward-line -1) (point))))))
 418           (set-buffer msg-buf))
 419         (widen)
 420         (narrow-to-region beg (or end (point-max))))
 421        (t
 422         (set-buffer msg-buf)
 423         (widen)
 424         (goto-char (point-min))
 425         (let ((header (nnsoup-header
 426                        (gnus-soup-encoding-format
 427                         (gnus-soup-area-encoding (nth 1 area))))))
 428           (re-search-forward header nil t (- article (car (car area))))
 429           (narrow-to-region
 430            (match-beginning 0)
 431            (if (re-search-forward header nil t)
 432                (match-beginning 0)
 433              (point-max))))))
 434       (goto-char (point-min))
 435       (if (not head)
 436           ()
 437         (narrow-to-region
 438          (point-min)
 439          (if (search-forward "\n\n" nil t)
 440              (1- (point))
 441            (point-max))))
 442       msg-buf)))
 443
 444 (defun nnsoup-header (format)
 445   (cond
 446    ((= format ?n)
 447     "^#! *rnews +[0-9]+ *$")
 448    ((= format ?m)
 449     (concat "^" rmail-unix-mail-delimiter))
 450    ((= format ?M)
 451     "^\^A\^A\^A\^A\n")
 452    (t
 453     (error "Unknown format: %c" format))))
 454
 455 (defun nnsoup-pack-replies ()
 456   "Make an outbound package of SOUP replies."
 457   (interactive)
 458   (nnsoup-write-active-file)
 459   (nnsoup-write-replies)
 460   (gnus-soup-pack nnsoup-replies-directory nnsoup-packer))
 461
 462 (defun nnsoup-write-replies ()
 463   (gnus-soup-write-replies nnsoup-replies-directory nnsoup-replies-list))
 464
 465 (defun nnsoup-article-to-area (article group)
 466   (let ((areas (cdr (assoc group nnsoup-group-alist))))
 467     (while (and areas (< (cdr (car (car areas))) article))
 468       (setq areas (cdr areas)))
 469     (and areas (car areas))))
 470
 471 (defun nnsoup-set-variables ()
 472   (setq gnus-inews-article-function 'nnsoup-request-post)
 473   (setq gnus-mail-send-method 'nnsoup-request-mail)
 474   (setq send-mail-function 'nnsoup-request-mail))
 475
 476 (defun nnsoup-store-reply (kind)
 477   ;; Mostly stolen from `sendmail.el'.
 478   (let ((tembuf (generate-new-buffer " sendmail temp"))
 479         (case-fold-search nil)
 480         (mailbuf (current-buffer))
 481         delimline)
 482     (save-excursion
 483       (set-buffer tembuf)
 484       (erase-buffer)
 485       (insert-buffer-substring mailbuf)
 486       (goto-char (point-max))
 487       ;; require one newline at the end.
 488       (or (= (preceding-char) ?\n)
 489           (insert ?\n))
 490       ;; Change header-delimiter to be what sendmail expects.
 491       (goto-char (point-min))
 492       (re-search-forward
 493         (concat "^" (regexp-quote mail-header-separator) "\n"))
 494       (replace-match "\n")
 495       (backward-char 1)
 496       (setq delimline (point-marker))
 497       (if mail-aliases (expand-mail-aliases (point-min) delimline))
 498       (goto-char (point-min))
 499       ;; ignore any blank lines in the header
 500       (while (and (re-search-forward "\n\n\n*" delimline t)
 501                   (< (point) delimline))
 502         (replace-match "\n"))
 503       (let ((case-fold-search t))
 504         (goto-char (point-min))
 505         ;; Find and handle any FCC fields.
 506         (goto-char (point-min))
 507         (if (re-search-forward "^FCC:" delimline t)
 508             (mail-do-fcc delimline))
 509         (goto-char (point-min))
 510         ;; "S:" is an abbreviation for "Subject:".
 511         (goto-char (point-min))
 512         (if (re-search-forward "^S:" delimline t)
 513             (replace-match "Subject:"))
 514         ;; Don't send out a blank subject line
 515         (goto-char (point-min))
 516         (if (re-search-forward "^Subject:[ \t]*\n" delimline t)
 517             (replace-match ""))
 518         ;; Insert an extra newline if we need it to work around
 519         ;; Sun's bug that swallows newlines.
 520         (goto-char (1+ delimline))
 521         (if (eval mail-mailer-swallows-blank-line)
 522             (newline)))
 523       (gnus-soup-store
 524        nnsoup-replies-directory
 525        (nnsoup-kind-to-prefix kind) nil nnsoup-replies-format-type
 526        nnsoup-replies-index-type)
 527       (kill-buffer tembuf))))
 528
 529 (defun nnsoup-kind-to-prefix (kind)
 530   (or nnsoup-replies-list
 531       (setq nnsoup-replies-list
 532             (gnus-soup-parse-replies
 533              (concat nnsoup-replies-directory "REPLIES"))))
 534   (let ((replies nnsoup-replies-list))
 535     (while (and replies
 536                 (not (string= kind (gnus-soup-reply-kind (car replies)))))
 537       (setq replies (cdr replies)))
 538     (if replies
 539         (gnus-soup-reply-prefix (car replies))
 540       (setq nnsoup-replies-list
 541             (cons (vector (gnus-soup-unique-prefix nnsoup-replies-directory)
 542                           kind
 543                           (format "%c%c%c"
 544                                   nnsoup-replies-format-type
 545                                   nnsoup-replies-index-type
 546                                   (if (string= kind "news")
 547                                       ?n ?m)))
 548                   nnsoup-replies-list))
 549       (gnus-soup-reply-prefix (car nnsoup-replies-list)))))
 550
 551 (provide 'nnsoup)
 552
 553 ;;; nnsoup.el ends here