lisp/gnus/nneething.el

   1 ;;; nneething.el --- arbitrary file access for Gnus
   2
   3 ;; Copyright (C) 1995-2012 Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   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 3 of the License, or
  14 ;; (at your option) 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.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (eval-when-compile (require 'cl))
  29
  30 (require 'mailcap)
  31 (require 'nnheader)
  32 (require 'nnmail)
  33 (require 'nnoo)
  34 (require 'gnus-util)
  35
  36 (nnoo-declare nneething)
  37
  38 (defvoo nneething-map-file-directory
  39   (nnheader-concat gnus-directory ".nneething/")
  40   "Where nneething stores the map files.")
  41
  42 (defvoo nneething-map-file ".nneething"
  43   "Name of the map files.")
  44
  45 (defvoo nneething-exclude-files nil
  46   "Regexp saying what files to exclude from the group.
  47 If this variable is nil, no files will be excluded.")
  48
  49 (defvoo nneething-include-files nil
  50   "Regexp saying what files to include in the group.
  51 If this variable is non-nil, only files matching this regexp will be
  52 included.")
  53
  54 \f
  55
  56 ;;; Internal variables.
  57
  58 (defconst nneething-version "nneething 1.0"
  59   "nneething version.")
  60
  61 (defvoo nneething-current-directory nil
  62   "Current news group directory.")
  63
  64 (defvoo nneething-status-string "")
  65
  66 (defvoo nneething-work-buffer " *nneething work*")
  67
  68 (defvoo nneething-group nil)
  69 (defvoo nneething-map nil)
  70 (defvoo nneething-read-only nil)
  71 (defvoo nneething-active nil)
  72 (defvoo nneething-address nil)
  73
  74 \f
  75
  76 ;;; Interface functions.
  77
  78 (nnoo-define-basics nneething)
  79
  80 (deffoo nneething-retrieve-headers (articles &optional group server fetch-old)
  81   (nneething-possibly-change-directory group)
  82
  83   (with-current-buffer nntp-server-buffer
  84     (erase-buffer)
  85     (let* ((number (length articles))
  86            (count 0)
  87            (large (and (numberp nnmail-large-newsgroup)
  88                        (> number nnmail-large-newsgroup)))
  89            article file)
  90
  91       (if (stringp (car articles))
  92           'headers
  93
  94         (while (setq article (pop articles))
  95           (setq file (nneething-file-name article))
  96
  97           (when (and (file-exists-p file)
  98                      (or (file-directory-p file)
  99                          (not (zerop (nnheader-file-size file)))))
 100             (insert (format "221 %d Article retrieved.\n" article))
 101             (nneething-insert-head file)
 102             (insert ".\n"))
 103
 104           (incf count)
 105
 106           (and large
 107                (zerop (% count 20))
 108                (nnheader-message 5 "nneething: Receiving headers... %d%%"
 109                                  (/ (* count 100) number))))
 110
 111         (when large
 112           (nnheader-message 5 "nneething: Receiving headers...done"))
 113
 114         (nnheader-fold-continuation-lines)
 115         'headers))))
 116
 117 (deffoo nneething-request-article (id &optional group server buffer)
 118   (nneething-possibly-change-directory group)
 119   (let ((file (unless (stringp id)
 120                 (nneething-file-name id)))
 121         (nntp-server-buffer (or buffer nntp-server-buffer)))
 122     (and (stringp file)            ; We did not request by Message-ID.
 123          (file-exists-p file)           ; The file exists.
 124          (not (file-directory-p file))  ; It's not a dir.
 125          (save-excursion
 126            (let ((nnmail-file-coding-system 'binary))
 127              (nnmail-find-file file))   ; Insert the file in the nntp buf.
 128            (unless (nnheader-article-p) ; Either it's a real article...
 129              (let ((type
 130                     (unless (file-directory-p file)
 131                       (or (cdr (assoc (concat "." (file-name-extension file))
 132                                       mailcap-mime-extensions))
 133                           "text/plain")))
 134                    (charset
 135                     (mm-detect-mime-charset-region (point-min) (point-max)))
 136                    (encoding))
 137                (unless (string-match "\\`text/" type)
 138                  (base64-encode-region (point-min) (point-max))
 139                  (setq encoding "base64"))
 140                (goto-char (point-min))
 141                (nneething-make-head file (current-buffer)
 142                                     nil type charset encoding))
 143              (insert "\n"))
 144            t))))
 145
 146 (deffoo nneething-request-group (group &optional server dont-check info)
 147   (nneething-possibly-change-directory group server)
 148   (unless dont-check
 149     (nneething-create-mapping)
 150     (if (> (car nneething-active) (cdr nneething-active))
 151         (nnheader-insert "211 0 1 0 %s\n" group)
 152       (nnheader-insert
 153        "211 %d %d %d %s\n"
 154        (- (1+ (cdr nneething-active)) (car nneething-active))
 155        (car nneething-active) (cdr nneething-active)
 156        group)))
 157   t)
 158
 159 (deffoo nneething-request-list (&optional server dir)
 160   (nnheader-report 'nneething "LIST is not implemented."))
 161
 162 (deffoo nneething-request-newgroups (date &optional server)
 163   (nnheader-report 'nneething "NEWSGROUPS is not implemented."))
 164
 165 (deffoo nneething-request-type (group &optional article)
 166   'unknown)
 167
 168 (deffoo nneething-close-group (group &optional server)
 169   (setq nneething-current-directory nil)
 170   t)
 171
 172 (deffoo nneething-open-server (server &optional defs)
 173   (nnheader-init-server-buffer)
 174   (if (nneething-server-opened server)
 175       t
 176     (unless (assq 'nneething-address defs)
 177       (setq defs (append defs (list (list 'nneething-address server)))))
 178     (nnoo-change-server 'nneething server defs)))
 179
 180 \f
 181 ;;; Internal functions.
 182
 183 (defun nneething-possibly-change-directory (group &optional server)
 184   (when (and server
 185              (not (nneething-server-opened server)))
 186     (nneething-open-server server))
 187   (when (and group
 188              (not (equal nneething-group group)))
 189     (setq nneething-group group)
 190     (setq nneething-map nil)
 191     (setq nneething-active (cons 1 0))
 192     (nneething-create-mapping)))
 193
 194 (defun nneething-map-file ()
 195   ;; We make sure that the .nneething directory exists.
 196   (gnus-make-directory nneething-map-file-directory)
 197   ;; We store it in a special directory under the user's home dir.
 198   (concat (file-name-as-directory nneething-map-file-directory)
 199           nneething-group nneething-map-file))
 200
 201 (defun nneething-create-mapping ()
 202   ;; Read nneething-active and nneething-map.
 203   (when (file-exists-p nneething-address)
 204     (let ((map-file (nneething-map-file))
 205           (files (directory-files nneething-address))
 206           touched map-files)
 207       (when (file-exists-p map-file)
 208         (ignore-errors
 209           (load map-file nil t t)))
 210       (unless nneething-active
 211         (setq nneething-active (cons 1 0)))
 212       ;; Old nneething had a different map format.
 213       (when (and (cdar nneething-map)
 214                  (atom (cdar nneething-map)))
 215         (setq nneething-map
 216               (mapcar (lambda (n)
 217                         (list (cdr n) (car n)
 218                               (nth 5 (file-attributes
 219                                       (nneething-file-name (car n))))))
 220                       nneething-map)))
 221       ;; Remove files matching the exclusion regexp.
 222       (when nneething-exclude-files
 223         (let ((f files)
 224               prev)
 225           (while f
 226             (if (string-match nneething-exclude-files (car f))
 227                 (if prev (setcdr prev (cdr f))
 228                   (setq files (cdr files)))
 229               (setq prev f))
 230             (setq f (cdr f)))))
 231       ;; Remove files not matching the inclusion regexp.
 232       (when nneething-include-files
 233         (let ((f files)
 234               prev)
 235           (while f
 236             (if (not (string-match nneething-include-files (car f)))
 237                 (if prev (setcdr prev (cdr f))
 238                   (setq files (cdr files)))
 239               (setq prev f))
 240             (setq f (cdr f)))))
 241       ;; Remove deleted files from the map.
 242       (let ((map nneething-map)
 243             prev)
 244         (while map
 245           (if (and (member (cadr (car map)) files)
 246                   ;; We also remove files that have changed mod times.
 247                    (equal (nth 5 (file-attributes
 248                                   (nneething-file-name (cadr (car map)))))
 249                           (cadr (cdar map))))
 250               (progn
 251                 (push (cadr (car map)) map-files)
 252                 (setq prev map))
 253             (setq touched t)
 254             (if prev
 255                 (setcdr prev (cdr map))
 256               (setq nneething-map (cdr nneething-map))))
 257           (setq map (cdr map))))
 258       ;; Find all new files and enter them into the map.
 259       (while files
 260         (unless (member (car files) map-files)
 261           ;; This file is not in the map, so we enter it.
 262           (setq touched t)
 263           (setcdr nneething-active (1+ (cdr nneething-active)))
 264           (push (list (cdr nneething-active) (car files)
 265                       (nth 5 (file-attributes
 266                               (nneething-file-name (car files)))))
 267                 nneething-map))
 268         (setq files (cdr files)))
 269       (when (and touched
 270                  (not nneething-read-only))
 271         (with-temp-file map-file
 272           (insert "(setq nneething-map '")
 273           (gnus-prin1 nneething-map)
 274           (insert ")\n(setq nneething-active '")
 275           (gnus-prin1 nneething-active)
 276           (insert ")\n"))))))
 277
 278 (defun nneething-insert-head (file)
 279   "Insert the head of FILE."
 280   (when (nneething-get-head file)
 281     (insert-buffer-substring nneething-work-buffer)
 282     (goto-char (point-max))))
 283
 284 (defun nneething-encode-file-name (file &optional coding-system)
 285   "Encode the name of the FILE in CODING-SYSTEM."
 286   (let ((pos 0) buf)
 287     (setq file (mm-encode-coding-string
 288                 file (or coding-system nnmail-pathname-coding-system)))
 289     (while (string-match "[^-0-9a-zA-Z_:/.]" file pos)
 290       (setq buf (cons (format "%%%02x" (aref file (match-beginning 0)))
 291                       (cons (substring file pos (match-beginning 0)) buf))
 292             pos (match-end 0)))
 293     (apply (function concat)
 294            (nreverse (cons (substring file pos) buf)))))
 295
 296 (defun nneething-decode-file-name (file &optional coding-system)
 297   "Decode the name of the FILE is encoded in CODING-SYSTEM."
 298   (let ((pos 0) buf)
 299     (while (string-match "%\\([0-9a-fA-F][0-9a-fA-F]\\)" file pos)
 300       (setq buf (cons (string (string-to-number (match-string 1 file) 16))
 301                       (cons (substring file pos (match-beginning 0)) buf))
 302             pos (match-end 0)))
 303     (mm-decode-coding-string
 304      (apply (function concat)
 305             (nreverse (cons (substring file pos) buf)))
 306      (or coding-system nnmail-pathname-coding-system))))
 307
 308 (defun nneething-get-file-name (id)
 309   "Extract the file name from the message ID string."
 310   (when (string-match "\\`<nneething-\\([^@]+\\)@.*>\\'" id)
 311     (nneething-decode-file-name (match-string 1 id))))
 312
 313 (defun nneething-make-head (file &optional buffer extra-msg
 314                                  mime-type mime-charset mime-encoding)
 315   "Create a head by looking at the file attributes of FILE."
 316   (let ((atts (file-attributes file)))
 317     (insert
 318      "Subject: " (file-name-nondirectory file) (or extra-msg "") "\n"
 319      "Message-ID: <nneething-" (nneething-encode-file-name file)
 320      "@" (system-name) ">\n"
 321      (if (equal '(0 0) (nth 5 atts)) ""
 322        (concat "Date: " (current-time-string (nth 5 atts)) "\n"))
 323      (or (when buffer
 324            (with-current-buffer buffer
 325              (when (re-search-forward "<[a-zA-Z0-9_]@[-a-zA-Z0-9_]>" 1000 t)
 326                (concat "From: " (match-string 0) "\n"))))
 327          (nneething-from-line (nth 2 atts) file))
 328      (if (> (string-to-number (int-to-string (nth 7 atts))) 0)
 329          (concat "Chars: " (int-to-string (nth 7 atts)) "\n")
 330        "")
 331      (if buffer
 332          (with-current-buffer buffer
 333            (concat "Lines: " (int-to-string
 334                               (count-lines (point-min) (point-max)))
 335                    "\n"))
 336        "")
 337      (if mime-type
 338          (concat "Content-Type: " mime-type
 339                  (if mime-charset
 340                      (concat "; charset="
 341                              (if (stringp mime-charset)
 342                                  mime-charset
 343                                (symbol-name mime-charset)))
 344                    "")
 345                  (if mime-encoding
 346                      (concat "\nContent-Transfer-Encoding: " mime-encoding)
 347                    "")
 348                  "\nMIME-Version: 1.0\n")
 349        ""))))
 350
 351 (defun nneething-from-line (uid &optional file)
 352   "Return a From header based of UID."
 353   (let* ((login (condition-case nil
 354                     (user-login-name uid)
 355                   (error
 356                    (cond ((= uid (user-uid)) (user-login-name))
 357                          ((zerop uid) "root")
 358                          (t (int-to-string uid))))))
 359          (name (condition-case nil
 360                    (user-full-name uid)
 361                  (error
 362                   (cond ((= uid (user-uid)) (user-full-name))
 363                         ((zerop uid) "Ms. Root")))))
 364          (host (if  (string-match "\\`/[^/@]*@\\([^:/]+\\):" file)
 365                    (prog1
 366                        (substring file
 367                                   (match-beginning 1)
 368                                   (match-end 1))
 369                      (when (string-match
 370                             "/\\(users\\|home\\)/\\([^/]+\\)/" file)
 371                        (setq login (substring file
 372                                               (match-beginning 2)
 373                                               (match-end 2))
 374                              name nil)))
 375                  (system-name))))
 376     (concat "From: " login "@" host
 377             (if name (concat " (" name ")") "") "\n")))
 378
 379 (defun nneething-get-head (file)
 380   "Either find the head in FILE or make a head for FILE."
 381   (with-current-buffer (get-buffer-create nneething-work-buffer)
 382     (setq case-fold-search nil)
 383     (buffer-disable-undo)
 384     (erase-buffer)
 385     (cond
 386      ((not (file-exists-p file))
 387       ;; The file do not exist.
 388       nil)
 389      ((or (file-directory-p file)
 390           (file-symlink-p file))
 391       ;; It's a dir, so we fudge a head.
 392       (nneething-make-head file) t)
 393      (t
 394       ;; We examine the file.
 395       (condition-case ()
 396           (progn
 397             (nnheader-insert-head file)
 398             (if (nnheader-article-p)
 399                 (delete-region
 400                  (progn
 401                    (goto-char (point-min))
 402                    (or (and (search-forward "\n\n" nil t)
 403                             (1- (point)))
 404                        (point-max)))
 405                  (point-max))
 406               (goto-char (point-min))
 407               (nneething-make-head file (current-buffer))
 408               (delete-region (point) (point-max))))
 409         (file-error
 410          (nneething-make-head file (current-buffer) " (unreadable)")))
 411       t))))
 412
 413 (defun nneething-file-name (article)
 414   "Return the file name of ARTICLE."
 415   (let ((dir (file-name-as-directory nneething-address))
 416         fname)
 417     (if (numberp article)
 418         (if (setq fname (cadr (assq article nneething-map)))
 419             (expand-file-name fname dir)
 420           (make-temp-name (expand-file-name "nneething" dir)))
 421       (expand-file-name article dir))))
 422
 423 (provide 'nneething)
 424
 425 ;;; nneething.el ends here