code.delx.au - gnu-emacs/blob - lisp/url/url-cache.el

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