Mercurial > emacs
annotate lisp/url/url-cache.el @ 107168:282ddc0ca465
* simple.el (save-interprogram-paste-before-kill): Doc fix.
author | Chong Yidong <cyd@stupidchicken.com> |
---|---|
date | Tue, 16 Feb 2010 09:40:45 -0500 |
parents | 1d1d5d9bd884 |
children | 5495085c9b6c 94013d67543b |
rev | line source |
---|---|
54695 | 1 ;;; url-cache.el --- Uniform Resource Locator retrieval tool |
57612 | 2 |
64748
875dcc490074
Update years in copyright notice; nfc.
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
64084
diff
changeset
|
3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2004, |
106815 | 4 ;; 2005, 2006, 2007, 2008, 2009, 2010 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) | |
31 "*The directory where cache files should be stored." | |
32 :type 'directory | |
33 :group 'url-file) | |
34 | |
35 ;; Cache manager | |
36 (defun url-cache-file-writable-p (file) | |
37 "Follows the documentation of `file-writable-p', unlike `file-writable-p'." | |
38 (and (file-writable-p file) | |
39 (if (file-exists-p file) | |
40 (not (file-directory-p file)) | |
41 (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
|
42 |
54695 | 43 (defun url-cache-prepare (file) |
44 "Makes it possible to cache data in FILE. | |
45 Creates any necessary parent directories, deleting any non-directory files | |
46 that would stop this. Returns nil if parent directories can not be | |
47 created. If FILE already exists as a non-directory, it changes | |
48 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
|
49 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
|
50 exists as a directory. Otherwise, returns t, indicating that |
54695 | 51 FILE can be created or overwritten." |
52 (cond | |
53 ((url-cache-file-writable-p file) | |
54 t) | |
55 ((file-directory-p file) | |
56 nil) | |
57 (t | |
58 (condition-case () | |
59 (or (make-directory (file-name-directory file) t) t) | |
60 (error nil))))) | |
61 | |
62 ;;;###autoload | |
63 (defun url-store-in-cache (&optional buff) | |
64 "Store buffer BUFF in the cache." | |
65 (if (not (and buff (get-buffer buff))) | |
66 nil | |
67851
eebc9bf86f06
(url-store-in-cache): Use save-current-buffer.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
64748
diff
changeset
|
67 (save-current-buffer |
54695 | 68 (and buff (set-buffer buff)) |
69 (let* ((fname (url-cache-create-filename (url-view-url t)))) | |
70 (if (url-cache-prepare fname) | |
71 (let ((coding-system-for-write 'binary)) | |
72 (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
|
73 |
54695 | 74 ;;;###autoload |
75 (defun url-is-cached (url) | |
76 "Return non-nil if the URL is cached." | |
77 (let* ((fname (url-cache-create-filename url)) | |
78 (attribs (file-attributes fname))) | |
79 (and fname ; got a filename | |
80 (file-exists-p fname) ; file exists | |
81 (not (eq (nth 0 attribs) t)) ; Its not a directory | |
82 (nth 5 attribs)))) ; Can get last mod-time | |
83 | |
84 (defun url-cache-create-filename-human-readable (url) | |
96486
7369ded3b436
Typo and docstring fixes.
Juanma Barranquero <lekktu@gmail.com>
parents:
94668
diff
changeset
|
85 "Return a filename in the local cache for URL." |
54695 | 86 (if url |
87 (let* ((url (if (vectorp url) (url-recreate-url url) url)) | |
88 (urlobj (url-generic-parse-url url)) | |
89 (protocol (url-type urlobj)) | |
90 (hostname (url-host urlobj)) | |
91 (host-components | |
92 (cons | |
93 (user-real-login-name) | |
94 (cons (or protocol "file") | |
95 (reverse (split-string (or hostname "localhost") | |
96 (eval-when-compile | |
97 (regexp-quote "."))))))) | |
98 (fname (url-filename urlobj))) | |
99 (if (and fname (/= (length fname) 0) (= (aref fname 0) ?/)) | |
100 (setq fname (substring fname 1 nil))) | |
101 (if fname | |
102 (let ((slash nil)) | |
103 (setq fname | |
104 (mapconcat | |
105 (function | |
106 (lambda (x) | |
107 (cond | |
108 ((and (= ?/ x) slash) | |
109 (setq slash nil) | |
110 "%2F") | |
111 ((= ?/ x) | |
112 (setq slash t) | |
113 "/") | |
114 (t | |
115 (setq slash nil) | |
116 (char-to-string x))))) fname "")))) | |
117 | |
118 (setq fname (and fname | |
119 (mapconcat | |
120 (function (lambda (x) | |
121 (if (= x ?~) "" (char-to-string x)))) | |
122 fname "")) | |
123 fname (cond | |
124 ((null fname) nil) | |
125 ((or (string= "" fname) (string= "/" fname)) | |
126 url-directory-index-file) | |
127 ((= (string-to-char fname) ?/) | |
128 (if (string= (substring fname -1 nil) "/") | |
129 (concat fname url-directory-index-file) | |
130 (substring fname 1 nil))) | |
131 (t | |
132 (if (string= (substring fname -1 nil) "/") | |
133 (concat fname url-directory-index-file) | |
134 fname)))) | |
135 (and fname | |
136 (expand-file-name fname | |
137 (expand-file-name | |
138 (mapconcat 'identity host-components "/") | |
139 url-cache-directory)))))) | |
140 | |
141 (defun url-cache-create-filename-using-md5 (url) | |
142 "Create a cached filename using MD5. | |
54793
4051557a5374
(url-util): Require.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54770
diff
changeset
|
143 Very fast if you have an `md5' primitive function, suitably fast otherwise." |
54695 | 144 (require 'md5) |
145 (if url | |
146 (let* ((url (if (vectorp url) (url-recreate-url url) url)) | |
147 (checksum (md5 url)) | |
148 (urlobj (url-generic-parse-url url)) | |
149 (protocol (url-type urlobj)) | |
150 (hostname (url-host urlobj)) | |
151 (host-components | |
152 (cons | |
153 (user-real-login-name) | |
154 (cons (or protocol "file") | |
155 (nreverse | |
156 (delq nil | |
157 (split-string (or hostname "localhost") | |
158 (eval-when-compile | |
159 (regexp-quote ".")))))))) | |
160 (fname (url-filename urlobj))) | |
161 (and fname | |
162 (expand-file-name checksum | |
163 (expand-file-name | |
164 (mapconcat 'identity host-components "/") | |
165 url-cache-directory)))))) | |
166 | |
167 (defcustom url-cache-creation-function 'url-cache-create-filename-using-md5 | |
168 "*What function to use to create a cached filename." | |
169 :type '(choice (const :tag "MD5 of filename (low collision rate)" | |
170 :value url-cache-create-filename-using-md5) | |
171 (const :tag "Human readable filenames (higher collision rate)" | |
172 :value url-cache-create-filename-human-readable) | |
173 (function :tag "Other")) | |
174 :group 'url-cache) | |
175 | |
176 (defun url-cache-create-filename (url) | |
177 (funcall url-cache-creation-function url)) | |
178 | |
179 ;;;###autoload | |
180 (defun url-cache-extract (fnam) | |
96486
7369ded3b436
Typo and docstring fixes.
Juanma Barranquero <lekktu@gmail.com>
parents:
94668
diff
changeset
|
181 "Extract FNAM from the local disk cache." |
54695 | 182 (erase-buffer) |
183 (insert-file-contents-literally fnam)) | |
184 | |
185 ;;;###autoload | |
186 (defun url-cache-expired (url mod) | |
78481
bc53aa750f3b
Replace `iff' in doc-strings and comments.
Glenn Morris <rgm@gnu.org>
parents:
78222
diff
changeset
|
187 "Return t if a cached file has expired." |
54695 | 188 (let* ((urlobj (if (vectorp url) url (url-generic-parse-url url))) |
189 (type (url-type urlobj))) | |
190 (cond | |
191 (url-standalone-mode | |
192 (not (file-exists-p (url-cache-create-filename url)))) | |
193 ((string= type "http") | |
194 t) | |
195 ((member type '("file" "ftp")) | |
196 (if (or (equal mod '(0 0)) (not mod)) | |
197 t | |
198 (or (> (nth 0 mod) (nth 0 (current-time))) | |
199 (> (nth 1 mod) (nth 1 (current-time)))))) | |
200 (t nil)))) | |
201 | |
202 (provide 'url-cache) | |
54699 | 203 |
67851
eebc9bf86f06
(url-store-in-cache): Use save-current-buffer.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
64748
diff
changeset
|
204 ;; arch-tag: 95b050a6-8e81-4f23-8e63-191b9d1d657c |
57612 | 205 ;;; url-cache.el ends here |