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