lisp/url/url-cache.el

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