rehearsal

#!/bin/sh
# vim: set filetype=tcl : \
exec expect -f "$0" -- ${1+"$@"}

package require Tcl 8.5

# term definitions
#
# test case:
#     test execution unit which is ok or not ok.
#     corresponds to a heading in source file.
#
# step:
#     command invocation inside a test case.
#     A test case can include multiple steps.
#
# test suite:
#     a bundle of multiple test cases.
#     corresponds to a single source file.

namespace eval testcase {
    # operations for 'testcase' dict type

    proc new {} {
        return [dict create desc "" steps [list] input [list] output [list]]
    }

    proc set_desc {test_var desc} {
        upvar $test_var test
        dict set test desc $heading
    }

    proc append_input {test_var line} {
        upvar $test_var test
        dict lappend test input $line
    }

    proc append_output {test_var line} {
        upvar $test_var test
        dict lappend test output -ex $line
    }

    proc append_snip {test_var} {
        upvar $test_var test
        dict lappend test output snip {}
    }

    proc carry_step {test_var} {
        upvar $test_var test

        if {[llength [dict get $test input]] > 0} {
            dict lappend test steps \
                [dict get $test input] \
                [dict get $test output]
            dict set test input [list]
            dict set test output [list]
        }
    }

    proc carry {tests_var test_var} {
        upvar $tests_var tests
        upvar $test_var test

        if {[llength [dict get $test steps]] > 0} {
            lappend tests $test
            dict set test steps [list]
        }
    }
}

namespace eval markdown {
    # markdown parser

    proc parse {channel ps1 ps2} {
        set state [list md_default $ps1 $ps2]
        set prev ""
        set tests [list]
        set test [testcase::new]
        while {![eof $channel]} {
            gets $channel line
            debug "state: $state, line: $line"
            set state [{*}$state $line]
            set prev $line
        }
        testcase::carry tests test
        debug "tests: $tests"
        return $tests
    }

