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