Commit | Line | Data |
---|---|---|
8c8b8430 | 1 | ;;; url-cache.el --- Uniform Resource Locator retrieval tool |
00eef4de | 2 | |
acaf905b | 3 | ;; Copyright (C) 1996-1999, 2004-2012 Free Software Foundation, Inc. |
00eef4de | 4 | |
8c8b8430 SM |
5 | ;; Keywords: comm, data, processes, hypermedia |
6 | ||
00eef4de LH |
7 | ;; This file is part of GNU Emacs. |
8 | ||
4936186e | 9 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
00eef4de | 10 | ;; it under the terms of the GNU General Public License as published by |
4936186e GM |
11 | ;; the Free Software Foundation, either version 3 of the License, or |
12 | ;; (at your option) any later version. | |
00eef4de LH |
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 | |
4936186e | 20 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
00eef4de LH |
21 | |
22 | ;;; Code: | |
23 | ||
8c8b8430 | 24 | (require 'url-parse) |
55d6ea46 | 25 | (require 'url-util) |
8abe1fd5 | 26 | (require 'url) ;E.g. for url-configuration-directory. |
8c8b8430 SM |
27 | |
28 | (defcustom url-cache-directory | |
29 | (expand-file-name "cache" url-configuration-directory) | |
a5cda60e | 30 | "The directory where cache files should be stored." |
8c8b8430 SM |
31 | :type 'directory |
32 | :group 'url-file) | |
33 | ||
18d68e52 | 34 | (defcustom url-cache-expire-time 3600 |
97161df8 GM |
35 | "Default maximum time in seconds before cache files expire. |
36 | Used by the function `url-cache-expired'." | |
18d68e52 JD |
37 | :version "24.1" |
38 | :type 'integer | |
39 | :group 'url-cache) | |
40 | ||
8c8b8430 SM |
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))))) | |
71ddfde5 | 48 | |
8c8b8430 SM |
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 | |
d1ce47b0 JB |
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 | |
8c8b8430 SM |
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." | |
6f6dc4da JD |
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)))))) | |
71ddfde5 | 76 | |
50e4f0bf JD |
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 | ||
8c8b8430 SM |
83 | ;;;###autoload |
84 | (defun url-is-cached (url) | |
7ee54def GM |
85 | "Return non-nil if the URL is cached. |
86 | The actual return value is the last modification time of the cache file." | |
8c8b8430 SM |
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) | |
d1ce47b0 | 95 | "Return a filename in the local cache for URL." |
8c8b8430 | 96 | (if url |
cbdd0d58 | 97 | (let* ((urlobj (url-generic-parse-url url)) |
8c8b8430 SM |
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") | |
5589b70e | 105 | "\\."))))) |
8c8b8430 SM |
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. | |
55d6ea46 | 151 | Very fast if you have an `md5' primitive function, suitably fast otherwise." |
8c8b8430 SM |
152 | (require 'md5) |
153 | (if url | |
cbdd0d58 | 154 | (let* ((checksum (md5 url)) |
8c8b8430 SM |
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") | |
5589b70e | 165 | "\\.")))))) |
8c8b8430 SM |
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 | |
a5cda60e | 174 | "What function to use to create a cached filename." |
8c8b8430 SM |
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) | |
cbdd0d58 JD |
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 (vectorp url) url | |
189 | (url-generic-parse-url url))))) | |
8c8b8430 SM |
190 | |
191 | ;;;###autoload | |
192 | (defun url-cache-extract (fnam) | |
d1ce47b0 | 193 | "Extract FNAM from the local disk cache." |
8c8b8430 | 194 | (erase-buffer) |
53d21671 | 195 | (set-buffer-multibyte nil) |
8c8b8430 SM |
196 | (insert-file-contents-literally fnam)) |
197 | ||
18d68e52 | 198 | (defun url-cache-expired (url &optional expire-time) |
48ff1664 GM |
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))) | |
8ea8e174 GM |
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)))))) | |
8c8b8430 SM |
211 | |
212 | (provide 'url-cache) | |
e5566bd5 | 213 | |
00eef4de | 214 | ;;; url-cache.el ends here |