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

   1 ;;; nnsoup.el --- SOUP packet reading access for Gnus
   2 ;; Copyright (C) 1995 Free Software Foundation, Inc.
   3
   4 ;; Author: Per Abrahamsen <abraham@iesd.auc.dk>
   5 ;;      Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
   6 ;;      Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
   7 ;; Keywords: news, mail
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  23 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; For an overview of what the interface functions do, please see the
  28 ;; Gnus sources.
  29
  30 ;; For more information on SOUP, see the comments in the file
  31 ;; `gnus-soup.el'.
  32
  33 ;;; Code:
  34
  35 (require 'gnus-soup)
  36 (require 'nnheader)
  37 (require 'rmail)
  38 (require 'nnmail)
  39
  40 (defvar nnsoup-directory (expand-file-name "~/SOUP/")
  41   "The name of the directory containing the unpacket SOUP packet.")
  42
  43 \f
  44
  45 (defconst nnsoup-version "nnsoup 0.0"
  46   "nnsoup version.")
  47
  48 (defconst nnsoup-areas-file (concat nnsoup-directory  "AREAS"))
  49 (defconst nnsoup-list-file (concat nnsoup-directory "LIST"))
  50 (defconst nnsoup-gnus-file (concat nnsoup-directory "gnus.touched"))
  51
  52 (defvar nnsoup-current-group nil)
  53 (defvar nnsoup-current-buffer nil)
  54 (defvar nnsoup-status-string "")
  55 (defvar nnsoup-group-alist nil)
  56 (defvar nnsoup-buffer-alist nil)
  57 (defconst nnsoup-areas-list nil)
  58
  59 ;;; Interface functions
  60
  61 (defun nnsoup-retrieve-headers (sequence &optional newsgroup server)
  62   (save-excursion
  63     (set-buffer nntp-server-buffer)
  64     (erase-buffer)
  65     (let ((file nil)
  66           (number (length sequence))
  67           beg article art-string start stop)
  68       (nnsoup-possibly-change-group newsgroup)
  69       (while sequence
  70         (setq article (car sequence))
  71         (setq art-string (nnsoup-article-string article))
  72         (set-buffer nnsoup-current-buffer)
  73         (if (or (search-forward art-string nil t)
  74                 (progn (goto-char 1)
  75                        (search-forward art-string nil t)))
  76             (progn
  77               (setq start
  78                     (save-excursion
  79                       (re-search-backward
  80                        (concat "^" rmail-unix-mail-delimiter) nil t)
  81                       (point)))
  82               (search-forward "\n\n" nil t)
  83               (setq stop (1- (point)))
  84               (set-buffer nntp-server-buffer)
  85               (insert (format "221 %d Article retrieved.\n" article))
  86               (setq beg (point))
  87               (insert-buffer-substring nnsoup-current-buffer start stop)
  88               (goto-char (point-max))
  89               (insert ".\n")))
  90         (setq sequence (cdr sequence)))
  91
  92       ;; Fold continuation lines.
  93       (goto-char 1)
  94       (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
  95         (replace-match " " t t))
  96       'headers)))
  97
  98 (defun nnsoup-open-server (host &optional service)
  99   (setq nnsoup-status-string "")
 100   (setq nnsoup-group-alist nil)
 101   (nnheader-init-server-buffer))
 102
 103 (defun nnsoup-close-server (&optional server)
 104   t)
 105
 106 (defun nnsoup-server-opened (&optional server)
 107   (and nntp-server-buffer
 108        (buffer-name nntp-server-buffer)))
 109
 110 (defun nnsoup-status-message (&optional server)
 111   nnsoup-status-string)
 112
 113 (defun nnsoup-request-article (article &optional newsgroup server buffer)
 114   (nnsoup-possibly-change-group newsgroup)
 115   (if (stringp article)
 116       nil
 117     (save-excursion
 118       (set-buffer nnsoup-current-buffer)
 119       (goto-char 1)
 120       (if (search-forward (nnsoup-article-string article) nil t)
 121           (let (start stop)
 122             (re-search-backward (concat "^" rmail-unix-mail-delimiter) nil t)
 123             (setq start (point))
 124             (forward-line 1)
 125             (or (and (re-search-forward
 126                       (concat "^" rmail-unix-mail-delimiter) nil t)
 127                      (forward-line -1))
 128                 (goto-char (point-max)))
 129             (setq stop (point))
 130             (let ((nntp-server-buffer (or buffer nntp-server-buffer)))
 131               (set-buffer nntp-server-buffer)
 132               (erase-buffer)
 133               (insert-buffer-substring nnsoup-current-buffer start stop)
 134               (goto-char (point-min))
 135               (while (looking-at "From ")
 136                 (delete-char 5)
 137                 (insert "X-From-Line: ")
 138                 (forward-line 1))
 139               t))))))
 140
 141 (defun nnsoup-request-group (group &optional server dont-check)
 142   (save-excursion
 143     (nnsoup-possibly-change-group group)
 144     (and (assoc group nnsoup-group-alist)
 145          (save-excursion
 146            (set-buffer nntp-server-buffer)
 147            (erase-buffer)
 148            (if dont-check
 149                t
 150              (nnsoup-request-list)
 151              (setq nnsoup-group-alist (nnmail-get-active))
 152              (let ((active (assoc group nnsoup-group-alist)))
 153                (insert (format "211 %d %d %d %s\n"
 154                                (1+ (- (cdr (car (cdr active)))
 155                                       (car (car (cdr active)))))
 156                                (car (car (cdr active)))
 157                                (cdr (car (cdr active)))
 158                                (car active))))
 159              t)))))
 160
 161 (defun nnsoup-close-group (group &optional server)
 162   t)
 163
 164 (defun nnsoup-request-list (&optional server)
 165   (if server
 166       (if (or (file-exists-p nnsoup-gnus-file)
 167               (not (file-directory-p nnsoup-directory)))
 168           ()
 169         (write-region 1 1 nnsoup-gnus-file)
 170         (setq nnsoup-areas-list nil
 171               nnsoup-current-group nil
 172               nnsoup-current-buffer nil
 173               nnsoup-group-alist nil)
 174         (let ((buffer (get-file-buffer nnsoup-areas-file))
 175               (groups gnus-newsrc-assoc)
 176               group)
 177           (while groups
 178             (setq group (car groups)
 179                   groups (cdr groups))
 180             (if (eq (car (gnus-group-method-name (car group))) 'nnsoup)
 181                 (progn
 182                   (setcar (nthcdr 2 group) nil)
 183                   (setcar (nthcdr 3 group) nil))))
 184           (gnus-make-hashtable-from-newsrc-alist)
 185           (if buffer
 186               (kill-buffer buffer))
 187           (while nnsoup-buffer-alist
 188             (setq buffer (nth 1 (car nnsoup-buffer-alist))
 189                   nnsoup-buffer-alist (cdr nnsoup-buffer-alist))
 190             (if (buffer-name buffer)
 191                 (kill-buffer buffer))))))
 192   (nnsoup-find-active))
 193
 194 (defun nnsoup-request-newgroups (date &optional server)
 195   (nnsoup-request-list server))
 196
 197 (defun nnsoup-request-list-newsgroups (&optional server)
 198   (nnmail-find-file nnsoup-newsgroups-file))
 199
 200 (defun nnsoup-request-post (&optional server)
 201   (mail-send-and-exit nil))
 202
 203 (fset 'nnsoup-request-post-buffer 'nnmail-request-post-buffer)
 204
 205 (defun nnsoup-request-expire-articles (articles newsgroup &optional server force)
 206   (setq nnsoup-status-string "nnsoup: expire not possible")
 207   nil)
 208
 209 (defun nnsoup-request-move-article (article group server accept-form)
 210   (setq nnsoup-status-string "nnsoup: move not possible")
 211   nil)
 212
 213 (defun nnsoup-request-accept-article (group)
 214   (setq nnsoup-status-string "nnsoup: accept not possible")
 215   nil)
 216
 217 \f
 218 ;;; Internal functions.
 219
 220 (defun nnsoup-possibly-change-group (group)
 221   (or (file-exists-p nnsoup-directory)
 222       (make-directory (directory-file-name nnsoup-directory)))
 223   (if (not nnsoup-group-alist)
 224       (progn
 225         (nnsoup-request-list)
 226         (setq nnsoup-group-alist (nnmail-get-active))))
 227   (let (inf file)
 228     (if (and (equal group nnsoup-current-group)
 229              (buffer-name nnsoup-current-buffer))
 230         ()
 231       (if (setq inf (member group nnsoup-buffer-alist))
 232           (setq nnsoup-current-buffer (nth 1 inf)))
 233       (setq nnsoup-current-group group)
 234       (if (not (buffer-name nnsoup-current-buffer))
 235           (progn
 236             (setq nnsoup-buffer-alist (delq inf nnsoup-buffer-alist))
 237             (setq inf nil)))
 238       (if inf
 239           ()
 240         (save-excursion
 241           (setq file (nnsoup-group-file group))
 242 ;;;;      (if (not (file-exists-p file))
 243 ;;;;          (write-region 1 1 file t 'nomesg))
 244           (set-buffer (nnsoup-read-folder file))
 245           (setq nnsoup-buffer-alist (cons (list group (current-buffer))
 246                                             nnsoup-buffer-alist))))))
 247   (setq nnsoup-current-group group))
 248
 249 (defun nnsoup-article-string (article)
 250   (concat "\nX-Gnus-Article-Number: " (int-to-string article) " "))
 251
 252 (defun nnsoup-read-folder (file)
 253   (nnsoup-request-list)
 254   (setq nnsoup-group-alist (nnmail-get-active))
 255   (save-excursion
 256     (set-buffer
 257      (setq nnsoup-current-buffer
 258            (find-file-noselect file)))
 259     (buffer-disable-undo (current-buffer))
 260     (let ((delim (concat "^" rmail-unix-mail-delimiter))
 261           start end
 262           (number 1))
 263       (goto-char (point-min))
 264       (while (re-search-forward delim nil t)
 265         (setq start (match-beginning 0))
 266         (save-excursion
 267           (setq end (or (and (re-search-forward delim nil t)
 268                              (match-beginning 0))
 269                         (point-max))))
 270         (save-excursion
 271           (save-restriction
 272             (narrow-to-region start end)
 273             (nnmail-insert-lines)
 274             (save-excursion
 275               (goto-char (point-min))
 276               (if (search-forward "\n\n" nil t)
 277                   (progn
 278                     (forward-char -1)
 279                     (insert (format "X-Gnus-Article-Number: %d   %s\n"
 280                                     number (current-time-string))))))
 281             (setq number (1+ number))))
 282         (goto-char end)))
 283     (set-buffer-modified-p nil)
 284     (current-buffer)))
 285
 286 (defun nnsoup-find-active ()
 287   (set-buffer nntp-server-buffer)
 288   (erase-buffer)
 289   (or nnsoup-areas-list (nnsoup-read-areas))
 290   (condition-case ()
 291       (progn
 292         (let ((areas nnsoup-areas-list)
 293               area)
 294           (while areas
 295             (setq area (car areas)
 296                   areas (cdr areas))
 297             (insert (format "%s %s 1 y\n" (aref area 1) (aref area 4)))))
 298         t)
 299     (file-error nil)))
 300
 301 (defun nnsoup-read-areas ()
 302   (setq nnsoup-areas-list (gnus-soup-parse-areas nnsoup-areas-file))
 303   (let ((areas nnsoup-areas-list)
 304         area)
 305     (while areas
 306       (setq area (car areas)
 307             areas (cdr areas))
 308       (aset area 4 (nnsoup-count-area area)))))
 309
 310 (defun nnsoup-count-area (area)
 311   (or (aref area 4)
 312       (number-to-string
 313        (nnsoup-count-mbox (concat nnsoup-directory (aref area 0) ".MSG")))))
 314
 315 (defun nnsoup-count-mbox (file)
 316   (let ((delete (find-buffer-visiting file))
 317         (num 0)
 318         (delim (concat "^" rmail-unix-mail-delimiter)))
 319     (save-excursion
 320       (set-buffer (find-file-noselect file))
 321       (goto-char (point-min))
 322       (while (re-search-forward delim nil t)
 323         (setq num (1+ num)))
 324       (if delete (kill-buffer delete))
 325       num)))
 326
 327 (defun nnsoup-group-file (group)
 328   (let ((areas nnsoup-areas-list)
 329         area result)
 330     (while areas
 331       (setq area (car areas)
 332             areas (cdr areas))
 333       (if (equal (aref area 1) group)
 334           (setq result (concat nnsoup-directory (aref area 0) ".MSG"))))
 335     result))
 336
 337 (provide 'nnsoup)
 338
 339 ;;; nnsoup.el ends here