cache.lisp 2.55 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 #:consult-asdf-cache #:do-asdf-cache #:normalize-namestring
8 9 10 11 12 13 14 15
           #:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*))
(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

16 17 18 19 20 21 22 23 24
(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)))

25
  (defun consult-asdf-cache (key &optional thunk)
26 27 28 29
    (if *asdf-cache*
        (multiple-value-bind (results foundp) (gethash key *asdf-cache*)
          (if foundp
              (apply 'values results)
30 31
              (set-asdf-cache-entry key (multiple-value-list (call-function thunk)))))
        (call-function thunk)))
32 33 34 35

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

36 37 38 39 40 41
  (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)
          (let ((*asdf-cache* (make-hash-table :test 'equal)))
            (funcall fun)))))
42

43 44
  (defmacro with-asdf-cache ((&key key override) &body body)
    `(call-with-asdf-cache #'(lambda () ,@body) :override ,override :key ,key))
45

46 47 48
  (defun normalize-namestring (pathname)
    (let ((resolved (resolve-symlinks*
                     (ensure-absolute-pathname
49
                      (physicalize-pathname pathname)
50 51
                      'get-pathname-defaults))))
      (with-pathname-defaults () (namestring resolved))))
52

53 54 55
  (defun compute-file-stamp (normalized-namestring)
    (with-pathname-defaults ()
      (safe-file-write-date normalized-namestring)))
56

57 58 59 60
  (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))))
61

62
  (defun get-file-stamp (file)
63 64 65
    (when file
      (let ((namestring (normalize-namestring file)))
        (do-asdf-cache `(get-file-stamp ,namestring) (compute-file-stamp namestring))))))
66