~ chicken-core (chicken-5) /scripts/mini-salmonella.scm

  1;;;; mini-salmonella.scm - very simple tool to build all eggs
  2
  3
  4(module mini-salmonella ()
  5
  6(import scheme chicken)
  7(import posix file extras data-structures setup-api (chicken process))
  8
  9(define (usage code)
 10  (print "usage: mini-salmonella [-h] [-test] [-debug] [-download] [-trunk] EGGDIR [PREFIX]")
 11  (exit code) )
 12
 13(define *eggdir* #f)
 14(define *debug* #f)
 15(define *run-tests* #f)
 16(define *download* #f)
 17(define *trunk* #f)
 18
 19(define *prefix* (get-environment-variable "CHICKEN_PREFIX"))
 20
 21(let loop ((args (command-line-arguments)))
 22  (when (pair? args)
 23    (let ((arg (car args)))
 24      (cond ((string=? "-h" arg) (usage 0))
 25	    ((string=? "-test" arg) (set! *run-tests* #t))
 26	    ((string=? "-debug" arg) (set! *debug* #t))
 27	    ((string=? "-download" arg) (set! *download* #t))
 28	    ((string=? "-trunk" arg) (set! *trunk* #t))
 29	    (*eggdir* (set! *prefix* arg))
 30	    (else (set! *eggdir* arg)))
 31      (loop (cdr args)))))
 32
 33(unless *eggdir* (usage 1))
 34
 35(define-foreign-variable *binary-version* int "C_BINARY_VERSION")
 36(define *repository* (make-pathname *prefix* (conc "lib/chicken/" *binary-version*)))
 37(define *snapshot* (directory *repository*))
 38
 39(define (cleanup-repository)
 40  (for-each 
 41   (lambda (f)
 42     (let ((f2 (make-pathname *repository* f)))
 43       (cond ((member f2 *snapshot*))
 44             ((directory? f2)
 45              (remove-directory f2))
 46             (else
 47              (delete-file f2)))))
 48   (directory *repository*)))
 49
 50(define *chicken-install*
 51  (normalize-pathname (make-pathname *prefix* "bin/chicken-install")))
 52
 53(define *eggs* (directory *eggdir*))
 54
 55(define (find-newest egg)
 56  (let* ((ed (make-pathname *eggdir* egg))
 57	 (tagsdir (directory-exists? (make-pathname ed "tags")))
 58	 (trunkdir (directory-exists? (make-pathname ed "trunk"))))
 59    (cond ((and *trunk* trunkdir) trunkdir)
 60	  (tagsdir
 61	   (let ((tags (sort (directory tagsdir) version>=?)))
 62	     (if (null? tags)
 63		 (or trunkdir ed)
 64		 (make-pathname ed (string-append "tags/" (car tags))))))
 65	  (else (or trunkdir ed)))))
 66
 67(define (report egg msg . args)
 68  (printf "~a..~?~%" (make-string (max 2 (- 32 (string-length egg))) #\.)
 69	  msg args) )
 70
 71(define *errlogfile* "mini-salmonella.errors.log")
 72(define *logfile* "mini-salmonella.log")
 73(define *tmplogfile* "mini-salmonella.tmp.log")
 74
 75(on-exit (lambda () (delete-file* *tmplogfile*)))
 76
 77(define (copy-log egg file)
 78  (let ((log (with-input-from-file file read-string)))
 79    (with-output-to-file *errlogfile*
 80      (lambda ()
 81	(print #\newline egg #\:)
 82	(display log))
 83      #:append)))
 84
 85(define *failed* 0)
 86(define *succeeded* 0)
 87
 88(define (install-egg egg dir)
 89  (let ((command
 90	 (conc
 91	  *chicken-install* " -force "
 92	  (if *run-tests* "-test " "")
 93	  (if *trunk* "-trunk " "")
 94	  (if *download* 
 95	      ""
 96	      (string-append "-t local -l " (normalize-pathname *eggdir*) " "))
 97	  egg " "
 98	  (cond ((not *debug*)
 99		 (delete-file* (string-append *logfile* ".out"))
100		 (sprintf "2>~a >>~a.out" *tmplogfile* *logfile*))
101		(else "")))))
102    (when *debug*
103      (print "  " command))
104    (let ((status (system command)))
105      (cond ((zero? status)
106	     (report egg "OK")
107	     (set! *succeeded* (add1 *succeeded*)))
108	    (else
109	     (report egg "FAILED")
110	     (set! *failed* (add1 *failed*))
111	     (unless *debug* (copy-log egg *tmplogfile*)))))))
112
113(delete-file* *errlogfile*)
114(delete-file* *logfile*)
115
116(for-each
117 (lambda (egg)
118   (and-let* ((dir (find-newest egg)))
119     (if *debug*
120	 (print "\n\n######################################## " egg "\n")
121	 (print* egg))
122     (cleanup-repository)
123     (let ((meta (file-exists? (make-pathname dir egg "meta"))))
124       (if meta
125	   (let ((setup (file-exists? (make-pathname dir egg "setup"))))
126	     (if setup
127		 (install-egg egg dir)
128		 (report egg "<no .setup script>")) )
129	   (report egg "<no .meta file>")))))
130 (sort (directory *eggdir*) string<?))
131
132(print "\nSucceeded: " *succeeded* ", failed: " *failed* ", total: "
133       (+ *succeeded* *failed*))
134
135)