From 3ff72a728b850698eec5b204b74896ce14cca096 Mon Sep 17 00:00:00 2001 From: moritz Date: Thu, 26 Jan 2012 22:53:47 +0100 Subject: add -i/--init-file option for giving an init file that is loaded before the update process starts. implement hook functionality which can be used from the init file (download-release-success and download-release-error hooks only so far). --- henrietta-cache.scm | 36 ++++++++++++++++++++++++++++++++++-- 1 file changed, 34 insertions(+), 2 deletions(-) diff --git a/henrietta-cache.scm b/henrietta-cache.scm index 76276cb..24a00d5 100644 --- a/henrietta-cache.scm +++ b/henrietta-cache.scm @@ -18,6 +18,29 @@ EOF (define *cache-directory* "cache") (define *egg-list* "egg-locations") (define *chicken-release* (##sys#fudge 41)) +(define *init-file* #f) + +(define download-release-success-hook + (make-parameter #f)) + +(define download-release-error-hook + (make-parameter #f)) + +(define hooks + `((download-release-success . ,download-release-success-hook) + (download-release-error . ,download-release-error-hook))) + +(define (run-hook hook-name . args) + (and-let* ((hook (or (alist-ref hook-name hooks) + (error "invalid hook" hook-name))) + (hook (and hook (hook)))) + (condition-case + (apply hook args) + (exn () + (print-error-message exn + (current-error-port) + (sprintf "Error running hook `~A'" hook-name)) + (flush-output (current-error-port)))))) ;; This works on raw URI strings, not URI objects (for now?) (define (replace-uri-patterns uri patterns) @@ -175,9 +198,11 @@ EOF "Error downloading or extracting egg '~A' release ~A: " egg-name egg-release) (print-error-message exn (current-error-port)) - (flush-output (current-error-port))) + (flush-output (current-error-port)) + (run-hook 'download-release-error egg-name egg-release)) (create-directory cache-dir #t) - (download-release type uri cache-dir)))))) + (download-release type uri cache-dir) + (run-hook 'download-release-success egg-name egg-release)))))) (cdr uri/releases)))) uris/releases))) @@ -195,6 +220,9 @@ EOF (with-input-from-request uri #f read-file))) (define (update-egg-cache) + (when *init-file* + (load *init-file*)) + (for-each (lambda (egg) (let* ((egg-name (car egg)) @@ -256,6 +284,10 @@ EOF (unless (pair? (cdr args)) (usage 1)) (set! *egg-list* (cadr args)) (loop (cddr args))) + ((or (string=? arg "-i") (string=? arg "-init-file")) + (unless (pair? (cdr args)) (usage 1)) + (set! *init-file* (cadr args)) + (loop (cddr args))) ((and (positive? (string-length arg)) (char=? #\- (string-ref arg 0))) (if (> (string-length arg) 2) -- cgit v1.2.3 From 909a9db0526e8edcce678ad9e5f92cf37794ffd8 Mon Sep 17 00:00:00 2001 From: moritz Date: Fri, 27 Jan 2012 12:49:12 +0100 Subject: remove redundant `and' guard in `and-let*' (thanks Peter) --- henrietta-cache.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/henrietta-cache.scm b/henrietta-cache.scm index 24a00d5..f7914fe 100644 --- a/henrietta-cache.scm +++ b/henrietta-cache.scm @@ -33,7 +33,7 @@ EOF (define (run-hook hook-name . args) (and-let* ((hook (or (alist-ref hook-name hooks) (error "invalid hook" hook-name))) - (hook (and hook (hook)))) + (hook (hook))) (condition-case (apply hook args) (exn () -- cgit v1.2.3