cache.lisp 3.17 KB
Newer Older
1 2 3
;;;; -------------------------------------------------------------------------
;;;; Stamp cache

4
(uiop/package:define-package :asdf/cache
5
  (:use :uiop/common-lisp :uiop :asdf/upgrade)
6
  (:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp
7
           #:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache
8
           #:do-asdf-cache #:normalize-namestring
Robert P. Goldman's avatar
Robert P. Goldman committed
9
           #:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*
10
           #:clear-configuration-and-retry #:retry))
11 12 13 14 15 16 17
(in-package :asdf/cache)

;;; This stamp cache is useful for:
;; * consistency of stamps used within a single run
;; * fewer accesses to the filesystem
;; * the ability to test with fake timestamps, without touching files

18 19 20 21 22 23 24 25 26
(with-upgradability ()
  (defvar *asdf-cache* nil)

  (defun set-asdf-cache-entry (key value-list)
    (apply 'values
           (if *asdf-cache*
               (setf (gethash key *asdf-cache*) value-list)
               value-list)))

27 28 29 30
  (defun unset-asdf-cache-entry (key)
    (when *asdf-cache*
      (remhash key *asdf-cache*)))

31
  (defun consult-asdf-cache (key &optional thunk)
32 33 34 35
    (if *asdf-cache*
        (multiple-value-bind (results foundp) (gethash key *asdf-cache*)
          (if foundp
              (apply 'values results)
36 37
              (set-asdf-cache-entry key (multiple-value-list (call-function thunk)))))
        (call-function thunk)))
38 39 40 41

  (defmacro do-asdf-cache (key &body body)
    `(consult-asdf-cache ,key #'(lambda () ,@body)))

42 43 44 45
  (defun call-with-asdf-cache (thunk &key override key)
    (let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk)))
      (if (and *asdf-cache* (not override))
          (funcall fun)
46
          (loop
47
            (restart-case
48 49 50 51 52 53
                (let ((*asdf-cache* (make-hash-table :test 'equal)))
                  (return (funcall fun)))
              (retry ()
                :report (lambda (s)
                          (format s (compatfmt "~@<Retry ASDF operation.~@:>"))))
              (clear-configuration-and-retry ()
54
                :report (lambda (s)
55 56
                          (format s (compatfmt "~@<Retry ASDF operation after resetting the configuration.~@:>")))
                (clear-configuration)))))))
57

58 59
  (defmacro with-asdf-cache ((&key key override) &body body)
    `(call-with-asdf-cache #'(lambda () ,@body) :override ,override :key ,key))
60

61 62 63
  (defun normalize-namestring (pathname)
    (let ((resolved (resolve-symlinks*
                     (ensure-absolute-pathname
64
                      (physicalize-pathname pathname)
65 66
                      'get-pathname-defaults))))
      (with-pathname-defaults () (namestring resolved))))
67

68 69 70
  (defun compute-file-stamp (normalized-namestring)
    (with-pathname-defaults ()
      (safe-file-write-date normalized-namestring)))
71

72 73 74 75
  (defun register-file-stamp (file &optional (stamp nil stampp))
    (let* ((namestring (normalize-namestring file))
           (stamp (if stampp stamp (compute-file-stamp namestring))))
      (set-asdf-cache-entry `(get-file-stamp ,namestring) (list stamp))))
76

77
  (defun get-file-stamp (file)
78 79 80
    (when file
      (let ((namestring (normalize-namestring file)))
        (do-asdf-cache `(get-file-stamp ,namestring) (compute-file-stamp namestring))))))
81