1 ;;; url-cache.el --- Uniform Resource Locator retrieval tool
2 ;; Keywords: comm, data, processes, hypermedia
4 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
5 ;;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
6 ;;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc.
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)
13 ;;; any later version.
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., 59 Temple Place - Suite 330,
23 ;;; Boston, MA 02111-1307, USA.
24 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28 (defcustom url-cache-directory
29 (expand-file-name "cache" url-configuration-directory
)
30 "*The directory where cache files should be stored."
35 (defun url-cache-file-writable-p (file)
36 "Follows the documentation of `file-writable-p', unlike `file-writable-p'."
37 (and (file-writable-p file
)
38 (if (file-exists-p file
)
39 (not (file-directory-p file
))
40 (file-directory-p (file-name-directory file
)))))
42 (defun url-cache-prepare (file)
43 "Makes it possible to cache data in FILE.
44 Creates any necessary parent directories, deleting any non-directory files
45 that would stop this. Returns nil if parent directories can not be
46 created. If FILE already exists as a non-directory, it changes
47 permissions of FILE or deletes FILE to make it possible to write a new
48 version of FILE. Returns nil if this can not be done. Returns nil if
49 FILE already exists as a directory. Otherwise, returns t, indicating that
50 FILE can be created or overwritten."
52 ((url-cache-file-writable-p file
)
54 ((file-directory-p file
)
58 (or (make-directory (file-name-directory file
) t
) t
)
62 (defun url-store-in-cache (&optional buff
)
63 "Store buffer BUFF in the cache."
64 (if (not (and buff
(get-buffer buff
)))
67 (and buff
(set-buffer buff
))
68 (let* ((fname (url-cache-create-filename (url-view-url t
))))
69 (if (url-cache-prepare fname
)
70 (let ((coding-system-for-write 'binary
))
71 (write-region (point-min) (point-max) fname nil
5)))))))
74 (defun url-is-cached (url)
75 "Return non-nil if the URL is cached."
76 (let* ((fname (url-cache-create-filename url
))
77 (attribs (file-attributes fname
)))
78 (and fname
; got a filename
79 (file-exists-p fname
) ; file exists
80 (not (eq (nth 0 attribs
) t
)) ; Its not a directory
81 (nth 5 attribs
)))) ; Can get last mod-time
83 (defun url-cache-create-filename-human-readable (url)
84 "Return a filename in the local cache for URL"
86 (let* ((url (if (vectorp url
) (url-recreate-url url
) url
))
87 (urlobj (url-generic-parse-url url
))
88 (protocol (url-type urlobj
))
89 (hostname (url-host urlobj
))
92 (user-real-login-name)
93 (cons (or protocol
"file")
94 (reverse (split-string (or hostname
"localhost")
96 (regexp-quote ".")))))))
97 (fname (url-filename urlobj
)))
98 (if (and fname
(/= (length fname
) 0) (= (aref fname
0) ?
/))
99 (setq fname
(substring fname
1 nil
)))
107 ((and (= ?
/ x
) slash
)
115 (char-to-string x
))))) fname
""))))
117 (setq fname
(and fname
119 (function (lambda (x)
120 (if (= x ?~
) "" (char-to-string x
))))
124 ((or (string= "" fname
) (string= "/" fname
))
125 url-directory-index-file
)
126 ((= (string-to-char fname
) ?
/)
127 (if (string= (substring fname -
1 nil
) "/")
128 (concat fname url-directory-index-file
)
129 (substring fname
1 nil
)))
131 (if (string= (substring fname -
1 nil
) "/")
132 (concat fname url-directory-index-file
)
135 (expand-file-name fname
137 (mapconcat 'identity host-components
"/")
138 url-cache-directory
))))))
140 (defun url-cache-create-filename-using-md5 (url)
141 "Create a cached filename using MD5.
142 Very fast if you have an `md5' primitive function, suitably fast otherwise."
145 (let* ((url (if (vectorp url
) (url-recreate-url url
) url
))
147 (urlobj (url-generic-parse-url url
))
148 (protocol (url-type urlobj
))
149 (hostname (url-host urlobj
))
152 (user-real-login-name)
153 (cons (or protocol
"file")
156 (split-string (or hostname
"localhost")
158 (regexp-quote "."))))))))
159 (fname (url-filename urlobj
)))
161 (expand-file-name checksum
163 (mapconcat 'identity host-components
"/")
164 url-cache-directory
))))))
166 (defcustom url-cache-creation-function
'url-cache-create-filename-using-md5
167 "*What function to use to create a cached filename."
168 :type
'(choice (const :tag
"MD5 of filename (low collision rate)"
169 :value url-cache-create-filename-using-md5
)
170 (const :tag
"Human readable filenames (higher collision rate)"
171 :value url-cache-create-filename-human-readable
)
172 (function :tag
"Other"))
175 (defun url-cache-create-filename (url)
176 (funcall url-cache-creation-function url
))
179 (defun url-cache-extract (fnam)
180 "Extract FNAM from the local disk cache"
182 (insert-file-contents-literally fnam
))
185 (defun url-cache-expired (url mod
)
186 "Return t iff a cached file has expired."
187 (let* ((urlobj (if (vectorp url
) url
(url-generic-parse-url url
)))
188 (type (url-type urlobj
)))
191 (not (file-exists-p (url-cache-create-filename url
))))
192 ((string= type
"http")
194 ((member type
'("file" "ftp"))
195 (if (or (equal mod
'(0 0)) (not mod
))
197 (or (> (nth 0 mod
) (nth 0 (current-time)))
198 (> (nth 1 mod
) (nth 1 (current-time))))))
203 ;;; arch-tag: 95b050a6-8e81-4f23-8e63-191b9d1d657c