1 ;;; url-cache.el --- Uniform Resource Locator retrieval tool
3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2004,
4 ;; 2005 Free Software Foundation, Inc.
6 ;; Keywords: comm, data, processes, hypermedia
8 ;; This file is part of GNU Emacs.
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)
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.
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.
30 (defcustom url-cache-directory
31 (expand-file-name "cache" url-configuration-directory
)
32 "*The directory where cache files should be stored."
37 (defun url-cache-file-writable-p (file)
38 "Follows the documentation of `file-writable-p', unlike `file-writable-p'."
39 (and (file-writable-p file
)
40 (if (file-exists-p file
)
41 (not (file-directory-p file
))
42 (file-directory-p (file-name-directory file
)))))
44 (defun url-cache-prepare (file)
45 "Makes it possible to cache data in FILE.
46 Creates any necessary parent directories, deleting any non-directory files
47 that would stop this. Returns nil if parent directories can not be
48 created. If FILE already exists as a non-directory, it changes
49 permissions of FILE or deletes FILE to make it possible to write a new
50 version of FILE. Returns nil if this can not be done. Returns nil if
51 FILE already exists as a directory. Otherwise, returns t, indicating that
52 FILE can be created or overwritten."
54 ((url-cache-file-writable-p file
)
56 ((file-directory-p file
)
60 (or (make-directory (file-name-directory file
) t
) t
)
64 (defun url-store-in-cache (&optional buff
)
65 "Store buffer BUFF in the cache."
66 (if (not (and buff
(get-buffer buff
)))
69 (and buff
(set-buffer buff
))
70 (let* ((fname (url-cache-create-filename (url-view-url t
))))
71 (if (url-cache-prepare fname
)
72 (let ((coding-system-for-write 'binary
))
73 (write-region (point-min) (point-max) fname nil
5)))))))
76 (defun url-is-cached (url)
77 "Return non-nil if the URL is cached."
78 (let* ((fname (url-cache-create-filename url
))
79 (attribs (file-attributes fname
)))
80 (and fname
; got a filename
81 (file-exists-p fname
) ; file exists
82 (not (eq (nth 0 attribs
) t
)) ; Its not a directory
83 (nth 5 attribs
)))) ; Can get last mod-time
85 (defun url-cache-create-filename-human-readable (url)
86 "Return a filename in the local cache for URL"
88 (let* ((url (if (vectorp url
) (url-recreate-url url
) url
))
89 (urlobj (url-generic-parse-url url
))
90 (protocol (url-type urlobj
))
91 (hostname (url-host urlobj
))
94 (user-real-login-name)
95 (cons (or protocol
"file")
96 (reverse (split-string (or hostname
"localhost")
98 (regexp-quote ".")))))))
99 (fname (url-filename urlobj
)))
100 (if (and fname
(/= (length fname
) 0) (= (aref fname
0) ?
/))
101 (setq fname
(substring fname
1 nil
)))
109 ((and (= ?
/ x
) slash
)
117 (char-to-string x
))))) fname
""))))
119 (setq fname
(and fname
121 (function (lambda (x)
122 (if (= x ?~
) "" (char-to-string x
))))
126 ((or (string= "" fname
) (string= "/" fname
))
127 url-directory-index-file
)
128 ((= (string-to-char fname
) ?
/)
129 (if (string= (substring fname -
1 nil
) "/")
130 (concat fname url-directory-index-file
)
131 (substring fname
1 nil
)))
133 (if (string= (substring fname -
1 nil
) "/")
134 (concat fname url-directory-index-file
)
137 (expand-file-name fname
139 (mapconcat 'identity host-components
"/")
140 url-cache-directory
))))))
142 (defun url-cache-create-filename-using-md5 (url)
143 "Create a cached filename using MD5.
144 Very fast if you have an `md5' primitive function, suitably fast otherwise."
147 (let* ((url (if (vectorp url
) (url-recreate-url url
) url
))
149 (urlobj (url-generic-parse-url url
))
150 (protocol (url-type urlobj
))
151 (hostname (url-host urlobj
))
154 (user-real-login-name)
155 (cons (or protocol
"file")
158 (split-string (or hostname
"localhost")
160 (regexp-quote "."))))))))
161 (fname (url-filename urlobj
)))
163 (expand-file-name checksum
165 (mapconcat 'identity host-components
"/")
166 url-cache-directory
))))))
168 (defcustom url-cache-creation-function
'url-cache-create-filename-using-md5
169 "*What function to use to create a cached filename."
170 :type
'(choice (const :tag
"MD5 of filename (low collision rate)"
171 :value url-cache-create-filename-using-md5
)
172 (const :tag
"Human readable filenames (higher collision rate)"
173 :value url-cache-create-filename-human-readable
)
174 (function :tag
"Other"))
177 (defun url-cache-create-filename (url)
178 (funcall url-cache-creation-function url
))
181 (defun url-cache-extract (fnam)
182 "Extract FNAM from the local disk cache"
184 (insert-file-contents-literally fnam
))
187 (defun url-cache-expired (url mod
)
188 "Return t iff a cached file has expired."
189 (let* ((urlobj (if (vectorp url
) url
(url-generic-parse-url url
)))
190 (type (url-type urlobj
)))
193 (not (file-exists-p (url-cache-create-filename url
))))
194 ((string= type
"http")
196 ((member type
'("file" "ftp"))
197 (if (or (equal mod
'(0 0)) (not mod
))
199 (or (> (nth 0 mod
) (nth 0 (current-time)))
200 (> (nth 1 mod
) (nth 1 (current-time))))))
205 ;;; arch-tag: 95b050a6-8e81-4f23-8e63-191b9d1d657c
206 ;;; url-cache.el ends here