1;;; url-cache.el --- Uniform Resource Locator retrieval tool 2 3;; Copyright (C) 1996-1999, 2004-2021 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 <https://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. 36Used 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. 51Creates any necessary parent directories, deleting any non-directory files 52that would stop this. Returns nil if parent directories can not be 53created. If FILE already exists as a non-directory, it changes 54permissions of FILE or deletes FILE to make it possible to write a new 55version of FILE. Returns nil if this can not be done, or if FILE already 56exists as a directory. Otherwise, returns t, indicating that 57FILE 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. 86The 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 90 (file-exists-p fname) 91 (not (eq (file-attribute-type attribs) t)) 92 (file-attribute-modification-time attribs)))) 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. 151Very 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 (url-p 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. 199The default value of EXPIRE-TIME is `url-cache-expire-time'. 200If `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 (or expire-time url-cache-expire-time)) 209 nil))))) 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 214considered \"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 (file-attribute-modification-time (file-attributes file)) 230 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 242