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 1.0"
  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            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                    (not (zerop (nth 7 (file-attributes file)))))
  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 make sure that the .neething directory exists.
 205   (make-directory nneething-map-file-directory 'parents)
 206   ;; We store it in a special directory under the user's home dir.
 207   (concat (file-name-as-directory nneething-map-file-directory)
 208           nneething-group nneething-map-file))
 209
 210 (defun nneething-create-mapping ()
 211   ;; Read nneething-active and nneething-map
 212   (let ((map-file (nneething-map-file))
 213         (files (directory-files nneething-directory))
 214         touched)
 215     (if (file-exists-p map-file)
 216         (condition-case nil
 217             (load map-file nil t t)
 218           (error nil)))
 219     (or nneething-active (setq nneething-active (cons 1 0)))
 220     ;; Remove files matching that regexp.
 221     (let ((f files)
 222           prev)
 223       (while f
 224         (if (string-match nneething-exclude-files (car f))
 225             (if prev (setcdr prev (cdr f))
 226               (setq files (cdr files)))
 227           (setq prev f))
 228         (setq f (cdr f))))
 229     ;; Remove files that have disappeared from the map.
 230     (let ((map nneething-map)
 231           prev)
 232       (while map
 233         (if (member (car (car map)) files)
 234             (setq prev map)
 235           (setq touched t)
 236           (if prev
 237               (setcdr prev (cdr map))
 238             (setq nneething-map (cdr nneething-map))))
 239         (setq map (cdr map))))
 240     ;; Find all new files and enter them into the map.
 241     (while files
 242       (or (assoc (car files) nneething-map) ; If already in the map, ignore.
 243           (progn
 244             (setq touched t)
 245             (setcdr nneething-active (1+ (cdr nneething-active)))
 246             (setq nneething-map
 247                   (cons (cons (car files) (cdr nneething-active)) nneething-map))))
 248       (setq files (cdr files)))
 249     (if (or (not touched) nneething-read-only)
 250         ()
 251       (save-excursion
 252         (set-buffer (get-buffer-create " *nneething map*"))
 253         (buffer-disable-undo (current-buffer))
 254         (erase-buffer)
 255         (insert "(setq nneething-map '" (prin1-to-string nneething-map) ")\n"
 256                 "(setq nneething-active '" (prin1-to-string nneething-active)
 257                 ")\n")
 258         (write-region (point-min) (point-max) map-file nil 'nomesg)
 259         (kill-buffer (current-buffer))))))
 260
 261 (defvar nneething-message-id-number 0)
 262 (defvar nneething-work-buffer " *nneething work*")
 263
 264 (defun nneething-insert-head (file)
 265   (and (nneething-get-head file)
 266        (insert-buffer-substring nneething-work-buffer)))
 267
 268 (defun nneething-make-head (file)
 269   (let ((atts (file-attributes file)))
 270     (insert "Subject: " (file-name-nondirectory file) "\n"
 271             "Message-ID: <nneething-"
 272             (int-to-string
 273              (setq nneething-message-id-number
 274                    (1+ nneething-message-id-number)))
 275             "@" (system-name) ">\n"
 276             "Date: " (current-time-string (nth 5 atts)) "\n"
 277             (nneething-from-line (nth 2 atts))
 278             "Chars: " (int-to-string (nth 7 atts)) "\n")))
 279
 280 (defun nneething-from-line (uid)
 281   (let ((login (condition-case nil
 282                    (user-login-name uid)
 283                  (error
 284                   (cond ((= uid (user-uid)) (user-login-name))
 285                         ((zerop uid) "root")
 286                         (t (int-to-string uid))))))
 287         (name (condition-case nil
 288                   (user-full-name uid)
 289                 (error
 290                  (cond ((= uid (user-uid)) (user-full-name))
 291                        ((zerop uid) "Ms. Root"))))))
 292     (concat "From: " login "@" (system-name)
 293             (if name (concat " (" name ")") "") "\n")))
 294
 295 (defun nneething-get-head (file)
 296   (save-excursion
 297     (set-buffer (get-buffer-create nneething-work-buffer))
 298     (setq case-fold-search nil)
 299     (buffer-disable-undo (current-buffer))
 300     (erase-buffer)
 301     (cond
 302      ((not (file-exists-p file))
 303       ;; The file do not exist.
 304       nil)
 305      ((or (file-directory-p file)
 306           (file-symlink-p file))
 307       ;; It's a dir, so we fudge a head.
 308       (nneething-make-head file) t)
 309      (t
 310       ;; We examine the file.
 311       (nnheader-insert-head file)
 312       (if (nnheader-article-p)
 313           (delete-region
 314            (progn
 315              (goto-char (point-min))
 316              (or (and (search-forward "\n\n" nil t)
 317                       (1- (point)))
 318                  (point-max)))
 319            (point-max))
 320         (erase-buffer)
 321         (nneething-make-head file))
 322       t))))
 323
 324 (defun nneething-number-to-file (number)
 325   (car (rassq number nneething-map)))
 326
 327 (defun nneething-file-name (article)
 328   (concat (file-name-as-directory nneething-directory)
 329           (if (numberp article) (nneething-number-to-file article)
 330             article)))
 331
 332 (provide 'nneething)
 333
 334 ;;; nneething.el ends here