>From 6fe198345f53150a582443d604d923b61a15648c Mon Sep 17 00:00:00 2001 From: Mario Domenech Goulart Date: Sat, 11 Feb 2023 21:36:27 +0100 Subject: [PATCH 1/2] chicken-install: Cache eggs installed from local locations Cache eggs whose sources are retrieved from local locations. With this change, egg versions get properly reported by chicken-status. Piggyback the use of make-pathname instead of string-append in compare-trees. --- NEWS | 1 + chicken-install.scm | 91 ++++++++++++++++++++++++++++----------------- 2 files changed, 58 insertions(+), 34 deletions(-) diff --git a/NEWS b/NEWS index 1d874890..a314faf3 100644 --- a/NEWS +++ b/NEWS @@ -26,6 +26,7 @@ and TIMESTAMP with an underscore to reduce likelihood of collisions with source files on case-insensitive file systems like on MacOS (#1753, reported by Kon Lovett). + - chicken-install now caches eggs installed from local locations. - Compiler - When emitting types files, the output list is now sorted, to ensure diff --git a/chicken-install.scm b/chicken-install.scm index 05fc1494..506f9771 100644 --- a/chicken-install.scm +++ b/chicken-install.scm @@ -424,8 +424,7 @@ (when (file-exists? cached) (delete-directory cached #t)) (create-directory cached #t) - (fetch-egg-sources name version cached lax) - (with-output-to-file status (cut write current-status))) + (fetch-egg-sources name version cached lax)) (cond ((or (not (probe-dir cached)) (not (file-exists? eggfile))) (d "~a not cached~%" name) @@ -474,19 +473,34 @@ ;; directory layouts in order: ;; * //.egg ;; * ///.egg - (and-let* ((egg-dir (probe-dir (make-pathname location egg-name)))) + ;; + ;; Return (values ). and + ;; will be #f in case they cannot be determined. + (let ((egg-dir (probe-dir (make-pathname location egg-name)))) (cond + ((not egg-dir) + (values #f #f)) ;; //.egg ((file-exists? (make-pathname egg-dir egg-name +egg-extension+)) - egg-dir) + (values egg-dir #f)) (else ;; ///.egg (if version - (probe-dir (make-pathname egg-dir version)) + (values (probe-dir (make-pathname egg-dir version)) version) (let ((versions (directory egg-dir))) - (and (not (null? versions)) - (let ((latest (car (sort versions version>=?)))) - (make-pathname egg-dir latest))))))))) + (if (null? versions) + (values #f #f) + (let ((latest (car (sort versions version>=?)))) + (values (make-pathname egg-dir latest) latest))))))))) + +(define (write-cache-metadata egg-cache-dir egg-version) + (when egg-version + (with-output-to-file (make-pathname egg-cache-dir +version-file+) + (cut write egg-version))) + (with-output-to-file (make-pathname egg-cache-dir +timestamp-file+) + (cut write (current-seconds))) + (with-output-to-file (make-pathname egg-cache-dir +status-file+) + (cut write current-status))) (define (fetch-egg-sources name version dest lax) (print "fetching " name) @@ -514,26 +528,32 @@ (cond (dir (copy-egg-sources tmpdir dest) (delete-directory tmpdir #t) - (when ver - (with-output-to-file - (make-pathname dest +version-file+) - (cut write ver))) - (with-output-to-file - (make-pathname dest +timestamp-file+) - (cut write (current-seconds)))) + (write-cache-metadata dest ver)) (else (loop (cdr srvs)))))))))) - ((locate-local-egg-dir (car locs) name version) - => (lambda (dir) - (d "trying location ~a ...~%" dir) - (let* ((eggfile (make-pathname dir name +egg-extension+)) - (info (validate-egg-info (load-egg-info eggfile))) - (rversion (get-egg-property info 'version))) - (if (or (not rversion) - (not version) - (version>=? rversion version)) - (copy-egg-sources dir dest) - (loop (cdr locs)))))) - (else (loop (cdr locs)))))) + (else + (receive (dir version-from-path) + (locate-local-egg-dir (car locs) name version) + (if dir + (let* ((eggfile (make-pathname dir name +egg-extension+)) + (info (validate-egg-info (load-egg-info eggfile))) + (rversion + ;; If version-from-path is non-#f, prefer it + ;; over rversion, as it means the egg author + ;; actually tagged the egg. rversion might + ;; be outdated in case the egg author forgot + ;; to bump it in the .egg file. + (or version-from-path + (get-egg-property info 'version)))) + (d "trying location ~a ...~%" dir) + (if (or (not rversion) + (not version) + (version>=? rversion version)) + (begin + (copy-egg-sources dir dest) + (write-cache-metadata dest (or rversion version))) + (loop (cdr locs)))) + (loop (cdr locs)))))))) + (define (copy-egg-sources from to) ;;XXX should probably be done manually, instead of calling tool @@ -554,11 +574,14 @@ (or (and versions (every (cut version>=? lversion <>) versions)) (loop (cdr srvs))))))) - ((probe-dir (make-pathname (car locs) name)) => - (lambda (dir) - ;; for locally available eggs, check set of files and - ;; timestamps - (compare-trees dir cached))) + ;; The order of probe-dir's here is important. First try + ;; the path with version, then the path without version. + ((or (probe-dir (make-pathname (list (car locs) name) lversion)) + (probe-dir (make-pathname (car locs) name))) + => (lambda (dir) + ;; for locally available eggs, check set of files and + ;; timestamps + (compare-trees dir cached))) (else (loop (cdr locs)))))) (define (compare-trees there here) @@ -568,8 +591,8 @@ (hfs (directory here))) (every (lambda (f) (and (member f hfs) - (let ((tf2 (string-append there "/" f)) - (hf2 (string-append here "/" f))) + (let ((tf2 (make-pathname there f)) + (hf2 (make-pathname here f))) (and (<= (file-modification-time tf2) (file-modification-time hf2)) (if (directory-exists? tf2) -- 2.30.2