git.chise.org Git - elisp/gnus.git-/blob - lisp/nneething.el

   1 ;;; nneething.el --- arbitrary file access for Gnus
   2
   3 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002
   4 ;;      Free Software Foundation, Inc.
   5
   6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   7 ;;      Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
   8 ;; Keywords: news, mail
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; Commentary:
  28
  29 ;;; Code:
  30
  31 (eval-when-compile (require 'cl))
  32
  33 (require 'nnheader)
  34 (require 'nnmail)
  35 (require 'nnoo)
  36 (require 'gnus-util)
  37
  38 (nnoo-declare nneething)
  39
  40 (defvoo nneething-map-file-directory "~/.nneething/"
  41   "Where nneething stores the map files.")
  42
  43 (defvoo nneething-map-file ".nneething"
  44   "Name of the map files.")
  45
  46 (defvoo nneething-exclude-files nil
  47   "Regexp saying what files to exclude from the group.
  48 If this variable is nil, no files will be excluded.")
  49
  50 (defvoo nneething-include-files nil
  51   "Regexp saying what files to include in the group.
  52 If this variable is non-nil, only files matching this regexp will be
  53 included.")
  54
  55 \f
  56
  57 ;;; Internal variables.
  58
  59 (defconst nneething-version "nneething 1.0"
  60   "nneething version.")
  61
  62 (defvoo nneething-current-directory nil
  63   "Current news group directory.")
  64
  65 (defvoo nneething-status-string "")
  66
  67 (defvoo nneething-work-buffer " *nneething work*")
  68
  69 (defvoo nneething-group nil)
  70 (defvoo nneething-map nil)
  71 (defvoo nneething-read-only nil)
  72 (defvoo nneething-active nil)
  73 (defvoo nneething-address nil)
  74
  75 (defvar nneething-mime-extensions
  76   '((""        . "text/plain")
  77     (".abs"   . "audio/x-mpeg")
  78     (".aif"   . "audio/aiff")
  79     (".aifc"  . "audio/aiff")
  80     (".aiff"  . "audio/aiff")
  81     (".ano"   . "application/x-annotator")
  82     (".au"    . "audio/ulaw")
  83     (".avi"   . "video/x-msvideo")
  84     (".bcpio" . "application/x-bcpio")
  85     (".bin"   . "application/octet-stream")
  86     (".cdf"   . "application/x-netcdr")
  87     (".cpio"  . "application/x-cpio")
  88     (".csh"   . "application/x-csh")
  89     (".css"   . "text/css")
  90     (".dvi"   . "application/x-dvi")
  91     (".diff"  . "text/x-patch")
  92     (".el"    . "application/emacs-lisp")
  93     (".eps"   . "application/postscript")
  94     (".etx"   . "text/x-setext")
  95     (".exe"   . "application/octet-stream")
  96     (".fax"   . "image/x-fax")
  97     (".gif"   . "image/gif")
  98     (".hdf"   . "application/x-hdf")
  99     (".hqx"   . "application/mac-binhex40")
 100     (".htm"   . "text/html")
 101     (".html"  . "text/html")
 102     (".icon"  . "image/x-icon")
 103     (".ief"   . "image/ief")
 104     (".jpg"   . "image/jpeg")
 105     (".macp"  . "image/x-macpaint")
 106     (".man"   . "application/x-troff-man")
 107     (".me"    . "application/x-troff-me")
 108     (".mif"   . "application/mif")
 109     (".mov"   . "video/quicktime")
 110     (".movie" . "video/x-sgi-movie")
 111     (".mp2"   . "audio/x-mpeg")
 112     (".mp3"   . "audio/x-mpeg")
 113     (".mp2a"  . "audio/x-mpeg2")
 114     (".mpa"   . "audio/x-mpeg")
 115     (".mpa2"  . "audio/x-mpeg2")
 116     (".mpe"   . "video/mpeg")
 117     (".mpeg"  . "video/mpeg")
 118     (".mpega" . "audio/x-mpeg")
 119     (".mpegv" . "video/mpeg")
 120     (".mpg"   . "video/mpeg")
 121     (".mpv"   . "video/mpeg")
 122     (".ms"    . "application/x-troff-ms")
 123     (".nc"    . "application/x-netcdf")
 124     (".nc"    . "application/x-netcdf")
 125     (".oda"   . "application/oda")
 126     (".patch" . "text/x-patch")
 127     (".pbm"   . "image/x-portable-bitmap")
 128     (".pdf"   . "application/pdf")
 129     (".pgm"   . "image/portable-graymap")
 130     (".pict"  . "image/pict")
 131     (".png"   . "image/png")
 132     (".pnm"   . "image/x-portable-anymap")
 133     (".ppm"   . "image/portable-pixmap")
 134     (".ps"    . "application/postscript")
 135     (".qt"    . "video/quicktime")
 136     (".ras"   . "image/x-raster")
 137     (".rgb"   . "image/x-rgb")
 138     (".rtf"   . "application/rtf")
 139     (".rtx"   . "text/richtext")
 140     (".sh"    . "application/x-sh")
 141     (".sit"   . "application/x-stuffit")
 142     (".siv"   . "application/sieve")
 143     (".snd"   . "audio/basic")
 144     (".src"   . "application/x-wais-source")
 145     (".tar"   . "archive/tar")
 146     (".tcl"   . "application/x-tcl")
 147     (".tex"   . "application/x-tex")
 148     (".texi"  . "application/texinfo")
 149     (".tga"   . "image/x-targa")
 150     (".tif"   . "image/tiff")
 151     (".tiff"  . "image/tiff")
 152     (".tr"    . "application/x-troff")
 153     (".troff" . "application/x-troff")
 154     (".tsv"   . "text/tab-separated-values")
 155     (".txt"   . "text/plain")
 156     (".vbs"   . "video/mpeg")
 157     (".vox"   . "audio/basic")
 158     (".vrml"  . "x-world/x-vrml")
 159     (".wav"   . "audio/x-wav")
 160     (".xls"   . "application/vnd.ms-excel")
 161     (".wrl"   . "x-world/x-vrml")
 162     (".xbm"   . "image/xbm")
 163     (".xpm"   . "image/xpm")
 164     (".xwd"   . "image/windowdump")
 165     (".zip"   . "application/zip")
 166     (".ai"    . "application/postscript")
 167     (".jpe"   . "image/jpeg")
 168     (".jpeg"  . "image/jpeg"))
 169   "An alist of file extensions and corresponding MIME content-types.
 170 This variable is used as the alternative of `mailcap-mime-extensions'.")
 171
 172 \f
 173
 174 ;;; Interface functions.
 175
 176 (nnoo-define-basics nneething)
 177
 178 (deffoo nneething-retrieve-headers (articles &optional group server fetch-old)
 179   (nneething-possibly-change-directory group)
 180
 181   (save-excursion
 182     (set-buffer nntp-server-buffer)
 183     (erase-buffer)
 184     (let* ((number (length articles))
 185            (count 0)
 186            (large (and (numberp nnmail-large-newsgroup)
 187                        (> number nnmail-large-newsgroup)))
 188            article file)
 189
 190       (if (stringp (car articles))
 191           'headers
 192
 193         (while (setq article (pop articles))
 194           (setq file (nneething-file-name article))
 195
 196           (when (and (file-exists-p file)
 197                      (or (file-directory-p file)
 198                          (not (zerop (nnheader-file-size file)))))
 199             (insert (format "221 %d Article retrieved.\n" article))
 200             (nneething-insert-head file)
 201             (insert ".\n"))
 202
 203           (incf count)
 204
 205           (and large
 206                (zerop (% count 20))
 207                (nnheader-message 5 "nneething: Receiving headers... %d%%"
 208                                  (/ (* count 100) number))))
 209
 210         (when large
 211           (nnheader-message 5 "nneething: Receiving headers...done"))
 212
 213         (nnheader-fold-continuation-lines)
 214         'headers))))
 215
 216 (deffoo nneething-request-article (id &optional group server buffer)
 217   (nneething-possibly-change-directory group)
 218   (let ((file (unless (stringp id)
 219                 (nneething-file-name id)))
 220         (nntp-server-buffer (or buffer nntp-server-buffer)))
 221     (and (stringp file)                 ; We did not request by Message-ID.
 222          (file-exists-p file)           ; The file exists.
 223          (not (file-directory-p file))  ; It's not a dir.
 224          (save-excursion
 225            (let ((nnmail-file-coding-system 'binary))
 226              (nnmail-find-file file))   ; Insert the file in the nntp buf.
 227            (unless (nnheader-article-p) ; Either it's a real article...
 228              (let ((type
 229                     (unless (file-directory-p file)
 230                       (or (cdr (assoc (concat "." (file-name-extension file))
 231                                       (if (boundp 'mailcap-mime-extensions)
 232                                           (symbol-value 'mailcap-mime-extensions)
 233                                         nneething-mime-extensions)))
 234                           "text/plain")))
 235                    (charset
 236                     (mm-detect-mime-charset-region (point-min) (point-max)))
 237                    (encoding))
 238                (unless (string-match "\\`text/" type)
 239                  (base64-encode-region (point-min) (point-max))
 240                  (setq encoding "base64"))
 241                (goto-char (point-min))
 242                (nneething-make-head file (current-buffer)
 243                                     nil type charset encoding))
 244              (insert "\n"))
 245            t))))
 246
 247 (deffoo nneething-request-group (group &optional server dont-check)
 248   (nneething-possibly-change-directory group server)
 249   (unless dont-check
 250     (nneething-create-mapping)
 251     (if (> (car nneething-active) (cdr nneething-active))
 252         (nnheader-insert "211 0 1 0 %s\n" group)
 253       (nnheader-insert
 254        "211 %d %d %d %s\n"
 255        (- (1+ (cdr nneething-active)) (car nneething-active))
 256        (car nneething-active) (cdr nneething-active)
 257        group)))
 258   t)
 259
 260 (deffoo nneething-request-list (&optional server dir)
 261   (nnheader-report 'nneething "LIST is not implemented."))
 262
 263 (deffoo nneething-request-newgroups (date &optional server)
 264   (nnheader-report 'nneething "NEWSGROUPS is not implemented."))
 265
 266 (deffoo nneething-request-type (group &optional article)
 267   'unknown)
 268
 269 (deffoo nneething-close-group (group &optional server)
 270   (setq nneething-current-directory nil)
 271   t)
 272
 273 (deffoo nneething-open-server (server &optional defs)
 274   (nnheader-init-server-buffer)
 275   (if (nneething-server-opened server)
 276       t
 277     (unless (assq 'nneething-address defs)
 278       (setq defs (append defs (list (list 'nneething-address server)))))
 279     (nnoo-change-server 'nneething server defs)))
 280
 281 \f
 282 ;;; Internal functions.
 283
 284 (defun nneething-possibly-change-directory (group &optional server)
 285   (when (and server
 286              (not (nneething-server-opened server)))
 287     (nneething-open-server server))
 288   (when (and group
 289              (not (equal nneething-group group)))
 290     (setq nneething-group group)
 291     (setq nneething-map nil)
 292     (setq nneething-active (cons 1 0))
 293     (nneething-create-mapping)))
 294
 295 (defun nneething-map-file ()
 296   ;; We make sure that the .nneething directory exists.
 297   (gnus-make-directory nneething-map-file-directory)
 298   ;; We store it in a special directory under the user's home dir.
 299   (concat (file-name-as-directory nneething-map-file-directory)
 300           nneething-group nneething-map-file))
 301
 302 (defun nneething-create-mapping ()
 303   ;; Read nneething-active and nneething-map.
 304   (when (file-exists-p nneething-address)
 305     (let ((map-file (nneething-map-file))
 306           (files (directory-files nneething-address))
 307           touched map-files)
 308       (when (file-exists-p map-file)
 309         (ignore-errors
 310           (load map-file nil t t)))
 311       (unless nneething-active
 312         (setq nneething-active (cons 1 0)))
 313       ;; Old nneething had a different map format.
 314       (when (and (cdar nneething-map)
 315                  (atom (cdar nneething-map)))
 316         (setq nneething-map
 317               (mapcar (lambda (n)
 318                         (list (cdr n) (car n)
 319                               (nth 5 (file-attributes
 320                                       (nneething-file-name (car n))))))
 321                       nneething-map)))
 322       ;; Remove files matching the exclusion regexp.
 323       (when nneething-exclude-files
 324         (let ((f files)
 325               prev)
 326           (while f
 327             (if (string-match nneething-exclude-files (car f))
 328                 (if prev (setcdr prev (cdr f))
 329                   (setq files (cdr files)))
 330               (setq prev f))
 331             (setq f (cdr f)))))
 332       ;; Remove files not matching the inclusion regexp.
 333       (when nneething-include-files
 334         (let ((f files)
 335               prev)
 336           (while f
 337             (if (not (string-match nneething-include-files (car f)))
 338                 (if prev (setcdr prev (cdr f))
 339                   (setq files (cdr files)))
 340               (setq prev f))
 341             (setq f (cdr f)))))
 342       ;; Remove deleted files from the map.
 343       (let ((map nneething-map)
 344             prev)
 345         (while map
 346           (if (and (member (cadr (car map)) files)
 347                    ;; We also remove files that have changed mod times.
 348                    (equal (nth 5 (file-attributes
 349                                   (nneething-file-name (cadr (car map)))))
 350                           (cadr (cdar map))))
 351               (progn
 352                 (push (cadr (car map)) map-files)
 353                 (setq prev map))
 354             (setq touched t)
 355             (if prev
 356                 (setcdr prev (cdr map))
 357               (setq nneething-map (cdr nneething-map))))
 358           (setq map (cdr map))))
 359       ;; Find all new files and enter them into the map.
 360       (while files
 361         (unless (member (car files) map-files)
 362           ;; This file is not in the map, so we enter it.
 363           (setq touched t)
 364           (setcdr nneething-active (1+ (cdr nneething-active)))
 365           (push (list (cdr nneething-active) (car files)
 366                       (nth 5 (file-attributes
 367                               (nneething-file-name (car files)))))
 368                 nneething-map))
 369         (setq files (cdr files)))
 370       (when (and touched
 371                  (not nneething-read-only))
 372         (with-temp-file map-file
 373           (insert "(setq nneething-map '")
 374           (gnus-prin1 nneething-map)
 375           (insert ")\n(setq nneething-active '")
 376           (gnus-prin1 nneething-active)
 377           (insert ")\n"))))))
 378
 379 (defun nneething-insert-head (file)
 380   "Insert the head of FILE."
 381   (when (nneething-get-head file)
 382     (insert-buffer-substring nneething-work-buffer)
 383     (goto-char (point-max))))
 384
 385 (defun nneething-encode-file-name (file &optional coding-system)
 386   "Encode the name of the FILE in CODING-SYSTEM."
 387   (let ((pos 0) buf)
 388     (setq file (mm-encode-coding-string
 389                 file (or coding-system nnmail-pathname-coding-system)))
 390     (while (string-match "[^-0-9a-zA-Z_:/.]" file pos)
 391       (setq buf (cons (format "%%%02x" (aref file (match-beginning 0)))
 392                       (cons (substring file pos (match-beginning 0)) buf))
 393             pos (match-end 0)))
 394     (apply (function concat)
 395            (nreverse (cons (substring file pos) buf)))))
 396
 397 (defun nneething-decode-file-name (file &optional coding-system)
 398   "Decode the name of the FILE is encoded in CODING-SYSTEM."
 399   (let ((pos 0) buf)
 400     (while (string-match "%\\([0-9a-fA-F][0-9a-fA-F]\\)" file pos)
 401       (setq buf (cons (string (string-to-number (match-string 1 file) 16))
 402                       (cons (substring file pos (match-beginning 0)) buf))
 403             pos (match-end 0)))
 404     (decode-coding-string
 405      (apply (function concat)
 406             (nreverse (cons (substring file pos) buf)))
 407      (or coding-system nnmail-pathname-coding-system))))
 408
 409 (defun nneething-get-file-name (id)
 410   "Extract the file name from the message ID string."
 411   (when (string-match "\\`<nneething-\\([^@]+\\)@.*>\\'" id)
 412     (nneething-decode-file-name (match-string 1 id))))
 413
 414 (defun nneething-make-head (file &optional buffer extra-msg
 415                                  mime-type mime-charset mime-encoding)
 416   "Create a head by looking at the file attributes of FILE."
 417   (let ((atts (file-attributes file)))
 418     (insert
 419      "Subject: " (file-name-nondirectory file) (or extra-msg "") "\n"
 420      "Message-ID: <nneething-" (nneething-encode-file-name file)
 421      "@" (system-name) ">\n"
 422      (if (equal '(0 0) (nth 5 atts)) ""
 423        (concat "Date: " (current-time-string (nth 5 atts)) "\n"))
 424      (or (when buffer
 425            (save-excursion
 426              (set-buffer buffer)
 427              (when (re-search-forward "<[a-zA-Z0-9_]@[-a-zA-Z0-9_]>" 1000 t)
 428                (concat "From: " (match-string 0) "\n"))))
 429          (nneething-from-line (nth 2 atts) file))
 430      (if (> (string-to-int (int-to-string (nth 7 atts))) 0)
 431          (concat "Chars: " (int-to-string (nth 7 atts)) "\n")
 432        "")
 433      (if buffer
 434          (save-excursion
 435            (set-buffer buffer)
 436            (concat "Lines: " (int-to-string
 437                               (count-lines (point-min) (point-max)))
 438                    "\n"))
 439        "")
 440      (if mime-type
 441          (concat "Content-Type: " mime-type
 442                  (if mime-charset
 443                      (concat "; charset="
 444                              (if (stringp mime-charset)
 445                                  mime-charset
 446                                (symbol-name mime-charset)))
 447                    "")
 448                  (if mime-encoding
 449                      (concat "\nContent-Transfer-Encoding: " mime-encoding)
 450                    "")
 451                  "\nMIME-Version: 1.0\n")
 452        ""))))
 453
 454 (defun nneething-from-line (uid &optional file)
 455   "Return a From header based of UID."
 456   (let* ((login (condition-case nil
 457                     (user-login-name uid)
 458                   (error
 459                    (cond ((= uid (user-uid)) (user-login-name))
 460                          ((zerop uid) "root")
 461                          (t (int-to-string uid))))))
 462          (name (condition-case nil
 463                    (user-full-name uid)
 464                  (error
 465                   (cond ((= uid (user-uid)) (user-full-name))
 466                         ((zerop uid) "Ms. Root")))))
 467          (host (if  (string-match "\\`/[^/@]*@\\([^:/]+\\):" file)
 468                    (prog1
 469                        (substring file
 470                                   (match-beginning 1)
 471                                   (match-end 1))
 472                      (when (string-match
 473                             "/\\(users\\|home\\)/\\([^/]+\\)/" file)
 474                        (setq login (substring file
 475                                               (match-beginning 2)
 476                                               (match-end 2))
 477                              name nil)))
 478                  (system-name))))
 479     (concat "From: " login "@" host
 480             (if name (concat " (" name ")") "") "\n")))
 481
 482 (defun nneething-get-head (file)
 483   "Either find the head in FILE or make a head for FILE."
 484   (save-excursion
 485     (set-buffer (get-buffer-create nneething-work-buffer))
 486     (setq case-fold-search nil)
 487     (buffer-disable-undo)
 488     (erase-buffer)
 489     (cond
 490      ((not (file-exists-p file))
 491       ;; The file do not exist.
 492       nil)
 493      ((or (file-directory-p file)
 494           (file-symlink-p file))
 495       ;; It's a dir, so we fudge a head.
 496       (nneething-make-head file) t)
 497      (t
 498       ;; We examine the file.
 499       (condition-case ()
 500           (progn
 501             (nnheader-insert-head file)
 502             (if (nnheader-article-p)
 503                 (delete-region
 504                  (progn
 505                    (goto-char (point-min))
 506                    (or (and (search-forward "\n\n" nil t)
 507                             (1- (point)))
 508                        (point-max)))
 509                  (point-max))
 510               (goto-char (point-min))
 511               (nneething-make-head file (current-buffer))
 512               (delete-region (point) (point-max))))
 513         (file-error
 514          (nneething-make-head file (current-buffer) " (unreadable)")))
 515       t))))
 516
 517 (defun nneething-file-name (article)
 518   "Return the file name of ARTICLE."
 519   (let ((dir (file-name-as-directory nneething-address))
 520         fname)
 521     (if (numberp article)
 522         (if (setq fname (cadr (assq article nneething-map)))
 523             (expand-file-name fname dir)
 524           (mm-make-temp-file (expand-file-name "nneething" dir)))
 525       (expand-file-name article dir))))
 526
 527 (provide 'nneething)
 528
 529 ;;; nneething.el ends here