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 (file-exists-p file)
  93               (progn
  94                 (insert (format "221 %d Article retrieved.\n" article))
  95                 (nneething-insert-head file)
  96                 (insert ".\n")))
  97
  98           (setq sequence (cdr sequence)
  99                 count (1+ count))
 100
 101           (and large
 102                (zerop (% count 20))
 103                (message "nneething: Receiving headers... %d%%"
 104                         (/ (* count 100) number))))
 105
 106         (and large (message "nneething: Receiving headers...done"))
 107
 108         ;; Fold continuation lines.
 109         (goto-char (point-min))
 110         (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
 111           (replace-match " " t t))
 112         'headers))))
 113
 114 (defun nneething-open-server (server &optional defs)
 115   (setq nneething-status-string "")
 116   (nnheader-init-server-buffer))
 117
 118 (defun nneething-close-server (&optional server)
 119   t)
 120
 121 (defun nneething-server-opened (&optional server)
 122   t)
 123
 124 (defun nneething-status-message (&optional server)
 125   nneething-status-string)
 126
 127 (defun nneething-request-article (id &optional newsgroup server buffer)
 128   (nneething-possibly-change-directory newsgroup)
 129   (let ((file (if (stringp id) nil (nneething-file-name id)))
 130         (nntp-server-buffer (or buffer nntp-server-buffer)))
 131     (and (stringp file)                 ; We did not request by Message-ID.
 132          (file-exists-p file)           ; The file exists.
 133          (not (file-directory-p file))  ; It's not a dir.
 134          (save-excursion
 135            (nnmail-find-file file)      ; Insert the file in the nntp buf.
 136            (or (nnheader-article-p)     ; Either it's a real article...
 137                (progn
 138                  (goto-char (point-min))
 139                  (nneething-make-head file) ; ... or we fake some headers.
 140                  (insert "\n")))
 141            t))))
 142
 143 (defun nneething-request-group (group &optional dir dont-check)
 144   (nneething-possibly-change-directory group dir)
 145   (or dont-check (nneething-create-mapping))
 146   (save-excursion
 147     (set-buffer nntp-server-buffer)
 148     (erase-buffer)
 149     (if (> (car nneething-active) (cdr nneething-active))
 150         (insert (format "211 0 1 0 %s\n" group))
 151       (insert (format "211 %d %d %d %s\n"
 152                       (- (1+ (cdr nneething-active)) (car nneething-active))
 153                       (car nneething-active) (cdr nneething-active)
 154                       group)))
 155     t))
 156
 157 (defun nneething-request-list (&optional server dir)
 158   (save-excursion
 159     (set-buffer nntp-server-buffer)
 160     (erase-buffer))
 161   nil)
 162
 163 (defun nneething-request-newgroups (date &optional server)
 164   (save-excursion
 165     (set-buffer nntp-server-buffer)
 166     (erase-buffer))
 167   nil)
 168
 169 (defun nneething-request-post (&optional server)
 170   (mail-send-and-exit nil))
 171
 172 (defalias 'nneething-request-post-buffer 'nnmail-request-post-buffer)
 173
 174 (defun nneething-close-group (group &optional server)
 175   t)
 176
 177 \f
 178 ;;; Internal functions.
 179
 180 (defun nneething-possibly-change-directory (group &optional dir)
 181   (if (not group)
 182       ()
 183     (if (and nneething-group
 184              (string= group nneething-group))
 185         t
 186       (let (entry)
 187         (if (setq entry (assoc group nneething-group-alist))
 188             (progn
 189               (setq nneething-group group)
 190               (setq nneething-directory (nth 1 entry))
 191               (setq nneething-map (nth 2 entry))
 192               (setq nneething-active (nth 3 entry)))
 193           (setq nneething-group group)
 194           (setq nneething-directory dir)
 195           (setq nneething-map nil)
 196           (setq nneething-active (cons 1 0))
 197           (nneething-create-mapping)
 198           (setq nneething-group-alist
 199                 (cons (list group dir nneething-map nneething-active)
 200                       nneething-group-alist)))))))
 201
 202 (defun nneething-map-file ()
 203   ;; We store it in a special directory under the user's home dir.
 204   (concat (file-name-as-directory nneething-map-file-directory)
 205           nneething-group nneething-map-file))
 206
 207 (defun nneething-create-mapping ()
 208   ;; Read nneething-active and nneething-map
 209   (let ((map-file (nneething-map-file))
 210         (files (directory-files nneething-directory))
 211         (dir (file-name-as-directory nneething-directory))
 212         touched)
 213     (if (file-exists-p map-file)
 214         (condition-case nil
 215             (load map-file nil t t)
 216           (error nil)))
 217     (or nneething-active (setq nneething-active (cons 1 0)))
 218     ;; Remove files matching that regexp.
 219     (let ((f files)
 220           prev)
 221       (while f
 222         (if (string-match nneething-exclude-files (car f))
 223             (if prev (setcdr prev (cdr f))
 224               (setq files (cdr files)))
 225           (setq prev f))
 226         (setq f (cdr f))))
 227     ;; Remove files that have disappeared from the map.
 228     (let ((map nneething-map)
 229           prev)
 230       (while map
 231         (if (member (car (car map)) files)
 232             (setq prev map)
 233           (setq touched t)
 234           (if prev
 235               (setcdr prev (cdr map))
 236             (setq nneething-map (cdr nneething-map))))
 237         (setq map (cdr map))))
 238     ;; Find all new files and enter them into the map.
 239     (while files
 240       (or (assoc (car files) nneething-map) ; If already in the map, ignore.
 241           (progn
 242             (setq touched t)
 243             (setcdr nneething-active (1+ (cdr nneething-active)))
 244             (setq nneething-map
 245                   (cons (cons (car files) (cdr nneething-active)) nneething-map))))
 246       (setq files (cdr files)))
 247     (if (or (not touched) nneething-read-only)
 248         ()
 249       (save-excursion
 250         (set-buffer (get-buffer-create " *nneething map*"))
 251         (buffer-disable-undo (current-buffer))
 252         (erase-buffer)
 253         (insert "(setq nneething-map '" (prin1-to-string nneething-map) ")\n"
 254                 "(setq nneething-active '" (prin1-to-string nneething-active)
 255                 ")\n")
 256         (write-region (point-min) (point-max) map-file nil 'nomesg)
 257         (kill-buffer (current-buffer))))))
 258
 259 (defvar nneething-message-id-number 0)
 260 (defvar nneething-work-buffer " *nneething work*")
 261
 262 (defun nneething-insert-head (file)
 263   (and (nneething-get-head file)
 264        (insert-buffer-substring nneething-work-buffer)))
 265
 266 (defun nneething-make-head (file)
 267   (let ((atts (file-attributes file)))
 268     (insert "Subject: " (file-name-nondirectory file) "\n"
 269             "Message-ID: <nneething-"
 270             (int-to-string
 271              (setq nneething-message-id-number
 272                    (1+ nneething-message-id-number)))
 273             "@" (system-name) ">\n"
 274             "Date: " (current-time-string (nth 5 atts)) "\n"
 275             (nneething-from-line (nth 2 atts))
 276             "Chars: " (int-to-string (nth 7 atts)) "\n")))
 277
 278 (defun nneething-from-line (uid)
 279   (let ((login (condition-case nil
 280                    (user-login-name uid)
 281                  (error
 282                   (cond ((= uid (user-uid)) (user-login-name))
 283                         ((zerop uid) "root")
 284                         (t (int-to-string uid))))))
 285         (name (condition-case nil
 286                   (user-full-name uid)
 287                 (error
 288                  (cond ((= uid (user-uid)) (user-full-name))
 289                        ((zerop uid) "Ms. Root"))))))
 290     (concat "From: " login "@" (system-name)
 291             (if name (concat " (" name ")") "") "\n")))
 292
 293 (defun nneething-get-head (file)
 294   (save-excursion
 295     (set-buffer (get-buffer-create nneething-work-buffer))
 296     (setq case-fold-search nil)
 297     (buffer-disable-undo (current-buffer))
 298     (erase-buffer)
 299     (if (not (file-exists-p file))
 300         ()
 301       (if (or (not (file-regular-p file))
 302               (progn
 303                 (nnheader-insert-head file)
 304                 (if (nnheader-article-p)
 305                     (progn
 306                       (delete-region (point) (point-max))
 307                       nil))))
 308           (progn
 309             (erase-buffer)
 310             (nneething-make-head file)))
 311       t)))
 312
 313 (defun nneething-number-to-file (number)
 314   (car (rassq number nneething-map)))
 315
 316 (defun nneething-file-name (article)
 317   (concat (file-name-as-directory nneething-directory)
 318           (if (numberp article) (nneething-number-to-file article)
 319             article)))
 320
 321 (provide 'nneething)
 322
 323 ;;; nneething.el ends here