Mercurial > emacs
annotate lisp/url/url-cache.el @ 112426:59f7ce1a78c6
* admin/notes/bzrmerge: Comment on skipped revisions.
author | Glenn Morris <rgm@gnu.org> |
---|---|
date | Sat, 22 Jan 2011 11:44:38 -0800 |
parents | ef719132ddfa |
children |
rev | line source |
---|---|
54695 | 1 ;;; url-cache.el --- Uniform Resource Locator retrieval tool |
57612 | 2 |
110522
4bca1a43c0d3
* lisp/url/url-cache.el (url-is-cached): Doc fix.
Glenn Morris <rgm@gnu.org>
parents:
110343
diff
changeset
|
3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2004, 2005, 2006, 2007, 2008, |
112218
376148b31b5e
Add 2011 to FSF/AIST copyright years.
Glenn Morris <rgm@gnu.org>
parents:
110522
diff
changeset
|
4 ;; 2009, 2010, 2011 Free Software Foundation, Inc. |
57612 | 5 |
54695 | 6 ;; Keywords: comm, data, processes, hypermedia |
7 | |
57612 | 8 ;; This file is part of GNU Emacs. |
9 | |
94668
8259d0d8e107
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
79720
diff
changeset
|
10 ;; GNU Emacs is free software: you can redistribute it and/or modify |
57612 | 11 ;; it under the terms of the GNU General Public License as published by |
94668
8259d0d8e107
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
79720
diff
changeset
|
12 ;; the Free Software Foundation, either version 3 of the License, or |
8259d0d8e107
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
79720
diff
changeset
|
13 ;; (at your option) any later version. |
57612 | 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 | |
94668
8259d0d8e107
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
79720
diff
changeset
|
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
57612 | 22 |
23 ;;; Code: | |
24 | |
54695 | 25 (require 'url-parse) |
54793
4051557a5374
(url-util): Require.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54770
diff
changeset
|
26 (require 'url-util) |
67974 | 27 (require 'url) ;E.g. for url-configuration-directory. |
54695 | 28 |
29 (defcustom url-cache-directory | |
30 (expand-file-name "cache" url-configuration-directory) | |
110307 | 31 "The directory where cache files should be stored." |
54695 | 32 :type 'directory |
33 :group 'url-file) | |
34 | |
110490 | 35 (defcustom url-cache-expire-time 3600 |
110493
4dea687a331f
* lisp/url/url-cache.el (url-cache-expire-time): Doc fix.
Glenn Morris <rgm@gnu.org>
parents:
110492
diff
changeset
|
36 "Default maximum time in seconds before cache files expire. |
4dea687a331f
* lisp/url/url-cache.el (url-cache-expire-time): Doc fix.
Glenn Morris <rgm@gnu.org>
parents:
110492
diff
changeset
|
37 Used by the function `url-cache-expired'." |
110490 | 38 :version "24.1" |
39 :type 'integer | |
40 :group 'url-cache) | |
41 | |
54695 | 42 ;; Cache manager |
43 (defun url-cache-file-writable-p (file) | |
44 "Follows the documentation of `file-writable-p', unlike `file-writable-p'." | |
45 (and (file-writable-p file) | |
46 (if (file-exists-p file) | |
47 (not (file-directory-p file)) | |
48 (file-directory-p (file-name-directory file))))) | |
64748
875dcc490074
Update years in copyright notice; nfc.
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
64084
diff
changeset
|
49 |
54695 | 50 (defun url-cache-prepare (file) |
51 "Makes it possible to cache data in FILE. | |
52 Creates any necessary parent directories, deleting any non-directory files | |
53 that would stop this. Returns nil if parent directories can not be | |
54 created. If FILE already exists as a non-directory, it changes | |
55 permissions of FILE or deletes FILE to make it possible to write a new | |
96486
7369ded3b436
Typo and docstring fixes.
Juanma Barranquero <lekktu@gmail.com>
parents:
94668
diff
changeset
|
56 version of FILE. Returns nil if this can not be done, or if FILE already |
7369ded3b436
Typo and docstring fixes.
Juanma Barranquero <lekktu@gmail.com>
parents:
94668
diff
changeset
|
57 exists as a directory. Otherwise, returns t, indicating that |
54695 | 58 FILE can be created or overwritten." |
59 (cond | |
60 ((url-cache-file-writable-p file) | |
61 t) | |
62 ((file-directory-p file) | |
63 nil) | |
64 (t | |
65 (condition-case () | |
66 (or (make-directory (file-name-directory file) t) t) | |
67 (error nil))))) | |
68 | |
69 ;;;###autoload | |
70 (defun url-store-in-cache (&optional buff) | |
71 "Store buffer BUFF in the cache." | |
110343
94013d67543b
* lisp/url/url-cache (url-store-in-cache): Make `buff' argument really optional.
Glenn Morris <rgm@gnu.org>
parents:
106815
diff
changeset
|
72 (with-current-buffer (get-buffer (or buff (current-buffer))) |
94013d67543b
* lisp/url/url-cache (url-store-in-cache): Make `buff' argument really optional.
Glenn Morris <rgm@gnu.org>
parents:
106815
diff
changeset
|
73 (let ((fname (url-cache-create-filename (url-view-url t)))) |
94013d67543b
* lisp/url/url-cache (url-store-in-cache): Make `buff' argument really optional.
Glenn Morris <rgm@gnu.org>
parents:
106815
diff
changeset
|
74 (if (url-cache-prepare fname) |
94013d67543b
* lisp/url/url-cache (url-store-in-cache): Make `buff' argument really optional.
Glenn Morris <rgm@gnu.org>
parents:
106815
diff
changeset
|
75 (let ((coding-system-for-write 'binary)) |
94013d67543b
* lisp/url/url-cache (url-store-in-cache): Make `buff' argument really optional.
Glenn Morris <rgm@gnu.org>
parents:
106815
diff
changeset
|
76 (write-region (point-min) (point-max) fname nil 5)))))) |
64748
875dcc490074
Update years in copyright notice; nfc.
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
64084
diff
changeset
|
77 |
110430
838a8c24850f
* lisp/url/url-cache.el (url-fetch-from-cache): New function.
Glenn Morris <rgm@gnu.org>
parents:
110357
diff
changeset
|
78 (defun url-fetch-from-cache (url) |
838a8c24850f
* lisp/url/url-cache.el (url-fetch-from-cache): New function.
Glenn Morris <rgm@gnu.org>
parents:
110357
diff
changeset
|
79 "Fetch URL from cache and return a buffer with the content." |
838a8c24850f
* lisp/url/url-cache.el (url-fetch-from-cache): New function.
Glenn Morris <rgm@gnu.org>
parents:
110357
diff
changeset
|
80 (with-current-buffer (generate-new-buffer " *temp*") |
838a8c24850f
* lisp/url/url-cache.el (url-fetch-from-cache): New function.
Glenn Morris <rgm@gnu.org>
parents:
110357
diff
changeset
|
81 (url-cache-extract (url-cache-create-filename url)) |
838a8c24850f
* lisp/url/url-cache.el (url-fetch-from-cache): New function.
Glenn Morris <rgm@gnu.org>
parents:
110357
diff
changeset
|
82 (current-buffer))) |
838a8c24850f
* lisp/url/url-cache.el (url-fetch-from-cache): New function.
Glenn Morris <rgm@gnu.org>
parents:
110357
diff
changeset
|
83 |
54695 | 84 ;;;###autoload |
85 (defun url-is-cached (url) | |
110522
4bca1a43c0d3
* lisp/url/url-cache.el (url-is-cached): Doc fix.
Glenn Morris <rgm@gnu.org>
parents:
110343
diff
changeset
|
86 "Return non-nil if the URL is cached. |
4bca1a43c0d3
* lisp/url/url-cache.el (url-is-cached): Doc fix.
Glenn Morris <rgm@gnu.org>
parents:
110343
diff
changeset
|
87 The actual return value is the last modification time of the cache file." |
54695 | 88 (let* ((fname (url-cache-create-filename url)) |
89 (attribs (file-attributes fname))) | |
90 (and fname ; got a filename | |
91 (file-exists-p fname) ; file exists | |
92 (not (eq (nth 0 attribs) t)) ; Its not a directory | |
93 (nth 5 attribs)))) ; Can get last mod-time | |
94 | |
95 (defun url-cache-create-filename-human-readable (url) | |
96486
7369ded3b436
Typo and docstring fixes.
Juanma Barranquero <lekktu@gmail.com>
parents:
94668
diff
changeset
|
96 "Return a filename in the local cache for URL." |
54695 | 97 (if url |
110578 | 98 (let* ((urlobj (url-generic-parse-url url)) |
54695 | 99 (protocol (url-type urlobj)) |
100 (hostname (url-host urlobj)) | |
101 (host-components | |
102 (cons | |
103 (user-real-login-name) | |
104 (cons (or protocol "file") | |
105 (reverse (split-string (or hostname "localhost") | |
110744
dab4cfd7ea71
Cosmetic changes for some lisp/url files.
Glenn Morris <rgm@gnu.org>
parents:
110578
diff
changeset
|
106 "\\."))))) |
54695 | 107 (fname (url-filename urlobj))) |
108 (if (and fname (/= (length fname) 0) (= (aref fname 0) ?/)) | |
109 (setq fname (substring fname 1 nil))) | |
110 (if fname | |
111 (let ((slash nil)) | |
112 (setq fname | |
113 (mapconcat | |
114 (function | |
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 (function (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. | |
54793
4051557a5374
(url-util): Require.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54770
diff
changeset
|
152 Very fast if you have an `md5' primitive function, suitably fast otherwise." |
54695 | 153 (require 'md5) |
154 (if url | |
110578 | 155 (let* ((checksum (md5 url)) |
54695 | 156 (urlobj (url-generic-parse-url url)) |
157 (protocol (url-type urlobj)) | |
158 (hostname (url-host urlobj)) | |
159 (host-components | |
160 (cons | |
161 (user-real-login-name) | |
162 (cons (or protocol "file") | |
163 (nreverse | |
164 (delq nil | |
165 (split-string (or hostname "localhost") | |
110744
dab4cfd7ea71
Cosmetic changes for some lisp/url files.
Glenn Morris <rgm@gnu.org>
parents:
110578
diff
changeset
|
166 "\\.")))))) |
54695 | 167 (fname (url-filename urlobj))) |
168 (and fname | |
169 (expand-file-name checksum | |
170 (expand-file-name | |
171 (mapconcat 'identity host-components "/") | |
172 url-cache-directory)))))) | |
173 | |
174 (defcustom url-cache-creation-function 'url-cache-create-filename-using-md5 | |
110307 | 175 "What function to use to create a cached filename." |
54695 | 176 :type '(choice (const :tag "MD5 of filename (low collision rate)" |
177 :value url-cache-create-filename-using-md5) | |
178 (const :tag "Human readable filenames (higher collision rate)" | |
179 :value url-cache-create-filename-human-readable) | |
180 (function :tag "Other")) | |
181 :group 'url-cache) | |
182 | |
183 (defun url-cache-create-filename (url) | |
110578 | 184 (funcall url-cache-creation-function |
185 ;; We need to parse+recreate in order to remove the default port | |
186 ;; if it has been specified: e.g. http://www.example.com:80 will | |
187 ;; be transcoded as http://www.example.com | |
188 (url-recreate-url | |
189 (if (vectorp url) url | |
190 (url-generic-parse-url url))))) | |
54695 | 191 |
192 ;;;###autoload | |
193 (defun url-cache-extract (fnam) | |
96486
7369ded3b436
Typo and docstring fixes.
Juanma Barranquero <lekktu@gmail.com>
parents:
94668
diff
changeset
|
194 "Extract FNAM from the local disk cache." |
54695 | 195 (erase-buffer) |
196 (insert-file-contents-literally fnam)) | |
197 | |
110490 | 198 (defun url-cache-expired (url &optional expire-time) |
110491
3501c2b9e719
* url-cache.el (url-cache-expired): Don't autoload. Tweak previous change.
Glenn Morris <rgm@gnu.org>
parents:
110490
diff
changeset
|
199 "Return non-nil if a cached URL is older than EXPIRE-TIME seconds. |
3501c2b9e719
* url-cache.el (url-cache-expired): Don't autoload. Tweak previous change.
Glenn Morris <rgm@gnu.org>
parents:
110490
diff
changeset
|
200 The default value of EXPIRE-TIME is `url-cache-expire-time'. |
3501c2b9e719
* url-cache.el (url-cache-expired): Don't autoload. Tweak previous change.
Glenn Morris <rgm@gnu.org>
parents:
110490
diff
changeset
|
201 If `url-standalone-mode' is non-nil, cached items never expire." |
3501c2b9e719
* url-cache.el (url-cache-expired): Don't autoload. Tweak previous change.
Glenn Morris <rgm@gnu.org>
parents:
110490
diff
changeset
|
202 (if url-standalone-mode |
3501c2b9e719
* url-cache.el (url-cache-expired): Don't autoload. Tweak previous change.
Glenn Morris <rgm@gnu.org>
parents:
110490
diff
changeset
|
203 (not (file-exists-p (url-cache-create-filename url))) |
3501c2b9e719
* url-cache.el (url-cache-expired): Don't autoload. Tweak previous change.
Glenn Morris <rgm@gnu.org>
parents:
110490
diff
changeset
|
204 (let ((cache-time (url-is-cached url))) |
110492 | 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)))))) | |
54695 | 211 |
212 (provide 'url-cache) | |
54699 | 213 |
57612 | 214 ;;; url-cache.el ends here |