lisp/url/url-cache.el

   1 ;;; url-cache.el --- Uniform Resource Locator retrieval tool
   2
   3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2004,
   4 ;;   2005, 2006, 2007, 2008  Free Software Foundation, Inc.
   5
   6 ;; Keywords: comm, data, processes, hypermedia
   7
   8 ;; This file is part of GNU Emacs.
   9
  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 3, or (at your option)
  13 ;; any later version.
  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
  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.
  24
  25 ;;; Code:
  26
  27 (require 'url-parse)
  28 (require 'url-util)
  29 (require 'url)                        ;E.g. for url-configuration-directory.
  30
  31 (defcustom url-cache-directory
  32   (expand-file-name "cache" url-configuration-directory)
  33   "*The directory where cache files should be stored."
  34   :type 'directory
  35   :group 'url-file)
  36
  37 ;; Cache manager
  38 (defun url-cache-file-writable-p (file)
  39   "Follows the documentation of `file-writable-p', unlike `file-writable-p'."
  40   (and (file-writable-p file)
  41        (if (file-exists-p file)
  42            (not (file-directory-p file))
  43          (file-directory-p (file-name-directory file)))))
  44
  45 (defun url-cache-prepare (file)
  46   "Makes it possible to cache data in FILE.
  47 Creates any necessary parent directories, deleting any non-directory files
  48 that would stop this.  Returns nil if parent directories can not be
  49 created.  If FILE already exists as a non-directory, it changes
  50 permissions of FILE or deletes FILE to make it possible to write a new
  51 version of FILE.  Returns nil if this can not be done.  Returns nil if
  52 FILE already exists as a directory.  Otherwise, returns t, indicating that
  53 FILE can be created or overwritten."
  54   (cond
  55    ((url-cache-file-writable-p file)
  56     t)
  57    ((file-directory-p file)
  58     nil)
  59    (t
  60     (condition-case ()
  61         (or (make-directory (file-name-directory file) t) t)
  62       (error nil)))))
  63
  64 ;;;###autoload
  65 (defun url-store-in-cache (&optional buff)
  66   "Store buffer BUFF in the cache."
  67   (if (not (and buff (get-buffer buff)))
  68       nil
  69     (save-current-buffer
  70       (and buff (set-buffer buff))
  71       (let* ((fname (url-cache-create-filename (url-view-url t))))
  72         (if (url-cache-prepare fname)
  73             (let ((coding-system-for-write 'binary))
  74               (write-region (point-min) (point-max) fname nil 5)))))))
  75
  76 ;;;###autoload
  77 (defun url-is-cached (url)
  78   "Return non-nil if the URL is cached."
  79   (let* ((fname (url-cache-create-filename url))
  80          (attribs (file-attributes fname)))
  81     (and fname                          ; got a filename
  82          (file-exists-p fname)          ; file exists
  83          (not (eq (nth 0 attribs) t))   ; Its not a directory
  84          (nth 5 attribs))))             ; Can get last mod-time
  85
  86 (defun url-cache-create-filename-human-readable (url)
  87   "Return a filename in the local cache for URL"
  88   (if url
  89       (let* ((url (if (vectorp url) (url-recreate-url url) url))
  90              (urlobj (url-generic-parse-url url))
  91              (protocol (url-type urlobj))
  92              (hostname (url-host urlobj))
  93              (host-components
  94               (cons
  95                (user-real-login-name)
  96                (cons (or protocol "file")
  97                      (reverse (split-string (or hostname "localhost")
  98                                             (eval-when-compile
  99                                               (regexp-quote ".")))))))
 100              (fname    (url-filename urlobj)))
 101         (if (and fname (/= (length fname) 0) (= (aref fname 0) ?/))
 102             (setq fname (substring fname 1 nil)))
 103         (if fname
 104             (let ((slash nil))
 105               (setq fname
 106                     (mapconcat
 107                      (function
 108                       (lambda (x)
 109                         (cond
 110                          ((and (= ?/ x) slash)
 111                           (setq slash nil)
 112                           "%2F")
 113                          ((= ?/ x)
 114                           (setq slash t)
 115                           "/")
 116                          (t
 117                           (setq slash nil)
 118                           (char-to-string x))))) fname ""))))
 119
 120         (setq fname (and fname
 121                          (mapconcat
 122                           (function (lambda (x)
 123                                       (if (= x ?~) "" (char-to-string x))))
 124                           fname ""))
 125               fname (cond
 126                      ((null fname) nil)
 127                      ((or (string= "" fname) (string= "/" fname))
 128                       url-directory-index-file)
 129                      ((= (string-to-char fname) ?/)
 130                       (if (string= (substring fname -1 nil) "/")
 131                           (concat fname url-directory-index-file)
 132                         (substring fname 1 nil)))
 133                      (t
 134                       (if (string= (substring fname -1 nil) "/")
 135                           (concat fname url-directory-index-file)
 136                         fname))))
 137         (and fname
 138              (expand-file-name fname
 139                                (expand-file-name
 140                                 (mapconcat 'identity host-components "/")
 141                                 url-cache-directory))))))
 142
 143 (defun url-cache-create-filename-using-md5 (url)
 144   "Create a cached filename using MD5.
 145 Very fast if you have an `md5' primitive function, suitably fast otherwise."
 146   (require 'md5)
 147   (if url
 148       (let* ((url (if (vectorp url) (url-recreate-url url) url))
 149              (checksum (md5 url))
 150              (urlobj (url-generic-parse-url url))
 151              (protocol (url-type urlobj))
 152              (hostname (url-host urlobj))
 153              (host-components
 154               (cons
 155                (user-real-login-name)
 156                (cons (or protocol "file")
 157                      (nreverse
 158                       (delq nil
 159                             (split-string (or hostname "localhost")
 160                                           (eval-when-compile
 161                                             (regexp-quote "."))))))))
 162              (fname    (url-filename urlobj)))
 163         (and fname
 164              (expand-file-name checksum
 165                                (expand-file-name
 166                                 (mapconcat 'identity host-components "/")
 167                                 url-cache-directory))))))
 168
 169 (defcustom url-cache-creation-function 'url-cache-create-filename-using-md5
 170   "*What function to use to create a cached filename."
 171   :type '(choice (const :tag "MD5 of filename (low collision rate)"
 172                         :value url-cache-create-filename-using-md5)
 173                  (const :tag "Human readable filenames (higher collision rate)"
 174                         :value url-cache-create-filename-human-readable)
 175                  (function :tag "Other"))
 176   :group 'url-cache)
 177
 178 (defun url-cache-create-filename (url)
 179   (funcall url-cache-creation-function url))
 180
 181 ;;;###autoload
 182 (defun url-cache-extract (fnam)
 183   "Extract FNAM from the local disk cache"
 184   (erase-buffer)
 185   (insert-file-contents-literally fnam))
 186
 187 ;;;###autoload
 188 (defun url-cache-expired (url mod)
 189   "Return t if a cached file has expired."
 190   (let* ((urlobj (if (vectorp url) url (url-generic-parse-url url)))
 191          (type (url-type urlobj)))
 192     (cond
 193      (url-standalone-mode
 194       (not (file-exists-p (url-cache-create-filename url))))
 195      ((string= type "http")
 196       t)
 197      ((member type '("file" "ftp"))
 198       (if (or (equal mod '(0 0)) (not mod))
 199           t
 200         (or (> (nth 0 mod) (nth 0 (current-time)))
 201             (> (nth 1 mod) (nth 1 (current-time))))))
 202      (t nil))))
 203
 204 (provide 'url-cache)
 205
 206 ;; arch-tag: 95b050a6-8e81-4f23-8e63-191b9d1d657c
 207 ;;; url-cache.el ends here