Mercurial > emacs
comparison lisp/url/url-cache.el @ 54695:3fb37923e567
Initial revision
author | Stefan Monnier <monnier@iro.umontreal.ca> |
---|---|
date | Sun, 04 Apr 2004 01:21:46 +0000 |
parents | |
children | 7784ae10206d |
comparison
equal
deleted
inserted
replaced
54694:253149f265f2 | 54695:3fb37923e567 |
---|---|
1 ;;; url-cache.el --- Uniform Resource Locator retrieval tool | |
2 ;; Author: $Author: fx $ | |
3 ;; Created: $Date: 2002/01/22 17:53:45 $ | |
4 ;; Version: $Revision: 1.4 $ | |
5 ;; Keywords: comm, data, processes, hypermedia | |
6 | |
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
8 ;;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu> | |
9 ;;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc. | |
10 ;;; | |
11 ;;; This file is part of GNU Emacs. | |
12 ;;; | |
13 ;;; GNU Emacs is free software; you can redistribute it and/or modify | |
14 ;;; it under the terms of the GNU General Public License as published by | |
15 ;;; the Free Software Foundation; either version 2, or (at your option) | |
16 ;;; any later version. | |
17 ;;; | |
18 ;;; GNU Emacs is distributed in the hope that it will be useful, | |
19 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
20 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
21 ;;; GNU General Public License for more details. | |
22 ;;; | |
23 ;;; You should have received a copy of the GNU General Public License | |
24 ;;; along with GNU Emacs; see the file COPYING. If not, write to the | |
25 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
26 ;;; Boston, MA 02111-1307, USA. | |
27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
28 (require 'url-parse) | |
29 | |
30 (defcustom url-cache-directory | |
31 (expand-file-name "cache" url-configuration-directory) | |
32 "*The directory where cache files should be stored." | |
33 :type 'directory | |
34 :group 'url-file) | |
35 | |
36 ;; Cache manager | |
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))))) | |
43 | |
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." | |
53 (cond | |
54 ((url-cache-file-writable-p file) | |
55 t) | |
56 ((file-directory-p file) | |
57 nil) | |
58 (t | |
59 (condition-case () | |
60 (or (make-directory (file-name-directory file) t) t) | |
61 (error nil))))) | |
62 | |
63 ;;;###autoload | |
64 (defun url-store-in-cache (&optional buff) | |
65 "Store buffer BUFF in the cache." | |
66 (if (not (and buff (get-buffer buff))) | |
67 nil | |
68 (save-excursion | |
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))))))) | |
74 | |
75 ;;;###autoload | |
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 | |
84 | |
85 (defun url-cache-create-filename-human-readable (url) | |
86 "Return a filename in the local cache for URL" | |
87 (if 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)) | |
92 (host-components | |
93 (cons | |
94 (user-real-login-name) | |
95 (cons (or protocol "file") | |
96 (reverse (split-string (or hostname "localhost") | |
97 (eval-when-compile | |
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))) | |
102 (if fname | |
103 (let ((slash nil)) | |
104 (setq fname | |
105 (mapconcat | |
106 (function | |
107 (lambda (x) | |
108 (cond | |
109 ((and (= ?/ x) slash) | |
110 (setq slash nil) | |
111 "%2F") | |
112 ((= ?/ x) | |
113 (setq slash t) | |
114 "/") | |
115 (t | |
116 (setq slash nil) | |
117 (char-to-string x))))) fname "")))) | |
118 | |
119 (setq fname (and fname | |
120 (mapconcat | |
121 (function (lambda (x) | |
122 (if (= x ?~) "" (char-to-string x)))) | |
123 fname "")) | |
124 fname (cond | |
125 ((null fname) nil) | |
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))) | |
132 (t | |
133 (if (string= (substring fname -1 nil) "/") | |
134 (concat fname url-directory-index-file) | |
135 fname)))) | |
136 (and fname | |
137 (expand-file-name fname | |
138 (expand-file-name | |
139 (mapconcat 'identity host-components "/") | |
140 url-cache-directory)))))) | |
141 | |
142 (defun url-cache-create-filename-using-md5 (url) | |
143 "Create a cached filename using MD5. | |
144 Very fast if you are in XEmacs, suitably fast otherwise." | |
145 (require 'md5) | |
146 (if url | |
147 (let* ((url (if (vectorp url) (url-recreate-url url) url)) | |
148 (checksum (md5 url)) | |
149 (urlobj (url-generic-parse-url url)) | |
150 (protocol (url-type urlobj)) | |
151 (hostname (url-host urlobj)) | |
152 (host-components | |
153 (cons | |
154 (user-real-login-name) | |
155 (cons (or protocol "file") | |
156 (nreverse | |
157 (delq nil | |
158 (split-string (or hostname "localhost") | |
159 (eval-when-compile | |
160 (regexp-quote ".")))))))) | |
161 (fname (url-filename urlobj))) | |
162 (and fname | |
163 (expand-file-name checksum | |
164 (expand-file-name | |
165 (mapconcat 'identity host-components "/") | |
166 url-cache-directory)))))) | |
167 | |
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")) | |
175 :group 'url-cache) | |
176 | |
177 (defun url-cache-create-filename (url) | |
178 (funcall url-cache-creation-function url)) | |
179 | |
180 ;;;###autoload | |
181 (defun url-cache-extract (fnam) | |
182 "Extract FNAM from the local disk cache" | |
183 (erase-buffer) | |
184 (insert-file-contents-literally fnam)) | |
185 | |
186 ;;;###autoload | |
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))) | |
191 (cond | |
192 (url-standalone-mode | |
193 (not (file-exists-p (url-cache-create-filename url)))) | |
194 ((string= type "http") | |
195 t) | |
196 ((member type '("file" "ftp")) | |
197 (if (or (equal mod '(0 0)) (not mod)) | |
198 t | |
199 (or (> (nth 0 mod) (nth 0 (current-time))) | |
200 (> (nth 1 mod) (nth 1 (current-time)))))) | |
201 (t nil)))) | |
202 | |
203 (provide 'url-cache) |