tcltest: do a better job of cleanup up after tests

[jimtcl.git] / tests / misc.test

source [file dirname [info script]]/testing.tcl

needs constraint jim
needs cmd gets tclcompat
needs cmd array

catch {unset a b}
test regr-1.1 "Double dereference arrays" {
        array set a {one ONE two TWO three THREE}
        array set b {ONE 1 TWO 2 THREE 3}
        set chan two
        set b($a($chan))
} {2}

# Will assert on exit if the bug exists
test regr-1.2 "Reference count shared literals" {
        proc a {} {
                while {1} {break}
        }
        a
        rename a ""
        return 1
} {1}

test regr-1.3 "Invalid for expression" jim {
        # Crashes with invalid expression
        catch {
                for {set i 0} {$i < n} {incr i} {
                        set a(b) $i
                        set a(c) $i
                        break
                }
        }
} 1

test regr-1.4 "format double percent" {
        format (%d%%) 12
} {(12%)}

test regr-1.5 "lassign with empty list" {
        unset -nocomplain a b c
        lassign {} a b c
        info exists c
} {1}

test io-1.1 "Read last line with no newline" {
        set lines 0
        set f [open [file dirname [info script]]/testio.in]
        while {[gets $f buf] >= 0} {
                incr lines
        }
        close $f
        list $lines
} {2}

set g1 1
set g2 2
array set g3 {4 5 6 7}

