1;;; url-cache.el --- Uniform Resource Locator retrieval tool -*- lexical-binding: t; -*- 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;;; Commentary: 23 24;;; Code: 25 26(require 'url-parse) 27(require 'url-util) 28(require 'url) ;E.g. for url-configuration-directory. 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(defcustom url-cache-expire-time 3600 37 "Default maximum time in seconds before cache files expire. 38Used by the function `url-cache-expired'." 39 :version "24.1" 40 :type 'integer 41 :group 'url-cache) 42 43;; Cache manager 44(defun url-cache-file-writable-p (file) 45 "Follows the documentation of `file-writable-p', unlike `file-writable-p'." 46 (and (file-writable-p file) 47 (if (file-exists-p file) 48 (not (file-directory-p file)) 49 (file-directory-p (file-name-directory file))))) 50 51(defun url-cache-prepare (file) 52 "Make it possible to cache data in FILE. 53Creates any necessary parent directories, deleting any non-directory files 54that would stop this. Returns nil if parent directories can not be 55created. If FILE already exists as a non-directory, it changes 56permissions of FILE or deletes FILE to make it possible to write a new 57version of FILE. Returns nil if this can not be done, or if FILE already 58exists as a directory. Otherwise, returns t, indicating that 59FILE can be created or overwritten." 60 (cond 61 ((url-cache-file-writable-p file) 62 t) 63 ((file-directory-p file) 64 nil) 65 (t 66 (condition-case () 67 (or (make-directory (file-name-directory file) t) t) 68 (error nil))))) 69 70;;;###autoload 71(defun url-store-in-cache (&optional buff) 72 "Store buffer BUFF in the cache." 73 (with-current-buffer (get-buffer (or buff (current-buffer))) 74 (let ((fname (url-cache-create-filename (url-view-url t)))) 75 (if (url-cache-prepare fname) 76 (let ((coding-system-for-write 'binary)) 77 (write-region (point-min) (point-max) fname nil 5)))))) 78 79(defun url-fetch-from-cache (url) 80 "Fetch URL from cache and return a buffer with the content." 81 (with-current-buffer (generate-new-buffer " *temp*") 82 (url-cache-extract (url-cache-create-filename url)) 83 (current-buffer))) 84 85;;;###autoload 86(defun url-is-cached (url) 87 "Return non-nil if the URL is cached. 88The actual return value is the last modification time of the cache file." 89 (let* ((fname (url-cache-create-filename url)) 90 (attribs (file-attributes fname))) 91 (and fname 92 (file-exists-p fname) 93 (not (eq (file-attribute-type attribs) t)) 94 (file-attribute-modification-time attribs)))) 95 96(defun url-cache-create-filename-human-readable (url) 97 "Return a filename in the local cache for URL." 98 (if url 99 (let* ((urlobj (url-generic-parse-url url)) 100 (protocol (url-type urlobj)) 101 (hostname (url-host urlobj)) 102 (host-components 103 (cons 104 (user-real-login-name) 105 (cons (or protocol "file") 106 (reverse (split-string (or hostname "localhost") 107 "\\."))))) 108 (fname (url-filename urlobj))) 109 (if (and fname (/= (length fname) 0) (= (aref fname 0) ?/)) 110 (setq fname (substring fname 1 nil))) 111 (if fname 112 (let ((slash nil)) 113 (setq fname 114 (mapconcat 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 (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. 152Very fast if you have an `md5' primitive function, suitably fast otherwise." 153 (if url 154 (let* ((checksum (md5 url)) 155 (urlobj (url-generic-parse-url url)) 156 (protocol (url-type urlobj)) 157 (hostname (url-host urlobj)) 158 (host-components 159 (cons 160 (user-real-login-name) 161 (cons (or protocol "file") 162 (nreverse 163 (delq nil 164 (split-string (or hostname "localhost") 165 "\\.")))))) 166 (fname (url-filename urlobj))) 167 (and fname 168 (expand-file-name checksum 169 (expand-file-name 170 (mapconcat 'identity host-components "/") 171 url-cache-directory)))))) 172 173(defcustom url-cache-creation-function 'url-cache-create-filename-using-md5 174 "What function to use to create a cached filename." 175 :type '(choice (const :tag "MD5 of filename (low collision rate)" 176 :value url-cache-create-filename-using-md5) 177 (const :tag "Human readable filenames (higher collision rate)" 178 :value url-cache-create-filename-human-readable) 179 (function :tag "Other")) 180 :group 'url-cache) 181 182(defun url-cache-create-filename (url) 183 (funcall url-cache-creation-function 184 ;; We need to parse+recreate in order to remove the default port 185 ;; if it has been specified: e.g. http://www.example.com:80 will 186 ;; be transcoded as http://www.example.com 187 (url-recreate-url 188 (if (url-p url) url 189 (url-generic-parse-url url))))) 190 191;;;###autoload 192(defun url-cache-extract (fnam) 193 "Extract FNAM from the local disk cache." 194 (erase-buffer) 195 (set-buffer-multibyte nil) 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. 200The default value of EXPIRE-TIME is `url-cache-expire-time'. 201If `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 (or expire-time url-cache-expire-time)) 210 nil))))) 211 212(defun url-cache-prune-cache (&optional directory) 213 "Remove all expired files from the cache. 214`url-cache-expire-time' says how old a file has to be to be 215considered \"expired\"." 216 (let ((now (current-time)) 217 (total-files 0) 218 (deleted-files 0)) 219 (setq directory (or directory url-cache-directory)) 220 (when (file-exists-p directory) 221 (dolist (file (directory-files directory t)) 222 (unless (member (file-name-nondirectory file) '("." "..")) 223 (setq total-files (1+ total-files)) 224 (cond 225 ((file-directory-p file) 226 (when (url-cache-prune-cache file) 227 (setq deleted-files (1+ deleted-files)))) 228 ((time-less-p 229 (time-add 230 (file-attribute-modification-time (file-attributes file)) 231 url-cache-expire-time) 232 now) 233 (delete-file file) 234 (setq deleted-files (1+ deleted-files)))))) 235 (if (< deleted-files total-files) 236 nil 237 (delete-directory directory) 238 t)))) 239 240(provide 'url-cache) 241 242;;; url-cache.el ends here 243