lisp/url/url-cache.el

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