#!//bin/sh
# \
exec tclsh "$0" ${1+"$@"}

### ===========================================================================
### -program  : simpletest
# -version    : 0.2
# -purpose    : Simple Library regression testing tool.
# -overview   :
#     simpletest checks whether a test package exist for each of the packages
#  to be tested.  For each of those, the package is tested and its test
#  results are displayed together with per-test-case information as directed
#  by the -v flag.  Finally, the statistics of all tested packages and
#  test-case results are displayed. 
#
#     simpletest is based on the testing framework provided by the SimpleTest
#  package, and does not require other Simple Library packages so as to keep
#  the number of dependences to a minimum in order to have a testing
#  environment as robust as possible. 
#
#     simpletest can be used for testing packages other than those of the
#  Simple Library provided that the package test-cases are exposed when
#  requiring the package named package-test where package is the name of the
#  package to test.  Check Simple Library file structure to see how the Simple
#  Library accomplishes this.
#
# -usage      : simpletest [-v verbosity] [-w width] [-c criteria]
#                  (-all | package [package ...])
#
# -keywords   : regression test package
# -examples   :
#  * To test all packages:
#    simpletest -all
#
#  * To test the foo and bar packages displaying the result of all test-cases:
#    simpletest -v 2 foo bar
#
#  * To test foo package test-cases numbers 1 to 20 and 22 in a 132 columns
#    display:
#    simpletest -w 132 -c 1-20,22 foo
#
# -requires   :
#  Tcl 8.0, SimpleTest 0.2
#
# -history    :
#  19-feb-1999   Unreleased first version 0.1
#  23-apr-2000   First public release, version 0.2
#
# -copyright  :
#  Copyright (C) 1999, 2000, Juan C. Gil (jgil@gmv.es)
#
### ===========================================================================

### Program name and version
set ::SIMPLE(ProgramName) simpletest
set ::SIMPLE(ProgramVersion) 0.2

### Require and install the required packages
package require SimplePackage
::Simple::Package::require-and-install SimpleTest

### ===========================================================================
### -procedure: soft-line
# -purpose    : Displays a soft line.
#
proc soft-line {
} {
   puts [string-repeat - $::TERM_WIDTH]
}

### ===========================================================================
### -procedure: hard-line
# -purpose    : Displays a hard line.
#
proc hard-line {
} {
   puts [string-repeat = $::TERM_WIDTH]
}

### ===========================================================================
### -procedure: puts-justified
# -purpose    : Displays a padded message.
# -overview   :
#     If A<-right> is given, the message is displayed right justified to the
#  terminal width; otherwise the message is displayed left justified and no
#  carriage return is added.
#
# -arguments  :
#  { message          -string        {Message}}
#  {?extraWidth?      -int     0     {Extra width}}
#
proc puts-justified {
   arg1
   {arg2 {}}
} {
   # Protection against ::LINE_LENGTH undefined
   if {![info exists ::LINE_LENGTH]} {
      set ::LINE_LENGTH 0
   }

   # A<-right> not given
   if {[string compare $arg1 -right]} {

      # Display the message left justified
      puts -nonewline $arg1

      # Do not advance to the newx lie but keep this
      # line length in the LINE_LENGTH global variable
      incr ::LINE_LENGTH [string length $arg1]

   # A<-right> given
   } else {

      puts [format "%[expr {$::TERM_WIDTH - $::LINE_LENGTH}]s" $arg2]

      # New line
      set ::LINE_LENGTH 0
   }
}

### ===========================================================================
### -procedure: string-repeat
# -purpose    : Returns a string repeated a number of times.
# -arguments  :
#  { string           -string        {String to repeat}}
#  { times            -int           {Times to repeat}}
#
# -returns    : The string repeated the given number of times.
#
proc string-repeat {
   string
   times
} {
   # fixme: Tcl 8.3 has [string repeat]
   set nHalf [expr {$times / 2}]
   set isOdd [expr {$times % 2}]
   if {$nHalf} {
      set stringHalf [string-repeat $string $nHalf]
      if {$isOdd} {
         append stringHalf $stringHalf$string
      } else {
         append stringHalf $stringHalf
      }
   } else {
      if {$isOdd} {
         set string
      }
   }
}