    proc md_default {ps1 ps2 line} {
        upvar tests tests
        upvar test test

        if {[regexp {^#{1,6}\s*(.*)#{0,6}\s*$} $line match heading]} {
            testcase::carry tests test
            dict set test desc $heading
            return [list md_default $ps1 $ps2]
        } elseif {[string match "`````*" $line]} {
            return [list md_in_fence_ps1 5 $ps1 $ps2]
        } elseif {[string match "````*" $line]} {
            return [list md_in_fence_ps1 4 $ps1 $ps2]
        } elseif {[string match "```*" $line]} {
            return [list md_in_fence_ps1 3 $ps1 $ps2]
        } elseif {[regexp {^    (.*)} $line match line]} {
            if {[regexp "^${ps1}(.*)\$" $line match line]} {
                testcase::append_input test $line
                return [list md_indent_ps2 $ps1 $ps2]
            } else {
                return [list md_indent_skip $ps1 $ps2]
            }
        } else {
            return [list md_default $ps1 $ps2]
        }
    }

    proc md_in_fence_ps1 {num_ticks ps1 ps2 line} {
        upvar tests tests
        upvar test test

        set ticks [string repeat "`" $num_ticks]
        if {$line == $ticks} {
            testcase::carry_step test
            return [list md_default $ps1 $ps2]
        } elseif {[regexp "^${ps1}(.*)\$" $line match line]} {
            testcase::append_input test $line
            return [list md_in_fence_ps2 $num_ticks $ps1 $ps2]
        } else {
            return [list md_in_fence_skip $num_ticks $ps1 $ps2]
        }
    }

    proc md_in_fence_ps2 {num_ticks ps1 ps2 line} {
        global snip
        upvar tests tests
        upvar test test

        set ticks [string repeat "`" $num_ticks]
        if {$line == $ticks} {
            testcase::carry_step test
            return [list md_default $ps1 $ps2]
        } elseif {[regexp "^${ps2}(.*)\$" $line match line]} {
            testcase::append_input test $line
            return [list md_in_fence_ps2 $num_ticks $ps1 $ps2]
        } elseif {[regexp "^${ps1}(.*)\$" $line match line]} {
            testcase::carry_step test
            testcase::append_input test $line
            return [list md_in_fence_ps2 $num_ticks $ps1 $ps2]
        } elseif {$line == $snip} {
            testcase::append_snip test
            return [list md_in_fence_output $num_ticks $ps1 $ps2]
        } else {
            testcase::append_output test $line
            return [list md_in_fence_output $num_ticks $ps1 $ps2]
        }
    }

    proc md_in_fence_output {num_ticks ps1 ps2 line} {
        global snip
        upvar tests tests
        upvar test test

        set ticks [string repeat "`" $num_ticks]
        if {$line == $ticks} {
            testcase::carry_step test
            return [list md_default $ps1 $ps2]
        } elseif {[regexp "^${ps1}(.*)\$" $line match line]} {
            testcase::carry_step test
            testcase::append_input test $line
            return [list md_in_fence_ps2 $num_ticks $ps1 $ps2]
        } elseif {$line == $snip} {
            testcase::append_snip test
            return [list md_in_fence_output $num_ticks $ps1 $ps2]
        } else {
            testcase::append_output test $line
            return [list md_in_fence_output $num_ticks $ps1 $ps2]
        }
    }

    proc md_in_fence_skip {num_ticks ps1 ps2 line} {
        upvar tests tests
        upvar test test

        set ticks [string repeat "`" $num_ticks]
        if {$line == $ticks} {
            return [list md_default $ps1 $ps2]
        } else {
            return [list md_in_fence_skip $num_ticks $ps1 $ps2]
        }
    }

    proc md_indent_ps2 {ps1 ps2 line} {
        global snip
        upvar tests tests
        upvar test test

        if {[regexp {^    (.*)} $line match line]} {
            if {[regexp "^${ps2}(.*)\$" $line match line]} {
                testcase::append_input test $line
                return [list md_indent_ps2 $ps1 $ps2]
            } elseif {[regexp "^${ps1}(.*)\$" $line match line]} {
                testcase::carry_step test
                testcase::append_input test $line
                return [list md_indent_ps2 $ps1 $ps2]
            } elseif {$line == $snip} {
                testcase::append_snip test
                return [list md_indent_output $ps1 $ps2]
            } else {
                testcase::append_output test $line
                return [list md_indent_output $ps1 $ps2]
            }
        } else {
            testcase::carry_step test
            return [md_default $ps1 $ps2 $line]
        }
    }

    proc md_indent_output {ps1 ps2 line} {
        global snip
        upvar tests tests
        upvar test test

        if {[regexp {^    (.*)} $line match line]} {
            if {[regexp "^${ps1}(.*)\$" $line match line]} {
                testcase::carry_step test
                testcase::append_input test $line
                return [list md_indent_ps2 $ps1 $ps2]
            } elseif {$line == $snip} {
                testcase::append_snip test
                return [md_default $ps1 $ps2 $line]
            } else {
                testcase::append_output test $line
                return [list md_indent_output $ps1 $ps2]
            }
        } else {
            testcase::carry_step test
            return [md_default $ps1 $ps2 $line]
        }
    }

    proc md_indent_skip {ps1 ps2 line} {
        upvar tests tests
        upvar test test

        if {[regexp {^    (.*)} $line]} {
            return [list md_indent_skip $ps1 $ps2]
        } else {
            return [md_default $ps1 $ps2 $line]
        }
    }
}

namespace eval testcase_result {
    # num: test case number
    # desc: description of the test
    # result: "ok", "not ok" or "Bail out!"
    # diag: diagnosis of the failure/error
    proc new {num desc result diag} {
        return [dict create num $num desc $desc result $result diag $diag]
    }

    proc num {testcase_result} {
        return [dict get $testcase_result num]
    }

    proc desc {testcase_result} {
        return [dict get $testcase_result desc]
    }

    proc result {testcase_result} {
        return [dict get $testcase_result result]
    }

    proc diag {testcase_result} {
        return [dict get $testcase_result diag]
    }

    proc print_tap {testcase_result} {
        set n      [num    $testcase_result]
        set desc   [desc   $testcase_result]
        set result [result $testcase_result]
        set diag   [diag   $testcase_result]
        puts "$result $n $desc"
        foreach diag_line $diag {
            puts "# $diag_line"
        }
    }
}

proc shift {var n} {
    upvar $var list
    set list [lrange $list $n end]
}

proc debug {msg} {
    global debug
    if {$debug} {
        puts "# debug: $msg"
    }
}

proc expect_prompt {} {
    uplevel 1 {
        global ps1
        global anchor
        if {$anchor} {
            set re "(^|\\n)$ps1"
        } else {
            set re $ps1
        }
        expect -re $re {
        } timeout {
            expect -re .*
            error "timeout: prompt /${re}/ expected but got <$expect_out(buffer)>"
        }
        regexp "^(.*)${re}\$" $expect_out(buffer) match before_prompt
        return $before_prompt
    }
}

proc expect_banner {} {
    uplevel 1 {
        global banner
        if {$banner == ""} return
        expect -re $banner {
        } timeout {
            expect -re .*
            error "timeout: banner /${banner}/ expected but got <$expect_out(buffer)>"
        }
    }
}

proc send_lines {} {
    uplevel 1 {
        global ps2
        set cont false
        foreach input_line $input_lines {
            if {$cont} {
                expect $ps2 {} timeout {error "no ps2"}
            }
            debug "sending: $input_line"
            send $input_line
            send "\r"
            # expect no echo back from tty, send to the log instead
            send_log "$input_line\r\n"
            set cont true
        }
    }
}

proc run_test {} {
    uplevel 1 {
        debug "test: $test"
        set desc [dict get $test desc]
        set result "unknown"
        set diag [list]
        set steps [dict get $test steps]
        set state normal
        set actual_output [list]
        foreach {input output} $steps {
            debug "input: $input"
            debug "output: $output"
            set input_lines $input
            send_lines

            set actual_output [expect_prompt]
            regsub -all {\r} $actual_output "" actual_output
            set actual_output [split [string trimright $actual_output "\r\n"] "\n"]

            if {[llength $output] > 0} {
                # peek first two elements, options and line, from output
                lassign $output opts output_line
                shift output 2
                if {$opts == "snip"} {
                    if {[llength $output] > 0} {
                        set state snip
                        lassign $output opts output_line
                        debug "until: $output_line"
                        shift output 2
                    } else {
                        continue
                    }
                } else {
                    set state normal
                }
            } else {
                set state end
            }
            foreach line $actual_output {
                debug "state: $state"
                if {$state == "end"} {
                    lappend diag "expected end but got <$line>"
                    return [list "not ok" $desc "" $diag]
                }
                if {$state == "normal"} {
                    debug "actual_line: <$line>"
                    debug "expected_line: <$output_line>"
                    if {$line == $output_line} {
                        debug "match"
                    } else {
                        debug "unmatch"
                        if {$state != "snip"} {
                            lappend diag "expected: $output_line"
                            lappend diag "actual: $line"
                            return [list "not ok" $desc "" $diag]
                        }
                    }
                } elseif {$state == "snip"} {
                    debug "actual_line: <$line>"
                    debug "expected_line: <$output_line>"
                    if {$line == $output_line} {
                        debug "match"
                    } else {
                        debug "unmatch (snip)"
                        continue
                    }
                }
                # next state
                if {[llength $output] > 0} {
                    # peek first two elements, options and line, from output
                    lassign $output opts output_line
                    shift output 2
                    if {$opts == "snip"} {
                        if {[llength $output] > 0} {
                            set state snip
                            lassign $output opts output_line
                            debug "until: $output_line"
                            shift output 2
                        } else {
                            break
                        }
                    } else {
                        set state normal
                    }
                } else {
                    set state end
                }
            }
            debug "end state: $state"
            if {$state != "end" && $output_line != ""} {
                lappend diag "expected <$output_line> but reached end"
                return [list "not ok" $desc "" $diag]
            }
        }
        return [list "ok" $desc "" $diag]
    }
}

proc run_testcases {testcases} {
    global command_line
    set tests $testcases
    set num_tests [llength $tests]
    if {$num_tests == 0} return

    puts "1..$num_tests"
    set n 0
    set testcase_results [list]
    if {[catch {
            debug "spawning $command_line"
            set stty_init -echo
            spawn {*}$command_line
            expect_banner
            expect_prompt

            foreach test $tests {
                incr n
                debug "running $n"
                lassign [run_test] result desc directive diag
                set testcase_result [testcase_result::new $n $desc $result $diag]
                lappend testcase_results $testcase_result
                testcase_result::print_tap $testcase_result
            }

            send "\004"
            expect eof
        } message]} {
        lappend testcase_results [testcase_result::new $n "?" "Bail out!" [split $message]]
        puts "Bail out!"
        puts $message
    }
    return $testcase_results
}

proc escape_xml {s} {
    return [string map [list "\"" {&quot;} ' {&apos;} < {&lt;} > {&gt;} & {&amp;}] $s]
}

proc write_junit {testsuite_results junit_dir} {
    foreach {source_file testcase_results} $testsuite_results {
        set testsuite_name [join [file split [file rootname $source_file]] .]
        set failures 0
        set errors 0
        foreach testcase_result $testcase_results {
            set result [testcase_result::result $testcase_result]
            if {$result == "not ok"} {
                incr failures
            } elseif {$result == "Bail out!"} {
                incr errors
            }
        }
        set f [open [file join $junit_dir "TEST-${testsuite_name}.xml"] w]
        fconfigure $f -encoding utf-8
        puts $f {<?xml version="1.0" ?>}
        puts $f "<testsuite name='[escape_xml $testsuite_name]'"
        puts $f "    tests='[llength $testcase_results]'"
        puts $f "    failures='$failures'"
        puts $f "    errors='$errors'>"
        foreach testcase_result $testcase_results {
            puts $f "<testcase name='[escape_xml "[testcase_result::num $testcase_result] [testcase_result::desc $testcase_result]"]'>"
            if {[testcase_result::result $testcase_result] == "not ok"} {
                puts -nonewline $f {<failure>}
                foreach line [testcase_result::diag $testcase_result] {
                    puts $f [escape_xml $line]
                }
                puts $f {</failure>}
            } elseif {[testcase_result::result $testcase_result] == "Bail out!"} {
                puts -nonewline $f {<error>}
                foreach line [testcase_result::diag $testcase_result] {
                    puts $f [escape_xml $line]
                }
                puts $f {</error>}
            }
            puts $f {</testcase>}
        }
        puts $f {</testsuite>}
        close $f
    }
}

proc usage {} {
    # $usage will be filled in make process; see Makefile
    set usage {
    }
    puts [string trim $usage]
}

# starting point

# globals
set debug 0
set log_file "" 
set junit_dir ""
set command_line {ksh}
set ps1 {\$ }
set ps2 {> }
set banner ""
set snip "..."
set anchor 0

# parse argv
while {true} {
    lassign $argv first
    if {![string match {-*} $first]} break
    shift argv 1
    if {$first == "--"} {
        break
    } elseif {$first == "-v"} {
        set debug 1
    } elseif {[regexp -- {^--?h(elp)?$} $first]} {
        usage
        exit 0
    } elseif {$first == "-log"} {
        lassign $argv log_file
        shift argv 1
    } elseif {$first == "-junit"} {
        lassign $argv junit_dir
        shift argv 1
    } elseif {$first == "-command"} {
        lassign $argv command_line
        shift argv 1
    } elseif {$first == "-banner"} {
        lassign $argv banner
        shift argv 1
    } elseif {$first == "-ps1"} {
        lassign $argv ps1
        shift argv 1
    } elseif {$first == "-ps2"} {
        lassign $argv ps2
        shift argv 1
    } elseif {$first == "-snip"} {
        lassign $argv snip
        shift argv 1
    } elseif {$first == "-anchor"} {
        set anchor 1
    } elseif {$first == "-timeout"} {
        lassign $argv timeout; # timeout variable of Expect
        shift argv 1
    } else {
        puts "unknown option: $first"
        usage
        exit 1
    }
}

if {[llength $argv] == 0} {
    puts "no input files"
    exit 1
}

log_user 0
if {$log_file != ""} {
    log_file -a $log_file
}

# testsuite_results is a list whose even index is source filename
# and odd index is a list of testcase_results
set testsuite_results [list]
foreach source_file $argv {
    set f [open $source_file]
    if {$ps2 == ""} {
        set testcases [markdown::parse $f $ps1 $ps1]
    } else {
        set testcases [markdown::parse $f $ps1 $ps2]
    }
    close $f
    set testcase_results [run_testcases $testcases]
    lappend testsuite_results $source_file $testcase_results
}

if {$junit_dir != ""} {
    write_junit $testsuite_results $junit_dir
}

set exit_status 0
foreach testcase_result $testcase_results {
    set result [testcase_result::result $testcase_result]
    if {$result != "ok"} {
        set exit_status 1
    }
}
exit $exit_status