Find file
Fetching contributors…
Cannot retrieve contributors at this time
329 lines (280 sloc) 12.5 KB
(use setup-api) ;; for installation-prefix
(use salmonella salmonella-log-parser)
(include "salmonella-version.scm")
(include "salmonella-common.scm")
(define salmonella-log-version 2)
(define default-verbosity 2)
(define *instance-id* #f) ;; for when salmonella is called by salmonella-epidemy
(define (progress-indicator action egg verbosity #!optional egg-count total)
(case verbosity
((0) "")
((1) (when (eq? action 'fetch)
(print "=== " egg
" "
(if *instance-id*
(sprintf "(instance ~a, ~a of ~a)"
(sprintf "(~a of ~a)"
(let ((running (case action
((fetch) (print "==== " egg " (" egg-count " of " total ") ====")
" Fetching")
((install) " Installing")
((check-version) " Checking version")
((test) " Testing")
((meta-data) " Reading .meta")
((check-dependencies) " Checking dependencies")
((check-category) " Checking category")
((check-license) " Checking license")
((check-author) " Checking author")
((check-doc) " Checking documentation")
(else (error 'salmonella-progress-indicator
"Invalid action"
(display (string-pad-right running 50 #\.))
(define (status-reporter report verbosity)
(case verbosity
((0 1) "")
(let ((status (report-status report))
(action (report-action report)))
(case status
((0 #t) "[ ok ]")
((-1) "[ -- ]")
(else "[fail]"))
" "
(if (or (eq? action 'check-version)
(and (eq? action 'test)
(= status -1)))
(conc (prettify-time
(inexact->exact (report-duration report))))))))))
(define (show-statistics log-file verbosity)
(when (> verbosity 1)
(let ((log (read-log-file log-file)))
(print #<#EOF
=== Summary
Total eggs: #(count-total-eggs log)
==== Installation
Ok: #(count-install-ok log)
Failed: #(count-install-fail log)
==== Tests
Ok: #(count-test-ok log)
Failed: #(count-test-fail log)
No tests: #(count-no-test log)
==== Documentation
Documented: #(count-documented log)
Undocumented: #(count-undocumented log)
==== Total run time
#(prettify-time (inexact->exact (total-time log)))
(define (check-chicken-home chicken-installation-prefix this-egg?)
;; Return a warning message if (chicken-home) contains Scheme files
;; or #f otherwise.
(and (not chicken-installation-prefix)
(let* ((share-dir (make-pathname (list (installation-prefix)
(scheme-files (glob (make-pathname share-dir "*.scm"))))
(and (not (null? scheme-files))
"======================[ W A R N I N G ]======================\n"
"=== Scheme files have been found in " share-dir ", \n"
"=== which is in CHICKEN's include path. Those files may \n"
"=== influence the test results:\n"
(if (null? scheme-files)
(map (lambda (file-path)
(let* ((file (pathname-strip-directory file-path))
(egg (case (string->symbol file)
((setup-helper.scm) "setup-helper")
((inline-type-checks.scm) "check-errors")
(else #f))))
(sprintf "=== * ~a~a\n"
(if egg
(sprintf " (~a egg)" egg)
(if (and this-egg? (not (null? scheme-files)))
"=== If your egg depends on eggs that install these files,\n"
"=== check if you have added them to you egg's dependencies list.\n")
(let* ((args (command-line-arguments)))
(when (or (member "-h" args)
(member "--help" args))
(usage exit-code: 0))
(when (member "--version" args)
(print salmonella-version)
(exit 0))
(let* ((this-egg? (and (null? (remove (lambda (arg)
(string-prefix? "--" arg))
(not (null? (glob "*.setup")))))
(cmd-line-arg '--chicken-installation-prefix args))
(log-file (or (cmd-line-arg '--log-file args) "salmonella.log"))
(cmd-line-arg '--chicken-install-args args))
(cmd-line-arg '--eggs-source-dir args))
(cmd-line-arg '--eggs-doc-dir args))
(skip-eggs (let ((skip (cmd-line-arg '--skip-eggs args)))
(if skip
(map string->symbol (string-split skip ","))
(keep-repo? (and (member "--keep-repo" args) #t))
(clear-chicken-home? (and (member "--clear-chicken-home" args) #t))
(repo-dir (and-let* ((path (cmd-line-arg '--repo-dir args)))
(if (absolute-pathname? path)
(make-pathname (current-directory) path)))))
(tmp-dir (or repo-dir (mktempdir)))
(verbosity (or (and-let* ((verbosity (cmd-line-arg '--verbosity args)))
(or (string->number verbosity) default-verbosity))
(salmonella (make-salmonella
eggs-source-dir: eggs-source-dir
eggs-doc-dir: eggs-doc-dir
chicken-installation-prefix: chicken-installation-prefix
clear-chicken-home?: clear-chicken-home?
(and chicken-install-args
(lambda (repo)
(or (irregex-replace "<repo>" chicken-install-args repo)
this-egg?: this-egg?))
(eggs (if this-egg?
(let ((setup (glob "*.setup")))
(cond ((null? setup)
(die "Could not find a .setup file. Aborting."))
((null? (cdr setup))
(map (compose string->symbol pathname-file) setup))
(die "Found more than one .setup file. Aborting."))))
(remove (lambda (egg)
(memq egg skip-eggs))
(map string->symbol
(remove (lambda (arg)
(string-prefix? "--" arg))
(total-eggs (length eggs)))
(when (null? eggs)
(delete-path tmp-dir)
(print "Nothing to do.")
;; Remove the temporary directory if interrupted
(set-signal-handler! signal/int
(lambda (signal)
(delete-path tmp-dir)
(when (> verbosity 1)
(print (salmonella 'env-info)))
;; for salmonella-epidemy
(set! *instance-id* (cmd-line-arg '--instance-id args))
;; Remove old log
(delete-file* log-file)
;; Log start
(log! (make-report #f 'start 0 (salmonella 'env-info) (current-seconds))
;; Log version
(log! (make-report #f 'log-version 0 salmonella-log-version 0)
;; Log skipped eggs
(for-each (lambda (egg)
(log! (make-report egg 'skip 0 "" 0) log-file))
;; Maybe show warning about existing Scheme files in chicken-home
(let ((msg (check-chicken-home chicken-installation-prefix this-egg?)))
(when msg
(with-output-to-port (current-error-port)
(cut print msg))))
;; Handle all eggs
(lambda (egg egg-count)
(unless keep-repo? (salmonella 'clear-repo!))
(salmonella 'init-repo!)
;; Fetch egg
(progress-indicator 'fetch egg verbosity egg-count total-eggs)
(let ((fetch-log (salmonella 'fetch egg)))
(log! fetch-log log-file)
(status-reporter fetch-log verbosity)
(when (zero? (report-status fetch-log))
;; Meta data
(progress-indicator 'meta-data egg verbosity)
(let ((meta-log (salmonella 'meta-data egg)))
(log! meta-log log-file)
(status-reporter meta-log verbosity)
(when (report-status meta-log)
(let ((meta-data (report-message meta-log)))
;; Warnings (only logged when indicate problems)
;; Check dependencies
(progress-indicator 'check-dependencies egg verbosity)
(let ((deps-log (salmonella 'check-dependencies egg meta-data)))
(unless (report-status deps-log)
(log! deps-log log-file))
(status-reporter deps-log verbosity))
;; Check category
(progress-indicator 'check-category egg verbosity)
(let ((categ-log (salmonella 'check-category egg meta-data)))
(unless (report-status categ-log)
(log! categ-log log-file))
(status-reporter categ-log verbosity))
;; Check license
(progress-indicator 'check-license egg verbosity)
(let ((license-log (salmonella 'check-license egg meta-data)))
(unless (report-status license-log)
(log! license-log log-file))
(status-reporter license-log verbosity))
;; Check author
(progress-indicator 'check-author egg verbosity)
(let ((author-log (salmonella 'check-author egg meta-data)))
(unless (report-status author-log)
(log! author-log log-file))
(status-reporter author-log verbosity))
;; Install egg
(progress-indicator 'install egg verbosity)
(let ((install-log (salmonella 'install egg)))
(log! install-log log-file)
(status-reporter install-log verbosity)
(when (zero? (report-status install-log))
;; Check version
(let ((check-version-log (salmonella 'check-version egg)))
(progress-indicator 'check-version egg verbosity)
(log! check-version-log log-file)
(status-reporter check-version-log verbosity))
;; Test egg
(progress-indicator 'test egg verbosity)
(let ((test-log (salmonella 'test egg)))
(log! test-log log-file)
(status-reporter test-log verbosity)))))))))
;; Check doc
(progress-indicator 'check-doc egg verbosity)
(let ((doc-log (salmonella 'check-doc egg)))
(log! doc-log log-file)
(status-reporter doc-log verbosity)))
(iota total-eggs 1))
(log! (make-report #f 'end 0 "" (current-seconds)) log-file)
(unless this-egg?
(show-statistics log-file verbosity))
(unless keep-repo? (delete-path tmp-dir))))