pax_global_header00006660000000000000000000000064146257360540014526gustar00rootroot0000000000000052 comment=3ba1300a9dd6bafdaef2af76d261d73bdf7e4bf0 fiveam-1.4.3/000077500000000000000000000000001462573605400130025ustar00rootroot00000000000000fiveam-1.4.3/.boring000066400000000000000000000002321462573605400142600ustar00rootroot00000000000000# Boring file regexps: \# ~$ (^|/)_darcs($|/) \.dfsl$ \.ppcf$ \.fasl$ \.x86f$ \.fas$ \.lib$ ^docs/html($|/) ^docs/pdf($|/) ^\{arch\}$ (^|/).arch-ids($|/) fiveam-1.4.3/.github/000077500000000000000000000000001462573605400143425ustar00rootroot00000000000000fiveam-1.4.3/.github/workflows/000077500000000000000000000000001462573605400163775ustar00rootroot00000000000000fiveam-1.4.3/.github/workflows/ci.yml000066400000000000000000000051671462573605400175260ustar00rootroot00000000000000name: testing # Controls when the action will run. on: # Triggers the workflow on push or pull request events but only for the master branch push: branches: [ master ] pull_request: branches: - master # Allows you to run this workflow manually from the Actions tab workflow_dispatch: # A workflow run is made up of one or more jobs that can run sequentially or in parallel jobs: test: # The type of runner that the job will run on runs-on: ubuntu-latest container: image: containers.common-lisp.net/cl-docker-images/${{matrix.l}}:${{matrix.IMAGE_TAG}} strategy: matrix: os: [ubuntu-latest] # just going to try to get ONE lisp to work first # can't run CMUCL on GitHub actions. # ccl's ASDF seems to be having trouble with source initialization l: [abcl, allegro, clisp, ecl, sbcl] # ccl, cmucl (probably not the last). IMAGE_TAG: [latest] include: - l: clasp IMAGE_TAG: "b14e329f49998275579926da2a737885ceb2cea7" - l: allegro IMAGE_TAG: latest variant: modern - l: abcl IMAGE_TAG: 1.7.1-jdk8 # FIXME: this is likely obsolete env: GITHUB_ACTION: true I_AGREE_TO_ALLEGRO_EXPRESS_LICENSE: yes QUICKLISP_SETUP: /github/home/quicklisp/setup.lisp GITHUB_WORKSPACE: steps: - uses: actions/checkout@v4 - name: collect ASDF shell: bash if: ${{ matrix.l == 'clisp' }} run: | mkdir -p /usr/local/share/common-lisp/asdf && \ pushd /usr/local/share/common-lisp/asdf && \ curl https://asdf.common-lisp.dev/archives/asdf.lisp > asdf.lisp - name: prepare quicklisp shell: bash run: | install-quicklisp && \ if [ ! -f ${{ env.QUICKLISP_SETUP }} ]; then \ echo "Did not find Quicklisp setup file where expected: ${QUICKLISP_SETUP}"; \ find / -name 'quicklisp' -type d ; \ fi - name: test build shell: bash run: | ./run-tests.sh -c ${{ matrix.l }} || ${{ matrix.l == 'clisp' }} # no idea how to get FiveAM to build clean on clisp - name: save build output uses: actions/upload-artifact@v3 with: name: ${{matrix.l}}-${{matrix.IMAGE_TAG}}-build-output.text path: build/results/${{matrix.l}}-load.text - name: tests shell: bash run: | ./run-tests.sh ${{ matrix.l }} - name: save test output uses: actions/upload-artifact@v3 with: name: ${{matrix.l}}-${{matrix.IMAGE_TAG}}-test-output.text path: build/results/${{matrix.l}}-test.text fiveam-1.4.3/.gitignore000066400000000000000000000000241462573605400147660ustar00rootroot00000000000000/build/ /docs/html/ fiveam-1.4.3/.travis.yml000066400000000000000000000015371462573605400151210ustar00rootroot00000000000000os: linux dist: focal language: generic env: jobs: - LISP=sbcl - LISP=ccl - LISP=ecl - LISP=abcl - LISP=clisp # - LISP=allegro # - LISP=sbcl32 # - LISP=ccl32 # - LISP=cmucl matrix: fast_finish: true allow_failures: # - env: LISP=sbcl32 # - env: LISP=ccl32 # - env: LISP=cmucl notifications: email: on_success: change on_failure: always irc: channels: - "chat.freenode.net#iolib" on_success: change on_failure: always use_notice: true skip_join: true install: - curl -L https://raw.githubusercontent.com/lispci/cl-travis/master/install.sh | sh script: - cl -e "(prin1 (lisp-implementation-type)) (terpri) (prin1 (lisp-implementation-version)) (terpri) (ql:quickload :fiveam/test :verbose t) (uiop:quit (if (5am:run! :it.bese.fiveam) 0 -1))" fiveam-1.4.3/COPYING000066400000000000000000000027501462573605400140410ustar00rootroot00000000000000Copyright (c) 2003-2006, Edward Marco Baringer All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - Neither the name of Edward Marco Baringer, nor BESE, nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. fiveam-1.4.3/README000066400000000000000000000004311462573605400136600ustar00rootroot00000000000000This is FiveAM, a common lisp testing framework. The documentation can be found in the docstrings, start with the package :it.bese.fiveam (nicknamed 5AM). The mailing list for FiveAM is fiveam-devel@common-lisp.net All the code is Copyright (C) 2002-2006 Edward Marco Baringer. fiveam-1.4.3/build.lisp000066400000000000000000000046071462573605400150010ustar00rootroot00000000000000(in-package :common-lisp-user) #+clisp (if (ext:getenv "GITHUB_ACTION") (require :asdf "/usr/local/share/common-lisp/asdf/asdf") (require :asdf)) #-clisp (require :asdf) (declaim (optimize (speed 3) (space 3) (safety 3))) (asdf:load-system "asdf") (asdf:initialize-source-registry '(:source-registry (:tree :here) :inherit-configuration)) ;;; try to find Quicklisp -- this is a mess because it isn't consistently installed in the ;;; same location. (if (uiop:find-package* '#:ql nil) (format t "~&Quicklisp pre-loaded into image.~%") (let ((ql-filename (uiop:getenv "QUICKLISP_SETUP")) loaded) (if ql-filename (if (probe-file ql-filename) (let ((result (load ql-filename :if-does-not-exist nil))) (when result (format t "~&Have loaded quicklisp setup file ~a.~%" ql-filename) (setf loaded t))) (format t "Quicklisp not installed where expected: ~a~%" ql-filename))) (unless loaded (let* ((fallback-name "/root/quicklisp/setup.lisp") (result (load fallback-name :if-does-not-exist nil))) (when result (format t "~&Have loaded quicklisp setup file from /root.~%") (setf loaded t)))) (unless loaded (format t "~&Unable to find quicklisp.~%") (uiop:quit 1 t)))) (ql:quickload "alexandria") (ql:quickload "trivial-backtrace") (ql:quickload "net.didierverna.asdf-flv") (setf asdf::*compile-file-failure-behaviour* :error) ;;(setf asdf::*compile-file-warnings-behaviour* :warn) (defvar *build-warning* nil) (defvar *build-error* nil) (catch 'build-failed (handler-bind ((warning #'(lambda (x) ;; this is necessary because on SBCL ;; there's an EXTERNAL handler for some ;; uninteresting warnings. (signal x) (push x *build-warning*))) (error #'(lambda (x) (setf *build-error* x) (throw 'build-failed t)))) (asdf:load-system "fiveam" :force :all))) (cond (*build-error* (uiop:die 1 "FiveAM build failed with an error: ~a.~%" *build-error*)) (*build-warning* (uiop:die 2 "FiveAM build failed with warnings:~%~{~t~a~%~}" *build-warning*)) (t (format t "FiveAM build successful.~%") (uiop:quit 0))) fiveam-1.4.3/docs/000077500000000000000000000000001462573605400137325ustar00rootroot00000000000000fiveam-1.4.3/docs/make-qbook.lisp000066400000000000000000000010121462573605400166430ustar00rootroot00000000000000(asdf:oos 'asdf:load-op :FiveAM) (asdf:oos 'asdf:load-op :qbook) (asdf:oos 'qbook:publish-op :FiveAM :generator (make-instance 'qbook:html-generator :title "FiveAM" :output-directory (merge-pathnames (make-pathname :directory '(:relative "docs" "html")) (asdf:component-pathname (asdf:find-system :FiveAM))))) fiveam-1.4.3/fiveam.asd000066400000000000000000000027521462573605400147500ustar00rootroot00000000000000;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; -*- #.(unless (or #+asdf3.1 (version<= "3.1" (asdf-version))) (error "You need ASDF >= 3.1 to load this system correctly.")) (defsystem :fiveam :author "Edward Marco Baringer " :version (:read-file-form "version.sexp") :description "A simple regression testing framework" :license "BSD" :depends-on (:alexandria :net.didierverna.asdf-flv :trivial-backtrace) :pathname "src/" :components ((:file "package") (:file "utils" :depends-on ("package")) (:file "check" :depends-on ("package" "utils")) (:file "fixture" :depends-on ("package")) (:file "classes" :depends-on ("package")) (:file "random" :depends-on ("package" "check")) (:file "test" :depends-on ("package" "fixture" "classes")) (:file "explain" :depends-on ("package" "utils" "check" "classes" "random")) (:file "suite" :depends-on ("package" "test" "classes")) (:file "run" :depends-on ("package" "check" "classes" "test" "explain" "suite"))) :in-order-to ((test-op (test-op :fiveam/test)))) (defsystem :fiveam/test :author "Edward Marco Baringer " :description "FiveAM's own test suite" :license "BSD" :depends-on (:fiveam) :pathname "t/" :components ((:file "tests")) :perform (test-op (o c) (symbol-call :5am :run! :it.bese.fiveam))) ;;;;@include "src/package.lisp" ;;;;@include "t/example.lisp" fiveam-1.4.3/run-tests.sh000077500000000000000000000467471462573605400153270ustar00rootroot00000000000000#!/bin/sh # run-tests {lisp invocation} {scripts-regex} # - read lisp forms one at a time from standard input # - quit with exit status 0 on getting eof # - quit with exit status >0 if an unhandled error occurs usage () { echo "$0 [lisp invocation] [scripts-regex]" echo " - read lisp forms one at a time from matching scripts" echo " - quit with exit status 0 on getting eof" echo " - quit with exit status >0 if an unhandled error occurs" echo " you need to supply the .script in the second argument" echo " lisps include abcl, ccl (clozure)," echo " allegro, allegro8, allegromodern, allegromodern8," echo " allegro_s, allegro8_s, allegromodern_s, allegromodern8_s (SMP variants)" echo " allegro_64, allegro8_64, allegromodern_64, allegromodern8_64 (64-bit variants)," echo " allegro_64_s, allegro8_64_s, allegromodern_64_s, allegromodern8_64_s, (SMP, 64-bit variants)" echo " clasp, clisp, cmucl, ecl, gcl, sbcl, scl and xcl." echo " To configure the script, you may set environment variables to point to the various lisp runtimes." echo " Allegro CL is a special case: instead of setting environment variables for the specific runtime" echo " locations, you may simply specify the Allegro install directories using these variables:" echo " ALLEGRO64DIR, ALLEGRO64SDIR (64-bit Allegro and SMP Allegro, respectively), ALLEGRODIR, and" echo " ALLEGROSDIR." echo "OPTIONS:" echo " -c -- clean load test." echo " -d -- debug mode." echo " -t -- test interactively." echo " -h -- show this message." echo " -u -- upgrade tests." echo " -l -- load systems tests." echo " -H -- extract all asdf versions to upgrade from." echo " -u -- upgrade tests, we already told you." } unset DEBUG_ASDF_TEST upgrade clean_load load_systems test_interactively extract_all SHELL=/bin/sh export SHELL DEBUG_ASDF_TEST GCL_ANSI ASDF_OUTPUT_TRANSLATIONS if [ -n "$ALLEGRO64DIR" ] ; then ALLEGRO_64=${ALLEGRO64DIR}/alisp ALLEGRO8_64=${ALLEGRO64DIR}/alisp8 ALLEGROMODERN_64=${ALLEGRO64DIR}/mlisp ALLEGROMODERN8_64=${ALLEGRO64DIR}/mlisp8 fi if [ -n "$ALLEGRO64SDIR" ] ; then ALLEGRO_64_S=${ALLEGRO64SDIR}/alisp ALLEGRO8_64_S=${ALLEGRO64SDIR}/alisp8 ALLEGROMODERN_64_S=${ALLEGRO64SDIR}/mlisp ALLEGROMODERN8_64_S=${ALLEGRO64SDIR}/mlisp8 fi if [ -n "$ALLEGRODIR" ] ; then ALLEGRO=${ALLEGRODIR}/alisp ALLEGRO8=${ALLEGRODIR}/alisp8 ALLEGROMODERN=${ALLEGRODIR}/mlisp ALLEGROMODERN8=${ALLEGRODIR}/mlisp8 fi if [ -n "$ALLEGROSDIR" ] ; then ALLEGRO_S=${ALLEGROSDIR}/alisp ALLEGRO8_S=${ALLEGROSDIR}/alisp8 ALLEGROMODERN_S=${ALLEGROSDIR}/mlisp ALLEGROMODERN8_S=${ALLEGROSDIR}/mlisp8 fi while getopts "cdtHulhu" OPTION do case $OPTION in c) clean_load=t echo "Should be testing clean load." ;; d) DEBUG_ASDF_TEST=t ;; t) test_interactively=t ;; h) usage exit 1 ;; u) upgrade=t ;; l) load_systems=t ;; H) extract_all=t ;; esac done shift $(($OPTIND - 1)) if [ x"$1" = "xhelp" ]; then usage exit 1 fi lisp=${1:-sbcl} ; shift ECHO () { printf '%s\n' "$*" ;} ECHOn () { printf '%s' "$*" ;} DBG () { ECHO "$*" >& 2 ;} simple_term_p () { case "$1" in *[!a-zA-Z0-9-+_,.:=%/]*) return 1 ;; *) return 0 ;; esac } kwote0 () { ECHOn "$1" | sed -e "s/\([\\\\\"\$\`]\)/\\\\\\1/g" ;} kwote1 () { if simple_term_p "$1" ; then ECHOn "$1" else ECHOn "\"$(kwote0 "$1")\"" ; fi ;} kwote () { ( set +x k="" ; for i ; do ECHOn "$k" ; kwote1 "$i" ; k=" " ; done ; echo ) } DO () { kwote "$@" ; "$@" ; } do_tests () { # if [ -z "$*" ]; then # scripts="*.script" # else # scripts="$*" # fi # env | grep -i asdf ## We go through great lengths to avoid " in the command line, ## the quoting of which many Windows implementations get wrong. ## While we're at it, we also avoid spaces and backslashes. ( DO $bcmd $eval '(load(string`|test.lisp|))' ) } # # not used currently but leave here for future reference. # case $(uname) in CYGWIN*|MSYS_NT*) os=windows ;; Darwin*) os=macos ;; Linux*) os=linux ;; *) os=unknown ;; esac # terminate on error set -e command= flags= nodebug= eval= bcmd= icmd= case "$lisp" in abcl) command="${ABCL:-abcl}" flags="--noinit --nosystem --noinform" eval="--eval" ;; allegro*) case "$lisp" in allegro) command="${ALLEGRO:-alisp}" ;; allegro8) command="${ALLEGRO8:-alisp8}" ;; allegromodern) command="${ALLEGROMODERN:-mlisp}" ;; allegromodern8) command="${ALLEGROMODERN8:-mlisp8}" ;; allegro_s) command="${ALLEGRO_S:-alisp_s}" ;; allegro8_s) command="${ALLEGRO8_S:-alisp8_s}" ;; allegromodern_s) command="${ALLEGROMODERN_S:-mlisp_s}" ;; allegromodern8_s) command="${ALLEGROMODERN8_S:-mlisp8_s}" ;; allegro_64) command="${ALLEGRO_64:-alisp_64}" ;; allegro8_64) command="${ALLEGRO8_64:-alisp8_64}" ;; allegromodern_64) command="${ALLEGROMODERN_64:-mlisp_64}" ;; allegromodern8_64) command="${ALLEGROMODERN8_64:-mlisp8_64}" ;; allegro_64_s) command="${ALLEGRO_64_S:-alisp_64_s}" ;; allegro8_64_s) command="${ALLEGRO8_64_S:-alisp8_64_s}" ;; allegromodern_64_s) command="${ALLEGROMODERN_64_S:-mlisp_64_s}" ;; allegromodern8_64_s) command="${ALLEGROMODERN8_64_S:-mlisp8_64_s}" ;; esac # For the sake of the lisp-invocation library, re-export these # ALLEGRO=$command ; export ALLEGRO ; # echo ALLEGRO=$ALLEGRO flags="-q" nodebug="-batch" if [ "$os" = windows ] ; then adir=$(dirname "${command}") ; allegroName=$(basename "${command}" ".exe") ; if [[ ${allegroName: -1} == "8" ]] ; then build=build ; else build=buildi ; fi ; # this takes somewhat unjustifiable advantage of the fact that # the Allegro images have the same name (with .dxl extension) # as the corresponding executables. the "build" executable # runs an ACL image in the current terminal instead of a # separate window, as is normal on Windows. bcmd="${adir}/${build}.exe -I ${adir}/${allegroName}.dxl $flags" ; fi eval="-e" ;; ccl) command="${CCL:-ccl}" flags="--no-init --quiet" nodebug="--batch" eval="--eval" ;; clasp) command="${CLASP:-clasp}" flags="--norc --noinit" eval="--eval" ;; clisp) command="${CLISP:-clisp}" flags="-norc --silent -ansi -I " nodebug="-on-error exit" eval="-x" ;; cmucl) # cmucl likes to have its executable called lisp, but so does scl # Please use a symlink or an exec ... "$@" trampoline script. command="${CMUCL:-cmucl}" flags="-noinit" nodebug="-batch" eval="-eval" ;; ecl) command="${ECL:-ecl}" flags="-norc -load sys:cmp" eval="-eval" ;; ecl_bytecodes) command="${ECL:-ecl}" flags="-norc -eval (ext::install-bytecodes-compiler)" eval="-eval" ;; gcl) GCL_ANSI=t command="${GCL:-gcl}" flags="" nodebug="-batch" eval="-eval" ;; lispworks) command="${LISPWORKS:-lispworks-console}" # If you have a licensed copy of lispworks, # you can obtain the "lispworks" binary with, e.g. # echo '(hcl:save-image "/lispworks" :environment nil)' > /tmp/build.lisp ; # ./lispworks-6-0-0-x86-linux -siteinit - -init - -build /tmp/build.lisp flags="-siteinit - -init -" eval="-eval" ;; mkcl) command="${MKCL:-mkcl}" flags="-norc" eval="-eval" ;; sbcl) command="${SBCL:-sbcl}" flags="--no-userinit --no-sysinit" # flags="--noinform --no-userinit --no-sysinit" nodebug="--disable-debugger" eval="--eval" ;; scl) command="${SCL:-scl}" flags="-noinit" nodebug="-batch" eval="-eval" ;; xcl) command="${XCL:-xcl}" flags="--no-userinit --no-siteinit --noinform" eval="--eval" ;; *) echo "Unsupported lisp: $1" >&2 echo "Please add support to run-tests.sh" >&2 exit 42 ;; esac if ! type "$command" > /dev/null ; then echo "lisp implementation not found: $command" >&2 exit 43 fi ASDFDIR="$(cd $(dirname $0)/.. ; command pwd)" : ${bcmd:=$command $flags} ${icmd:=$command $flags} # batch and interactive if [ -z "${DEBUG_ASDF_TEST}" ] ; then bcmd="$bcmd $nodebug" fi create_config () { # cd ${ASDFDIR} mkdir -p build/results/ # build/test-source-registry-conf.d build/test-asdf-output-translations-conf.d } # upgrade_tags () { # if [ -n "$ASDF_UPGRADE_TEST_TAGS" ] ; then # echo $ASDF_UPGRADE_TEST_TAGS ; return # fi # # REQUIRE is a magic tag meaning whatever your implementation provides, if anything # # # # 1.85 (2004-05-16) is the last release by Daniel Barlow (not 1.37, which is the README revision!) # # 1.97 (2006-05-14) is the last release before Gary King takes over # # 1.369 (2009-10-27) is the last release by Gary King # # # # 2.000 to 2.019 and 2.20 to 2.26 are Faré's "stable" ASDF 2 releases # # 2.000 (2010-05-31) was the first ASDF 2 release # # 2.008 (2010-09-10) was a somewhat stable ASDF 2 release # # 2.011 (2010-11-28) was used by CLISP 2.49, Debian squeeze, Ubuntu 10.04 LTS # # 2.014.6 (2011-04-06) was used by Quicklisp in 2011 # # 2.019 (2011-11-27) was stable and used by LispWorks since 2012. # # 2.20 (2012-01-18) was in CCL 1.8, Ubuntu 12.04 LTS # # 2.22 (2012-06-12) was used by debian wheezy # # 2.26 (2012-10-30) was used by Quicklisp in 2013 # # # # 2.26.x is where the refactoring that begat ASDF 3 took place. # # 2.26.61 is the last single-file, single-package ASDF. # # 2.27 to 2.33 are Faré's "stable" ASDF 3 pre-releases # # 2.27 (2013-02-01) is the first ASDF 3 pre-release # # 2.32 (2013-03-05) is the first really stable ASDF 3 pre-release # # # # The 3.0 series is a stable release of ASDF 3 # # with Robert Goldman taking over maintainership at 3.0.2. # # 3.0.0 was just 2.33.10 promoted, but version-satisfies meant it was suddenly # # not compatible with ASDF2 anymore, so we immediately released 3.0.1 # # 3.0.1 (2013-05-16) is the first stable ASDF 3 release # # 3.0.2 (2013-07-02) is the first ASDF 3 in SBCL # # 3.0.3 (2013-10-22) is the last in the ASDF 3.0 series # # # # The 3.1 series provides the 3.1 feature, meaning users can rely on # # all the stabilization work done in 3.0 so far, plus extra developments # # in UIOP, package-inferred-system, and more robustification. # # 3.1.2 (2014-05-06) is the first ASDF 3.1 release # # 3.1.3 (2014-07-24) a bug fix release for 3.1.2 # # 3.1.4 (2014-10-09) more bug fixes, source-registry cache, in LispWorks 7 # # 3.1.5 (2015-07-21) more bug fixes, what SBCL sports (as of 1.3.14, 2017-02-04) # # 3.1.6 (2015-10-17) more bug fixes # # 3.1.7 (2016-03-23) more bug fixes, last in 3.1 series # # # # The 3.2 series provides the asdf3.2 feature, meaning users can rely on # # all its new features (launch-program, improved bundle support), as well as # # the improvements done in 3.1 (e.g. XDG support). # # 3.2.0 (2017-01-08) first in 3.2 series # # 3.2.1 (2017-04-03) bug fixes, second and last in 3.2 series # # # # The 3.3 series provides the asdf3.3 feature, meaning users can rely on # # all its new features (proper phase separation) as well as earlier features. # # 3.3.0 (2017-10-06) first in 3.3 series # # 3.3.1 (2017-11-14) bug fixes, second # # 3.3.2 (2018-05-03) bug fixes, third and latest in 3.3 series # # # # We return the above designated versions in order of decreasing relevance, # # which pretty much means REQUIRE and most recent first. # # We picked the last and first in each relevant series, plus 2.26. # if [ "$lisp" = cmucl ]; then # echo REQUIRE 3.3.2 3.3.1 3.3.0 # else # echo REQUIRE 3.3.2 3.3.1 3.3.0 3.2.1 3.2.0 3.1.7 3.1.2 3.0.3 2.26 # fi # #echo 3.1.7 3.1.6 3.1.5 3.1.4 3.1.3 3.1.2 # #echo 3.0.3 3.0.2 3.0.1 # #echo 2.32 2.27 # #echo 2.26 2.22 2.20 2.019 2.014.6 2.011 2.008 2.000 # #echo 1.369 1.97 1.85 # } # upgrade_methods () { # if [ -n "$ASDF_UPGRADE_TEST_METHODS" ] ; then # echo $ASDF_UPGRADE_TEST_METHODS ; return # fi # cat < $file ;; # 2.2[7-9]*|2.[3-9][0-9]*|3.*) # mkdir -p build/old/build # git archive ${tag} | (cd build/old/ ; tar xf -) # make -C build/old # mv build/old/build/asdf.lisp build/asdf-${tag}.lisp # rm -rf build/old ;; # *) # echo "Don't know how to extract asdf.lisp for version $tag" # exit 55 # ;; # esac # fi # } # extract_all_tagged_asdf () { # for i in `upgrade_tags` ; do # extract_tagged_asdf $i # done # } # valid_upgrade_test_p () { # case "${1}:${2}:${3}" in # # It's damn slow. Also, we punt on anything 2.26 or earlier. # abcl:1.*|abcl:2.[01]*|abcl:2.2[0-5]:*) : ;; # # Allegro ships with versions 3*, so give up testing 2 # # Also, unpatched Allegro 10 has bug updating from 2.26 and before # allegro*:[12].*) : ;; # # ccl fasl numbering broke loading of old asdf 2.0. 2.27 has trouble with deferred-warnings. # ccl:2.[01]*|ccl:2.2[0-7]*) : ;; # # clasp only since 3.1.4.3 # clasp:2.*|clasp:3.0*|clasp:3.1.[0-4]*) : ;; # # CLISP: My old ubuntu 10.04LTS clisp 2.44.1 came wired in # # with an antique ASDF 1.374 from CLC that can't be downgraded. # # More recent CLISPs work. # # 2.00[0-7] use UID, which fails on some old CLISPs. # # Note that for the longest time, CLISP has included 2.011 in its source repository. # # Now its hg repository includes 3.x, but clisp hasn't released in many years(!) # # We don't punt on upgrade anymore, so we can go at it! # #clisp:2.00[0-7]:*|clisp:1.*|clisp:2.0[01]*|clisp:2.2[0-5]:*) : ;; # # CMUCL has problems with 3.2.1 and earlier because of # # the redefinition of system's superclass component. # cmucl:1.*|cmucl:2.*|cmucl:3.[012]*) : ;; # # Skip many ECL tests, for various ASDF issues # ecl*:1.*|ecl*:2.0[01]*|ecl*:2.20:*) : ;; # # GCL 2.7.0 from late November 2013 is required, with ASDF 3.1.2 # gcl:REQUIRE:*|gcl:1.*|gcl:2.*|gcl:3.0*|gcl:3.1.[0-3]*) : ;; # # LispWorks is broken at ASDF 3.0.3, but can upgrade from earlier and later ASDFs. # lispworks:1*|lispworks:2.[0-2]*|lispworks:2.3[0-2]*|lispworks:3.0.3:*) : ;; # # MKCL is only supported starting with specific versions 2.24, 2.26.x, 3.0.3.0.x, so skip. # mkcl:[12]*|mkcl:3.0*) : ;; # # SBCL won't run ASDF 1 anymore # sbcl:1*) : ;; # # XCL support starts with ASDF 2.014.2 # # — It also dies during upgrade trying to show the backtrace. # xcl:1.*|xcl:2.00*|xcl:2.01[0-4]:*|xcl:*) : ;; # *) return 0 ;; # esac # return 1 # } # run_upgrade_tests () { # cd ${ASDFDIR} # mkdir -p build/results/ # rm -f build/*.*f* uiop/*.*f* test/*.*f* ## Remove stale FASLs from ASDF 1.x, especially when different implementations have same name # ASDF_OUTPUT_TRANSLATIONS="(:output-translations (\"${ASDFDIR}\" (\"${ASDFDIR}/build/fasls/\" :implementation \"asdf/\")) (t (\"${ASDFDIR}/build/fasls/\" :implementation \"root/\")) :ignore-inherited-configuration)" # su=test/script-support.lisp # tags="`upgrade_tags`" # methods="`upgrade_methods`" # echo success > build/results/${lisp}-upgrade.status # { # for tag in $tags ; do # for method in $methods ; do # if valid_upgrade_test_p $lisp $tag $method ; then # echo "Testing ASDF upgrade from ${tag} using method $method" # extract_tagged_asdf $tag # $bcmd $eval \ # "'(#.(load(string'|$su|))#.#.\`(in-package,:asdf-test)#.(test-upgrade$method\`|$tag|))" || # { echo "upgrade FAILED for $lisp from $tag using method $method" ; # echo "you can retry just that test with:" ; # echo ASDF_UPGRADE_TEST_TAGS=\"$tag\" ASDF_UPGRADE_TEST_METHODS=\"$method\" ./test/run-tests.sh -u $lisp ; # echo "or more interactively (and maybe with rlwrap or in emacs), start with:" # echo "$icmd" # echo "then copy/paste:" # echo "(load \"$su\") (asdf-test::da) (test-upgrade $method \"$tag\")" # echo "failure" > "build/results/${lisp}-upgrade.status" ;} # fi ; done ; done ; # read status < "build/results/${lisp}-upgrade.status" # if [ "$status" = "success" ]; then # echo "Upgrade test succeeded for ${lisp}" # else # echo "Upgrade test failed for ${lisp}" # fi ; # } 2>&1 | tee build/results/${lisp}-upgrade.text # # We need to reread the status because the piping to tee causes everything # # in the block above to be run in a subshell. # read status < "build/results/${lisp}-upgrade.status" # if [ "$status" = "failure" ]; then # exit 1 # fi # } run_tests () { create_config thedate=`date "+%Y-%m-%d"` rm -f "build/results/${lisp}-test.text" || : do_tests "$@" 2>&1 | \ tee "build/results/${lisp}-test.text" "build/results/${lisp}-test-${thedate}.save" success=$? clean_up return ${success} } clean_up () { : # noop # rm -rf ../build/test-source-registry-conf.d ../build/test-asdf-output-translations-conf.d } test_clean_load () { echo "Calling test clean load. with " $bcmd $eval '(load "build.lisp")' mkdir -p build/results/ load=build/results/${lisp}-load.text if $bcmd $eval '(load "build.lisp")' > $load 2>&1 ; then echo "GOOD: Loading FiveAM on $lisp produces no message" >&2 ; return 0 else echo "BAD: Loading FiveAM on $lisp produces messages" >&2 ; return 1 fi } # test_load_systems () { # cd ${ASDFDIR} # mkdir -p build/results/ # echo "Loading all these systems: $*" # $bcmd $eval \ # "(or #.(load(string'|test/script-support.lisp|))#.(asdf-test:with-test()(asdf-test:test-load-systems $*)))" \ # 2>&1 | tee build/results/${lisp}-systems.text # } # test_interactively () { # cd ${ASDFDIR} # mkdir -p build/results/ # rlwrap $icmd $eval "(or'#.(load(string'|test/script-support.lisp|))#.(asdf-test:interactive-test'($*)))" # } if [ -z "$command" ] ; then echo "Error: cannot find or do not know how to run Lisp named $lisp" # elif [ -n "$test_interactively" ] ; then # test_interactively "$@" elif [ -n "$clean_load" ] ; then test_clean_load # elif [ -n "$load_systems" ] ; then # test_load_systems "$@" # elif [ -n "$upgrade" ] ; then # run_upgrade_tests # elif [ -n "$extract_all" ] ; then # extract_all_tagged_asdf else run_tests "$@" fi ; exit # NB: "; exit" makes it robust wrt the script being modified while running. fiveam-1.4.3/src/000077500000000000000000000000001462573605400135715ustar00rootroot00000000000000fiveam-1.4.3/src/check.lisp000066400000000000000000000317161462573605400155470ustar00rootroot00000000000000;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Package: FIVEAM; Base: 10; -*- (in-package :it.bese.fiveam) ;;;; * Checks ;;;; At the lowest level testing the system requires that certain ;;;; forms be evaluated and that certain post conditions are met: the ;;;; value returned must satisfy a certain predicate, the form must ;;;; (or must not) signal a certain condition, etc. In FiveAM these ;;;; low level operations are called 'checks' and are defined using ;;;; the various checking macros. ;;;; Checks are the basic operators for collecting results. Tests and ;;;; test suites on the other hand allow grouping multiple checks into ;;;; logic collections. (defvar *test-dribble* t) (defmacro with-*test-dribble* (stream &body body) `(let ((*test-dribble* ,stream)) (declare (special *test-dribble*)) ,@body)) (eval-when (:compile-toplevel :load-toplevel :execute) (def-special-environment run-state () result-list current-test)) ;;;; ** Types of test results ;;;; Every check produces a result object. (defclass test-result () ((reason :accessor reason :initarg :reason :initform "no reason given") (test-case :accessor test-case :initarg :test-case) (test-expr :accessor test-expr :initarg :test-expr)) (:documentation "All checking macros will generate an object of type TEST-RESULT.")) (defclass test-passed (test-result) () (:documentation "Class for successful checks.")) (defgeneric test-passed-p (object) (:method ((o t)) nil) (:method ((o test-passed)) t)) (define-condition check-failure (error) ((reason :accessor reason :initarg :reason :initform "no reason given") (test-case :accessor test-case :initarg :test-case) (test-expr :accessor test-expr :initarg :test-expr)) (:documentation "Signaled when a check fails.") (:report (lambda (c stream) (format stream "The following check failed: ~S~%~A." (test-expr c) (reason c))))) (defun process-failure (test-expr &optional reason-format &rest format-args) (let ((reason (and reason-format (apply #'format nil reason-format format-args)))) (with-simple-restart (ignore-failure "Continue the test run.") (error 'check-failure :test-expr test-expr :reason reason)) (add-result 'test-failure :test-expr test-expr :reason reason))) (defclass test-failure (test-result) () (:documentation "Class for unsuccessful checks.")) (defgeneric test-failure-p (object) (:method ((o t)) nil) (:method ((o test-failure)) t)) (defclass unexpected-test-failure (test-failure) ((actual-condition :accessor actual-condition :initarg :condition)) (:documentation "Represents the result of a test which neither passed nor failed, but signaled an error we couldn't deal with. Note: This is very different than a SIGNALS check which instead creates a TEST-PASSED or TEST-FAILURE object.")) (defclass test-skipped (test-result) () (:documentation "A test which was not run. Usually this is due to unsatisfied dependencies, but users can decide to skip the test when appropriate.")) (defgeneric test-skipped-p (object) (:method ((o t)) nil) (:method ((o test-skipped)) t)) (defun add-result (result-type &rest make-instance-args) "Create a TEST-RESULT object of type RESULT-TYPE passing it the initialize args MAKE-INSTANCE-ARGS and add the resulting object to the list of test results." (with-run-state (result-list current-test) (let ((result (apply #'make-instance result-type (append make-instance-args (list :test-case current-test))))) (etypecase result (test-passed (format *test-dribble* ".")) (unexpected-test-failure (format *test-dribble* "X")) (test-failure (format *test-dribble* "f")) (test-skipped (format *test-dribble* "s"))) (push result result-list)))) ;;;; ** The check operators ;;;; *** The IS check (defmacro is (test &rest reason-args) "The DWIM checking operator. If TEST returns a true value a test-passed result is generated, otherwise a test-failure result is generated. The reason, unless REASON-ARGS is provided, is generated based on the form of TEST: (predicate expected actual) - Means that we want to check whether, according to PREDICATE, the ACTUAL value is in fact what we EXPECTED. (predicate value) - Means that we want to ensure that VALUE satisfies PREDICATE. Wrapping the TEST form in a NOT simply produces a negated reason string." (assert (listp test) (test) "Argument to IS must be a list, not ~S" test) (let (bindings effective-test default-reason-args) (with-gensyms (e a v) (flet ((process-entry (predicate expected actual &optional negatedp) ;; make sure EXPECTED is holding the entry that starts with 'values (when (and (consp actual) (eq (car actual) 'values)) (assert (not (and (consp expected) (eq (car expected) 'values))) () "Both the expected and actual part is a values expression.") (rotatef expected actual)) (let ((setf-forms)) (if (and (consp expected) (eq (car expected) 'values)) (progn (setf expected (copy-list expected)) (setf setf-forms (loop for cell = (rest expected) then (cdr cell) for i from 0 while cell when (eq (car cell) '*) collect `(setf (elt ,a ,i) nil) and do (setf (car cell) nil))) (setf bindings (list (list e `(list ,@(rest expected))) (list a `(multiple-value-list ,actual))))) (setf bindings (list (list e expected) (list a actual)))) (setf effective-test `(progn ,@setf-forms ,(if negatedp `(not (,predicate ,e ,a)) `(,predicate ,e ,a))))))) (list-match-case test ((not (?predicate ?expected ?actual)) (process-entry ?predicate ?expected ?actual t) (setf default-reason-args (list "~2&~S~2% evaluated to ~2&~S~2% which is ~2&~S~2%to ~2&~S~2% (it should not be)" `',?actual a `',?predicate e))) ((not (?satisfies ?value)) (setf bindings (list (list v ?value)) effective-test `(not (,?satisfies ,v)) default-reason-args (list "~2&~S~2% evaluated to ~2&~S~2% which satisfies ~2&~S~2% (it should not)" `',?value v `',?satisfies))) ((?predicate ?expected ?actual) (process-entry ?predicate ?expected ?actual) (setf default-reason-args (list "~2&~S~2% evaluated to ~2&~S~2% which is not ~2&~S~2% to ~2&~S~2%" `',?actual a `',?predicate e))) ((?satisfies ?value) (setf bindings (list (list v ?value)) effective-test `(,?satisfies ,v) default-reason-args (list "~2&~S~2% evaluated to ~2&~S~2% which does not satisfy ~2&~S~2%" `',?value v `',?satisfies))) (?_ (setf bindings '() effective-test test default-reason-args (list "~2&~S~2% was NIL." `',test))))) `(let ,bindings (if ,effective-test (add-result 'test-passed :test-expr ',test) (process-failure ',test ,@(or reason-args default-reason-args))))))) ;;;; *** Other checks (defmacro skip (&rest reason) "Generates a TEST-SKIPPED result." `(add-result 'test-skipped :reason (format nil ,@reason))) (defmacro is-every (predicate &body clauses) "The input is either a list of lists, or a list of pairs. Generates (is (,predicate ,expr ,value)) for each pair of elements or (is (,predicate ,expr ,value) ,@reason) for each list." `(progn ,@(if (every #'consp clauses) (loop for (expected actual . reason) in clauses collect `(is (,predicate ,expected ,actual) ,@reason)) (progn (assert (evenp (list-length clauses))) (loop for (expr value) on clauses by #'cddr collect `(is (,predicate ,expr ,value))))))) (defmacro is-true (condition &rest reason-args) "Like IS this check generates a pass if CONDITION returns true and a failure if CONDITION returns false. Unlike IS this check does not inspect CONDITION to determine how to report the failure." `(if ,condition (add-result 'test-passed :test-expr ',condition) (process-failure ',condition ,@(or reason-args `("~S did not return a true value" ',condition))))) (defmacro is-false (condition &rest reason-args) "Generates a pass if CONDITION returns false, generates a failure otherwise. Like IS-TRUE, and unlike IS, IS-FALSE does not inspect CONDITION to determine what reason to give it case of test failure" (with-gensyms (value) `(let ((,value ,condition)) (if ,value (process-failure ',condition ,@(or reason-args `("~S returned the value ~S, which is true" ',condition ,value))) (add-result 'test-passed :test-expr ',condition))))) (defmacro signals (condition-spec &body body) "Generates a pass if BODY signals a condition of type CONDITION. BODY is evaluated in a block named NIL, CONDITION is not evaluated." (let ((block-name (gensym))) (destructuring-bind (condition &optional reason-control &rest reason-args) (ensure-list condition-spec) `(block ,block-name (handler-bind ((,condition (lambda (c) (declare (ignore c)) ;; ok, body threw condition (add-result 'test-passed :test-expr ',condition) (return-from ,block-name t)))) (block nil ,@body)) (process-failure ',condition ,@(if reason-control `(,reason-control ,@reason-args) `("Failed to signal a ~S" ',condition))) (return-from ,block-name nil))))) (defmacro finishes (&body body) "Generates a pass if BODY executes to normal completion. In other words if body does signal, return-from or throw this test fails." `(unwind-protect-case () (progn ,@body) (:normal (add-result 'test-passed :test-expr ',body)) (:abort (process-failure ',body "Test didn't finish")))) (defmacro pass (&rest message-args) "Simply generate a PASS." `(add-result 'test-passed :test-expr ',message-args ,@(when message-args `(:reason (format nil ,@message-args))))) (defmacro fail (&rest message-args) "Simply generate a FAIL." `(process-failure ',message-args ,@message-args)) ;; Copyright (c) 2002-2003, Edward Marco Baringer ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions are ;; met: ;; ;; - Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; ;; - Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; ;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names ;; of its contributors may be used to endorse or promote products ;; derived from this software without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE fiveam-1.4.3/src/classes.lisp000066400000000000000000000141461462573605400161250ustar00rootroot00000000000000;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Package: FIVEAM; Base: 10; -*- (in-package :it.bese.fiveam) (defclass testable-object () ((name :initarg :name :accessor name :documentation "A symbol naming this test object.") (description :initarg :description :accessor description :initform nil :documentation "The textual description of this test object.") (depends-on :initarg :depends-on :accessor depends-on :initform nil :documentation "The list of AND, OR, NOT forms specifying when to run this test.") (status :initarg :status :accessor status :initform :unknown :documentation "A symbol specifying the current status of this test. Either: T - this test (and all its dependencies, have passed. NIL - this test failed (either it failed or its dependecies weren't met. :circular this test has a circular dependency and was skipped. Or :depends-not-satisfied or :resolving") (profiling-info :accessor profiling-info :initform nil :documentation "An object representing how much time and memory where used by the test.") (collect-profiling-info :accessor collect-profiling-info :initarg :collect-profiling-info :initform nil :documentation "When T profiling information will be collected when the test is run."))) (defmethod print-object ((test testable-object) stream) (print-unreadable-object (test stream :type t :identity t) (format stream "~S" (name test)))) (defclass test-bundle () ((names :initform () :accessor %test-names) (tests :initform (make-hash-table :test 'eql) :accessor %tests))) (defmethod print-object ((bundle test-bundle) stream) (print-unreadable-object (bundle stream :type t :identity t) (format stream "~S tests" (hash-table-count (%tests bundle))))) (defclass test-suite (testable-object) ((tests :accessor tests :initform (make-instance 'test-bundle) :documentation "The hash table mapping names to test objects in this suite. The values in this hash table can be either test-cases or other test-suites.")) (:documentation "A test suite is a collection of tests or test suites. Test suites serve to organize tests into groups so that the developer can chose to run some tests and not just one or all. Like tests test suites have a name and a description. Test suites, like tests, can be part of other test suites, this allows the developer to create a hierarchy of tests where sub trees can be singularly run. Running a test suite has the effect of running every test (or suite) in the suite.")) (defclass test-case (testable-object) ((test-lambda :initarg :test-lambda :accessor test-lambda :documentation "The function to run.") (runtime-package :initarg :runtime-package :accessor runtime-package :documentation "By default it stores *package* from the time this test was defined (macroexpanded).") (test-suite :initarg :test-suite :accessor test-suite :initform nil :documentation "The test-suite associated with this test")) (:documentation "A test case is a single, named, collection of checks. A test case is the smallest organizational element which can be run individually. Every test case has a name, which is a symbol, a description and a test lambda. The test lambda is a regular funcall'able function which should use the various checking macros to collect results. Every test case is part of a suite, when a suite is not explicitly specified (either via the :SUITE parameter to the TEST macro or the global variable *SUITE*) the test is inserted into the global suite named NIL. Sometimes we want to run a certain test only if another test has passed. FiveAM allows us to specify the ways in which one test is dependent on another. - AND Run this test only if all the named tests passed. - OR Run this test if at least one of the named tests passed. - NOT Run this test only if another test has failed. FiveAM considers a test to have passed if all the checks executed were successful, otherwise we consider the test a failure. When a test is not run due to it's dependencies having failed a test-skipped result is added to the results.")) (defclass explainer () ()) (defclass text-explainer (explainer) ()) (defclass simple-text-explainer (text-explainer) ()) (defclass detailed-text-explainer (text-explainer) ()) ;; Copyright (c) 2002-2003, Edward Marco Baringer ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions are ;; met: ;; ;; - Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; ;; - Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; ;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names ;; of its contributors may be used to endorse or promote products ;; derived from this software without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE fiveam-1.4.3/src/explain.lisp000066400000000000000000000143021462573605400161220ustar00rootroot00000000000000;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Package: FIVEAM; Base: 10; -*- (in-package :it.bese.fiveam) ;;;; * Analyzing the results (defparameter *verbose-failures* nil "T if we should print the expression failing, NIL otherwise.") ;;;; Just as important as defining and runnig the tests is ;;;; understanding the results. FiveAM provides the function EXPLAIN ;;;; which prints a human readable summary (number passed, number ;;;; failed, what failed and why, etc.) of a list of test results. (defgeneric explain (explainer results &optional stream recursive-depth) (:documentation "Given a list of test results report write to stream detailed human readable statistics regarding the results.")) (defmethod explain ((exp detailed-text-explainer) results &optional (stream *test-dribble*) (recursive-depth 0)) (multiple-value-bind (num-checks passed num-passed passed% skipped num-skipped skipped% failed num-failed failed% unknown num-unknown unknown%) (partition-results results) (declare (ignore passed)) (flet ((output (&rest format-args) (format stream "~&~vT" recursive-depth) (apply #'format stream format-args))) (when (zerop num-checks) (output "Didn't run anything...huh?") (return-from explain nil)) (output "Did ~D check~P.~%" num-checks num-checks) (output " Pass: ~D (~2D%)~%" num-passed passed%) (output " Skip: ~D (~2D%)~%" num-skipped skipped%) (output " Fail: ~D (~2D%)~%" num-failed failed%) (when unknown (output " UNKNOWN RESULTS: ~D (~2D)~%" num-unknown unknown%)) (terpri stream) (when failed (output "Failure Details:~%") (dolist (f (reverse failed)) (output "--------------------------------~%") (output "~A ~A~@{[~A]~}: ~%" (name (test-case f)) (let ((suite (name (test-suite (test-case f))))) (if suite (format nil "in ~A " suite) "")) (description (test-case f))) (output " ~A~%" (reason f)) (when (for-all-test-failed-p f) (output "Results collected with failure data:~%") (explain exp (slot-value f 'result-list) stream (+ 4 recursive-depth))) (when (and *verbose-failures* (test-expr f)) (output " ~S~%" (test-expr f))) (output "--------------------------------~%")) (terpri stream)) (when skipped (output "Skip Details:~%") (dolist (f skipped) (output "~A ~@{[~A]~}: ~%" (name (test-case f)) (description (test-case f))) (output " ~A~%" (reason f))) (terpri stream))))) (defmethod explain ((exp simple-text-explainer) results &optional (stream *test-dribble*) (recursive-depth 0)) (multiple-value-bind (num-checks passed num-passed passed% skipped num-skipped skipped% failed num-failed failed% unknown num-unknown unknown%) (partition-results results) (declare (ignore passed passed% skipped skipped% failed failed% unknown unknown%)) (format stream "~&~vTRan ~D checks, ~D passed" recursive-depth num-checks num-passed) (when (plusp num-skipped) (format stream ", ~D skipped " num-skipped)) (format stream " and ~D failed.~%" num-failed) (when (plusp num-unknown) (format stream "~vT~D UNKNOWN RESULTS.~%" recursive-depth num-unknown)))) (defun partition-results (results-list) (let ((num-checks (length results-list))) (destructuring-bind (passed skipped failed unknown) (partitionx results-list (lambda (res) (typep res 'test-passed)) (lambda (res) (typep res 'test-skipped)) (lambda (res) (typep res 'test-failure)) t) (if (zerop num-checks) (values 0 nil 0 0 nil 0 0 nil 0 0 nil 0 0) (values num-checks passed (length passed) (floor (* 100 (/ (length passed) num-checks))) skipped (length skipped) (floor (* 100 (/ (length skipped) num-checks))) failed (length failed) (floor (* 100 (/ (length failed) num-checks))) unknown (length unknown) (floor (* 100 (/ (length failed) num-checks)))))))) ;; Copyright (c) 2002-2003, Edward Marco Baringer ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions are ;; met: ;; ;; - Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; ;; - Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; ;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names ;; of its contributors may be used to endorse or promote products ;; derived from this software without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE fiveam-1.4.3/src/fixture.lisp000066400000000000000000000064441462573605400161600ustar00rootroot00000000000000;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Package: FIVEAM; Base: 10; -*- (in-package :it.bese.fiveam) ;;;; ** Fixtures ;;;; When running tests we often need to setup some kind of context ;;;; (create dummy db connections, simulate an http request, ;;;; etc.). Fixtures provide a way to conviently hide this context ;;;; into a macro and allow the test to focus on testing. ;;;; NB: A FiveAM fixture is nothing more than a macro. Since the term ;;;; 'fixture' is so common in testing frameworks we've provided a ;;;; wrapper around defmacro for this purpose. (defvar *fixture* (make-hash-table :test 'eql) "Lookup table mapping fixture names to fixture objects.") (defun get-fixture (key &optional default) (gethash key *fixture* default)) (defun (setf get-fixture) (value key) (setf (gethash key *fixture*) value)) (defun rem-fixture (key) (remhash key *fixture*)) (defmacro def-fixture (name (&rest args) &body body) "Defines a fixture named NAME. A fixture is very much like a macro but is used only for simple templating. A fixture created with DEF-FIXTURE is a macro which can use the special macrolet &BODY to specify where the body should go. See Also: WITH-FIXTURE " `(eval-when (:compile-toplevel :load-toplevel :execute) (setf (get-fixture ',name) (cons ',args ',body)) ',name)) (defmacro with-fixture (fixture-name (&rest args) &body body) "Insert BODY into the fixture named FIXTURE-NAME. See Also: DEF-FIXTURE" (assert (get-fixture fixture-name) (fixture-name) "Unknown fixture ~S." fixture-name) (destructuring-bind ((&rest largs) &rest lbody) (get-fixture fixture-name) `(macrolet ((&body () '(progn ,@body))) (funcall (lambda (,@largs) ,@lbody) ,@args)))) ;; Copyright (c) 2002-2003, Edward Marco Baringer ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions are ;; met: ;; ;; - Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; ;; - Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; ;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names ;; of its contributors may be used to endorse or promote products ;; derived from this software without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. fiveam-1.4.3/src/package.lisp000066400000000000000000000076061462573605400160660ustar00rootroot00000000000000;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Package: CL-USER; Base: 10; -*- ;;;; * Introduction ;;;; FiveAM is a testing framework. It takes care of all the boring ;;;; bookkeeping associated with managing a test framework allowing ;;;; the developer to focus on writing tests and code. ;;;; FiveAM was designed with the following premises: ;;;; - Defining tests should be about writing tests, not ;;;; infrastructure. The developer should be able to focus on what ;;;; they're testing, not the testing framework. ;;;; - Interactive testing is the norm. Common Lisp is an interactive ;;;; development environment, the testing environment should allow the ;;;; developer to quickly and easily redefine, change, remove and run ;;;; tests. (defpackage :it.bese.fiveam (:use :common-lisp :alexandria) (:nicknames :5am :fiveam) #+sb-package-locks (:lock t) (:export ;; creating tests and test-suites #:make-suite #:def-suite #:def-suite* #:in-suite #:in-suite* #:test #:def-test #:get-test #:rem-test #:test-names #:*default-test-compilation-time* ;; fixtures #:def-fixture #:with-fixture #:get-fixture #:rem-fixture ;; running checks #:is #:is-every #:is-true #:is-false #:signals #:finishes #:skip #:pass #:fail #:*test-dribble* #:for-all #:for-all* #:*num-trials* #:*max-trials* #:gen-integer #:gen-float #:gen-character #:gen-string #:gen-list #:gen-tree #:gen-buffer #:gen-one-element ;; running tests #:run #:run-all-tests #:explain #:explain! #:run! #:debug! #:! #:!! #:!!! #:*run-test-when-defined* #:*debug-on-error* #:*debug-on-failure* #:*on-error* #:*on-failure* #:*verbose-failures* #:*print-names* #:results-status)) ;;;; You can use #+5am to put your test-defining code inline with your ;;;; other code - and not require people to have fiveam to run your ;;;; package. (pushnew :5am *features*) ;;;;@include "check.lisp" ;;;;@include "random.lisp" ;;;;@include "fixture.lisp" ;;;;@include "test.lisp" ;;;;@include "suite.lisp" ;;;;@include "run.lisp" ;;;;@include "explain.lisp" ;;;; * Colophon ;;;; This documentaion was written by Edward Marco Baringer ;;;; and generated by qbook. ;;;; ** COPYRIGHT ;;;; Copyright (c) 2002-2003, Edward Marco Baringer ;;;; All rights reserved. ;;;; Redistribution and use in source and binary forms, with or without ;;;; modification, are permitted provided that the following conditions are ;;;; met: ;;;; - Redistributions of source code must retain the above copyright ;;;; notice, this list of conditions and the following disclaimer. ;;;; - Redistributions in binary form must reproduce the above copyright ;;;; notice, this list of conditions and the following disclaimer in the ;;;; documentation and/or other materials provided with the distribution. ;;;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names ;;;; of its contributors may be used to endorse or promote products ;;;; derived from this software without specific prior written permission. ;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE fiveam-1.4.3/src/random.lisp000066400000000000000000000266531462573605400157560ustar00rootroot00000000000000;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Package: FIVEAM; Base: 10; -*- (in-package :it.bese.fiveam) ;;;; ** Random (QuickCheck-ish) testing ;;;; FiveAM provides the ability to automatically generate a ;;;; collection of random input data for a specific test and run a ;;;; test multiple times. ;;;; Specification testing is done through the FOR-ALL macro. This ;;;; macro will bind variables to random data and run a test body a ;;;; certain number of times. Should the test body ever signal a ;;;; failure we stop running and report what values of the variables ;;;; caused the code to fail. ;;;; The generation of the random data is done using "generator ;;;; functions" (see below for details). A generator function is a ;;;; function which creates, based on user supplied parameters, a ;;;; function which returns random data. In order to facilitate ;;;; generating good random data the FOR-ALL macro also supports guard ;;;; conditions and creating one random input based on the values of ;;;; another (see the FOR-ALL macro for details). ;;;; *** Public Interface to the Random Tester (defparameter *num-trials* 100 "Number of times we attempt to run the body of the FOR-ALL test.") (defparameter *max-trials* 10000 "Number of total times we attempt to run the body of the FOR-ALL test including when the body is skipped due to failed guard conditions. Since we have guard conditions we may get into infinite loops where the test code is never run due to the guards never returning true. This second run limit prevents that.") (defmacro for-all (bindings &body body) "Bind BINDINGS to random variables and test BODY *num-trials* times. BINDINGS is a list of binding forms, each element is a list of (BINDING VALUE &optional GUARD). Value, which is evaluated once when the for-all is evaluated, must return a generator which be called each time BODY is evaluated. BINDING is either a symbol or a list which will be passed to destructuring-bind. GUARD is a form which, if present, stops BODY from executing when IT returns NIL. The GUARDS are evaluated after all the random data has been generated and they can refer to the current value of any binding. NB: Generator forms, unlike guard forms, can not contain references to the bound variables. Examples: (for-all ((a (gen-integer))) (is (integerp a))) (for-all ((a (gen-integer) (plusp a))) (is (integerp a)) (is (plusp a))) (for-all ((less (gen-integer)) (more (gen-integer) (< less more))) (is (<= less more))) (for-all (((a b) (gen-two-integers))) (is (integerp a)) (is (integerp b)))" (with-gensyms (test-lambda-args) `(perform-random-testing (list ,@(mapcar #'second bindings)) (lambda (,test-lambda-args) (destructuring-bind ,(mapcar #'first bindings) ,test-lambda-args (if (and ,@(delete-if #'null (mapcar #'third bindings))) (progn ,@body) (throw 'run-once (list :guard-conditions-failed)))))))) (defmacro dbind-rec (bindings &body body) (let* ((binding (first bindings)) (dbind-ll (first binding)) (dbind-sp (second binding)) (body-form (if (null (rest bindings)) `(progn ,@body) `(dbind-rec ,(rest bindings) ,@body))) (bind-form (if (atom dbind-ll) `(let ((,dbind-ll (funcall ,dbind-sp))) ,body-form) `(destructuring-bind ,dbind-ll (funcall ,dbind-sp) ,body-form)))) (if (null bindings) body-form bind-form))) (defmacro for-all* (bindings &body body) "Bind BINDINGS to random variables and test BODY *num-trials* times. Works like FOR-ALL but variables are defined sequentially - subsequent generator bindings may use value of a previous generator. Example: (for-all* ((a (gen-integer)) (b (gen-integer :min a :max (+ a 20))) (is (<= a b)))" (with-gensyms (test-lambda-args) `(perform-random-testing nil (lambda (,test-lambda-args) (declare (ignore ,test-lambda-args)) (dbind-rec ,bindings (if (and ,@(delete-if #'null (mapcar #'third bindings))) (progn ,@body) (throw 'run-once (list :guard-conditions-failed)))))))) ;;;; *** Implementation ;;;; We could just make FOR-ALL a monster macro, but having FOR-ALL be ;;;; a preproccessor for the perform-random-testing function is ;;;; actually much easier. (defun perform-random-testing (generators body) (loop with random-state = *random-state* with total-counter = *max-trials* with counter = *num-trials* with run-at-least-once = nil until (or (zerop total-counter) (zerop counter)) do (let ((result (perform-random-testing/run-once generators body))) (ecase (first result) (:pass (decf counter) (decf total-counter) (setf run-at-least-once t)) (:no-tests (add-result 'for-all-test-no-tests :reason "No tests" :random-state random-state) (return-from perform-random-testing nil)) (:guard-conditions-failed (decf total-counter)) (:fail (add-result 'for-all-test-failed :reason "Found failing test data" :random-state random-state :failure-values (second result) :result-list (third result)) (return-from perform-random-testing nil)))) finally (if run-at-least-once (add-result 'for-all-test-passed) (add-result 'for-all-test-never-run :reason "Guard conditions never passed")))) (defun perform-random-testing/run-once (generators body) (catch 'run-once (bind-run-state ((result-list '())) (let ((values (mapcar #'funcall generators))) (funcall body values) (cond ((null result-list) (throw 'run-once (list :no-tests))) ((every #'test-passed-p result-list) (throw 'run-once (list :pass))) ((notevery #'test-passed-p result-list) (throw 'run-once (list :fail values result-list)))))))) (defclass for-all-test-result () ((random-state :initarg :random-state))) (defclass for-all-test-passed (test-passed for-all-test-result) ()) (defclass for-all-test-failed (test-failure for-all-test-result) ((failure-values :initarg :failure-values) (result-list :initarg :result-list))) (defgeneric for-all-test-failed-p (object) (:method ((object for-all-test-failed)) t) (:method ((object t)) nil)) (defmethod reason ((result for-all-test-failed)) (format nil "Falsifiable with ~S" (slot-value result 'failure-values))) (defclass for-all-test-no-tests (test-failure for-all-test-result) ()) (defclass for-all-test-never-run (test-failure for-all-test-result) ()) ;;;; *** Generators ;;;; Since this is random testing we need some way of creating random ;;;; data to feed to our code. Generators are regular functions which ;;;; create this random data. ;;;; We provide a set of built-in generators. (defun gen-integer (&key (max (1+ most-positive-fixnum)) (min (1- most-negative-fixnum))) "Returns a generator which produces random integers greater than or equal to MIN and less than or equal to MAX." (lambda () (+ min (random (1+ (- max min)))))) (defun gen-float (&key bound (type 'short-float)) "Returns a generator which produces floats of type TYPE. BOUND, if specified, constrains the results to be in the range (-BOUND, BOUND)." (lambda () (let* ((most-negative (ecase type (short-float most-negative-short-float) (single-float most-negative-single-float) (double-float most-negative-double-float) (long-float most-negative-long-float))) (most-positive (ecase type (short-float most-positive-short-float) (single-float most-positive-single-float) (double-float most-positive-double-float) (long-float most-positive-long-float))) (bound (or bound (max most-positive (- most-negative))))) (coerce (ecase (random 2) (0 ;; generate a positive number (random (min most-positive bound))) (1 ;; generate a negative number (- (random (min (- most-negative) bound))))) type)))) (defun gen-character (&key (code-limit char-code-limit) (code (gen-integer :min 0 :max (1- code-limit))) (alphanumericp nil)) "Returns a generator of characters. CODE must be a generator of random integers. ALPHANUMERICP, if non-NIL, limits the returned chars to those which pass alphanumericp." (lambda () (loop for count upfrom 0 for char = (code-char (funcall code)) until (and char (or (not alphanumericp) (alphanumericp char))) when (= 1000 count) do (error "After 1000 iterations ~S has still not generated ~:[a valid~;an alphanumeric~] character :(." code alphanumericp) finally (return char)))) (defun gen-string (&key (length (gen-integer :min 0 :max 80)) (elements (gen-character)) (element-type 'character)) "Returns a generator which produces random strings. LENGTH must be a generator which produces integers, ELEMENTS must be a generator which produces characters of type ELEMENT-TYPE." (lambda () (loop with length = (funcall length) with string = (make-string length :element-type element-type) for index below length do (setf (aref string index) (funcall elements)) finally (return string)))) (defun gen-list (&key (length (gen-integer :min 0 :max 10)) (elements (gen-integer :min -10 :max 10))) "Returns a generator which produces random lists. LENGTH must be an integer generator and ELEMENTS must be a generator which produces objects." (lambda () (loop repeat (funcall length) collect (funcall elements)))) (defun gen-tree (&key (size 20) (elements (gen-integer :min -10 :max 10))) "Returns a generator which produces random trees. SIZE controls the approximate size of the tree, but don't try anything above 30, you have been warned. ELEMENTS must be a generator which will produce the elements." (labels ((rec (&optional (current-depth 0)) (let ((key (random (+ 3 (- size current-depth))))) (cond ((> key 2) (list (rec (+ current-depth 1)) (rec (+ current-depth 1)))) (t (funcall elements)))))) (lambda () (rec)))) (defun gen-buffer (&key (length (gen-integer :min 0 :max 50)) (element-type '(unsigned-byte 8)) (elements (gen-integer :min 0 :max (1- (expt 2 8))))) (lambda () (let ((buffer (make-array (funcall length) :element-type element-type))) (map-into buffer elements)))) (defun gen-one-element (&rest elements) (lambda () (nth (random (length elements)) elements))) ;;;; The trivial always-produce-the-same-thing generator is done using ;;;; cl:constantly. fiveam-1.4.3/src/run.lisp000066400000000000000000000422251462573605400152730ustar00rootroot00000000000000;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Package: FIVEAM; Base: 10; -*- (in-package :it.bese.fiveam) ;;;; * Running Tests ;;;; Once the programmer has defined what the tests are these need to ;;;; be run and the expected effects should be compared with the ;;;; actual effects. FiveAM provides the function RUN for this ;;;; purpose, RUN executes a number of tests and collects the results ;;;; of each individual check into a list which is then ;;;; returned. There are three types of test results: passed, failed ;;;; and skipped, these are represented by TEST-RESULT objects. ;;;; Generally running a test will return normally, but there are two ;;;; exceptional situations which can occur: ;;;; - An exception is signaled while running the test. If the ;;;; variable *on-error* is :DEBUG than FiveAM will enter the ;;;; debugger, otherwise a test failure (of type ;;;; unexpected-test-failure) is returned. When entering the ;;;; debugger two restarts are made available, one simply reruns the ;;;; current test and another signals a test-failure and continues ;;;; with the remaining tests. ;;;; - A circular dependency is detected. An error is signaled and a ;;;; restart is made available which signals a test-skipped and ;;;; continues with the remaining tests. This restart also sets the ;;;; dependency status of the test to nil, so any tests which depend ;;;; on this one (even if the dependency is not circular) will be ;;;; skipped. ;;;; The functions RUN!, !, !! and !!! are convenient wrappers around ;;;; RUN and EXPLAIN. (deftype on-problem-action () '(member :debug :backtrace nil)) (declaim (type on-problem-action *on-error* *on-failure*)) (defvar *on-error* nil "The action to perform on error: - :DEBUG if we should drop into the debugger - :BACKTRACE to print a backtrace - NIL to simply continue") (defvar *on-failure* nil "The action to perform on check failure: - :DEBUG if we should drop into the debugger - :BACKTRACE to print a backtrace - NIL to simply continue") (defvar *debug-on-error* nil "T if we should drop into the debugger on error, NIL otherwise. OBSOLETE: superseded by *ON-ERROR*") (defvar *debug-on-failure* nil "T if we should drop into the debugger on a failing check, NIL otherwise. OBSOLETE: superseded by *ON-FAILURE*") (defparameter *print-names* t "T if we should print test running progress, NIL otherwise.") (defparameter *test-dribble-indent* (make-array 0 :element-type 'character :fill-pointer 0 :adjustable t) "Used to indent tests and test suites in their parent suite") (defun import-testing-symbols (package-designator) (import '(5am::is 5am::is-true 5am::is-false 5am::signals 5am::finishes) package-designator)) (defparameter *run-queue* '() "List of test waiting to be run.") (define-condition circular-dependency (error) ((test-case :initarg :test-case)) (:report (lambda (cd stream) (format stream "A circular dependency wes detected in ~S." (slot-value cd 'test-case)))) (:documentation "Condition signaled when a circular dependency between test-cases has been detected.")) (defgeneric run-resolving-dependencies (test) (:documentation "Given a dependency spec determine if the spec is satisfied or not, this will generally involve running other tests. If the dependency spec can be satisfied the test is also run.")) (defmethod run-resolving-dependencies ((test test-case)) "Return true if this test, and its dependencies, are satisfied, NIL otherwise." (case (status test) (:unknown (setf (status test) :resolving) (if (or (not (depends-on test)) (eql t (resolve-dependencies (depends-on test)))) (progn (run-test-lambda test) (status test)) (with-run-state (result-list) (unless (eql :circular (status test)) (push (make-instance 'test-skipped :test-case test :reason "Dependencies not satisfied") result-list) (setf (status test) :depends-not-satisfied))))) (:resolving (restart-case (error 'circular-dependency :test-case test) (skip () :report (lambda (s) (format s "Skip the test ~S and all its dependencies." (name test))) (with-run-state (result-list) (push (make-instance 'test-skipped :reason "Circular dependencies" :test-case test) result-list)) (setf (status test) :circular)))) (t (status test)))) (defgeneric resolve-dependencies (depends-on)) (defmethod resolve-dependencies ((depends-on symbol)) "A test which depends on a symbol is interpreted as `(AND ,DEPENDS-ON)." (run-resolving-dependencies (get-test depends-on))) (defmethod resolve-dependencies ((depends-on list)) "Return true if the dependency spec DEPENDS-ON is satisfied, nil otherwise." (if (null depends-on) t (flet ((satisfies-depends-p (test) (funcall test (lambda (dep) (eql t (resolve-dependencies dep))) (cdr depends-on)))) (ecase (car depends-on) (and (satisfies-depends-p #'every)) (or (satisfies-depends-p #'some)) (not (satisfies-depends-p #'notany)) (:before (every #'(lambda (dep) (let ((status (status (get-test dep)))) (if (eql :unknown status) (run-resolving-dependencies (get-test dep)) status))) (cdr depends-on))))))) (defun results-status (result-list) "Given a list of test results (generated while running a test) return true if no results are of type TEST-FAILURE. Returns second and third values, which are the set of failed tests and skipped tests respectively." (let ((failed-tests (remove-if-not #'test-failure-p result-list)) (skipped-tests (remove-if-not #'test-skipped-p result-list))) (values (null failed-tests) failed-tests skipped-tests))) (defun return-result-list (test-lambda) "Run the test function TEST-LAMBDA and return a list of all test results generated, does not modify the special environment variable RESULT-LIST." (bind-run-state ((result-list '())) (funcall test-lambda) result-list)) (defgeneric run-test-lambda (test)) (defmethod run-test-lambda ((test test-case)) (with-run-state (result-list) (bind-run-state ((current-test test)) (labels ((abort-test (e &optional (reason (format nil "Unexpected Error: ~S~%~A." e e))) (add-result 'unexpected-test-failure :test-expr nil :test-case test :reason reason :condition e)) (run-it () (let ((result-list '())) (declare (special result-list)) (handler-bind ((check-failure (lambda (e) (declare (ignore e)) (cond ((eql *on-failure* :debug) nil) (t (when (eql *on-failure* :backtrace) (trivial-backtrace:print-backtrace-to-stream *test-dribble*)) (invoke-restart (find-restart 'ignore-failure)))))) (error (lambda (e) (unless (or (eql *on-error* :debug) (typep e 'check-failure)) (when (eql *on-error* :backtrace) (trivial-backtrace:print-backtrace-to-stream *test-dribble*)) (abort-test e) (return-from run-it result-list))))) (restart-case (handler-case (let ((*readtable* (copy-readtable)) (*package* (runtime-package test))) (when *print-names* (format *test-dribble* "~%~ARunning test ~A " *test-dribble-indent* (name test)) (force-output *test-dribble*)) (if (collect-profiling-info test) ;; Timing info doesn't get collected ATM, we need a portable library ;; (setf (profiling-info test) (collect-timing (test-lambda test))) (funcall (test-lambda test)) (funcall (test-lambda test)))) (storage-condition (e) ;; heap-exhausted/constrol-stack-exhausted ;; handler-case unwinds the stack (unlike handler-bind) (abort-test e (format nil "STORAGE-CONDITION: aborted for safety. ~S~%~A." e e)) (return-from run-it result-list))) (retest () :report (lambda (stream) #-genera (format stream "~@" test) #+genera (format stream "Rerun the test ~S" test)) (return-from run-it (run-it))) (ignore () :report (lambda (stream) #-genera (format stream "~@" test) #+genera (format stream "Signal an exceptional test failure and abort the test ~S." test)) (abort-test (make-instance 'test-failure :test-case test :reason "Failure restart.")))) result-list)))) (let ((results (run-it))) (setf (status test) (results-status results) result-list (nconc result-list results))))))) (defgeneric %run (test-spec) (:documentation "Internal method for running a test. Does not update the status of the tests nor the special variables !, !!, !!!")) (defmethod %run ((test test-case)) (run-resolving-dependencies test)) (defmethod %run ((tests list)) (mapc #'%run tests)) (defmethod %run ((suite test-suite)) (when *print-names* (format *test-dribble* "~%~ARunning test suite ~A" *test-dribble-indent* (name suite)) (force-output *test-dribble*)) (let ((suite-results '())) (flet ((run-tests () (loop :for test :in (reverse (%test-names (tests suite))) :do (%run test)))) (vector-push-extend #\space *test-dribble-indent*) (unwind-protect (bind-run-state ((result-list '())) (unwind-protect (if (collect-profiling-info suite) ;; Timing info doesn't get collected ATM, we need a portable library ;; (setf (profiling-info suite) (collect-timing #'run-tests)) (run-tests) (run-tests))) (setf suite-results result-list (status suite) (every #'test-passed-p suite-results))) (vector-pop *test-dribble-indent*) (with-run-state (result-list) (setf result-list (nconc result-list suite-results))))))) (defmethod %run ((test-name symbol)) (when-let (test (get-test test-name)) (%run test))) (defvar *initial-!* (lambda () (format t "Haven't run that many tests yet.~%"))) (defvar *!* *initial-!*) (defvar *!!* *initial-!*) (defvar *!!!* *initial-!*) ;;;; ** Public entry points #+#.(cl:if (cl:ignore-errors (cl:find-symbol "&OPTIONAL-AND-&KEY-IN-LAMBDA-LIST" "SB-KERNEL")) '(and) '(or)) (declaim (sb-ext:muffle-conditions sb-kernel:&optional-and-&key-in-lambda-list)) (defun run! (&optional (test-spec *suite*) &key ((:print-names *print-names*) *print-names*)) "Equivalent to (explain! (run TEST-SPEC))." (explain! (run test-spec))) (defun explain! (result-list) "Explain the results of RESULT-LIST using a detailed-text-explainer with output going to *test-dribble*. Return a boolean indicating whether no tests failed." (explain (make-instance 'detailed-text-explainer) result-list *test-dribble*) (results-status result-list)) (defun debug! (&optional (test-spec *suite*)) "Calls (run! test-spec) but enters the debugger if any kind of error happens." (let ((*on-error* :debug) (*on-failure* :debug)) (run! test-spec))) (defun run (test-spec &key ((:print-names *print-names*) *print-names*)) "Run the test specified by TEST-SPEC. TEST-SPEC can be either a symbol naming a test or test suite, or a testable-object object. This function changes the operations performed by the !, !! and !!! functions." (psetf *!* (lambda () (loop :for test :in (test-names) :do (setf (status (get-test test)) :unknown)) (bind-run-state ((result-list '())) (with-simple-restart (explain "Ignore the rest of the tests and explain current results") (%run test-spec)) result-list)) *!!* *!* *!!!* *!!*) (let ((*on-error* (or *on-error* (cond (*debug-on-error* (format *test-dribble* "*DEBUG-ON-ERROR* is obsolete. Use *ON-ERROR*.") :debug) (t nil)))) (*on-failure* (or *on-failure* (cond (*debug-on-failure* (format *test-dribble* "*DEBUG-ON-FAILURE* is obsolete. Use *ON-FAILURE*.") :debug) (t nil))))) (funcall *!*))) (defun ! () "Rerun the most recently run test and explain the results." (explain! (funcall *!*))) (defun !! () "Rerun the second most recently run test and explain the results." (explain! (funcall *!!*))) (defun !!! () "Rerun the third most recently run test and explain the results." (explain! (funcall *!!!*))) (defun run-all-tests (&key (summary :end)) "Runs all defined test suites, T if all tests passed and NIL otherwise. SUMMARY can be :END to print a summary at the end, :SUITE to print it after each suite or NIL to skip explanations." (check-type summary (member nil :suite :end)) (loop :for suite :in (cons 'nil (sort (copy-list *toplevel-suites*) #'string<=)) :for results := (if (suite-emptyp suite) nil (run suite)) :when (consp results) :collect results :into all-results :do (cond ((not (eql summary :suite)) nil) (results (explain! results)) (suite (format *test-dribble* "Suite ~A is empty~%" suite))) :finally (progn (when (eql summary :end) (explain! (alexandria:flatten all-results))) (return (every #'results-status all-results))))) ;; Copyright (c) 2002-2003, Edward Marco Baringer ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions are ;; met: ;; ;; - Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; ;; - Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; ;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names ;; of its contributors may be used to endorse or promote products ;; derived from this software without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. fiveam-1.4.3/src/style.css000066400000000000000000000042701462573605400154460ustar00rootroot00000000000000body { background-color: #FFFFFF; color: #000000; padding: 0px; margin: 0px; } .qbook { width: 600px; background-color: #FFFFFF; margin: 0px; border-left: 3em solid #660000; padding: 3px; } h1 { text-align: center; margin: 0px; color: #333333; border-bottom: 0.3em solid #660000; } p { padding-left: 1em; } h2 { border-bottom: 0.2em solid #000000; font-family: verdana; } h3 { border-bottom: 0.1em solid #000000; } pre.code { background-color: #eeeeee; border: solid 1px #d0d0d0; overflow: auto; } pre.code * .paren { color: #666666; } pre.code a:active { color: #000000; } pre.code a:link { color: #000000; } pre.code a:visited { color: #000000; } pre.code .first-line { font-weight: bold; } div.contents { font-family: verdana; } div.contents a:active { color: #000000; } div.contents a:link { color: #000000; } div.contents a:visited { color: #000000; } div.contents div.contents-heading-1 { padding-left: 0.5em; font-weight: bold; } div.contents div.contents-heading-1 a:active { color: #660000; } div.contents div.contents-heading-1 a:link { color: #660000; } div.contents div.contents-heading-1 a:visited { color: #660000; } div.contents div.contents-heading-2 { padding-left: 1.0em; } div.contents div.contents-heading-2 a:active { color: #660000; } div.contents div.contents-heading-2 a:link { color: #660000; } div.contents div.contents-heading-2 a:visited { color: #660000; } div.contents div.contents-heading-3 { padding-left: 1.5em; } div.contents div.contents-heading-3 a:active { color: #660000; } div.contents div.contents-heading-3 a:link { color: #660000; } div.contents div.contents-heading-3 a:visited { color: #660000; } div.contents div.contents-heading-4 { padding-left: 2em; } div.contents div.contents-heading-4 a:active { color: #660000; } div.contents div.contents-heading-4 a:link { color: #660000; } div.contents div.contents-heading-4 a:visited { color: #660000; } div.contents div.contents-heading-5 { padding-left: 2.5em; } div.contents div.contents-heading-5 a:active { color: #660000; } div.contents div.contents-heading-5 a:link { color: #660000; } div.contents div.contents-heading-5 a:visited { color: #660000; } fiveam-1.4.3/src/suite.lisp000066400000000000000000000125661462573605400156250ustar00rootroot00000000000000;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Package: FIVEAM; Base: 10; -*- (in-package :it.bese.fiveam) ;;;; * Test Suites ;;;; Test suites allow us to collect multiple tests into a single ;;;; object and run them all using asingle name. Test suites do not ;;;; affect the way test are run nor the way the results are handled, ;;;; they are simply a test organizing group. ;;;; Test suites can contain both tests and other test suites. Running ;;;; a test suite causes all of its tests and test suites to be ;;;; run. Suites do not affect test dependencies, running a test suite ;;;; can cause tests which are not in the suite to be run. ;;;; ** Current Suite (defvar *suite* nil "The current test suite object") ;; Only when compiling under ASDF, not under Bazel. #-bazel (net.didierverna.asdf-flv:set-file-local-variable *suite*) ;;;; ** Creating Suits ;; Suites that have no parent suites. (defvar *toplevel-suites* nil) (defgeneric suite-emptyp (suite) (:method ((suite symbol)) (suite-emptyp (get-test suite))) (:method ((suite test-suite)) (zerop (hash-table-count (%tests (tests suite)))))) (defmacro def-suite (name &key description in) "Define a new test-suite named NAME. IN (a symbol), if provided, causes this suite te be nested in the suite named by IN. NB: This macro is built on top of make-suite, as such it, like make-suite, will overrwrite any existing suite named NAME." `(eval-when (:compile-toplevel :load-toplevel :execute) (make-suite ',name ,@(when description `(:description ,description)) ,@(when in `(:in ',in))) ',name)) (defmacro def-suite* (name &rest def-suite-args) `(progn (def-suite ,name ,@def-suite-args) (in-suite ,name))) (defun make-suite (name &key description ((:in parent-suite))) "Create a new test suite object. Overrides any existing suite named NAME." (let ((suite (make-instance 'test-suite :name name))) (when description (setf (description suite) description)) (when (and name (null parent-suite)) (pushnew name *toplevel-suites*)) (loop for i in (ensure-list parent-suite) for in-suite = (get-test i) do (progn (when (null in-suite) (cerror "Create a new suite named ~A." "Unknown suite ~A." i) (setf (get-test in-suite) (make-suite i) in-suite (get-test in-suite))) (let ((*test* (tests in-suite))) (setf (get-test name) suite)))) (setf (get-test name) suite) suite)) (eval-when (:load-toplevel :execute) (setf *suite* (setf (get-test 'nil) (make-suite 'nil :description "Global Suite")))) (defun list-all-suites () "Returns an unordered LIST of all suites." (hash-table-values *suite*)) ;;;; ** Managing the Current Suite (defmacro in-suite (suite-name) "Set the *suite* special variable so that all tests defined after the execution of this form are, unless specified otherwise, in the test-suite named SUITE-NAME. See also: DEF-SUITE *SUITE*" `(eval-when (:compile-toplevel :load-toplevel :execute) (%in-suite ,suite-name))) (defmacro in-suite* (suite-name &key in) "Just like in-suite, but silently creates missing suites." `(eval-when (:compile-toplevel :load-toplevel :execute) (%in-suite ,suite-name :in ,in :fail-on-error nil))) (defmacro %in-suite (suite-name &key (fail-on-error t) in) (with-gensyms (suite) `(progn (if-let (,suite (get-test ',suite-name)) (setf *suite* ,suite) (progn (when ,fail-on-error (cerror "Create a new suite named ~A." "Unknown suite ~A." ',suite-name)) (setf (get-test ',suite-name) (make-suite ',suite-name :in ',in) *suite* (get-test ',suite-name)))) ',suite-name))) ;; Copyright (c) 2002-2003, Edward Marco Baringer ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions are ;; met: ;; ;; - Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; ;; - Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; ;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names ;; of its contributors may be used to endorse or promote products ;; derived from this software without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE fiveam-1.4.3/src/test.lisp000066400000000000000000000152551462573605400154510ustar00rootroot00000000000000;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Package: FIVEAM; Base: 10; -*- (in-package :it.bese.fiveam) ;;;; * Tests ;;;; While executing checks and collecting the results is the core job ;;;; of a testing framework it is also important to be able to ;;;; organize checks into groups, fiveam provides two mechanisms for ;;;; organizing checks: tests and test suites. A test is a named ;;;; collection of checks which can be run and a test suite is a named ;;;; collection of tests and test suites. (declaim (special *suite*)) (defvar *test* (make-instance 'test-bundle) "Lookup table mapping test (and test suite) names to objects.") (defun get-test (key &optional default) (gethash key (%tests *test*) default)) (defun (setf get-test) (value key) (push key (%test-names *test*)) (setf (gethash key (%tests *test*)) value)) (defun rem-test (key) (deletef (%test-names *test*) key) (remhash key (%tests *test*))) (defun test-names () (reverse (%test-names *test*))) (defmacro test (name &body body) "Create a test named NAME. If NAME is a list it must be of the form: (name &key depends-on suite fixture compile-at profile) NAME is the symbol which names the test. DEPENDS-ON is a list of the form: (AND . test-names) - This test is run only if all of the tests in TEST-NAMES have passed, otherwise a single test-skipped result is generated. (OR . test-names) - If any of TEST-NAMES has passed this test is run, otherwise a test-skipped result is generated. (NOT test-name) - This is test is run only if TEST-NAME failed. AND, OR and NOT can be combined to produce complex dependencies. If DEPENDS-ON is a symbol it is interpreted as `(AND ,depends-on), this is accomadate the common case of one test depending on another. FIXTURE specifies a fixture to wrap the body in. If PROFILE is T profiling information will be collected as well." (destructuring-bind (name &rest args) (ensure-list name) `(def-test ,name (,@args) ,@body))) (defvar *default-test-compilation-time* :definition-time) (defmacro def-test (name (&key depends-on (suite '*suite* suite-p) fixture (compile-at *default-test-compilation-time*) profile) &body body) "Create a test named NAME. NAME is the symbol which names the test. DEPENDS-ON is a list of the form: (AND . test-names) - This test is run only if all of the tests in TEST-NAMES have passed, otherwise a single test-skipped result is generated. (OR . test-names) - If any of TEST-NAMES has passed this test is run, otherwise a test-skipped result is generated. (NOT test-name) - This is test is run only if TEST-NAME failed. AND, OR and NOT can be combined to produce complex dependencies. If DEPENDS-ON is a symbol it is interpreted as `(AND ,depends-on), this is accomadate the common case of one test depending on another. FIXTURE specifies a fixture to wrap the body in. If PROFILE is T profiling information will be collected as well." (check-type compile-at (member :run-time :definition-time)) (multiple-value-bind (forms decls docstring) (parse-body body :documentation t :whole name) (let* ((description (or docstring "")) (body-forms (append decls forms)) (suite-form (if suite-p `(get-test ',suite) (or suite '*suite*))) (effective-body (if fixture (destructuring-bind (name &rest args) (ensure-list fixture) `((with-fixture ,name ,args ,@body-forms))) body-forms))) `(progn (register-test ',name ,description ',effective-body ,suite-form ',depends-on ,compile-at ,profile) (when *run-test-when-defined* (run! ',name)) ',name)))) (defun register-test (name description body suite depends-on compile-at profile) (let ((lambda-name (format-symbol t "%~A-~A" '#:test name)) (inner-lambda-name (format-symbol t "%~A-~A" '#:inner-test name))) (setf (get-test name) (make-instance 'test-case :name name :runtime-package (find-package (package-name *package*)) :test-lambda (eval `(named-lambda ,lambda-name () ,@(ecase compile-at (:run-time `((funcall (let ((*package* (find-package ',(package-name *package*)))) (compile ',inner-lambda-name '(lambda () ,@body)))))) (:definition-time body)))) :description description :depends-on depends-on :collect-profiling-info profile :test-suite suite)) (let ((*test* (tests suite))) (setf (get-test name) name)))) (defvar *run-test-when-defined* nil "When non-NIL tests are run as soon as they are defined.") ;; Copyright (c) 2002-2003, Edward Marco Baringer ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions are ;; met: ;; ;; - Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; ;; - Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; ;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names ;; of its contributors may be used to endorse or promote products ;; derived from this software without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. fiveam-1.4.3/src/utils.lisp000066400000000000000000000210001462573605400156130ustar00rootroot00000000000000;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Package: FIVEAM; Base: 10; -*- (in-package :it.bese.fiveam) (defmacro dolist* ((iterator list &optional return-value) &body body) "Like DOLIST but destructuring-binds the elements of LIST. If ITERATOR is a symbol then dolist* is just like dolist EXCEPT that it creates a fresh binding." (if (listp iterator) (let ((i (gensym "DOLIST*-I-"))) `(dolist (,i ,list ,return-value) (destructuring-bind ,iterator ,i ,@body))) `(dolist (,iterator ,list ,return-value) (let ((,iterator ,iterator)) ,@body)))) (defun make-collector (&optional initial-value) "Create a collector function. A Collector function will collect, into a list, all the values passed to it in the order in which they were passed. If the callector function is called without arguments it returns the current list of values." (let ((value initial-value) (cdr (last initial-value))) (lambda (&rest items) (if items (progn (if value (if cdr (setf (cdr cdr) items cdr (last items)) (setf cdr (last items))) (setf value items cdr (last items))) items) value)))) (defun partitionx (list &rest lambdas) (let ((collectors (mapcar (lambda (l) (cons (if (and (symbolp l) (member l (list :otherwise t) :test #'string=)) (constantly t) l) (make-collector))) lambdas))) (dolist (item list) (block item (dolist* ((test-func . collector-func) collectors) (when (funcall test-func item) (funcall collector-func item) (return-from item))))) (mapcar #'funcall (mapcar #'cdr collectors)))) ;;;; ** Anaphoric conditionals (defmacro if-bind (var test &body then/else) "Anaphoric IF control structure. VAR (a symbol) will be bound to the primary value of TEST. If TEST returns a true value then THEN will be executed, otherwise ELSE will be executed." (assert (first then/else) (then/else) "IF-BIND missing THEN clause.") (destructuring-bind (then &optional else) then/else `(let ((,var ,test)) (if ,var ,then ,else)))) (defmacro aif (test then &optional else) "Just like IF-BIND but the var is always IT." `(if-bind it ,test ,then ,else)) ;;;; ** Simple list matching based on code from Paul Graham's On Lisp. (defmacro acond2 (&rest clauses) (if (null clauses) nil (with-gensyms (val foundp) (destructuring-bind ((test &rest progn) &rest others) clauses `(multiple-value-bind (,val ,foundp) ,test (if (or ,val ,foundp) (let ((it ,val)) (declare (ignorable it)) ,@progn) (acond2 ,@others))))))) (defun varsymp (x) (and (symbolp x) (let ((name (symbol-name x))) (and (>= (length name) 2) (char= (char name 0) #\?))))) (defun binding (x binds) (labels ((recbind (x binds) (aif (assoc x binds) (or (recbind (cdr it) binds) it)))) (let ((b (recbind x binds))) (values (cdr b) b)))) (defun list-match (x y &optional binds) (acond2 ((or (eql x y) (eql x '_) (eql y '_)) (values binds t)) ((binding x binds) (list-match it y binds)) ((binding y binds) (list-match x it binds)) ((varsymp x) (values (cons (cons x y) binds) t)) ((varsymp y) (values (cons (cons y x) binds) t)) ((and (consp x) (consp y) (list-match (car x) (car y) binds)) (list-match (cdr x) (cdr y) it)) (t (values nil nil)))) (defun vars (match-spec) (let ((vars nil)) (labels ((find-vars (spec) (cond ((null spec) nil) ((varsymp spec) (push spec vars)) ((consp spec) (find-vars (car spec)) (find-vars (cdr spec)))))) (find-vars match-spec)) (delete-duplicates vars))) (defmacro list-match-case (target &body clauses) (if clauses (destructuring-bind ((test &rest progn) &rest others) clauses (with-gensyms (tgt binds success) `(let ((,tgt ,target)) (multiple-value-bind (,binds ,success) (list-match ,tgt ',test) (declare (ignorable ,binds)) (if ,success (let ,(mapcar (lambda (var) `(,var (cdr (assoc ',var ,binds)))) (vars test)) (declare (ignorable ,@(vars test))) ,@progn) (list-match-case ,tgt ,@others)))))) nil)) ;;;; * def-special-environment (defun check-required (name vars required) (dolist (var required) (assert (member var vars) (var) "Unrecognized symbol ~S in ~S." var name))) (defmacro def-special-environment (name (&key accessor binder binder*) &rest vars) "Define two macros for dealing with groups or related special variables. ACCESSOR is defined as a macro: (defmacro ACCESSOR (VARS &rest BODY)). Each element of VARS will be bound to the current (dynamic) value of the special variable. BINDER is defined as a macro for introducing (and binding new) special variables. It is basically a readable LET form with the prorpe declarations appended to the body. The first argument to BINDER must be a form suitable as the first argument to LET. ACCESSOR defaults to a new symbol in the same package as NAME which is the concatenation of \"WITH-\" NAME. BINDER is built as \"BIND-\" and BINDER* is BINDER \"*\"." (unless accessor (setf accessor (format-symbol (symbol-package name) "~A-~A" '#:with name))) (unless binder (setf binder (format-symbol (symbol-package name) "~A-~A" '#:bind name))) (unless binder* (setf binder* (format-symbol (symbol-package binder) "~A~A" binder '#:*))) `(eval-when (:compile-toplevel :load-toplevel :execute) (flet () (defmacro ,binder (requested-vars &body body) (check-required ',name ',vars (mapcar #'car requested-vars)) `(let ,requested-vars (declare (special ,@(mapcar #'car requested-vars))) ,@body)) (defmacro ,binder* (requested-vars &body body) (check-required ',name ',vars (mapcar #'car requested-vars)) `(let* ,requested-vars (declare (special ,@(mapcar #'car requested-vars))) ,@body)) (defmacro ,accessor (requested-vars &body body) (check-required ',name ',vars requested-vars) `(locally (declare (special ,@requested-vars)) ,@body)) ',name))) ;; Copyright (c) 2002-2006, Edward Marco Baringer ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions are ;; met: ;; ;; - Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; ;; - Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; ;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names ;; of its contributors may be used to endorse or promote products ;; derived from this software without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE fiveam-1.4.3/t/000077500000000000000000000000001462573605400132455ustar00rootroot00000000000000fiveam-1.4.3/t/example.lisp000066400000000000000000000063511462573605400155760ustar00rootroot00000000000000;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- ;;;; * FiveAM Example (poor man's tutorial) (asdf:oos 'asdf:load-op :fiveam) (defpackage :it.bese.fiveam.example (:use :common-lisp :it.bese.fiveam)) (in-package :it.bese.fiveam.example) ;;;; First we need some functions to test. (defun add-2 (n) (+ n 2)) (defun add-4 (n) (+ n 4)) ;;;; Now we need to create a test which makes sure that add-2 and add-4 ;;;; work as specified. ;;;; we create a test named ADD-2 and supply a short description. (test add-2 "Test the ADD-2 function" ;; a short description ;; the checks (is (= 2 (add-2 0))) (is (= 0 (add-2 -2)))) ;;;; we can already run add-2. This will return the list of test ;;;; results, it should be a list of two test-passed objects. (run 'add-2) ;;;; since we'd like to have some kind of readbale output we'll explain ;;;; the results (explain! (run 'add-2)) ;;;; or we could do both at once: (run! 'add-2) ;;;; So now we've defined and run a single test. Since we plan on ;;;; having more than one test and we'd like to run them together let's ;;;; create a simple test suite. (def-suite example-suite :description "The example test suite.") ;;;; we could explictly specify that every test we create is in the the ;;;; example-suite suite, but it's easier to just change the default ;;;; suite: (in-suite example-suite) ;;;; now we'll create a new test for the add-4 function. (test add-4 (is (= 0 (add-4 -4)))) ;;;; now let's run the test (run! 'add-4) ;;;; we can get the same effect by running the suite: (run! 'example-suite) ;;;; since we'd like both add-2 and add-4 to be in the same suite, let's ;;;; redefine add-2 to be in this suite: (test add-2 "Test the ADD-2 function" (is (= 2 (add-2 0))) (is (= 0 (add-2 -2)))) ;;;; now we can run the suite and we'll see that both add-2 and add-4 ;;;; have been run (we know this since we no get 4 checks as opposed to ;;;; 2 as before. (run! 'example-suite) ;;;; Just for fun let's see what happens when a test fails. Again we'll ;;;; redefine add-2, but add in a third, failing, check: (test add-2 "Test the ADD-2 function" (is (= 2 (add-2 0))) (is (= 0 (add-2 -2))) (is (= 0 (add-2 0)))) ;;;; Finally let's try out the specification based testing. (defun dummy-add (a b) (+ a b)) (defun dummy-strcat (a b) (concatenate 'string a b)) (test dummy-add (for-all ((a (gen-integer)) (b (gen-integer))) ;; assuming we have an "oracle" to compare our function results to ;; we can use it: (is (= (+ a b) (dummy-add a b))) ;; if we don't have an oracle (as in most cases) we just ensure ;; that certain properties hold: (is (= (dummy-add a b) (dummy-add b a))) (is (= a (dummy-add a 0))) (is (= 0 (dummy-add a (- a)))) (is (< a (dummy-add a 1))) (is (= (* 2 a) (dummy-add a a))))) (test dummy-strcat (for-all ((result (gen-string)) (split-point (gen-integer :min 0 :max 10000) (< split-point (length result)))) (is (string= result (dummy-strcat (subseq result 0 split-point) (subseq result split-point)))))) (test random-failure (for-all ((result (gen-integer :min 0 :max 1))) (is (plusp result)) (is (= result 0)))) (run! 'example-suite) fiveam-1.4.3/t/tests.lisp000066400000000000000000000214101462573605400152760ustar00rootroot00000000000000;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Package: FIVEAM; Base: 10; -*- (in-package :it.bese.fiveam) (in-suite* :it.bese.fiveam) (def-suite test-suite :description "Suite for tests which should fail.") (defmacro with-test-results ((results test-name) &body body) `(let ((,results (with-*test-dribble* nil (run ',test-name)))) ,@body)) (def-fixture null-fixture () `(progn ,@(&body))) ;;;; Test the checks (def-test is1 (:suite test-suite) (is (plusp 1)) (is (< 0 1)) (is (not (plusp -1))) (is (not (< 1 0))) (is-true t) (is-false nil)) (def-test is2 (:suite test-suite :fixture null-fixture) (is (plusp 0)) (is (< 0 -1)) (is (not (plusp 1))) (is (not (< 0 1))) (is-true nil) (is-false t)) (def-test is (:profile t) (with-test-results (results is1) (is (= 6 (length results))) (is (every #'test-passed-p results))) (with-test-results (results is2) (is (= 6 (length results))) (is (every #'test-failure-p results)))) (def-test signals/finishes () (signals error (error "an error")) (signals (error "The form ~S is expected to signal an ~S" '(error "an error") 'error) (error "an error")) (finishes (signals error (error "an error")))) (def-test pass () (pass)) (def-test fail1 (:suite test-suite) (fail "This is supposed to fail")) (def-test fail () (with-test-results (results fail1) (is (= 1 (length results))) (is (test-failure-p (first results))))) ;;;; non top level checks (def-test foo-bar () (let ((state 0)) (is (= 0 state)) (is (= 1 (incf state))))) ;;;; Test dependencies (def-test ok (:suite test-suite) (pass)) (def-test not-ok (:suite test-suite) (fail "This is supposed to fail.")) (def-test and1 (:depends-on (and ok not-ok) :suite test-suite) (fail)) (def-test and2 (:depends-on (and ok) :suite test-suite) (pass)) (def-test dep-and () (with-test-results (results and1) (is (= 3 (length results))) ;; we should have one skippedw one failed and one passed (is (some #'test-passed-p results)) (is (some #'test-skipped-p results)) (is (some #'test-failure-p results))) (with-test-results (results and2) (is (= 2 (length results))) (is (every #'test-passed-p results)))) (def-test or1 (:depends-on (or ok not-ok) :suite test-suite) (pass)) (def-test or2 (:depends-on (or not-ok ok) :suite test-suite) (pass)) (def-test dep-or () (with-test-results (results or1) (is (= 2 (length results))) (is (every #'test-passed-p results))) (with-test-results (results or2) (is (= 3 (length results))) (is (= 2 (length (remove-if-not #'test-passed-p results)))))) (def-test not1 (:depends-on (not not-ok) :suite test-suite) (pass)) (def-test not2 (:depends-on (not ok) :suite test-suite) (fail)) (def-test not () (with-test-results (results not1) (is (= 2 (length results))) (is (some #'test-passed-p results)) (is (some #'test-failure-p results))) (with-test-results (results not2) (is (= 2 (length results))) (is (some #'test-passed-p results)) (is (some #'test-skipped-p results)))) (def-test nested-logic (:depends-on (and ok (not not-ok) (not not-ok)) :suite test-suite) (pass)) (def-test dep-nested () (with-test-results (results nested-logic) (is (= 3 (length results))) (is (= 2 (length (remove-if-not #'test-passed-p results)))) (is (= 1 (length (remove-if-not #'test-failure-p results)))))) (def-test circular-0 (:depends-on (and circular-1 circular-2 or1) :suite test-suite) (fail "we depend on a circular dependency, we should not be tested.")) (def-test circular-1 (:depends-on (and circular-2) :suite test-suite) (fail "we have a circular depednency, we should not be tested.")) (def-test circular-2 (:depends-on (and circular-1) :suite test-suite) (fail "we have a circular depednency, we should not be tested.")) (def-test circular () (signals circular-dependency (run 'circular-0)) (signals circular-dependency (run 'circular-1)) (signals circular-dependency (run 'circular-2))) (defun stack-exhaust () (declare (optimize (debug 3) (speed 0) (space 0) (safety 3))) (cons 42 (stack-exhaust))) ;; Disable until we determine on which implementations it's actually safe ;; to exhaust the stack. #| (def-test stack-exhaust (:suite test-suite) (stack-exhaust)) (def-test test-stack-exhaust () (with-test-results (results stack-exhaust) (is (= 1 (length results))) (is (test-failure-p (first results))))) |# (def-suite before-test-suite :description "Suite for before test") (def-test before-0 (:suite before-test-suite) (fail)) (def-test before-1 (:depends-on (:before before-0) :suite before-test-suite) (pass)) (def-suite before-test-suite-2 :description "Suite for before test") (def-test before-2 (:depends-on (:before before-3) :suite before-test-suite-2) (pass)) (def-test before-3 (:suite before-test-suite-2) (pass)) (def-test before () (with-test-results (results before-test-suite) (is (some #'test-skipped-p results))) (with-test-results (results before-test-suite-2) (is (every #'test-passed-p results)))) ;;;; dependencies with symbol (def-test dep-with-symbol-first (:suite test-suite) (pass)) (def-test dep-with-symbol-dependencies-not-met (:depends-on (not dep-with-symbol-first) :suite test-suite) (fail "Error in the test of the test, this should not ever happen")) (def-test dep-with-symbol-depends-on-ok (:depends-on dep-with-symbol-first :suite test-suite) (pass)) (def-test dep-with-symbol-depends-on-failed-dependency (:depends-on dep-with-symbol-dependencies-not-met :suite test-suite) (fail "No, I should not be tested because I depend on a test that in its turn has a failed dependecy.")) (def-test dependencies-with-symbol () (with-test-results (results dep-with-symbol-first) (is (some #'test-passed-p results))) (with-test-results (results dep-with-symbol-depends-on-ok) (is (some #'test-passed-p results))) (with-test-results (results dep-with-symbol-dependencies-not-met) (is (some #'test-skipped-p results))) ;; No failure here, because it means the test was run. (with-test-results (results dep-with-symbol-depends-on-failed-dependency) (is (not (some #'test-failure-p results))))) ;;;; test for-all (def-test gen-integer () (for-all ((a (gen-integer))) (is (integerp a)))) (def-test for-all-guarded () (for-all ((less (gen-integer)) (more (gen-integer) (< less more))) (is (< less more)))) (def-test gen-float () (macrolet ((test-gen-float (type) `(for-all ((unbounded (gen-float :type ',type)) (bounded (gen-float :type ',type :bound 42))) (is (typep unbounded ',type)) (is (typep bounded ',type)) (is (<= (abs bounded) 42))))) (test-gen-float single-float) (test-gen-float short-float) (test-gen-float double-float) (test-gen-float long-float))) (def-test gen-character () (for-all ((c (gen-character))) (is (characterp c))) (for-all ((c (gen-character :code (gen-integer :min 32 :max 40)))) (is (characterp c)) (member c (list #\Space #\! #\" #\# #\$ #\% #\& #\' #\()))) (def-test gen-string () (for-all ((s (gen-string))) (is (stringp s))) (for-all ((s (gen-string :length (gen-integer :min 0 :max 2)))) (is (<= (length s) 2))) (for-all ((s (gen-string :elements (gen-character :code (gen-integer :min 0 :max 0)) :length (constantly 2)))) (is (= 2 (length s))) (is (every (curry #'char= #\Null) s)))) (def-test for-all* () (for-all* ((a (gen-integer)) (b (gen-integer :min a :max (+ a 10)))) (is (<= a b)))) (defun dummy-mv-generator () (lambda () (list 1 1))) (def-test for-all-destructuring-bind () (for-all (((a b) (dummy-mv-generator))) (is (= 1 a)) (is (= 1 b)))) (defun dummy-mv-generator* (val) (lambda () (list val (1+ val)))) (def-test for-all*-destructuring-bind () (for-all* (((a b) (dummy-mv-generator* 1)) ((c d) (dummy-mv-generator* (1+ b)))) (is (= 1 a)) (is (= 2 b)) (is (= 3 c)) (is (= 4 d)))) (def-test return-values () "Return values indicate test failures." (is-true (with-*test-dribble* nil (explain! (run 'is1)))) (is-true (with-*test-dribble* nil (run! 'is1))) (is-false (with-*test-dribble* nil (explain! (run 'is2)))) (is-false (with-*test-dribble* nil (run! 'is2)))) (def-test dont-discard-suite () (let ((*suite* (make-suite 'nil)) (*toplevel-suites* nil)) (def-suite* :one-test-suite) (def-suite* :two-test-suite) (is (= 2 (length *toplevel-suites*))))) fiveam-1.4.3/test.lisp000066400000000000000000000060741462573605400146610ustar00rootroot00000000000000(defpackage testing (:use common-lisp)) (in-package :testing) #+clisp (if (ext:getenv "GITHUB_ACTION") (require :asdf "/usr/local/share/common-lisp/asdf/asdf") (require :asdf)) #-clisp (require :asdf) (declaim (optimize (speed 3) (space 3) (safety 3))) (asdf:load-system "asdf") (asdf:initialize-source-registry '(:source-registry (:tree :here) :inherit-configuration)) ;;; try to find quicklisp (if (uiop:find-package* '#:ql nil) (format t "~&Quicklisp pre-loaded into image.~%") (let ((ql-filename (uiop:getenv "QUICKLISP_SETUP")) loaded) (if ql-filename (if (probe-file ql-filename) (let ((result (load ql-filename :if-does-not-exist nil))) (when result (format t "~&Have loaded quicklisp setup file ~a.~%" ql-filename) (setf loaded t))) (format t "Quicklisp not installed where expected: ~a~%" ql-filename))) (unless loaded (let* ((fallback-name "/root/quicklisp/setup.lisp") (result (load fallback-name :if-does-not-exist nil))) (when result (format t "~&Have loaded quicklisp setup file from /root.~%") (setf loaded t)))) (unless loaded (format t "~&Unable to find quicklisp.~%") (uiop:quit 1 t)))) (ql:quickload "alexandria") (ql:quickload "trivial-backtrace") (ql:quickload "net.didierverna.asdf-flv") (defun leave-lisp (message return) (fresh-line *error-output*) (when message (format *error-output* message) (terpri *error-output*)) (finish-output *error-output*) (finish-output *standard-output*) (uiop:quit return)) (defmacro quit-on-error (&body body) `(call-quitting-on-error (lambda () ,@body))) (defun call-quitting-on-error (thunk) "Unless the environment variable DEBUG_ASDF_TEST is bound, write a message and exit on an error. If *asdf-test-debug* is true, enter the debugger." (flet ((quit (c desc) (format *error-output* "~&Encountered ~a during test.~%~a~%" desc c) (cond ;; decline to handle the error. ((ignore-errors (funcall (find-symbol "GETENV" :asdf) "DEBUG_ASDF_TEST")) (format t "~&Interactive mode (DEBUG_ASDF_TEST) -- Invoke debugger.~%") (invoke-debugger c)) (t (finish-output *standard-output*) (finish-output *trace-output*) (format *error-output* "~&ABORTING:~% ~S~%" c) (uiop:print-condition-backtrace c) (format *error-output* "~&ABORTING:~% ~S~%" c) (finish-output *error-output*) (leave-lisp "~&Script failed~%" 1))))) (handler-bind ((error (lambda (c) (quit c "ERROR"))) (storage-condition (lambda (c) (quit c "STORAGE-CONDITION"))) (serious-condition (lambda (c) (quit c "Other SERIOUS-CONDIITON")))) (funcall thunk) (format t "~&Script succeeded~%") t))) (quit-on-error (format t "~&;;; Testing standard FiveAM.~%") (asdf:test-system "fiveam")) (uiop:quit 0) fiveam-1.4.3/version.sexp000066400000000000000000000000301462573605400153610ustar00rootroot00000000000000;; -*- lisp -*- "1.4.3"