proc test_unset {} {
        test unset-1.1 "Simple var" {
                set g4 4
                list [catch {unset g4; info exists g4} msg] $msg
        } {0 0}

        test unset-1.2 "Simple var" {
                list [catch {unset g4; info exists g4} msg] $msg
        } {1 {can't unset "g4": no such variable}}

        test unset-1.3 "Simple var" {
                list [catch {unset g2; info exists g2} msg] $msg
        } {1 {can't unset "g2": no such variable}}

        test unset-1.4 "Global via global" {
                global g1
                list [catch {unset g1; info exists g1} msg] $msg
        } {0 0}

        test unset-1.5 "Global error" {
                list [catch {unset ::g2; info exists ::g2} msg] $msg
        } {0 0}

        test unset-1.6 "Global array" {
                list [catch {unset ::g3; info exists ::g3} msg] $msg
        } {0 0}

        test unset-1.7 "Simple var -nocomplain" {
                list [catch {unset -nocomplain g2; info exists g2} msg] $msg
        } {0 0}

        test unset-1.8 "Simple var --" {
                list [catch {unset -- g2; info exists g2} msg] $msg
        } {1 {can't unset "g2": no such variable}}

        test unset-1.9 "Simple var -nocomplain --" {
                set g2 1
                list [catch {unset -nocomplain -- g2; info exists g2} msg] $msg
        } {0 0}

        test unset-1.10 "Var named -nocomplain with --" {
                set -nocomplain 1
                list [catch {unset -- -nocomplain; info exists -nocomplain} msg] $msg
        } {0 0}

        test unset-1.11 "Unset no args" {
                list [catch {unset} msg] $msg
        } {0 {}}
}

test_unset

test lrepeat-1.1 "Basic tests" {
        lrepeat 1 a
} {a}

test lrepeat-1.2 "Basic tests" {
        lrepeat 1 a b
} {a b}

test lrepeat-1.3 "Basic tests" {
        lrepeat 2 a b
} {a b a b}

test lrepeat-1.4 "Basic tests" {
        lrepeat 2 a
} {a a}

test lrepeat-1.5 "Errors" {
        catch {lrepeat}
} {1}

test lrepeat-1.6 "Errors" {
        lrepeat 1
} {}

test lrepeat-1.7 "Errors" {
        lrepeat 0 a b
} {}

test lrepeat-1.8 "Errors" {
        catch {lrepeat -10 a}
} {1}

test lindex-1.1 "Integer" {
        lindex {a b c} 0
} a

test lindex-1.2 "Integer" {
        lindex {a b c} 2
} c

test lindex-1.3 "Integer" {
        lindex {a b c} -1
} {}

test lindex-1.4 "Integer" {
        lindex {a b c} 4
} {}

test lindex-1.5 "end" {
        lindex {a b c} end
} c

test lindex-1.6 "end" {
        lindex {a b c} end-1
} b

test lindex-1.7 "end" {
        lindex {a b c} end-4
} {}

test lindex-1.8 "end + " {
        lindex {a b c} end+1
} {}

test lindex-1.9 "end + " {
        lindex {a b c} end+-1
} b

test lindex-1.10 "end - errors" {
        catch {lindex {a b c} end-}
} 1

test lindex-1.11 "end - errors" {
        catch {lindex {a b c} end-blah}
} 1

test lindex-1.12 "int+int, int-int" {
        lindex {a b c} 0+4
} {}

test lindex-1.13 "int+int, int-int" {
        lindex {a b c} 3-1
} c

test lindex-1.14 "int+int, int-int" {
        lindex {a b c} 1--1
} c

test lindex-1.15 "int+int, int-int" {
        set l {a b c}
        lindex $l [lsearch $l b]-1
} a

test lindex-1.16 "int+int, int-int" {
        lindex {a b c} 0+1
} b

test lindex-1.17 "int+int - errors" {
        catch {lindex {a b c} 5-blah}
} 1

test lindex-1.18 "int+int - errors" {
        catch {lindex {a b c} blah-2}
} 1

test lindex-1.19 "int+int - errors" {
        catch {lindex {a b c} 5+blah}
} 1

test lindex-1.20 "unary plus" {
        lindex {a b c} +2
} c

test incr-1.1 "incr unset" {
        unset -nocomplain a
        incr a
        set a
} 1

test incr-1.2 "incr, incr unset" {
        incr a
} 2

test incr-1.3 "incr unset array element" {
        unset -nocomplain a
        incr a(2)
        set a(2)
} 1

test incr-1.4 "incr array element - shimmering" {
        set b "$a(2)-test"
        incr a(2)
} 2

test catch-1.1 "catch ok" {
        list [catch {set abc 2} result] $result
} {0 2}

test catch-1.2 "catch error" {
        list [catch {error 3} result] $result
} {1 3}

test catch-1.3 "catch break" {
        list [catch {break} result] $result
} {3 {}}

test catch-1.4 "catch -nobreak" {
        set result {}
        foreach x {a b c} {
                lappend result $x
                # This acts just like break since it won't be caught by catch
                catch -nobreak {break} tmp
        }
        set result
} {a}

test catch-1.5 "catch -no3" {
        set result {}
        foreach x {a b c} {
                lappend result $x
                # Same as above, but specify as an integer
                catch -no3 {break} tmp
        }
        set result
} {a}

test catch-1.6 "catch break" {
        set result {}
        foreach x {a b c} {
                lappend result $x
                # This does nothing since the break is caught
                catch {break} tmp
        }
        set result
} {a b c}


test catch-1.7 "catch exit" {
        # Normally exit would not be caught
        dict get [info returncodes] [catch -exit {exit 5} result]
} {exit}

test catch-1.8 "catch error has -errorinfo" {
        set rc [catch {set undefined} msg opts]
        list $rc [info exists opts(-errorinfo)]
} {1 1}

test catch-1.9 "catch no error has no -errorinfo" {
        set rc [catch {set x 1} msg opts]
        list $rc [info exists opts(-errorinfo)]
} {0 0}

test return-1.1 "return can rethrow an error" {
        proc a {} { error "from a" }
        proc b {} { catch {a} msg opts; return {*}$opts $msg }
        set rc [catch {b} msg opts]
        list $rc $msg [llength $opts(-errorinfo)]
} {1 {from a} 6}

test return-1.2 "error can rethrow an error" {
        proc a {} { error "from a" }
        proc b {} { catch {a} msg; error $msg [info stacktrace] }
        set rc [catch {b} msg opts]
        list $rc $msg [llength $opts(-errorinfo)]
} {1 {from a} 9}

test return-1.3 "return can rethrow no error" {
        proc a {} { return "from a" }
        proc b {} { catch {a} msg opts; return {*}$opts $msg }
        set rc [catch {b} msg opts]
        #list $rc $msg [llength $opts(-errorinfo)]
        list $rc $msg [info exists opts(-errorinfo)]
} {0 {from a} 0}

test stringreverse-1.1 "Containing nulls" {
        string reverse abc\0def
} "fed\0cba"

test split-1.1 "Split with leading null" {
        split "\0abc\0def\0" \0
} {{} abc def {}}

test parsevar-1.1 "Variables should include double colons" {
        set ::a::b 2
        set x $::a::b
        unset ::a::b
        set x
} 2

test sharing-1.1 "Problems with ref sharing in arrays: lappend" {
        set a {a 1 c 2}
        set b $a
        lappend b(c) 3
        set a(c)
} 2

test sharing-1.2 "Problems with ref sharing in arrays: append" {
        set a {a 1 c 2}
        set b $a
        append b(c) 3
        set a(c)
} 2

test sharing-1.3 "Problems with ref sharing in arrays: incr" {
        set a {a 1 c 2}
        set b $a
        incr b(c)
        set a(c)
} 2

test sharing-1.4 "Problems with ref sharing in arrays: lset" {
        set a {a 1 c {2 3}}
        set b $a
        lset b(c) 1 x
        set a(c)
} {2 3}

test jimexpr-1.1 "integer ** operator" {
    expr {2 ** 3}
} 8

test jimexpr-1.2 "integer ** operator" {
    expr {0 ** 3}
} 0

test jimexpr-1.3 "integer ** operator" {
    expr {2 ** 0}
} 1

test jimexpr-1.4 "integer ** operator" {
    expr {-2 ** 1}
} -2

test jimexpr-1.5 "integer ** operator" {
    expr {3 ** -2}
} 0

test jimexpr-1.6 "+ command" {
    + 1
} 1

test jimexpr-1.7 "+ command" {
    + 2 3.5
} 5.5

test jimexpr-1.8 "+ command" {
    + 2 3 4 -6
} 3

test jimexpr-1.9 "* command" {
    * 4
} 4

test jimexpr-1.10 "* command" {
    * 4 2
} 8

test jimexpr-1.11 "* command" {
    * 4 2 -0.5
} -4.0

test jimexpr-1.12 "/ command" {
    / 2
} 0.5

test jimexpr-1.12 "/ command" {
    / 0.5
} 2.0

test jimexpr-1.13 "/ command" {
    / 12 3
} 4

test jimexpr-1.14 "/ command" {
    / 12 3 2.0
} 2.0

test jimexpr-1.15 "- command" {
    - 6
} -6

test jimexpr-1.15 "- command" {
    - 6.5
} -6.5

test jimexpr-1.16 "- command" {
    - 6 3
} 3

test jimexpr-1.17 "- command" {
    - 6 3 1.5
} 1.5

test jimexpr-1.17 "- command" {
    - 6.5 3
} 3.5

test jimexpr-2.1 "errors in math commands" {
    list [catch /] [catch {/ x}] [catch -] [catch {- blah blah}] [catch {- 2.0 blah}] [catch {+ x y}] [catch {* x}]
} {1 1 1 1 1 1 1}

test jimexpr-2.2 "not var optimisation" {
        set x [expr 1]
        set y [expr 0]
        set z [expr 2.0]
        list [expr {!$x}] [expr {!$y}] [expr {!$z}]
} {0 1 0}

test jimexpr-2.3 "expr access unset var" {
        unset -nocomplain a
        catch {expr {3 * $a}}
} 1

test jimexpr-2.4 "expr double as bool" {
        set x 2
        if {1.0} {
                set x 3
        }
} 3

# May be supported if support compiled in
test jimexpr-2.5 "double ** operator" {
    catch {expr {2.0 ** 3}} result
    expr {$result in {unsupported 8.0}}
} 1

# This one is for test coverage of an unusual case
test jimobj-1.1 "duplicate obj with no dupIntRepProc" {
        proc "x x" {} { return 2 }
        set a "x x"
        # force it to be a command object
        set b [$a]
        # A second reference
        set c $a
        # Now force it to be duplicated
        lset a 1 x
        # force the duplicate object it to be a command object again
        set b [$a]
        # And get the string rep
        set x "y $a"
} "y x x"

test jimobj-1.2 "cooerced double to int" {
        set x 3
        # cooerce to a double
        expr {4.5 + $x}
        # Now get the int rep
        incr x
} 4

test jimobj-1.3 "cooerced double to double" {
        set x 3
        # cooerce to a double
        expr {4.5 + $x}
        # Now use as a double
        expr {1.5 + $x}
} 4.5

test jimobj-1.4 "incr dict sugar" {
        unset -nocomplain a
        set a(3) 3
        incr a(3)
        list $a(3) $a
} {4 {3 4}}

test jim-badvar-1.1 "invalid variable name" {
        set x b\0c
        catch {set $x 5}
} 1

test jim-badvar-1.2 "incr invalid variable name" {
        set x b\0c
        catch {incr $x}
} 1

test lset-1.1 "lset with bad var" {
        catch {lset badvar 1 x}
} 1

test dict-1.1 "dict to string" {
        set a [dict create abc \\ def \"]
        set x x$a
        # The order of keys in the dictionary is random
        if {$x eq "xabc \\\\ def {\"}" || $x eq "xdef {\"} abc \\\\"} {
                return ok
        } else {
                return "failed: \"$x\""
        }
} ok

test channels-1.1 {info channels} {
        lsort [info channels]
} {stderr stdin stdout}

test lmap-1.1 {lmap} {
        lmap p {1 2 3} {incr p}
} {2 3 4}

test exprerr-1.1 {Error message with bad expr} {
        catch {expr {5 ||}} msg
        set msg
} {Expression has bad operands to ||}

test eval-list-1.1 {Lost string rep with list} {
        set x {set y 1; incr y}
        # Convert to list rep internally
        lindex $x 4
        # But make sure we don't lost the original string rep
        list [catch $x] $y
} {0 2}

test info-statics-1.1 {info statics commands} {
        set x 1
        proc a {} {x {y 2}} {}
        lsort [info statics a]
} {1 2 x y}

testreport