diff --git a/doc/misc/url.texi b/doc/misc/url.texi index 8f15e11007..2ea34e0d03 100644 --- a/doc/misc/url.texi +++ b/doc/misc/url.texi @@ -923,6 +923,12 @@ Disk Caching expire-time argument of the function @code{url-cache-expired}. @end defopt +@defopt url-cache-expiry-alist +This variable is an alist of regular expressions matching @var{url}'s +and their associated expiration delay in seconds. It is used by the +functions @code{url-cache-expired} and @code{url-cache-prune-cache}. +@end defopt + @defun url-fetch-from-cache This function takes a URL as its argument and returns a buffer containing the data cached for that URL. diff --git a/lisp/url/url-cache.el b/lisp/url/url-cache.el index 830e6ba9dc..48f315a5cc 100644 --- a/lisp/url/url-cache.el +++ b/lisp/url/url-cache.el @@ -38,6 +38,15 @@ url-cache-expire-time :type 'integer :group 'url-cache) +(defcustom url-cache-expiry-alist nil + "Alist of URL regular expressions to override the `url-cache-expire-time'. +The key is a string to be matched against the URL of the cached entry and the +value is the expire time in seconds. Only the protocol and hostname of the URL +are available for matching." + :version "28.1" + :type 'alist + :group 'url-cache) + ;; Cache manager (defun url-cache-file-writable-p (file) "Follows the documentation of `file-writable-p', unlike `file-writable-p'." @@ -186,6 +195,31 @@ url-cache-create-filename (if (url-p url) url (url-generic-parse-url url))))) +(defun url-cache-create-url-from-file (file) + (let* ((url-path-list + (split-string + (file-name-directory + (string-trim-left file (concat "^.*/" (user-real-login-name)))) + "/" t)) + (protocol (pop url-path-list)) + (hostname + (string-join (reverse url-path-list) ".")) + (url (string-join (list protocol hostname) "://"))) + url)) + +(defun url-cache-expiry-by-url (url) + (let ((expire-time + (remove nil + (mapcar + (lambda (alist) + (let ((key (car alist)) + (value (cdr alist))) + (if (string-match + key url) + value))) + url-cache-expiry-alist)))) + (if (consp expire-time) (apply 'min expire-time) nil))) + ;;;###autoload (defun url-cache-extract (fnam) "Extract FNAM from the local disk cache." @@ -204,7 +238,9 @@ url-cache-expired (time-less-p (time-add cache-time - (or expire-time url-cache-expire-time)) + (or expire-time + (url-cache-expiry-by-url url) + url-cache-expire-time)) nil))))) (defun url-cache-prune-cache (&optional directory) @@ -226,8 +262,10 @@ url-cache-prune-cache ((time-less-p (time-add (file-attribute-modification-time (file-attributes file)) - url-cache-expire-time) - now) + (or (url-cache-expiry-by-url + (url-cache-create-url-from-file file)) + url-cache-expire-time)) + now) (delete-file file) (setq deleted-files (1+ deleted-files)))))) (if (< deleted-files total-files) diff --git a/test/lisp/url/url-cache-tests.el b/test/lisp/url/url-cache-tests.el new file mode 100644 index 0000000000..f4e49ce3b9 --- /dev/null +++ b/test/lisp/url/url-cache-tests.el @@ -0,0 +1,76 @@ +;;; url-cache-tests.el --- Test suite for url-cache. -*- lexical-binding:t -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; Author: Alex Bochannek +;; Keywords: data + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(require 'ert) +(require 'url-cache) + +(ert-deftest url-cache-url-to-filename-tests () + "Test the URL to filename resolution for the URL cache" + (should (equal (file-name-directory + (url-cache-create-filename "http://www.fsf.co.uk")) + (string-join + (list url-cache-directory (user-real-login-name) + "http/uk/co/fsf/www/") "/"))) + (should (equal (file-name-directory + (url-cache-create-filename "https://www.fsf.co.uk")) + (string-join + (list url-cache-directory (user-real-login-name) + "https/uk/co/fsf/www/") "/"))) + (should (equal (file-name-directory + (url-cache-create-filename "http://host")) + (string-join + (list url-cache-directory (user-real-login-name) + "http/host/") "/"))) + (should (equal (file-name-directory + (url-cache-create-filename "http://host:80")) + (string-join + (list url-cache-directory (user-real-login-name) + "http/host/") "/"))) + (should (equal (file-name-directory + (url-cache-create-filename "http://host#fragment")) + (string-join + (list url-cache-directory (user-real-login-name) + "http/host/") "/")))) + +(ert-deftest url-cache-filename-to-url-tests () + "Test the filename to URL resolution for the URL cache" + (should (equal (url-cache-create-url-from-file + (string-join + (list url-cache-directory (user-real-login-name) + "http/uk/co/fsf/www/") "/")) + "http://www.fsf.co.uk")) + (should (equal (url-cache-create-url-from-file + (string-join + (list url-cache-directory (user-real-login-name) + "https/uk/co/fsf/www/") "/")) + "https://www.fsf.co.uk")) + (should (equal (url-cache-create-url-from-file + (string-join + (list url-cache-directory (user-real-login-name) + "http/host/") "/")) + "http://host"))) + +(provide 'url-cache-tests) + +;;; url-cache-tests.el ends here