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

   1 ;;; nneething.el --- random file 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 ;; Based on nnspool.el by Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>.
  27 ;; For an overview of what the interface functions do, please see the
  28 ;; Gnus sources.
  29
  30 ;;; Code:
  31
  32 (require 'nnheader)
  33 (require 'nnmail)
  34
  35 (defvar nneething-map-file-directory "~/.nneething/"
  36   "*Map files directory.")
  37
  38 (defvar nneething-exclude-files "~$"
  39   "*Regexp saying what files to exclude from the group.")
  40
  41 (defvar nneething-map-file ".nneething"
  42   "*Name of map files.")
  43
  44 \f
  45
  46 (defconst nneething-version "nneething 0.1"
  47   "nneething version.")
  48
  49 (defvar nneething-current-directory nil
  50   "Current news group directory.")
  51
  52 (defvar nneething-status-string "")
  53 (defvar nneething-group-alist nil)
  54
  55 \f
  56
  57 (defvar nneething-directory nil)
  58 (defvar nneething-group nil)
  59 (defvar nneething-map nil)
  60 (defvar nneething-read-only nil)
  61 (defvar nneething-active nil)
  62 (defvar nneething-server-variables
  63   (list
  64    (list 'nneething-directory nneething-directory)
  65    '(nneething-current-directory nil)
  66    '(nneething-status-string "")
  67    '(nneething-group-alist)))
  68
  69 \f
  70
  71 ;;; Interface functions.
  72
  73 (defun nneething-retrieve-headers (sequence &optional newsgroup server)
  74   (nneething-possibly-change-directory newsgroup)
  75
  76   (save-excursion
  77     (set-buffer nntp-server-buffer)
  78     (erase-buffer)
  79     (let* ((number (length sequence))
  80            (count 0)
  81            (large (and (numberp nnmail-large-newsgroup)
  82                        (> number nnmail-large-newsgroup)))
  83            beg article file)
  84
  85       (if (stringp (car sequence))
  86           'headers
  87
  88         (while sequence
  89           (setq article (car sequence))
  90           (setq file (nneething-file-name article))
  91
  92           (if (and (file-exists-p file)
  93                    (> (nth 7 (file-attributes file)) 0))
  94               (progn
  95                 (insert (format "221 %d Article retrieved.\n" article))
  96                 (nneething-insert-head file)
  97                 (insert ".\n")))
  98
  99           (setq sequence (cdr sequence)
 100                 count (1+ count))
 101
 102           (and large
 103                (zerop (% count 20))
 104                (message "nneething: Receiving headers... %d%%"
 105                         (/ (* count 100) number))))
 106
 107         (and large (message "nneething: Receiving headers...done"))
 108
 109         ;; Fold continuation lines.
 110         (goto-char (point-min))
 111         (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
 112           (replace-match " " t t))
 113         'headers))))
 114
 115 (defun nneething-open-server (server &optional defs)
 116   (setq nneething-status-string "")
 117   (nnheader-init-server-buffer))
 118
 119 (defun nneething-close-server (&optional server)
 120   t)
 121
 122 (defun nneething-server-opened (&optional server)
 123   t)
 124
 125 (defun nneething-status-message (&optional server)
 126   nneething-status-string)
 127
 128 (defun nneething-request-article (id &optional newsgroup server buffer)
 129   (nneething-possibly-change-directory newsgroup)
 130   (let ((file (if (stringp id) nil (nneething-file-name id)))
 131         (nntp-server-buffer (or buffer nntp-server-buffer)))
 132     (and (stringp file)                 ; We did not request by Message-ID.
 133          (file-exists-p file)           ; The file exists.
 134          (not (file-directory-p file))  ; It's not a dir.
 135          (save-excursion
 136            (nnmail-find-file file)      ; Insert the file in the nntp buf.
 137            (or (nnheader-article-p)     ; Either it's a real article...
 138                (progn
 139                  (goto-char (point-min))
 140                  (nneething-make-head file) ; ... or we fake some headers.
 141                  (insert "\n")))
 142            t))))
 143
 144 (defun nneething-request-group (group &optional dir dont-check)
 145   (nneething-possibly-change-directory group dir)
 146   (or dont-check (nneething-create-mapping))
 147   (save-excursion
 148     (set-buffer nntp-server-buffer)
 149     (erase-buffer)
 150     (if (> (car nneething-active) (cdr nneething-active))
 151         (insert (format "211 0 1 0 %s\n" group))
 152       (insert (format "211 %d %d %d %s\n"
 153                       (- (1+ (cdr nneething-active)) (car nneething-active))
 154                       (car nneething-active) (cdr nneething-active)
 155                       group)))
 156     t))
 157
 158 (defun nneething-request-list (&optional server dir)
 159   (save-excursion
 160     (set-buffer nntp-server-buffer)
 161     (erase-buffer))
 162   nil)
 163
 164 (defun nneething-request-newgroups (date &optional server)
 165   (save-excursion
 166     (set-buffer nntp-server-buffer)
 167     (erase-buffer))
 168   nil)
 169
 170 (defun nneething-request-post (&optional server)
 171   (mail-send-and-exit nil))
 172
 173 (defalias 'nneething-request-post-buffer 'nnmail-request-post-buffer)
 174
 175 (defun nneething-close-group (group &optional server)
 176   t)
 177
 178 \f
 179 ;;; Internal functions.
 180
 181 (defun nneething-possibly-change-directory (group &optional dir)
 182   (if (not group)
 183       ()
 184     (if (and nneething-group
 185              (string= group nneething-group))
 186         t
 187       (let (entry)
 188         (if (setq entry (assoc group nneething-group-alist))
 189             (progn
 190               (setq nneething-group group)
 191               (setq nneething-directory (nth 1 entry))
 192               (setq nneething-map (nth 2 entry))
 193               (setq nneething-active (nth 3 entry)))
 194           (setq nneething-group group)
 195           (setq nneething-directory dir)
 196           (setq nneething-map nil)
 197           (setq nneething-active (cons 1 0))
 198           (nneething-create-mapping)
 199           (setq nneething-group-alist
 200                 (cons (list group dir nneething-map nneething-active)
 201                       nneething-group-alist)))))))
 202
 203 (defun nneething-map-file ()
 204   ;; We store it in a special directory under the user's home dir.
 205   (concat (file-name-as-directory nneething-map-file-directory)
 206           nneething-group nneething-map-file))
 207
 208 (defun nneething-create-mapping ()
 209   ;; Read nneething-active and nneething-map
 210   (let ((map-file (nneething-map-file))
 211         (files (directory-files nneething-directory))
 212         (dir (file-name-as-directory nneething-directory))
 213         touched)
 214     (if (file-exists-p map-file)
 215         (condition-case nil
 216             (load map-file nil t t)
 217           (error nil)))
 218     (or nneething-active (setq nneething-active (cons 1 0)))
 219     ;; Remove files matching that regexp.
 220     (let ((f files)
 221           prev)
 222       (while f
 223         (if (string-match nneething-exclude-files (car f))
 224             (if prev (setcdr prev (cdr f))
 225               (setq files (cdr files)))
 226           (setq prev f))
 227         (setq f (cdr f))))
 228     ;; Remove files that have disappeared from the map.
 229     (let ((map nneething-map)
 230           prev)
 231       (while map
 232         (if (member (car (car map)) files)
 233             (setq prev map)
 234           (setq touched t)
 235           (if prev
 236               (setcdr prev (cdr map))
 237             (setq nneething-map (cdr nneething-map))))
 238         (setq map (cdr map))))
 239     ;; Find all new files and enter them into the map.
 240     (while files
 241       (or (assoc (car files) nneething-map) ; If already in the map, ignore.
 242           (progn
 243             (setq touched t)
 244             (setcdr nneething-active (1+ (cdr nneething-active)))
 245             (setq nneething-map
 246                   (cons (cons (car files) (cdr nneething-active)) nneething-map))))
 247       (setq files (cdr files)))
 248     (if (or (not touched) nneething-read-only)
 249         ()
 250       (save-excursion
 251         (set-buffer (get-buffer-create " *nneething map*"))
 252         (buffer-disable-undo (current-buffer))
 253         (erase-buffer)
 254         (insert "(setq nneething-map '" (prin1-to-string nneething-map) ")\n"
 255                 "(setq nneething-active '" (prin1-to-string nneething-active)
 256                 ")\n")
 257         (write-region (point-min) (point-max) map-file nil 'nomesg)
 258         (kill-buffer (current-buffer))))))
 259
 260 (defvar nneething-message-id-number 0)
 261 (defvar nneething-work-buffer " *nneething work*")
 262
 263 (defun nneething-insert-head (file)
 264   (and (nneething-get-head file)
 265        (insert-buffer-substring nneething-work-buffer)))
 266
 267 (defun nneething-make-head (file)
 268   (let ((atts (file-attributes file)))
 269     (insert "Subject: " (file-name-nondirectory file) "\n"
 270             "Message-ID: <nneething-"
 271             (int-to-string
 272              (setq nneething-message-id-number
 273                    (1+ nneething-message-id-number)))
 274             "@" (system-name) ">\n"
 275             "Date: " (current-time-string (nth 5 atts)) "\n"
 276             (nneething-from-line (nth 2 atts))
 277             "Chars: " (int-to-string (nth 7 atts)) "\n")))
 278
 279 (defun nneething-from-line (uid)
 280   (let ((login (condition-case nil
 281                    (user-login-name uid)
 282                  (error
 283                   (cond ((= uid (user-uid)) (user-login-name))
 284                         ((zerop uid) "root")
 285                         (t (int-to-string uid))))))
 286         (name (condition-case nil
 287                   (user-full-name uid)
 288                 (error
 289                  (cond ((= uid (user-uid)) (user-full-name))
 290                        ((zerop uid) "Ms. Root"))))))
 291     (concat "From: " login "@" (system-name)
 292             (if name (concat " (" name ")") "") "\n")))
 293
 294 (defun nneething-get-head (file)
 295   (save-excursion
 296     (set-buffer (get-buffer-create nneething-work-buffer))
 297     (setq case-fold-search nil)
 298     (buffer-disable-undo (current-buffer))
 299     (erase-buffer)
 300     (cond
 301      ((not (file-exists-p file))
 302       ;; The file do not exist.
 303       nil)
 304      ((not (file-regular-p file))
 305       ;; It's a dir, so we fudge a head.
 306       (nneething-make-head file) t)
 307      (t
 308       ;; We examine the file.
 309       (nnheader-insert-head file)
 310       (if (nnheader-article-p)
 311           (delete-region
 312            (progn
 313              (goto-char (point-min))
 314              (or (and (search-forward "\n\n" nil t)
 315                       (1- (point)))
 316                  (point-max)))
 317            (point-max))
 318         (erase-buffer)
 319         (nneething-make-head file) t)))))
 320
 321 (defun nneething-number-to-file (number)
 322   (car (rassq number nneething-map)))
 323
 324 (defun nneething-file-name (article)
 325   (concat (file-name-as-directory nneething-directory)
 326           (if (numberp article) (nneething-number-to-file article)
 327             article)))
 328
 329 (provide 'nneething)
 330
 331 ;;; nneething.el ends here