Source File testing/testing.ils

    1 ;;; testing.ils --- Lightweight testing framework
    2 
    3 ;; Copyright (C) 2012-2013  Damien Diederen
    4 
    5 ;; @author Damien Diederen <dd@crosstwine.com>
    6 
    7 ;; All Rights Reserved.
    8 ;;
    9 ;; NOTICE: All information, intellectual and technical concepts
   10 ;; contained herein are, and remain the property of Damien Diederen
   11 ;; and his suppliers, if any.  Dissemination of this information or
   12 ;; reproduction of this material is strictly forbidden unless prior
   13 ;; written permission is obtained from Damien Diederen.
   14 
   15 ;;; Commentary:
   16 
   17 ;; Package testing (global prefix VedaTesting) provides support for
   18 ;; automated testing of SKILL(++) packages.  It is a port of the Go
   19 ;; testing framework (http://golang.org/src/pkg/testing/testing.go)
   20 ;; as provided by go1.0.2.
   21 ;;
   22 ;; It is intended to select and automate the execution of any method
   23 ;; of the form
   24 ;;
   25 ;;     (defmethod Test_Xxx ((context VedaTestingContext)) ...)
   26 ;;
   27 ;; where Xxx can be any alphanumeric string (but the first letter must
   28 ;; not be in [a-z]) and serves to identify the test routine.  These
   29 ;; Test_Xxx routines should be declared within the package they are
   30 ;; testing, in files ending in -test.il or -test.ils.
   31 ;;
   32 ;; This package does not yet implement the BenchmarkXxx or
   33 ;; Example{F,T,T_M} features of the Go testing package.
   34 
   35 ;;; Code:
   36 
   37 ;; Context instances are passed to Test methods to manage test state
   38 ;; and support test logs.  Logs are accumulated during execution and
   39 ;; dumped to a file or standard output depending on configuration
   40 ;; options.
   41 (defclass VedaTestingContext ()
   42   ((name        @initarg  name        @reader GetName)
   43    (packagePath @initarg  packagePath @reader GetPackagePath)
   44    (output      @initform nil         @reader GetOutput   @writer SetOutput)
   45    (failed      @initform nil         @reader GetFailed   @writer SetFailed)
   46    (start       @initform nil         @reader GetStart    @writer SetStart)
   47    (duration    @initform nil         @reader GetDuration @writer SetDuration)))
   48 
   49 ;; Note: A number of symbols below are excluded from the API
   50 ;; documentation because they are just imported from package via
   51 ;; source merging for bootstrapping purposes.
   52 
   53 ;; Class AbstractInfo holds information that is common to all
   54 ;; packages, independently of their underlying representation.
   55 ;;
   56 ;; @ignore Cf. "bootstrapping" note above.
   57 (defclass VedaTestingPackageAbstractInfo ()
   58   (;; The name of the package, as understood by the Info/Load
   59    ;; functions.
   60    (name
   61     @initarg name
   62     @reader GetName)
   63    ;; The package's synopsis.
   64    (description
   65     @initarg description
   66     @reader GetDescription)
   67    ;; A (possibly empty) list of package authors strings, each having
   68    ;; the following form (cf. name-addr production in RFC 5322):
   69    ;;
   70    ;;     Human-readable Name <email@example.com>
   71    (authors
   72     @initarg authors
   73     @reader GetAuthors)))
   74 
   75 ;; Class FilesystemInfo describes filesystem-based packages as
   76 ;; "natively" implemented by this package.
   77 ;;
   78 ;; @ignore Cf. "bootstrapping" note above.
   79 (defclass VedaTestingPackageFilesystemInfo (VedaTestingPackageAbstractInfo)
   80   (;; The directory of the search path in which the package was found,
   81    ;; a /-terminated string.
   82    (base
   83     @initarg base
   84     @reader GetBaseDir)
   85    ;; The titular file containing package information.
   86    (header
   87     @initarg header
   88     @reader GetHeaderFilename)
   89    ;; A list of other packages required by this package.  The contents
   90    ;; of this field can be controlled via the @requires tag, e.g.:
   91    ;;
   92    ;;     ;; @requires bar, baz
   93    (requires
   94     @initarg requires
   95     @reader GetPackageRequires)
   96    ;; The package's source files, in load order.
   97    ;;
   98    ;; The contents of this field can be controlled via the @load tag,
   99    ;; e.g.:
  100    ;;
  101    ;;     ;; @load foo.il, bar.ils
  102    ;;
  103    ;; or
  104    ;;
  105    ;;     ;; @load foo.il, bar.ils, ...
  106    ;;
  107    ;; where the ellipsis means that any other source file founds in
  108    ;; the package's directory are to be loaded after foo.il and
  109    ;; bar.ils (in an undefined order).
  110    (sources
  111     @initarg sources
  112     @reader GetSourceFilenames)
  113    ;; Package test files, in load order.
  114    (tests
  115     @initarg tests
  116     @reader GetTestFilenames)))
  117 
  118 ;; printObject formats unreadable FilesystemInfo instances for
  119 ;; diagnostic purposes.
  120 ;;
  121 ;; @ignore Cf. "bootstrapping" note above.
  122 (defmethod printObject ((pi VedaTestingPackageFilesystemInfo)
  123                         @optional (port poport))
  124   (fprintf port "#<%s %L; base: %L>"
  125            (className (classOf pi)) pi->name pi->base))
  126 
  127 ;; Class SearchOptions holds options that are used for locating
  128 ;; packages; cf. PackageLoad and PackageInfo.
  129 ;;
  130 ;; @ignore Cf. "bootstrapping" note above.
  131 (defclass VedaTestingPackageSearchOptions ()
  132   (;; The list of /-terminated directories which are searched (in
  133    ;; order) for packages.  Non-anchored directories are relative to
  134    ;; the execution directory.
  135    ;;
  136    ;; Defaults to searching pkg/ then ../.
  137    (searchPath
  138     @initarg searchPath
  139     @initform '("pkg/" "../")
  140     @reader GetSearchPath
  141     @writer SetSearchPath)))
  142 
  143 ;; Class LoadOptions holds options that are used when loading
  144 ;; packages; cf. PackageLoad.
  145 ;;
  146 ;; @ignore Cf. "bootstrapping" note above.
  147 (defclass VedaTestingPackageLoadOptions (VedaTestingPackageSearchOptions)
  148   (;; When t, honor the package's @requires tag.  Otherwise, a
  149    ;; (possibly) empty list of packages which are to be required
  150    ;; before the target.
  151    ;;
  152    ;; Defaults to t.
  153    (requires
  154     @initarg requires
  155     @initform t
  156     @reader GetRequires
  157     @writer SetRequires)
  158    ;; When t, reset the table of loaded packages before loading the
  159    ;; target.  Otherwise, a (possibly) empty list of package names to
  160    ;; be evicted from the table of loaded packages before loading the
  161    ;; target.
  162    ;;
  163    ;; Defaults to nil.
  164    (forceReload
  165     @initarg forceReload
  166     @initform nil
  167     @reader GetForceReload
  168     @writer SetForceReload)))
  169 
  170 ;; Scope/hide utility functions and related data.
  171 (let ()
  172   ;; Export exports function fn as a global symbol with the
  173   ;; VedaTesting prefix.
  174   (defun Export (suffix fn)
  175     (putd (concat 'VedaTesting suffix) fn))
  176 
  177   ;; Fail marks the function as having failed but continues execution.
  178   (defmethod VedaTestingFail ((context VedaTestingContext))
  179     (SetFailed context t))
  180 
  181   ;; FailNow marks the function as having failed and stops its execution.
  182   ;; Execution will continue at the next test or benchmark.
  183   (defmethod VedaTestingFailNow ((context VedaTestingContext))
  184     (VedaTestingFail context)
  185     (err nil))
  186 
  187   ;; Log appends lines of output to the current context.
  188   (defun Log (context s)
  189     (let ((lines (parseString s "\n"))
  190           (output (GetOutput context)))
  191       (foreach line lines
  192         (push line output))
  193       (SetOutput context output)))
  194 
  195   ;; Format works around the fact that sprintf in SKILL is not a
  196   ;; function, and cannot be applied to a list of arguments.  The
  197   ;; workaround is ugly and expensive, involving dynamic code
  198   ;; generation and a call to eval.
  199   (defun Format (format @rest args)
  200     (cond
  201       ;; Any hope to use this alternative printer?
  202       ((isCallable 'XtsSprintf)
  203        (apply XtsSprintf format args))
  204       (t
  205        (let ((code (nconc (list 'sprintf nil format)
  206                           (foreach mapcar arg args
  207                             (list 'quote arg)))))
  208          (eval code)))))
  209 
  210   ;; Log formats its arguments using default formatting, and records
  211   ;; the text in the error log.
  212   (defmethod VedaTestingLog ((context VedaTestingContext) @rest args)
  213     (let ((pieces nil))
  214       (foreach arg args
  215         (when pieces
  216           (push " " pieces))
  217         (cond
  218           ((stringp arg)
  219            (push arg pieces))
  220           (t
  221            (push (sprintf nil "%L" arg) pieces))))
  222       (Log context (buildString (reverse pieces) ""))))
  223 
  224   ;; Logf formats its arguments according to the format, analogous to
  225   ;; printf, and records the text in the error log.
  226   (defmethod VedaTestingLogf ((context VedaTestingContext) format @rest args)
  227     (Log context (apply Format format args)))
  228 
  229   ;; Error is equivalent to (Log) followed by (Fail).
  230   (defmethod VedaTestingError ((context VedaTestingContext) @rest args)
  231     (apply VedaTestingLog context args)
  232     (VedaTestingFail context))
  233 
  234   ;; Errorf is equivalent to (Logf) followed by (Fail).
  235   (defmethod VedaTestingErrorf ((context VedaTestingContext) format @rest args)
  236     (apply VedaTestingLogf context format args)
  237     (VedaTestingFail context))
  238 
  239   ;; Fatal is equivalent to (Log) followed by (FailNow).
  240   (defmethod VedaTestingFatal ((context VedaTestingContext) @rest args)
  241     (apply VedaTestingLog context args)
  242     (VedaTestingFailNow context))
  243 
  244   ;; Fatalf is equivalent to (Logf) followed by (FailNow).
  245   (defmethod VedaTestingFatalf ((context VedaTestingContext) format @rest args)
  246     (apply VedaTestingLogf context format args)
  247     (VedaTestingFailNow context))
  248 
  249   ;; Internal test runner method.
  250   (defun TRunner (context f traceOnErrorP)
  251     (SetStart context (getCurrentTime))
  252     (let ((r (errset (funcall f context) traceOnErrorP)))
  253       (unless r
  254         (SetFailed context t)))
  255     (SetDuration context
  256                  (compareTime (GetStart context)
  257                               (getCurrentTime))))
  258 
  259   ;; BuildOutput generates indented output text for report formatting.
  260   (defun BuildOutput (context)
  261     (if (GetOutput context)
  262         (strcat "\t" (buildString (reverse (GetOutput context)) "\n\t") "\n")
  263         ""))
  264 
  265   ;; A TextReporter dumps lightly-formatted test status information to
  266   ;; standard output.
  267   (defun TextReporter (options)
  268     (lambda (event @rest args)
  269       (case event
  270         (startTest
  271          (let ((context (car args)))
  272            (when options->chattyp
  273              (printf "=== RUN %s\n" (GetName context)))))
  274         (endTest
  275          (let ((context (car args)))
  276            (when (or (GetFailed context) options->chattyp)
  277              (let ((tstr (if (plusp (GetDuration context))
  278                              (sprintf nil " (%d seconds)"
  279                                       (GetDuration context))
  280                              ""))
  281                    (head (if (GetFailed context) "FAIL" "PASS"))
  282                    (format "--- %s: %s%s\n%s"))
  283                (printf format head (GetName context)
  284                        tstr (BuildOutput context)))))))))
  285 
  286   (defun GenTimestamp ()
  287     ;; TODO: Use getCurrentTime, and convert to ISO!
  288     "2012-09-25T18:48:46")
  289 
  290   ;; Characters which must be escaped in XML, no matter what.
  291   (define xmlMustEscapes
  292       '(("&" "&amp;")
  293         ("<" "&lt;")))
  294 
  295   ;; Characters which must be escaped in XML when outputting '-quoted
  296   ;; attribute values.
  297   (define xmlAposEscapes
  298       (append
  299        '(("'" "&apos"))
  300        xmlMustEscapes))
  301 
  302   ;; XmlEscape escapes a string with a specific alist of replacements.
  303   (defun XmlEscape (string escapes)
  304     (cond
  305       ((exists entry escapes
  306          (nindex string (car entry)))
  307        (letseq ((parts (parseString string ""))
  308                 (safe (foreach mapcar part parts
  309                         (let ((it (assoc part escapes)))
  310                           (if it (cadr it) part)))))
  311          (buildString safe "")))
  312       (t
  313        string)))
  314 
  315   ;; XmlEscaper returns a function which accepts one string arguments,
  316   ;; and will XmlEscape that string with the passed-in alist of
  317   ;; replacements.
  318   (defun XmlEscaper (escapes)
  319     (lambda (string)
  320       (XmlEscape string escapes)))
  321 
  322   ;; WriteXml writes a mostly-JUnit-compatible XML testing report to a
  323   ;; stream.  It also takes a list of contexts, and the corresponding
  324   ;; package name (or nil if unknown) as arguments.
  325   (defun WriteXml (stream contexts pkg)
  326     (let ((EA (XmlEscaper xmlAposEscapes))
  327           (EB (XmlEscaper xmlMustEscapes))
  328           (pkg (or pkg "<None>"))
  329           (timestamp (GenTimestamp))
  330           (testCount 0)
  331           (failureCount 0)
  332           (totalTime 0)
  333           (otherOutputs nil))
  334       (foreach context contexts
  335         (setq testCount (testCount + 1))
  336         (when (GetFailed context)
  337           (setq failureCount (failureCount + 1)))
  338         (setq totalTime (totalTime + (GetDuration context))))
  339       (fprintf stream "<?xml version='1.0' encoding='ISO-8859-1'?>\n")
  340       (fprintf stream "<testsuites>\n")
  341       (fprintf stream "  <testsuite package='%s' id='0' name='Unknown'\n"
  342                (EA pkg))
  343       (fprintf stream "             timestamp='%s' hostname='localhost'\n"
  344                (EA timestamp))
  345       (fprintf stream "             tests='%d' failures='%d' errors='0'\n"
  346                testCount failureCount)
  347       (fprintf stream "             time='%d'>\n"
  348                totalTime)
  349       (fprintf stream "    <properties/>\n")
  350       (foreach context contexts
  351         (fprintf stream "    <testcase name='%s' classname='t' time='%d'>\n"
  352                  (EA (GetName context))
  353                  (GetDuration context))
  354         (let ((lines (reverse (GetOutput context))))
  355           (cond
  356             ((GetFailed context)
  357              (let ((messageMea (when lines
  358                                  (sprintf nil " message='%s'"
  359                                           (EA (car lines))))))
  360                (fprintf stream "      <failure type='Fail'%s>"
  361                         messageMea)
  362                (foreach line lines
  363                  (fprintf stream "%s\n" (EB line)))
  364                (fprintf stream "</failure>\n")))
  365             (t
  366              (push lines otherOutputs))))
  367         (fprintf stream "    </testcase>\n"))
  368       (cond
  369         ((null otherOutputs)
  370          (fprintf stream "    <system-out/>\n"))
  371         (t
  372          (fprintf stream "    <system-out>")
  373          (foreach lines (reverse otherOutputs)
  374            (foreach line lines
  375              (fprintf stream "%s\n" (EB line))))
  376          (fprintf stream "</system-out>\n")))
  377       (fprintf stream "    <system-err/>\n")
  378       (fprintf stream "  </testsuite>\n")
  379       (fprintf stream "</testsuites>\n")))
  380 
  381   ;; XmlReporter returns a function which reports test events to a
  382   ;; file in XML format.
  383   (defun XmlReporter (options)
  384     (let ((filename (or options->reportFilename
  385                         "./result.xml"))
  386           (contexts nil))
  387       (lambda (event @rest args)
  388         (case event
  389           (startTest
  390            (let ((context (car args)))
  391              (when options->chattyp
  392                (printf "=== RUN %s\n" (GetName context)))))
  393           (endTest
  394            (let ((context (car args)))
  395              (push context contexts)))
  396           (endTestsuite
  397            (when contexts
  398              (let ((stream (or (outfile filename)
  399                                (error "Cannot open %L for writing." filename))))
  400                (WriteXml stream (reverse contexts) options->package)
  401                (close stream))))))))
  402 
  403   ;; FinalizeOptions processes the passed-in options (if any),
  404   ;; creating the corresponding test result reporter function.
  405   (defun FinalizeOptions (options)
  406     (let ((newOptions (if options (copy options) (list nil))))
  407       (newOptions->report = (case options->reportFormat
  408                               ((nil text) (TextReporter options))
  409                               (xml        (XmlReporter options))
  410                               ;; KLUDGE: This report format is to
  411                               ;; disappear and be replaced by output
  412                               ;; redirection at some point.
  413                               (void       (lambda (@rest _args)))
  414                               (t (error "Unsupported report format %L"
  415                                         options->reportFormat))))
  416       newOptions))
  417 
  418   ;; RunTests runs the test functions in tests, a list of funcallable
  419   ;; symbols, and generates reports according to the provided options.
  420   (defun RunTests (tests @key options)
  421     (let ((options (FinalizeOptions options))
  422           (ok tests))
  423       (let ((report options->report)
  424             (traceOnErrorP (neq options->reportFormat 'void)))
  425         (funcall report 'startTestsuite)
  426         (foreach test tests
  427           (letseq ((name (strcat test))
  428                    (context (makeInstance 'VedaTestingContext
  429                                           ?name name
  430                                           ?packagePath options->packagePath)))
  431             (funcall report 'startTest context)
  432             (TRunner context test traceOnErrorP)
  433             (funcall report 'endTest context)
  434             (setq ok (and ok (not (GetFailed context))))))
  435         (funcall report 'endTestsuite ok))
  436       ok))
  437 
  438   (Export 'RunTests RunTests)
  439 
  440   ;; FindTestMethods looks into the global environment callable
  441   ;; symbols starting with the Test_ prefix.
  442   (defun FindTestMethods ()
  443     (let ((syms (rexMatchList "^Test_" oblist)))
  444       (setof sym syms
  445         (and (isCallable sym)
  446              ;; TODO: Ensure that the callable is indeed a
  447              ;; one-argument method specializing on VedaTestingContext.
  448              t))))
  449 
  450   ;; MaskExistingTests records the currently defined Test_ functions
  451   ;; in a hash table, and (temporarily) removes their definitions.
  452   (defun MaskExistingTests ()
  453     (let ((pre (makeTable 'pre nil))
  454           (old (FindTestMethods)))
  455       (foreach sym old
  456         (setarray pre sym (getd sym))
  457         (putd sym nil))
  458       pre))
  459 
  460   ;; RestoreAndFindNewTests finds the current set of Test_ functions,
  461   ;; and restores the ones which have been previously recorded and
  462   ;; haven't been redefined.
  463   (defun RestoreAndFindNewTests (pre)
  464     (let ((now (FindTestMethods)))
  465       (foreach sym now
  466         (remove sym pre))
  467       (foreach sym pre
  468         ;; Restore original value.
  469         (putd sym (arrayref pre sym)))
  470       now))
  471 
  472   ;; LoadTestsUsingLoader loads test files via a loader function while
  473   ;; monitoring the set of defined test methods, and returns the
  474   ;; symbols naming newly-defined ones.  Cf. RunTestsFromFiles for
  475   ;; details.
  476   ;;
  477   ;; TODO: The current implementation is not as restrictive as it
  478   ;; should, and might erroneously match/return unrelated Test_
  479   ;; functions.
  480   (defun LoadTestsUsingLoader (loader)
  481     (let ((pre (MaskExistingTests)))
  482       (funcall loader ?subset 'tests)
  483       (RestoreAndFindNewTests pre)))
  484 
  485   ;; RunTestsFromFiles loads files in-order while monitoring the set
  486   ;; of methods having the form
  487   ;;
  488   ;;     (defmethod Test_Xxx ((context VedaTestingContext)) ...)
  489   ;;
  490   ;; then executes the newly-defined/redefined ones.
  491   (defun RunTestsFromFiles (files @key options)
  492     (let ((tests (LoadTestsUsingLoader (FilesLoader files))))
  493       (RunTests tests ?options options)))
  494 
  495   (Export 'RunTestsFromFiles RunTestsFromFiles)
  496 
  497   ;; Default options used by Load/Info, if not overriden by ?options.
  498   (define defaultOptions
  499       (makeInstance 'VedaTestingPackageLoadOptions))
  500 
  501   ;; FilesLoader returns a function which loads the provided list of
  502   ;; filenames in order.  If ?dir is non-nil, it is prepended to each
  503   ;; file before attempting the load operation.
  504   (defun FilesLoader (filenames @key dir)
  505     (lambda (@rest _ignored)
  506       (foreach filename filenames
  507         (when dir
  508           (setq filename (strcat dir filename)))
  509         (load filename))
  510       t))
  511 
  512   ;; Trim returns a substring of string, with all characters in
  513   ;; characterBag stripped off the beginning, or off the end if
  514   ;; ?fromEndP is true.
  515   ;;
  516   ;; If no characters need to be trimmed, string is returned.
  517   (defun Trim (characterBag string @key fromEndP)
  518     (let ((a 1)
  519           (n (strlen string)))
  520       (let ((b n)
  521             (i (if fromEndP n a)))
  522         (while (and (a <= b)
  523                     (nindex characterBag (getchar string i)))
  524           (setq i (if fromEndP
  525                       (setq b (b - 1))
  526                       (setq a (a + 1)))))
  527         (cond
  528           ((and (onep a) (equal b n))
  529            string)
  530           (t
  531            (substring string a (b - a + 1)))))))
  532 
  533   ;; Prefix characters which are ignored at the beginning of line
  534   ;; comment headers.
  535   (define lineCommentTrimBag
  536       "; \t")
  537 
  538   ;; Prefix characters which are ignored at the beginning of block
  539   ;; comment headers.
  540   (define blockCommentTrimBag
  541       "* \t")
  542 
  543   ;; ParseDescriptionLine parses a package's description line, which
  544   ;; is the first line in the package's titular file and has one of
  545   ;; the following formats:
  546   ;;
  547   ;;     ;;; <filename> --- <description>
  548   ;;
  549   ;;     /* <filename> --- <description>
  550   ;;
  551   ;; If the line does not match one of the required syntaxes, this
  552   ;; function returns nil.  Otherwise, it returns a list of two
  553   ;; elements: a string of characters to be trimmed on subsequent
  554   ;; lines, and the description.
  555   (defun ParseDescriptionLine (line filename)
  556     ;; FIXME: Should preserve tabs and multiple spaces.
  557     (letseq ((pieces (parseString line " \t\n"))
  558              (bag (cond
  559                     ((equal (car pieces) ";;;") lineCommentTrimBag)
  560                     ((equal (car pieces) "/*")  blockCommentTrimBag))))
  561       (when (and bag
  562                  (equal (cadr pieces) filename)
  563                  (equal (caddr pieces) "---"))
  564         (list bag (buildString (nthcdr 3 pieces))))))
  565 
  566   ;; PrefixP returns the length of needle if it is a prefix of
  567   ;; haystack, nil otherwise.
  568   (defun PrefixP (needle haystack)
  569     (let ((n (strlen needle)))
  570       (when (n <= (strlen haystack))
  571         (let ((i 1))
  572           (while (and i (i <= n))
  573             (setq i (when (eq (getchar needle i) (getchar haystack i))
  574                       (i + 1))))
  575           i))))
  576 
  577   ;; SuffixP returns the index of the last character before needle in
  578   ;; haystack when the former is a suffix of the latter.  Otherwise,
  579   ;; returns nil.
  580   (defun SuffixP (needle haystack)
  581     (let ((n (strlen needle))
  582           (m (strlen haystack)))
  583       (when (n <= m)
  584         (let ((i 1)
  585               (offset (m - n)))
  586           (while (and i (i <= n))
  587             (setq i (when (eq (getchar needle i)
  588                               (getchar haystack (offset + i)))
  589                       (i + 1))))
  590           (when i
  591             offset)))))
  592 
  593   ;; Tries and trim a specific mark, which may preceded by any number
  594   ;; of the characters in trimBag, at the beginning of line.  Returns
  595   ;; the remainder of line if successful, and nil otherwise.
  596   (defun TrimMark (trimBag line mark)
  597     (letseq ((trimmed (Trim trimBag line))
  598              (i (PrefixP mark trimmed)))
  599       (when i
  600         (substring trimmed i))))
  601 
  602   ;; ParseHeader tries and parses the comment header of the file
  603   ;; located at path, and whose base name is filename.  It either
  604   ;; returns a DPL to be interpreted by PackageInfoFromBase, or nil if
  605   ;; the file was either unreadable or could not be parsed as a
  606   ;; package descriptor.
  607   (defun ParseHeader (path filename)
  608     (let ((port (infile path)))
  609       (when port
  610         (let ((info (list nil 'header filename))
  611               (authors nil)
  612               (line nil)
  613               (desc nil)
  614               (it nil)
  615               (donep nil))
  616           (while (and (not donep) (gets line port))
  617             (cond
  618               ((equal line "\n")
  619                ;; Continue.
  620                )
  621               ((not (or desc (setq desc (ParseDescriptionLine line filename))))
  622                (setq info nil)
  623                (setq donep nil))
  624               ;; TODO: Understand RFC-2822-style continuation lines.
  625               ((setq it (TrimMark (car desc) line "@load"))
  626                (info->load = (parseString it ", \t\n")))
  627               ((setq it (TrimMark (car desc) line "@requires"))
  628                (info->requires = (parseString it ", \t\n")))
  629               ((setq it (TrimMark (car desc) line "@author"))
  630                (letseq ((s1 (Trim " \t\n" it))
  631                         (s2 (Trim " \t\n" s1 ?fromEndP t)))
  632                  (push s2 authors)))
  633               ;; These key-looking subtitles mark the (premature) end
  634               ;; of parsed header.
  635               ((or (TrimMark (car desc) line "Commentary:")
  636                    (TrimMark (car desc) line "Code:")
  637                    (when (eq (car desc) blockCommentTrimBag)
  638                      (nindex line "*/")))
  639                (setq donep t))))
  640           (close port)
  641           (when info
  642             (info->description = (cadr desc))
  643             (info->authors = (reverse authors))
  644             info)))))
  645 
  646   ;; The ellipsis marker is used at the end of Load directives to
  647   ;; indicate that the other source files ought to be loaded, too.
  648   (define ellipsis
  649       "...")
  650 
  651   ;; ProcessLoadDirective checks that each entry in directive is also
  652   ;; present in files or is a trailing ellipsis.  Returns a list of
  653   ;; three values: the files from directive, whether a trailing
  654   ;; ellipsis was present, and the rest of the files.
  655   (defun ProcessLoadDirective (directive files)
  656     (let ((files (copy files))
  657           (ellipsisp nil))
  658       (let ((loads (foreach maplist dtail directive
  659                      (let ((file (car dtail)))
  660                        (cond
  661                          ((let ((ftail (member file files)))
  662                             (when ftail
  663                               (rplaca ftail nil)
  664                               file)))
  665                          ((and (equal file ellipsis)
  666                                (null (cdr dtail)))
  667                           (setq ellipsisp t)
  668                           nil)
  669                          (t
  670                           (error "No such file: %L; Load header: %L"
  671                                  file directive)))))))
  672         (list (remove nil loads) ellipsisp (remove nil files)))))
  673 
  674   ;; ClassifyFiles saves the files which match one of the subsets in a
  675   ;; correspondingly-named slot of a fresh DPL (Cf. fileSubsets
  676   ;; variable for an example of subset designators), and returns the
  677   ;; DPL.
  678   (defun ClassifyFiles (files subsets)
  679     (let ((dpl (list nil)))
  680       (foreach file files
  681         (exists subset subsets
  682           (let ((suffixes (car subset)))
  683             (exists suffix suffixes
  684               (when (SuffixP suffix file)
  685                 (letseq ((key (cadr subset))
  686                          (accum (get dpl key)))
  687                   (putprop dpl (cons file accum) key)))))))
  688       dpl))
  689 
  690   ;; fileSubsets holds subset designators for test and source files.
  691   (define fileSubsets
  692       '(;; Files ending with these two suffixes are test files.
  693         (("-test.ils" "-test.il") tests)
  694         ;; Files ending in .ils or .il and which are not considered
  695         ;; test files are source files.
  696         ((".ils" ".il")           sources)))
  697 
  698   ;; Helper function for PackageInfoFromBase.
  699   (defun FinalizePackageInfo (base pkg headerInfo loads ellipsisp files)
  700     (letseq ((filesInfo (ClassifyFiles files fileSubsets))
  701              (sources (cond
  702                         ((and loads ellipsisp)
  703                          (append loads filesInfo->sources))
  704                         (loads)
  705                         (t
  706                          filesInfo->sources))))
  707       (makeInstance 'VedaTestingPackageFilesystemInfo
  708                     ?name pkg
  709                     ?description headerInfo->description
  710                     ?authors headerInfo->authors
  711                     ?base base
  712                     ?header headerInfo->header
  713                     ?requires headerInfo->requires
  714                     ?sources sources
  715                     ?tests filesInfo->tests)))
  716 
  717   ;; PackageInfoFromBase returns file-based information about package
  718   ;; pkg (contained below base, and for which some header info has
  719   ;; been found).  It combines the header and file-gathered data into
  720   ;; a fresh instance of VedaPackageFilesystemInfo.
  721   (defun PackageInfoFromBase (base pkg headerInfo)
  722     (letseq ((dir (strcat base pkg "/"))
  723              (files (getDirFiles dir)))
  724       (apply FinalizePackageInfo base pkg headerInfo
  725              (if headerInfo->load
  726                  (ProcessLoadDirective headerInfo->load files)
  727                  (list nil t files)))))
  728 
  729   ;; PackageInfoFromFilesystem tries and find package pkg under one of
  730   ;; the bases, which are filesystem directory names.  It returns a
  731   ;; fresh instance of VedaPackageFilesystemInfo if found, nil
  732   ;; otherwise.
  733   ;;
  734   ;; Cf. PackageInfoFromBase for more information.
  735   (defun PackageInfoFromFilesystem (pkg bases)
  736     (let (info)
  737       (exists base bases
  738         (let ((dir (strcat base pkg)))
  739           (exists suffix '(".il" ".ils")
  740             (letseq ((filename (strcat pkg suffix))
  741                      (path (strcat dir "/" filename))
  742                      (headerInfo (ParseHeader path filename)))
  743               (when headerInfo
  744                 (setq info (PackageInfoFromBase base pkg headerInfo)))))))
  745       info))
  746 
  747   ;; PackageInfo returns metadata about the package named by the
  748   ;; string pkg, either by querying a hook or by searching a number of
  749   ;; preset filesystem bases.
  750   ;;
  751   ;; It returns a concrete subclass of AbstractInfo, or nil if not
  752   ;; found.
  753   ;;
  754   ;; ?options, if non-nil, must be an instance of SearchOptions. If
  755   ;; nil, a default-initialized instance is used.
  756   ;;
  757   ;; The hook, if present, must be named VedaPackageInfoHook and is
  758   ;; invoked as:
  759   ;;
  760   ;;     (VedaPackageInfoHook pkg)
  761   ;;
  762   ;; where pkg is the package name.
  763   ;;
  764   ;; @ignore Cf. "bootstrapping" note above.
  765   (defun PackageInfo (pkg @key options)
  766     (cond
  767       ((isCallable 'VedaPackageInfoHook)
  768        (funcall 'VedaPackageInfoHook pkg))
  769       (t
  770        (let ((options (or options defaultOptions)))
  771          (PackageInfoFromFilesystem pkg (GetSearchPath options))))))
  772 
  773   (Export 'PackageInfo PackageInfo)
  774 
  775   ;; LoaderFromPackageInfo returns a function which will load a
  776   ;; specific subset of the package described by info, an instance of
  777   ;; VedaPackageFilesystemInfo.
  778   (defun LoaderFromPackageInfo (info subset)
  779     (let (files)
  780       (when (setq files (get info subset))
  781         (let ((dir (strcat info->base info->name "/")))
  782           (FilesLoader files ?dir dir)))))
  783 
  784   ;; LoadSubsetFromPackageInfo loads a specific subset of the package
  785   ;; described by info, an instance of VedaPackageFilesystemInfo.
  786   (defun LoadSubsetFromPackageInfo (info subset)
  787     (let ((loader (LoaderFromPackageInfo info subset)))
  788       (if loader
  789           (funcall loader ?subset subset)
  790           (error "Don't know how to load %s from package %L."
  791                  subset info)))
  792     t)
  793 
  794   ;; Recursive helper for RequirePackage.
  795   (defun RequirePackageRec (pkg loaded options noPackageRequiresP)
  796     (let (info)
  797       (cond
  798         ((arrayref loaded pkg))
  799         ((setq info (PackageInfo pkg ?options options))
  800          (unless noPackageRequiresP
  801            (foreach require info->requires
  802              (RequirePackageRec require loaded options noPackageRequiresP)))
  803          (LoadSubsetFromPackageInfo info 'sources)
  804          (setarray loaded pkg info))
  805         (t
  806          (error "Package %L not found." pkg)))))
  807 
  808   ;; RequirePackage loads the sources from pkg if and only if it is
  809   ;; not already indexed in the loaded table.  Each package mentioned
  810   ;; in options->requires is "RequirePackage'd" before this one, as is
  811   ;; any package mentioned in @requires--unless inhibited by the
  812   ;; noPackageRequiresP option.
  813   (defun RequirePackage (pkg loaded options)
  814     (letseq ((requires (GetRequires options))
  815              (noPackageRequiresP (neq requires t)))
  816       (when (pairp requires)
  817         (foreach require requires
  818           (RequirePackageRec require loaded options noPackageRequiresP)))
  819       (RequirePackageRec pkg loaded options noPackageRequiresP)))
  820 
  821   ;; BootstrapPackageInfo tries and determine package information from
  822   ;; filename.  This is used for bootstrapping purposes only;
  823   ;; cf. defaultLoadedTable.
  824   (defun BootstrapPackageInfo (filename)
  825     (let ((n (strlen filename))
  826           (suffix (rindex filename "/")))
  827       (cond
  828         (suffix
  829          (let ((slen (strlen suffix)))
  830            (let ((pkg (substring suffix 2 (slen - 5)))
  831                  (dir (strcat (substring filename 1 (n - slen + 1)) "../")))
  832              (PackageInfoFromFilesystem pkg (list dir)))))
  833         (t
  834          (let ((pkg (substring filename 1 (n - 4))))
  835            (PackageInfoFromFilesystem pkg '("../")))))))
  836 
  837   ;; The table of loaded packages.  Note how we try and mark the
  838   ;; package this file was loaded from as preloaded, which is only
  839   ;; correct for single-file packages.
  840   (define defaultLoadedTable
  841       (let ((loaded (makeTable 'loaded nil))
  842             (thisFilename (get_filename piport)))
  843         (when (and thisFilename (SuffixP ".ils" thisFilename))
  844           (let ((info (BootstrapPackageInfo thisFilename)))
  845             (when info
  846               (setarray loaded (GetName info) info))))
  847         loaded))
  848 
  849   ;; PackageLoad loads the sources of the package named by the string
  850   ;; pkg, as well as its dependencies, as necessary or requested via
  851   ;; the ?options argument.
  852   ;;
  853   ;; ?options, if non-nil, must be an instance of LoadOptions.  If
  854   ;; nil, a default-initialized instance is used.
  855   ;;
  856   ;; The PackageInfo function is used for locating the package and its
  857   ;; dependencies, using the same ?options argument as PackageLoad.
  858   ;; An error is raised if one of the packages cannot be found.
  859   ;;
  860   ;; The function returns the concrete subclass of AbstractInfo
  861   ;; corresponding to pkg.
  862   ;;
  863   ;; @ignore Cf. "bootstrapping" note above.
  864   (defun PackageLoad (pkg @key options)
  865     (letseq ((options (or options defaultOptions))
  866              (forceReload (GetForceReload options)))
  867       (cond
  868         ((eq forceReload t)
  869          (setq defaultLoadedTable (makeTable 'loaded nil)))
  870         ((pairp forceReload)
  871          (foreach pkg forceReload
  872            (remove pkg defaultLoadedTable))))
  873       (RequirePackage pkg defaultLoadedTable options)))
  874 
  875   (Export 'PackageLoad PackageLoad)
  876 
  877   ;; Create a copy of the default loaded table with the packages in
  878   ;; preloaded (which must be PackageInfo'able) considered loaded.
  879   (defun MakeLoadedTable (preloaded)
  880     (let ((table (makeTable 'loaded nil)))
  881       (foreach key defaultLoadedTable
  882         (setarray table key (arrayref defaultLoadedTable key)))
  883       (foreach pkg preloaded
  884         (unless (arrayref table pkg)
  885           (let ((info (or (PackageInfo pkg)
  886                           (error "Cannot mark %L as preloaded." pkg))))
  887             (setarray table pkg info))))
  888       table))
  889 
  890   ;; RunTestsOnPackage finds the set of source and test files
  891   ;; associated with package pkg, reloads all the source files, then
  892   ;; loads and runs all the tests contained in the test files.
  893   (defun RunTestsOnPackage (pkg @key options)
  894     (letseq ((loaded (MakeLoadedTable options->_preloaded))
  895              (info (RequirePackage pkg loaded defaultOptions))
  896              (pkgPath (when info->base
  897                         (list info->base)))
  898              (testOptions (constar (car options)
  899                                    'package pkg
  900                                    'packagePath pkgPath
  901                                    (cdr options)))
  902              (loader (LoaderFromPackageInfo info 'tests))
  903              (tests (when loader
  904                       (LoadTestsUsingLoader loader))))
  905       (RunTests tests ?options testOptions)))
  906 
  907   (Export 'RunTestsOnPackage RunTestsOnPackage))
  908 
  909 ;;; testing.ils ends here