Tcl Source Code

Check-in [92c423cb2e]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:* tests/expr.test: * tests/for-old.test: * tests/for.test: * tests/foreach.test: * tests/format.test: * tests/httpold.test: * tests/if.test: * tests/init.test: * tests/interp.test: * tests/while.test: Added some tests for known bugs (marked with knownBug constraint), and cleaned up a few bad tests.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | core-8-1-branch-old
Files: files | file ages | folders
SHA1: 92c423cb2e3b2fdc52edd70710f2366bd5fba591
User & Date: stanton 1999-04-02 23:44:37
Context
1999-04-02
23:44
* generic/regc_locale.c: * generic/regcustom.h: * generic/tcl.decls: * generic/tclCmdIL.c: * generic... check-in: de06484e63 user: stanton tags: core-8-1-branch-old
23:44
* tests/expr.test: * tests/for-old.test: * tests/for.test: * tests/foreach.test: * tests/format.test... check-in: 92c423cb2e user: stanton tags: core-8-1-branch-old
22:30
safe-6.3 now passes on Windows and Unix for both release and debug. This addresses item 81 on the wh... check-in: 8c40033f93 user: hershey tags: core-8-1-branch-old
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Changes to tests/expr.test.

     6      6   #
     7      7   # Copyright (c) 1996-1997 Sun Microsystems, Inc.
     8      8   # Copyright (c) 1998-1999 by Scriptics Corporation.
     9      9   #
    10     10   # See the file "license.terms" for information on usage and redistribution
    11     11   # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
    12     12   #
    13         -# RCS: @(#) $Id: expr.test,v 1.1.2.5 1999/03/24 02:49:08 hershey Exp $
           13  +# RCS: @(#) $Id: expr.test,v 1.1.2.6 1999/04/02 23:44:37 stanton Exp $
    14     14   
    15     15   if {[lsearch [namespace children] ::tcltest] == -1} {
    16     16       source [file join [pwd] [file dirname [info script]] defs.tcl]
    17     17   }
    18     18   
    19     19   if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
    20     20       set gotT1 0
................................................................................
   663    663           set x  [expr $x+$f+$center]
   664    664           set x  [expr $x+$f+$center]
   665    665           set y  [expr round($x)]
   666    666       }
   667    667       p
   668    668   } 3
   669    669   
          670  +# Test for incorrect "double evaluation" semantics
          671  +
          672  +test expr-20.1 {wrong brace matching} {
          673  +    catch {unset l}
          674  +    catch {unset r}
          675  +    catch {unset q}
          676  +    catch {unset cmd}
          677  +    catch {unset a}
          678  +    set l "\{"; set r "\}"; set q "\""
          679  +    set cmd "expr $l$q|$q == $q$r$q$r"
          680  +    list [catch $cmd a] $a
          681  +} {1 {extra characters after close-brace}}
          682  +test expr-20.2 {double invocation of variable traces} {knownBug} {
          683  +    set exprtracecounter 0
          684  +    proc exprtraceproc {args} {
          685  +       upvar #0 exprtracecounter counter
          686  +       set argc [llength $args]
          687  +       set extraargs [lrange $args 0 [expr {$argc - 4}]]
          688  +       set name [lindex $args [expr {$argc - 3}]]
          689  +       upvar 1 $name var
          690  +       if {[incr counter] % 2 == 1} {
          691  +           set var "$counter oops [concat $extraargs]"
          692  +       } else {
          693  +           set var "$counter + [concat $extraargs]"
          694  +       }
          695  +    }
          696  +    trace variable exprtracevar r [list exprtraceproc 10]
          697  +    list [catch {expr "$exprtracevar + 20"} a] $a \
          698  +        [catch {expr "$exprtracevar + 20"} b] $b \
          699  +        [unset exprtracevar exprtracecounter]
          700  +} {1 {syntax error in expression "1 oops 10 + 20"} 0 32 {}}
          701  +test expr-20.3 {broken substitution of integer digits} {
          702  +    # fails with 8.0.x, but not 8.1b2
          703  +    list [set a 000; expr 0x1$a] [set a 1; expr ${a}000]
          704  +} {4096 1000}
          705  +
   670    706   # cleanup
   671    707   unset a
   672    708   ::tcltest::cleanupTests
   673    709   return
   674         -
   675         -
   676         -
   677         -
   678         -
   679         -
   680         -
   681         -
   682         -
   683         -
   684         -
   685         -

