(in-package:asdf-tools);;; Testing(defparameter*test-lisps*:default"The list of lisp implementations to use for tests")(defparameter*upgrade-test-lisps*:default"The list of lisp implementations to use for upgrade tests")(defparameter*upgrade-test-tags*:default)(defparameter*test-systems*nil)(defparameter*test-scripts*:default)(defparameter*environment-variable-table*nil)(defparameter*environment-variable-specs*'((*test-lisps*ensure-list-of-keywords:default"ASDF_TEST_LISPS""l")(*upgrade-test-lisps*ensure-list-of-keywords:default"ASDF_UPGRADE_TEST_LISPS""L")(*test-systems*ensure-list-of-keywords()"ASDF_TEST_SYSTEMS""s")(*test-scripts*ensure-list-of-strings:default"ASDF_TESTS""t")(*upgrade-test-tags*ensure-list-of-strings:default"ASDF_UPGRADE_TEST_TAGS""u")(*upgrade-test-methods*ensure-list-of-test-methods:default"ASDF_UPGRADE_TEST_METHODS""U")(*new-version*string:default"=NEW_ASDF_VERSION""v")))(defunensure-list-of-strings(x)(removenil(etypecasex(string(uiop:split-stringx:separator" "))(listx))))(defunensure-keyword(x)(etypecasex((ornullkeyword)x)((orstringsymbol)(intern(string-upcasex):keyword))))(defunensure-list-of-keywords(x)(mapcar'ensure-keyword(ensure-list-of-stringsx)))(defunensure-test-method(x)(safe-read-from-string(strcat"("(substitute#\space#\:x)")"):package:keyword)); UGLY!(defunensure-list-of-test-methods(x)(mapcar'ensure-test-method(ensure-list-of-stringsx)))(defuninitialize-environment()(let((h(make-hash-table:test'equal)))(setf*environment-variable-table*h)(loop:for(variabletransformerdefaultsenvvarshort):in*environment-variable-specs*:forx=(listvariabletransformer):do(setf(symbol-valuevariable)(if-let(x(getenvpenvvar))(funcalltransformerx)defaults))(setf(gethashenvvarh)x)(setf(gethashshorth)x))))(defuntest-definition(def)(block()(cl-ppcre:register-groups-bind(varval)("^([^=]+)=(.*)$"def)(if-let(x(gethashvar*environment-variable-table*))(destructuring-bind(symtransformer&restr)x(declare(ignorer))(unless(emptypval)(setf(symbol-valuesym)(funcalltransformerval)))(return))(error"Unknown variable ~A"var)))(error"Unrecognized argument ~A"def)))(defunshow-environment()(loop:for(v):in*environment-variable-specs*:do(formatt"~A = ~S~%"v(symbol-valuev)))t)(defunmake-target(target&restenv)(map()'test-definitionenv)(shell-boolean-exit(main(listtarget))))(eval-when(:compile-toplevel:load-toplevel:execute)(defundecl-or-docstring-p(form)(or(stringpform)(and(conspform)(eq'declare(carform)))))(defundecl-and-body(decl-and-body)(let((p(position-if-not'decl-or-docstring-pdecl-and-body)))(values(subseqdecl-and-body0p)(nthcdrpdecl-and-body)))))(defmacrodeftestcmd(nameargs&restdecl-and-body)(loop:withargmap='((lisp((lisp*test-lisps*))(setflisp(get-lisplisp)))(lisps((lisps*test-lisps*))(setflisps(get-lispslisps)))(systems((systems*test-systems*)))(test-scripts((test-scripts*test-scripts*))(setftest-scripts(get-test-scriptstest-scripts)))(upgrade-tags((upgrade-tags*upgrade-test-tags*))(setfupgrade-tags(get-upgrade-tagsupgrade-tags)))(upgrade-methods((upgrade-methods*upgrade-test-methods*))(setfupgrade-methods(get-upgrade-methodsupgrade-methods)))):forarg:inargs:for(foundlarginit)=(assocargargmap):append(iffoundlarg(listarg)):intolargs:append(whenfound(listinit)):intoinits:finally(multiple-value-bind(declbody)(decl-and-bodydecl-and-body)(return`(defun,name(&optional,@largs),@decl,@inits,@body)))))(defunall-pass(&resttests)(every'identitytests))(defmacrodefalias(namereal)`(defun,name(&restargs),(formatnil"alias for ~S"real)(apply',realargs)))(deftestcmdinteractive-command(lisp)(let*((command(lisp-invocation-arglist:implementation-typelisp:debuggert)))(cons"rlwrap"command)))(defparameter*default-test-lisps*'(:ccl:clisp:sbcl:ecl:ecl_bytecodes:cmucl:abcl:scl:allegro:lispworks:allegromodern:gcl:xcl:mkcl);; NOT SUPPORTED BY OUR AUTOMATED TESTS:;; :cormancl :genera :lispworks-personal-edition :mcl;; Also, grep for #+/#- features in the test/ directory;; to see plenty of disabled tests on some platforms"Default Lisp implementations for tests")(defunget-lisps(&optional(lisps*test-lisps*))(if(eqlisps:default)*default-test-lisps*(ensure-list-of-keywordslisps)))(defunget-lisp(&optional(lisp*test-lisps*))(if(and(keywordplisp)(not(eqlisp:default)))lisp(first(get-lispslisp))))(defundate-string(&optional(date(get-universal-time)))(multiple-value-bind(secondminutehourdatemonthyearweekdaydaylight-savings-ptimezone)(decode-universal-timedate)(declare(ignoresecondminutehourweekdaydaylight-savings-ptimezone))(formatnil"~4,'0D-~2,'0D-~2,'0D"yearmonthdate)))(deftestcmdnewlogfile((kind"log")lisp)(let((log(pn(formatnil"build/results/~(~A-~A~).text"lispkind))))(ensure-directories-existlog)(if-let(date(safe-file-write-datelog))(rename-file-overwriting-targetlog(add-pathname-suffixlog(strcat"-"(date-stringdate)))))(with-output-file(slog));;(format t "Logging results to ~A" log)log))(defunlog!(logfmt&restargs)(let((msg(apply'formatnilfmtargs)))(formatt"~&~A~&"msg)(whenlog(with-output-file(slog:if-exists:append:if-does-not-exist:create);; re-open every time because we're interleaved with inferior process writing to the log,;; and on e.g. Windows there might be a locking conflict if we keep it open.(formats"~&~A~&"msg))))(values));; TODO: When composing a form to evaluate in the test lisp implementation,;; our shell script went through great lengths to avoid a double-quote #\" in the command line,;; the quoting of which many Windows implementations get wrong.;; While we're at it, we also avoid spaces and backslashes.;; We haven't tested our new Lisp implementation of the test infrastructure on Windows, though.(defunrun-test-lisp(activityforms&key(outputt)loglispdebugger);; Activity is of the form "compiling ASDF", "running this test", etc.(formatt"~&Now ~A...~%"activity)(let*((eval(compose-eval-stringforms))(command(lisp-invocation-arglist:implementation-type(get-lisplisp):evaleval:debuggerdebugger))(interactive(if(eqoutput:interactive):interactivenil))(output(if(eqoutputt)*standard-output*output))(output(if(eqoutput*stdout*):interactiveoutput)))(log!log"~A"(print-process-speccommandnil))(multiple-value-bind(outerrcode)(run`(pipe((>&21),@(wheninteractive'(rlwrap)),@command),@(whenlog`((tee-a,log)))):inputinteractive:outputoutput:error-output(orinteractive:output):on-errornil)(unlessinteractive(if(zeropcode)(log!log"SUCCEEDED at ~A."activity)(log!log"FAILED at ~A.You can retry ~A with: ~Aor more interactively, start with: ~A~%(rlwrap is optional; don't use it when in emacs; skip if not installed.)then copy/paste: ~A"activityactivity(print-process-speccommandnil)(interactive-command)(compose-copy-paste-stringforms))))(values(zeropcode)outerrcode))))