### ===========================================================================
### -procedure: priv-format-title
# -purpose    : Formats a test case title.
# -arguments  :
#  { tag              -string        {Test case tag}}
#  { major            -string        {Test case major title}}
#  { minor            -string        {Test case minor title}}
#
# -returns    : The formatted test case title.
#
proc priv-format-title {
   tag
   major
   minor
} {
   # Major and minor title lenghts
   set majorLength [string length $major]
   set minorLength [string length $minor]

   # The major and minor titles do not fit in a single line
   # 33 columns are lost:
   #    At the left 24: 4 for test case number and 20 for the test-case tag
   #    At the right 9 for the test result
   if {$majorLength + $minorLength > [expr {$::TERM_WIDTH - 33}]} {

      # Format the major title in a line and the minor in another
      format %-20s%s%*s $tag $major\n [expr {$::TERM_WIDTH - 9}] $minor

   # The major and minor titles do fit in a single line
   } else {

      # Format the major and minor title in a single line
      format %-20s%s%*s $tag $major\
         [expr {$::TERM_WIDTH - 33 - $majorLength}] $minor
   }
}

### ===========================================================================
### -procedure: format-title
# -purpose    : Formats a test case title.
# -overview   :
#     This procedure formats a test case title.  For one line titles (major
#  title only), no formatting is done.  For two line titles (major plus minor
#  title), the returned test case title is made of majopr plus the minor right
#  justified.  In this case, if the major title matches that of the previous
#  formatted test case, it is substituted in the output by a pair of inverted
#  commas (").
#
# -arguments  :
#  { tag              -string        {Test case tag}}
#  { title            -string        {Test case title}}
#
# -returns    : The formatted test case title.
#
proc format-title {
   tag
   title
} {
   ### Split title in lines
   #   Third and following lines are ignored
   set lines [split $title \n]
   set major [string trim [lindex $lines 0]]
   set minor [string trim [lindex $lines 1]]

   ### First line does not match previous
   if {[string compare $major $::OLD_MAJOR_TITLE]} {

      ### Use major title
      set formattedTitle [priv-format-title $tag $major $minor]

   ### First line matches previous
   } else {
      
      ### Do not use major title
      set formattedTitle [priv-format-title $tag {  "} $minor]
   }

   ### Save the major title
   set ::OLD_MAJOR_TITLE $major

   ### Return the formatted test-case title
   set formattedTitle
}

### ===========================================================================
### -procedure: incr-but-keep-empty
# -purpose    : Increments a variable value but empties it if zero.
# -overview   :
#     This procedure is similar to the K<incr> command but works for
#  non-existing and empty variablesa also.  In case the incremented value is
#  zero, the variable is emptied.  In case the increment is empty, the
#  variable is untouched.
#
# -arguments  :
#  { numberName       -name          {Number name}}
#  {?increment?       -int 1         {Increment}}
#
# -effects    :
#  * Modifies the variable named A<numberName> in the calling scope.
#
proc incr-but-keep-empty {
   numberName
   {increment 1}
} {
   upvar $numberName number
   if {![info exists number] || ![string compare $number {}]} {
      set number $increment
   } elseif {[string compare $increment {}]} {
      incr number $increment
   }
   if {$number == 0} {
      set number {}
   }
}

### ===========================================================================
### -procedure: die
# -purpose    : Displays an error message and exits.
#
# -arguments  :
#  { message          -string        {Error message}}
#
# -effects    :
#  * Finishes the program execution.
#
proc die {
   message
} {
   puts stderr $message
   exit 1
}

### ===========================================================================
### -procedure: test-package
# -purpose    : Tests a Simple library package.
# -overview   :
#     This procedure initialises the test environment, tests the package,
#  displays the package test results and shutdowns the test environment.
#
# -arguments  :
#  { package          -string        {Package name}}
#  { verbosity        -int           {Test verbosity}}
#  { testCriteria     -string        {Criteria for test cases to be tested}}
#
proc test-package {
   package
   verbosity
   testCriteria
} {
   ### Initialise the test environment
   ::Simple::Test::initialise
   ::Simple::Test::Priv::test-eval {package require SimplePackage}

   ### Display header
   puts-justified [format %-23s $package]
   incr-but-keep-empty ::N_PACKAGES

   ### The package exists
   set line 0
   if {[lsearch -exact [package names] $package] != -1} {

      ### Load the package to test into the test environment
      if {[catch {::Simple::Test::Priv::test-eval\
         [list ::Simple::Package::require $package]} result]} {

         die [format {error requiring package "%s": %s} $package $result]
      }

      ### If not already installed, install it
      if {[string compare [::Simple::Test::Priv::test-eval\
         [list ::Simple::Package::information state $package]] installed]} {
         
         if {[catch {::Simple::Test::Priv::test-eval\
            [list ::Simple::Package::install $package]} result]} {

            die [format {error installing package "%s": %s} $package $result]
         }
      }

      ### A test module exists for the package
      if {[lsearch -exact [package names] $package-test] != -1} {

         ### Set the criteria for test cases to be tested
         ::Simple::Test::set-test-criteria $testCriteria

         ### Test the package

         ### Error during testing
         if {[catch {set version [package require $package-test]} result]} {

            ### Issue error
            puts-justified "error during testing: $result"
            puts-justified -right {SKIPPED }
            incr-but-keep-empty ::N_PACKAGES_ERROR

         ### Testing completed successfully
         } else {

            ### Get and display statistics
            foreach {nTests nTestsPassed nTestsFailed nTestsSkipped\
               nTestsIgnored} [::Simple::Test::statistics] break
            incr-but-keep-empty nTests        0
            incr-but-keep-empty nTestsPassed  0
            incr-but-keep-empty nTestsFailed  0
            incr-but-keep-empty nTestsSkipped 0
            incr-but-keep-empty nTestsIgnored 0
            puts-justified [format {%7s%9s%8s%8s%8s%8s} $version\
               $nTests $nTestsPassed $nTestsFailed $nTestsSkipped\
               $nTestsIgnored]

            ### Update global statistics
            incr-but-keep-empty ::N_TESTS         $nTests
            incr-but-keep-empty ::N_TESTS_PASSED  $nTestsPassed
            incr-but-keep-empty ::N_TESTS_FAILED  $nTestsFailed
            incr-but-keep-empty ::N_TESTS_SKIPPED $nTestsSkipped
            incr-but-keep-empty ::N_TESTS_IGNORED $nTestsIgnored

            ### Not all tests passed or ignored
            if {[string compare $nTestsFailed {}] ||\
               [string compare $nTestsSkipped {}]} {

               puts-justified -right {FAILED }
               incr-but-keep-empty ::N_PACKAGES_FAILED
               set line 1

            ### All tests passed or ignored
            } else {
               puts-justified -right {PASSED }
               incr-but-keep-empty ::N_PACKAGES_PASSED
            }
         }

         ### Display the package test results
         if {$verbosity >= 0} {
            set previousPassed 1
            foreach test [::Simple::Test::results] {
               foreach {number tag title ignored skipped passed diagnostics}\
                  $test break

               if {!$ignored} {
                  if {!$passed || ($verbosity >= 1 && !$previousPassed)} {
                     soft-line
                  }
                  if {!$passed || $verbosity >= 1} {
                     if {$passed} {
                        set passedMessage passed
                     } else {
                        if {$skipped} {
                           set passedMessage skipped
                        } else {
                           set passedMessage failed
                        }
                     }
                     set formattedTitle [format-title $tag $title]

                     # For verbosity == 1, only display those test results
                     # whoe title does not contain {  " }, i.e., contain a
                     # major title
                     if {!$passed || $verbosity == 2 ||\
                        ![string match {*  \" *} $formattedTitle]} {

                        puts [format {%3d %-*s%8s} $number\
                           [expr {$::TERM_WIDTH - 13}]\
                           $formattedTitle $passedMessage]
                     }
                  }
                  if {!$passed} {
                     puts -nonewline $diagnostics
                  }
                  set previousPassed $passed
               }
            }
         }

      ### A test module does not exist for the package
      } else {

         puts-justified {test module not found}
         puts-justified -right {SKIPPED }
         incr-but-keep-empty ::N_PACKAGES_ERROR
      }

   ### The package does not exist
   } else {

      puts-justified {package not found}
      puts-justified -right {SKIPPED }
      incr-but-keep-empty ::N_PACKAGES_ERROR
   }

   ### Display footer
   if {$verbosity >= 1} {
      hard-line
   } elseif {$verbosity == 0 && $line} {
      soft-line
   }

   ### Shutdown the test environment
   ::Simple::Test::shutdown
}

### ===========================================================================
### -procedure: program-version
# -purpose    : Displays the program version message and exists.
#
proc program-version {
} {
   puts stderr "$::SIMPLE(ProgramName) $::SIMPLE(ProgramVersion)"
   exit -1
}

### ===========================================================================
### -procedure: program-usage
# -purpose    : Displays the program short usage message and exists.
#
proc program-usage {
} {
   puts stderr [format {Usage: %s [-v verbosity] [-w width] [-c criteria]}\
      $::SIMPLE(ProgramName)]
   puts stderr {     (-all | package [package ...])}
   puts stderr {Simple Library regression testing tool.}
   puts stderr {     -v verbosity: sets the verbosity level}
   puts stderr {        -1: no individual tests are displayed}
   puts stderr {         0: failed tests are displayed (default)}
   puts stderr {         1: test with distinct major titles are displayed}
   puts stderr {         2: all tests are displayed}
   puts stderr {     -w width: changes the width of the output (default 80)}
   puts stderr\
      {     -c criteria: provides a criteria of which test cases to test}
   exit -1
}

### ===========================================================================
### -procedure: main
# -purpose    : Main program.
#
# -todo       :
#  * Update the command line arguments handling when the required package is
#    available.
#
proc main {
} {
   ### Initialise the global variables
   set ::N_TESTS           {}
   set ::N_TESTS_PASSED    {}
   set ::N_TESTS_FAILED    {}
   set ::N_TESTS_SKIPPED   {}
   set ::N_TESTS_IGNORED   {}
   set ::N_PACKAGES        {}
   set ::N_PACKAGES_PASSED {}
   set ::N_PACKAGES_FAILED {}
   set ::N_PACKAGES_ERROR  {}
   set ::OLD_MAJOR_TITLE   {}
   set ::TERM_WIDTH        80

   ### Parse command line arguments
   set verbosity 0
   set testCriteria {}
   set all 0
   set nArgument 0
   set nArguments [llength $::argv]
   while {$nArgument < $nArguments} {
      set argument [lindex $::argv $nArgument]
      switch -glob -- $argument {
         --version {
            program-version
         }
         -v {
            set verbosity [lindex $::argv [incr nArgument]]
         }
         -w {
            set ::TERM_WIDTH [lindex $::argv [incr nArgument]]
            if {$::TERM_WIDTH < 80} {
               set ::TERM_WIDTH 80
            }
         }
         -c {
            set testCriteria [lindex $::argv [incr nArgument]]
         }
         -all {
            set all 1
         }
         -* {
            puts stderr [format {unrecognized option "%s"} $argument]
            program-usage
         }
         default {
            break
         }
      }
      incr nArgument
   }
   set packages [lrange $::argv $nArgument end]

   ### No packages given
   if {([llength $packages] == 0) && !$all} {

      ### Display the program usage message
      program-usage
   }

   ### Display header
   set user {}
   if {![string compare $::tcl_platform(platform) unix]} {
      catch {set user [exec whoami]}
      if {![string compare $user {}]} {
         catch {regexp {^[^(]*\(([^)]*)\)} [exec id] tmp user}
      }
   }
   if {![string compare $user {}]} {

      # Assume root
      set user root
   }
   puts "Testing session run by $user@[info hostname] at\
      [clock format [clock seconds] -format {%R %d-%b-%Y}]"
   puts "   using $::SIMPLE(ProgramName) $::SIMPLE(ProgramVersion) and\
      Tcl [info patchlevel] ([info nameofexecutable])"
   if {[string compare $testCriteria {}]} {
      puts "Testing test case(s) numbers $testCriteria"
   }
   hard-line

   puts [format {%-23s%7s%9s%8s%8s%8s%8s}\
      {Package name} version total passed failed skipped ignored]
   hard-line

   ### -all not given
   if {!$all} {

      ### Foreach package in the list
      foreach package $packages {

         ### Test the package
         test-package $package $verbosity $testCriteria
      }

   ### -all given
   } else {

      ### Foreach known package
      foreach package [package names] {

         ### A test module exists for this package
         if {[regsub -- (^.*)-test$ $package \\1 package_to_test]} {

            ### Test the package
            test-package $package_to_test $verbosity $testCriteria
         }
      }
   }

   ### Display footer
   if {$verbosity < 1} {
      hard-line
   }
   puts [format {%39s%8s%8s%8s%8s} total passed failed skipped ignored]
   puts [format {%-31s%8s%8s%8s%8s%8s} {Test cases statistics}\
      $::N_TESTS $::N_TESTS_PASSED $::N_TESTS_FAILED $::N_TESTS_SKIPPED\
      $::N_TESTS_IGNORED]

   puts-justified [format {%-31s%8s%8s%8s%8s   } {Package statistics}\
      $::N_PACKAGES $::N_PACKAGES_PASSED $::N_PACKAGES_FAILED\
      $::N_PACKAGES_ERROR]
   if {$::N_PACKAGES == $::N_PACKAGES_PASSED} {
      puts-justified -right {PASSED }
   } else {
      puts-justified -right {FAILED }
   }
}

### ===========================================================================

# Run the main procedure
main