Changes to tests/for-old.test.

     8      8   #
     9      9   # Copyright (c) 1991-1993 The Regents of the University of California.
    10     10   # Copyright (c) 1994-1996 Sun Microsystems, Inc.
    11     11   #
    12     12   # See the file "license.terms" for information on usage and redistribution
    13     13   # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
    14     14   #
    15         -# RCS: @(#) $Id: for-old.test,v 1.1.2.5 1999/03/24 02:49:09 hershey Exp $
           15  +# RCS: @(#) $Id: for-old.test,v 1.1.2.6 1999/04/02 23:44:38 stanton Exp $
    16     16   
    17         -if {[string compare test [info procs test]] == 1} then {source defs}
           17  +if {[lsearch [namespace children] ::tcltest] == -1} {
           18  +    source [file join [pwd] [file dirname [info script]] defs.tcl]
           19  +}
    18     20   
    19     21   # Check "for" and its use of continue and break.
    20     22   
    21     23   catch {unset a i}
    22     24   test for-old-1.1 {for tests} {
    23     25       set a {}
    24     26       for {set i 1} {$i<6} {set i [expr $i+1]} {

Changes to tests/for.test.

     5      5   # generates output for errors.  No output means no errors were found.
     6      6   #
     7      7   # Copyright (c) 1996 Sun Microsystems, Inc.
     8      8   #
     9      9   # See the file "license.terms" for information on usage and redistribution
    10     10   # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
    11     11   #
    12         -# RCS: @(#) $Id: for.test,v 1.1.2.5 1999/03/24 02:49:10 hershey Exp $
           12  +# RCS: @(#) $Id: for.test,v 1.1.2.6 1999/04/02 23:44:38 stanton Exp $
    13     13   
    14         -if {[string compare test [info procs test]] == 1} then {source defs}
           14  +if {[lsearch [namespace children] ::tcltest] == -1} {
           15  +    source [file join [pwd] [file dirname [info script]] defs.tcl]
           16  +}
    15     17   
    16     18   # Basic "for" operation.
    17     19   
    18     20   test for-1.1 {TclCompileForCmd: missing initial command} {
    19     21       list [catch {for} msg] $msg
    20     22   } {1 {wrong # args: should be "for start test next command"}}
    21     23   test for-1.2 {TclCompileForCmd: error in initial command} {
................................................................................
   708    710       set a
   709    711   } {}
   710    712   test for-5.15 {for cmd with computed command names: for command result} {
   711    713       set z for
   712    714       set a [$z {set i 0} {$i < 5} {incr i} {if $i==3 break}]
   713    715       set a
   714    716   } {}
          717  +
          718  +# Test for incorrect "double evaluation" semantics
          719  +
          720  +test for-6.1 {possible delayed substitution of increment command} {knownBug} {
          721  +    # Increment should be 5, and lappend should always append 5
          722  +    catch {unset a}
          723  +    catch {unset i}
          724  +    set a 5
          725  +    set i {}
          726  +    for {set a 1} {$a < 12} "incr a $a" {lappend i $a}
          727  +    set i
          728  +} {1 6 11}
          729  +
          730  +test for-6.2 {possible delayed substitution of body command} {knownBug} {
          731  +    # Increment should be 5, and lappend should always append 5
          732  +    set a 5
          733  +    set i {}
          734  +    for {set a 1} {$a < 12} {incr a $a} "lappend i $a"
          735  +    set i
          736  +} {5 5 5 5}
   715    737   
   716    738   # cleanup
   717    739   ::tcltest::cleanupTests
   718    740   return
   719    741   
   720    742   
   721    743   

Changes to tests/foreach.test.

     6      6   #
     7      7   # Copyright (c) 1991-1993 The Regents of the University of California.
     8      8   # Copyright (c) 1994-1997 Sun Microsystems, Inc.
     9      9   #
    10     10   # See the file "license.terms" for information on usage and redistribution
    11     11   # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
    12     12   #
    13         -# RCS: @(#) $Id: foreach.test,v 1.1.2.5 1999/03/24 02:49:11 hershey Exp $
           13  +# RCS: @(#) $Id: foreach.test,v 1.1.2.6 1999/04/02 23:44:38 stanton Exp $
    14     14   
    15         -if {[string compare test [info procs test]] == 1} then {source defs}
           15  +if {[lsearch [namespace children] ::tcltest] == -1} {
           16  +    source [file join [pwd] [file dirname [info script]] defs.tcl]
           17  +}
    16     18   
    17     19   catch {unset a}
    18     20   catch {unset x}
    19     21   
    20     22   # Basic "foreach" operation.
    21     23   
    22     24   test foreach-1.1 {basic foreach tests} {
................................................................................
   203    205       set a
   204    206   } {a b}
   205    207   test foreach-5.3 {break tests} {catch {break foo} msg} 1
   206    208   test foreach-5.4 {break tests} {
   207    209       catch {break foo} msg
   208    210       set msg
   209    211   } {wrong # args: should be "break"}
          212  +
          213  +# Test for incorrect "double evaluation" semantics
          214  +
          215  +test foreach-6.1 {delayed substitution of body} {knownBug} {
          216  +    proc foo {} {
          217  +       set a 0
          218  +       foreach a [list 1 2 3] "
          219  +           set x $a
          220  +       "
          221  +       set x
          222  +    }
          223  +    foo
          224  +} {0}
   210    225   
   211    226   # cleanup
   212    227   catch {unset a}
   213    228   catch {unset x}
   214    229   ::tcltest::cleanupTests
   215    230   return
   216    231   

Changes to tests/format.test.

     6      6   #
     7      7   # Copyright (c) 1991-1994 The Regents of the University of California.
     8      8   # Copyright (c) 1994-1998 Sun Microsystems, Inc.
     9      9   #
    10     10   # See the file "license.terms" for information on usage and redistribution
    11     11   # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
    12     12   #
    13         -# RCS: @(#) $Id: format.test,v 1.1.2.6 1999/03/24 02:49:11 hershey Exp $
           13  +# RCS: @(#) $Id: format.test,v 1.1.2.7 1999/04/02 23:44:38 stanton Exp $
    14     14   
    15         -if {[info commands test] != "test"} {
    16         -    source defs
           15  +if {[lsearch [namespace children] ::tcltest] == -1} {
           16  +    source [file join [pwd] [file dirname [info script]] defs.tcl]
    17     17   }
    18     18   
    19     19   # The following code is needed because some versions of SCO Unix have
    20     20   # a round-off error in sprintf which would cause some of the tests to
    21     21   # fail.  Someday I hope this code shouldn't be necessary (code added
    22     22   # 9/9/91).
    23     23   

Changes to tests/httpold.test.

     7      7   # Copyright (c) 1991-1993 The Regents of the University of California.
     8      8   # Copyright (c) 1994-1996 Sun Microsystems, Inc.
     9      9   # Copyright (c) 1998-1999 by Scriptics Corporation.
    10     10   #
    11     11   # See the file "license.terms" for information on usage and redistribution
    12     12   # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
    13     13   #
    14         -# RCS: @(#) $Id: httpold.test,v 1.1.2.6 1999/03/26 19:14:01 hershey Exp $
           14  +# RCS: @(#) $Id: httpold.test,v 1.1.2.7 1999/04/02 23:44:38 stanton Exp $
    15     15   
    16     16   if {[lsearch [namespace children] ::tcltest] == -1} {
    17     17       source [file join [pwd] [file dirname [info script]] defs.tcl]
    18     18   }
    19     19   
    20     20   if {[catch {package require http 1.0}]} {
    21     21       if {[info exist httpold]} {
................................................................................
   385    385   test http-4.11 {httpEvent} {
   386    386       set token [http_get $url -timeout 1 -command {#}]
   387    387       http_reset $token
   388    388       http_status $token
   389    389   } {reset}
   390    390   test http-4.12 {httpEvent} {
   391    391       update
          392  +    after 1000 {set x 1}
   392    393       set token [http_get $url -timeout 1 -command {#}]
   393         -    update
          394  +    vwait x
   394    395       http_status $token
   395    396   } {timeout}
   396    397   
   397    398   test http-5.1 {http_formatQuery} {
   398    399       http_formatQuery name1 value1 name2 "value two"
   399    400   } {name1=value1&name2=value+two}
   400    401   

Changes to tests/if.test.

     6      6   #
     7      7   # Copyright (c) 1996 Sun Microsystems, Inc.
     8      8   # Copyright (c) 1998-1999 by Scriptics Corporation.
     9      9   #
    10     10   # See the file "license.terms" for information on usage and redistribution
    11     11   # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
    12     12   #
    13         -# RCS: @(#) $Id: if.test,v 1.1.2.6 1999/03/24 02:49:14 hershey Exp $
           13  +# RCS: @(#) $Id: if.test,v 1.1.2.7 1999/04/02 23:44:38 stanton Exp $
    14     14   
    15     15   if {[lsearch [namespace children] ::tcltest] == -1} {
    16     16       source [file join [pwd] [file dirname [info script]] defs.tcl]
    17     17   }
    18     18   
    19     19   # Basic "if" operation.
    20     20   
................................................................................
   499    499   # Check "if" and computed command names.
   500    500   
   501    501   catch {unset a}
   502    502   test if-5.1 {if cmd with computed command names: missing if/elseif test} {
   503    503       set z if
   504    504       list [catch {$z} msg] $msg
   505    505   } {1 {wrong # args: no expression after "if" argument}}
          506  +
   506    507   test if-5.2 {if cmd with computed command names: error in if/elseif test} {
   507    508       set z if
   508    509       list [catch {$z {[error "error in condition"]} foo} msg] $msg
   509    510   } {1 {error in condition}}
   510    511   test if-5.3 {if cmd with computed command names: error in if/elseif test} {
   511    512       set z if
   512    513       list [catch {$z {1+}} msg] $msg $errorInfo
................................................................................
  1005   1006       $z 0 then {set a 22; concat abc} elseif 1 {concat def} {concat ghi}
  1006   1007   } def
  1007   1008   
  1008   1009   test if-9.1 {if cmd with namespace qualifiers} {
  1009   1010       ::if {1} {set x 4}
  1010   1011   } 4
  1011   1012   
         1013  +# Test for incorrect "double evaluation semantics"
         1014  +
         1015  +test if-10.1 {delayed substitution of then body} {knownBug} {
         1016  +    set j 0
         1017  +    if {[incr j] == 1} "
         1018  +       set result $j
         1019  +    "
         1020  +    set result
         1021  +} {0}
         1022  +test if-10.2 {delayed substitution of elseif expression} {knownBug} {
         1023  +    set j 0
         1024  +    if {[incr j] == 0} {
         1025  +       set result badthen
         1026  +    } elseif "$j == 1" {
         1027  +       set result badelseif
         1028  +    } else {
         1029  +       set result ok
         1030  +    }
         1031  +    set result
         1032  +} {ok}
         1033  +test if-10.3 {delayed substitution of elseif body} {knownBug} {
         1034  +    set j 0
         1035  +    if {[incr j] == 0} {
         1036  +       set result badthen
         1037  +    } elseif {1} "
         1038  +       set result $j
         1039  +    "
         1040  +    set result
         1041  +} {0}
         1042  +test if-10.4 {delayed substitution of else body} {knownBug} {
         1043  +    set j 0
         1044  +    if {[incr j] == 0} {
         1045  +       set result badthen
         1046  +    } else "
         1047  +       set result $j
         1048  +    "
         1049  +    set result
         1050  +} {0}
         1051  +test if-10.5 {substituted control words} {knownBug} {
         1052  +    set then then; proc then {} {return badthen}
         1053  +    set else else; proc else {} {return badelse}
         1054  +    set elseif elseif; proc elseif {} {return badelseif}
         1055  +    list [catch {if 1 $then {if 0 {} $elseif 1 {if 0 {} $else {list ok}}}} a] $a
         1056  +} {0 ok}
         1057  +test if-10.6 {double invocation of variable traces} {knownBug} {
         1058  +    set iftracecounter 0
         1059  +    proc iftraceproc {args} {
         1060  +       upvar #0 iftracecounter counter
         1061  +       set argc [llength $args]
         1062  +       set extraargs [lrange $args 0 [expr {$argc - 4}]]
         1063  +       set name [lindex $args [expr {$argc - 3}]]
         1064  +       upvar 1 $name var
         1065  +       if {[incr counter] % 2 == 1} {
         1066  +           set var "$counter oops [concat $extraargs]"
         1067  +       } else {
         1068  +           set var "$counter + [concat $extraargs]"
         1069  +       }
         1070  +    }
         1071  +    trace variable iftracevar r [list iftraceproc 10]
         1072  +    list [catch {if "$iftracevar + 20" {}} a] $a \
         1073  +        [catch {if "$iftracevar + 20" {}} b] $b \
         1074  +        [unset iftracevar iftracecounter]
         1075  +} {1 {syntax error in expression "1 oops 10 + 20"} 0 {} {}}
         1076  +
  1012   1077   # cleanup
  1013   1078   ::tcltest::cleanupTests
  1014   1079   return
  1015   1080   
  1016   1081   
  1017   1082   
  1018   1083   

Changes to tests/init.test.

     6      6   #
     7      7   # Copyright (c) 1997 Sun Microsystems, Inc.
     8      8   # Copyright (c) 1998-1999 by Scriptics Corporation.
     9      9   #
    10     10   # See the file "license.terms" for information on usage and redistribution
    11     11   # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
    12     12   #
    13         -# RCS: @(#) $Id: init.test,v 1.1.2.5 1999/03/24 02:49:17 hershey Exp $
           13  +# RCS: @(#) $Id: init.test,v 1.1.2.6 1999/04/02 23:44:39 stanton Exp $
    14     14   
    15     15   if {[lsearch [namespace children] ::tcltest] == -1} {
    16     16       source [file join [pwd] [file dirname [info script]] defs.tcl]
    17     17   }
    18     18   
    19     19   # Clear out any namespaces called test_ns_*
    20     20   catch {eval namespace delete [namespace children :: test_ns_*]}
................................................................................
    61     61   
    62     62   set testInterp [interp create]
    63     63   interp eval $testInterp [list set argv $argv]
    64     64   interp eval $testInterp [list source [file join $::tcltest::testsDir defs.tcl]]
    65     65   
    66     66   interp eval $testInterp {
    67     67   
    68         -if {[string compare test [info procs test]] == 1} then {source defs}
           68  +if {[lsearch [namespace children] ::tcltest] == -1} {
           69  +    source [file join [pwd] [file dirname [info script]] defs.tcl]
           70  +}
    69     71   
    70     72   auto_reset
    71     73   catch {rename parray {}}
    72     74   
    73     75   test init-2.0 {load parray - stage 1} {
    74     76       set ret [catch {namespace eval ::tcltest {parray}} error]
    75     77       rename parray {} ; # remove it, for the next test - that should not fail.

Changes to tests/interp.test.

     6      6   #
     7      7   # Copyright (c) 1995-1996 Sun Microsystems, Inc.
     8      8   # Copyright (c) 1998-1999 by Scriptics Corporation.
     9      9   #
    10     10   # See the file "license.terms" for information on usage and redistribution
    11     11   # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
    12     12   #
    13         -# RCS: @(#) $Id: interp.test,v 1.1.2.9 1999/03/26 02:24:46 stanton Exp $
           13  +# RCS: @(#) $Id: interp.test,v 1.1.2.10 1999/04/02 23:44:39 stanton Exp $
    14     14   
    15     15   if {[lsearch [namespace children] ::tcltest] == -1} {
    16     16       source [file join [pwd] [file dirname [info script]] defs.tcl]
    17     17   }
    18     18   
    19     19   # The set of hidden commands is platform dependent:
    20     20   
................................................................................
  2340   2340   	myNewSet a $value
  2341   2341   	return $a
  2342   2342       }
  2343   2343       catch {unset a}
  2344   2344       set result [testMyNewSet "ok"]
  2345   2345       rename testMyNewSet {}
  2346   2346       rename mySet {}
         2347  +    rename myNewSet {}
  2347   2348       set result
  2348   2349   } ok
  2349   2350   
  2350   2351   # cleanup
  2351   2352   foreach i [interp slaves] {
  2352   2353     interp delete $i
  2353   2354   }
  2354   2355   ::tcltest::cleanupTests
  2355   2356   return

Changes to tests/while.test.

     6      6   #
     7      7   # Copyright (c) 1996 Sun Microsystems, Inc.
     8      8   # Copyright (c) 1998-1999 by Scriptics Corporation.
     9      9   #
    10     10   # See the file "license.terms" for information on usage and redistribution
    11     11   # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
    12     12   #
    13         -# RCS: @(#) $Id: while.test,v 1.1.2.5 1999/03/24 02:49:51 hershey Exp $
           13  +# RCS: @(#) $Id: while.test,v 1.1.2.6 1999/04/02 23:44:39 stanton Exp $
    14     14   
    15     15   if {[lsearch [namespace children] ::tcltest] == -1} {
    16     16       source [file join [pwd] [file dirname [info script]] defs.tcl]
    17     17   }
    18     18   
    19     19   # Basic "while" operation.
    20     20   
................................................................................
    23     23   
    24     24   test while-1.1 {TclCompileWhileCmd: missing test expression} {
    25     25       catch {while } msg
    26     26       set msg
    27     27   } {wrong # args: should be "while test command"}
    28     28   test while-1.2 {TclCompileWhileCmd: error in test expression} {
    29     29       set i 0
    30         -    catch {while {$i<}} msg
           30  +    catch {while {$i<} break} msg
    31     31       set errorInfo
    32         -} {wrong # args: should be "while test command"
           32  +} {syntax error in expression "$i<"
           33  +    ("while" test expression)
    33     34       while compiling
    34         -"while {$i<}"}
           35  +"while {$i<} break"}
    35     36   test while-1.3 {TclCompileWhileCmd: error in test expression} {
    36     37       set err [catch {while {"a"+"b"} {error "loop aborted"}} msg]
    37     38       list $err $msg
    38     39   } {1 {can't use non-numeric string as operand of "+"}}
    39     40   test while-1.4 {TclCompileWhileCmd: multiline test expr} {
    40     41       set value 1
    41     42       while {($tcl_platform(platform) != "foobar1") && \
................................................................................
   600    601   	    catch {incr i -5} msg
   601    602   	}
   602    603   	set a [concat $a $i]
   603    604           incr i
   604    605       }
   605    606       set a
   606    607   } {1 3}
          608  +
          609  +# Test for incorrect "double evaluation" semantics
          610  +
          611  +test while-7.1 {delayed substitution of body} {knownBug} {
          612  +    set i 0
          613  +    while {[incr i] < 10} "
          614  +       set result $i
          615  +    "
          616  +    set result
          617  +} {0}
   607    618   
   608    619   # cleanup
   609    620   ::tcltest::cleanupTests
   610    621   return
   611    622   
   612    623   
   613    624