lisp/url/url-cache.el

   1 ;;; url-cache.el --- Uniform Resource Locator retrieval tool
   2 ;; Author: $Author: fx $
   3 ;; Created: $Date: 2002/01/22 17:53:45 $
   4 ;; Version: $Revision: 1.4 $
   5 ;; Keywords: comm, data, processes, hypermedia
   6
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8 ;;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
   9 ;;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc.
  10 ;;;
  11 ;;; This file is part of GNU Emacs.
  12 ;;;
  13 ;;; GNU Emacs is free software; you can redistribute it and/or modify
  14 ;;; it under the terms of the GNU General Public License as published by
  15 ;;; the Free Software Foundation; either version 2, or (at your option)
  16 ;;; any later version.
  17 ;;;
  18 ;;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;;; GNU General Public License for more details.
  22 ;;;
  23 ;;; You should have received a copy of the GNU General Public License
  24 ;;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26 ;;; Boston, MA 02111-1307, USA.
  27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  28 (require 'url-parse)
  29
  30 (defcustom url-cache-directory
  31   (expand-file-name "cache" url-configuration-directory)
  32   "*The directory where cache files should be stored."
  33   :type 'directory
  34   :group 'url-file)
  35
  36 ;; Cache manager
  37 (defun url-cache-file-writable-p (file)
  38   "Follows the documentation of `file-writable-p', unlike `file-writable-p'."
  39   (and (file-writable-p file)
  40        (if (file-exists-p file)
  41            (not (file-directory-p file))
  42          (file-directory-p (file-name-directory file)))))
  43
  44 (defun url-cache-prepare (file)
  45   "Makes it possible to cache data in FILE.
  46 Creates any necessary parent directories, deleting any non-directory files
  47 that would stop this.  Returns nil if parent directories can not be
  48 created.  If FILE already exists as a non-directory, it changes
  49 permissions of FILE or deletes FILE to make it possible to write a new
  50 version of FILE.  Returns nil if this can not be done.  Returns nil if
  51 FILE already exists as a directory.  Otherwise, returns t, indicating that
  52 FILE can be created or overwritten."
  53   (cond
  54    ((url-cache-file-writable-p file)
  55     t)
  56    ((file-directory-p file)
  57     nil)
  58    (t
  59     (condition-case ()
  60         (or (make-directory (file-name-directory file) t) t)
  61       (error nil)))))
  62
  63 ;;;###autoload
  64 (defun url-store-in-cache (&optional buff)
  65   "Store buffer BUFF in the cache."
  66   (if (not (and buff (get-buffer buff)))
  67       nil
  68     (save-excursion
  69       (and buff (set-buffer buff))
  70       (let* ((fname (url-cache-create-filename (url-view-url t))))
  71         (if (url-cache-prepare fname)
  72             (let ((coding-system-for-write 'binary))
  73               (write-region (point-min) (point-max) fname nil 5)))))))
  74
  75 ;;;###autoload
  76 (defun url-is-cached (url)
  77   "Return non-nil if the URL is cached."
  78   (let* ((fname (url-cache-create-filename url))
  79          (attribs (file-attributes fname)))
  80     (and fname                          ; got a filename
  81          (file-exists-p fname)          ; file exists
  82          (not (eq (nth 0 attribs) t))   ; Its not a directory
  83          (nth 5 attribs))))             ; Can get last mod-time
  84
  85 (defun url-cache-create-filename-human-readable (url)
  86   "Return a filename in the local cache for URL"
  87   (if url
  88       (let* ((url (if (vectorp url) (url-recreate-url url) url))
  89              (urlobj (url-generic-parse-url url))
  90              (protocol (url-type urlobj))
  91              (hostname (url-host urlobj))
  92              (host-components
  93               (cons
  94                (user-real-login-name)
  95                (cons (or protocol "file")
  96                      (reverse (split-string (or hostname "localhost")
  97                                             (eval-when-compile
  98                                               (regexp-quote ".")))))))
  99              (fname    (url-filename urlobj)))
 100         (if (and fname (/= (length fname) 0) (= (aref fname 0) ?/))
 101             (setq fname (substring fname 1 nil)))
 102         (if fname
 103             (let ((slash nil))
 104               (setq fname
 105                     (mapconcat
 106                      (function
 107                       (lambda (x)
 108                         (cond
 109                          ((and (= ?/ x) slash)
 110                           (setq slash nil)
 111                           "%2F")
 112                          ((= ?/ x)
 113                           (setq slash t)
 114                           "/")
 115                          (t
 116                           (setq slash nil)
 117                           (char-to-string x))))) fname ""))))
 118
 119         (setq fname (and fname
 120                          (mapconcat
 121                           (function (lambda (x)
 122                                       (if (= x ?~) "" (char-to-string x))))
 123                           fname ""))
 124               fname (cond
 125                      ((null fname) nil)
 126                      ((or (string= "" fname) (string= "/" fname))
 127                       url-directory-index-file)
 128                      ((= (string-to-char fname) ?/)
 129                       (if (string= (substring fname -1 nil) "/")
 130                           (concat fname url-directory-index-file)
 131                         (substring fname 1 nil)))
 132                      (t
 133                       (if (string= (substring fname -1 nil) "/")
 134                           (concat fname url-directory-index-file)
 135                         fname))))
 136         (and fname
 137              (expand-file-name fname
 138                                (expand-file-name
 139                                 (mapconcat 'identity host-components "/")
 140                                 url-cache-directory))))))
 141
 142 (defun url-cache-create-filename-using-md5 (url)
 143   "Create a cached filename using MD5.
 144  Very fast if you are in XEmacs, suitably fast otherwise."
 145   (require 'md5)
 146   (if url
 147       (let* ((url (if (vectorp url) (url-recreate-url url) url))
 148              (checksum (md5 url))
 149              (urlobj (url-generic-parse-url url))
 150              (protocol (url-type urlobj))
 151              (hostname (url-host urlobj))
 152              (host-components
 153               (cons
 154                (user-real-login-name)
 155                (cons (or protocol "file")
 156                      (nreverse
 157                       (delq nil
 158                             (split-string (or hostname "localhost")
 159                                           (eval-when-compile
 160                                             (regexp-quote "."))))))))
 161              (fname    (url-filename urlobj)))
 162         (and fname
 163              (expand-file-name checksum
 164                                (expand-file-name
 165                                 (mapconcat 'identity host-components "/")
 166                                 url-cache-directory))))))
 167
 168 (defcustom url-cache-creation-function 'url-cache-create-filename-using-md5
 169   "*What function to use to create a cached filename."
 170   :type '(choice (const :tag "MD5 of filename (low collision rate)"
 171                         :value url-cache-create-filename-using-md5)
 172                  (const :tag "Human readable filenames (higher collision rate)"
 173                         :value url-cache-create-filename-human-readable)
 174                  (function :tag "Other"))
 175   :group 'url-cache)
 176
 177 (defun url-cache-create-filename (url)
 178   (funcall url-cache-creation-function url))
 179
 180 ;;;###autoload
 181 (defun url-cache-extract (fnam)
 182   "Extract FNAM from the local disk cache"
 183   (erase-buffer)
 184   (insert-file-contents-literally fnam))
 185
 186 ;;;###autoload
 187 (defun url-cache-expired (url mod)
 188   "Return t iff a cached file has expired."
 189   (let* ((urlobj (if (vectorp url) url (url-generic-parse-url url)))
 190          (type (url-type urlobj)))
 191     (cond
 192      (url-standalone-mode
 193       (not (file-exists-p (url-cache-create-filename url))))
 194      ((string= type "http")
 195       t)
 196      ((member type '("file" "ftp"))
 197       (if (or (equal mod '(0 0)) (not mod))
 198           t
 199         (or (> (nth 0 mod) (nth 0 (current-time)))
 200             (> (nth 1 mod) (nth 1 (current-time))))))
 201      (t nil))))
 202
 203 (provide 'url-cache)