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