Package: emacs;
Reported by: Alex Bochannek <alex <at> bochannek.com>
Date: Tue, 15 Jun 2021 05:41:01 UTC
Severity: wishlist
Found in version 28.0.50
Message #11 received at 49033 <at> debbugs.gnu.org (full text, mbox):
From: Alex Bochannek <alex <at> bochannek.com> To: Lars Ingebrigtsen <larsi <at> gnus.org> Cc: 49033 <at> debbugs.gnu.org Subject: Re: bug#49033: 28.0.50; [PATCH] Feature suggestion, url-cache-expiry-alist to override expire time for cache pruning Date: Tue, 15 Jun 2021 15:55:54 -0700
[Message part 1 (text/plain, inline)]
Lars Ingebrigtsen <larsi <at> gnus.org> writes: >> - ;; Twelve hours. >> - (* 12 60 60)))) >> + gravatar-cache-ttl))) > > I don't mind that -- but is this really something that somebody would > want to control? It just seemed unlikely to me. I tend to find it difficult to reason about functionality if constants like this are in the code and not in variables. It may be unlikely that many people will want to customize it, but I'd rather expose this as a configuration variable than hide a static value in the code. As far as the URL caching code is concerned, I cleaned it up a bit and added some simple tests and documentation. Support URL-specific cache expiration * test/lisp/url/url-cache-tests.el: Test URL-to-filename and filename-to-URL mappings used by URL caching. * lisp/url/url-cache.el (url-cache-expiry-alist) (url-cache-create-url-from-file, url-cache-expired) (url-cache-prune-cache): Expire cache entries based on regular expressions matching URLs defined in new customizable variable url-cache-expire-alist. * doc/misc/url.texi (Disk Caching): Mention url-cache-expiry-alist variable.
[Message part 2 (text/x-patch, inline)]
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 <alex <at> bochannek.com>
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; 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
[Message part 3 (text/plain, inline)]
-- Alex.
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.