Symaptic: os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/proc.test@bde4ae8d615e

     1 # This file contains tests for the tclProc.c source file. Tests appear in

     2 # the same order as the C code that they test. The set of tests is

     3 # currently incomplete since it includes only new tests, in particular

     4 # tests for code changed for the addition of Tcl namespaces. Other

     5 # procedure-related tests appear in other test files such as proc-old.test.

6 #

     7 # Sourcing this file into Tcl runs the tests and generates output for

     8 # errors.  No output means no errors were found.

9 #

    10 # Copyright (c) 1997 Sun Microsystems, Inc.

    11 # Copyright (c) 1998-1999 by Scriptics Corporation.

    12 #

    13 # See the file "license.terms" for information on usage and redistribution

    14 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.

    15 #

    16 # RCS: @(#) $Id: proc.test,v 1.11.2.1 2004/05/02 21:07:16 msofer Exp $

    18 if {[lsearch [namespace children] ::tcltest] == -1} {

    19     package require tcltest

    20     namespace import -force ::tcltest::*

    21 }

    23 catch {eval namespace delete [namespace children :: test_ns_*]}

    24 catch {rename p ""}

    25 catch {rename {} ""}

    26 catch {unset msg}

    28 test proc-1.1 {Tcl_ProcObjCmd, put proc in namespace specified in name, if any} {

    29     catch {eval namespace delete [namespace children :: test_ns_*]}

    30     namespace eval test_ns_1 {

    31         namespace eval baz {}

    32     }

    33     proc test_ns_1::baz::p {} {

    34         return "p in [namespace current]"

    35     }

    36     list [test_ns_1::baz::p] \

    37          [namespace eval test_ns_1 {baz::p}] \

    38          [info commands test_ns_1::baz::*]

    39 } {{p in ::test_ns_1::baz} {p in ::test_ns_1::baz} ::test_ns_1::baz::p}

    40 test proc-1.2 {Tcl_ProcObjCmd, namespace specified in proc name must exist} {

    41     catch {eval namespace delete [namespace children :: test_ns_*]}

    42     list [catch {proc test_ns_1::baz::p {} {}} msg] $msg

    43 } {1 {can't create procedure "test_ns_1::baz::p": unknown namespace}}

    44 test proc-1.3 {Tcl_ProcObjCmd, empty proc name} {

    45     catch {eval namespace delete [namespace children :: test_ns_*]}

    46     proc :: {} {

    47         return "empty called"

    48     }

    49     list [::] \

    50          [info body {}]

    51 } {{empty called} {

    52         return "empty called"

    53     }}

    54 test proc-1.4 {Tcl_ProcObjCmd, simple proc name and proc defined in namespace} {

    55     catch {eval namespace delete [namespace children :: test_ns_*]}

    56     namespace eval test_ns_1 {

    57         namespace eval baz {

    58             proc p {} {

    59                 return "p in [namespace current]"

    60             }

    61         }

    62     }

    63     list [test_ns_1::baz::p] \

    64          [info commands test_ns_1::baz::*]

    65 } {{p in ::test_ns_1::baz} ::test_ns_1::baz::p}

    66 test proc-1.5 {Tcl_ProcObjCmd, qualified proc name and proc defined in namespace} {

    67     catch {eval namespace delete [namespace children :: test_ns_*]}

    68     namespace eval test_ns_1::baz {}

    69     namespace eval test_ns_1 {

    70         proc baz::p {} {

    71             return "p in [namespace current]"

    72         }

    73     }

    74     list [test_ns_1::baz::p] \

    75          [info commands test_ns_1::baz::*] \

    76          [namespace eval test_ns_1::baz {namespace which p}]

    77 } {{p in ::test_ns_1::baz} ::test_ns_1::baz::p ::test_ns_1::baz::p}

    78 test proc-1.6 {Tcl_ProcObjCmd, namespace code ignores single ":"s in middle or end of command names} {

    79     catch {eval namespace delete [namespace children :: test_ns_*]}

    80     namespace eval test_ns_1 {

    81         proc q: {} {return "q:"}

    82         proc value:at: {} {return "value:at:"}

    83     }

    84     list [namespace eval test_ns_1 {q:}] \

    85          [namespace eval test_ns_1 {value:at:}] \

    86          [test_ns_1::q:] \

    87          [test_ns_1::value:at:] \

    88          [lsort [info commands test_ns_1::*]] \

    89          [namespace eval test_ns_1 {namespace which q:}] \

    90          [namespace eval test_ns_1 {namespace which value:at:}]

    91 } {q: value:at: q: value:at: {::test_ns_1::q: ::test_ns_1::value:at:} ::test_ns_1::q: ::test_ns_1::value:at:}

    92 test proc-1.7 {Tcl_ProcObjCmd, check that formal parameter names are not array elements} {

    93     catch {rename p ""}

    94     list [catch {proc p {a(1) a(2)} {

    95             set z [expr $a(1)+$a(2)]

    96             puts "$z=z, $a(1)=$a(1)"

    97         }} msg] $msg

    98 } {1 {procedure "p" has formal parameter "a(1)" that is an array element}}

    99 test proc-1.8 {Tcl_ProcObjCmd, check that formal parameter names are simple names} {

   100     catch {rename p ""}

   101     list [catch {proc p {b:a b::a} {

   102     }} msg] $msg

   103 } {1 {procedure "p" has formal parameter "b::a" that is not a simple name}}

   105 test proc-2.1 {TclFindProc, simple proc name and proc not in namespace} {

   106     catch {eval namespace delete [namespace children :: test_ns_*]}

   107     catch {rename p ""}

   108     proc p {} {return "p in [namespace current]"}

   109     info body p

   110 } {return "p in [namespace current]"}

   111 test proc-2.2 {TclFindProc, simple proc name and proc defined in namespace} {

   112     catch {eval namespace delete [namespace children :: test_ns_*]}

   113     namespace eval test_ns_1 {

   114         namespace eval baz {

   115             proc p {} {return "p in [namespace current]"}

   116         }

   117     }

   118     namespace eval test_ns_1::baz {info body p}

   119 } {return "p in [namespace current]"}

   120 test proc-2.3 {TclFindProc, qualified proc name and proc defined in namespace} {

   121     catch {eval namespace delete [namespace children :: test_ns_*]}

   122     namespace eval test_ns_1::baz {}

   123     namespace eval test_ns_1 {

   124         proc baz::p {} {return "p in [namespace current]"}

   125     }

   126     namespace eval test_ns_1 {info body baz::p}

   127 } {return "p in [namespace current]"}

   128 test proc-2.4 {TclFindProc, global proc and executing in namespace} {

   129     catch {eval namespace delete [namespace children :: test_ns_*]}

   130     catch {rename p ""}

   131     proc p {} {return "global p"}

   132     namespace eval test_ns_1::baz {info body p}

   133 } {return "global p"}

   135 test proc-3.1 {TclObjInterpProc, proc defined and executing in same namespace} {

   136     catch {eval namespace delete [namespace children :: test_ns_*]}

   137     proc p {} {return "p in [namespace current]"}

   138     p

   139 } {p in ::}

   140 test proc-3.2 {TclObjInterpProc, proc defined and executing in same namespace} {

   141     catch {eval namespace delete [namespace children :: test_ns_*]}

   142     namespace eval test_ns_1::baz {

   143         proc p {} {return "p in [namespace current]"}

   144         p

   145     }

   146 } {p in ::test_ns_1::baz}

   147 test proc-3.3 {TclObjInterpProc, proc defined and executing in different namespaces} {

   148     catch {eval namespace delete [namespace children :: test_ns_*]}

   149     catch {rename p ""}

   150     proc p {} {return "p in [namespace current]"}

   151     namespace eval test_ns_1::baz {

   152         p

   153     }

   154 } {p in ::}

   155 test proc-3.4 {TclObjInterpProc, procs execute in the namespace in which they were defined unless renamed into new namespace} {

   156     catch {eval namespace delete [namespace children :: test_ns_*]}

   157     catch {rename p ""}

   158     namespace eval test_ns_1::baz {

   159         proc p {} {return "p in [namespace current]"}

   160         rename ::test_ns_1::baz::p ::p

   161         list [p] [namespace which p]

   162     }

   163 } {{p in ::} ::p}

   164 test proc-3.5 {TclObjInterpProc, any old result is reset before appending error msg about missing arguments} {

   165     proc p {x} {info commands 3m}

   166     list [catch {p} msg] $msg

   167 } {1 {wrong # args: should be "p x"}}

   169 test proc-3.6 {TclObjInterpProc, proper quoting of proc name, Bug 942757} {

   170     proc {a b  c} {x} {info commands 3m}

   171     list [catch {{a b  c}} msg] $msg

   172 } {1 {wrong # args: should be "{a b  c} x"}}

   174 catch {eval namespace delete [namespace children :: test_ns_*]}

   175 catch {rename p ""}

   176 catch {rename {} ""}

   177 catch {rename {a b  c} {}}

   178 catch {unset msg}

   180 if {[catch {package require procbodytest}]} {

   181     puts "This application couldn't load the \"procbodytest\" package, so I"

   182     puts "can't test creation of procs whose bodies have type \"procbody\"."

   183     ::tcltest::cleanupTests

   184     return

   185 }

   187 catch {rename p ""}

   188 catch {rename t ""}

   190 # Note that the test require that procedures whose body is used to create

   191 # procbody objects must be executed before the procbodytest::proc command

   192 # is executed, so that the Proc struct is populated correctly (CompiledLocals

   193 # are added at compile time).

   195 test proc-4.1 {TclCreateProc, procbody obj} {

   196     catch {

   197 	proc p x {return "$x:$x"}

   198 	set rv [p P]

   199 	procbodytest::proc t x p

   200 	lappend rv [t T]

   201 	set rv

   202     } result

   203     catch {rename p ""}

   204     catch {rename t ""}

   205     set result

   206 } {P:P T:T}

   208 test proc-4.2 {TclCreateProc, procbody obj, use compiled locals} {

   209     catch {

   210 	proc p x {

   211 	    set y [string tolower $x]

   212 	    return "$x:$y"

   213 	}

   214 	set rv [p P]

   215 	procbodytest::proc t x p

   216 	lappend rv [t T]

   217 	set rv

   218     } result

   219     catch {rename p ""}

   220     catch {rename t ""}

   221     set result

   222 } {P:p T:t}

   224 test proc-4.3 {TclCreateProc, procbody obj, too many args} {

   225     catch {

   226 	proc p x {

   227 	    set y [string tolower $x]

   228 	    return "$x:$y"

   229 	}

   230 	set rv [p P]

   231 	procbodytest::proc t {x x1 x2} p

   232 	lappend rv [t T]

   233 	set rv

   234     } result

   235     catch {rename p ""}

   236     catch {rename t ""}

   237     set result

   238 } {procedure "t": arg list contains 3 entries, precompiled header expects 1}

   240 test proc-4.4 {TclCreateProc, procbody obj, inconsitent arg name} {

   241     catch {

   242 	proc p {x y z} {

   243 	    set v [join [list $x $y $z]]

   244 	    set w [string tolower $v]

   245 	    return "$v:$w"

   246 	}

   247 	set rv [p P Q R]

   248 	procbodytest::proc t {x x1 z} p

   249 	lappend rv [t S T U]

   250 	set rv

   251     } result

   252     catch {rename p ""}

   253     catch {rename t ""}

   254     set result

   255 } {procedure "t": formal parameter 1 is inconsistent with precompiled body}

   257 test proc-4.5 {TclCreateProc, procbody obj, inconsitent arg default type} {

   258     catch {

   259 	proc p {x y {z Z}} {

   260 	    set v [join [list $x $y $z]]

   261 	    set w [string tolower $v]

   262 	    return "$v:$w"

   263 	}

   264 	set rv [p P Q R]

   265 	procbodytest::proc t {x y z} p

   266 	lappend rv [t S T U]

   267 	set rv

   268     } result

   269     catch {rename p ""}

   270     catch {rename t ""}

   271     set result

   272 } {procedure "t": formal parameter 2 is inconsistent with precompiled body}

   274 test proc-4.6 {TclCreateProc, procbody obj, inconsitent arg default type} {

   275     catch {

   276 	proc p {x y z} {

   277 	    set v [join [list $x $y $z]]

   278 	    set w [string tolower $v]

   279 	    return "$v:$w"

   280 	}

   281 	set rv [p P Q R]

   282 	procbodytest::proc t {x y {z Z}} p

   283 	lappend rv [t S T U]

   284 	set rv

   285     } result

   286     catch {rename p ""}

   287     catch {rename t ""}

   288     set result

   289 } {procedure "t": formal parameter 2 is inconsistent with precompiled body}

   291 test proc-4.7 {TclCreateProc, procbody obj, inconsitent arg default value} {

   292     catch {

   293 	proc p {x y {z Z}} {

   294 	    set v [join [list $x $y $z]]

   295 	    set w [string tolower $v]

   296 	    return "$v:$w"

   297 	}

   298 	set rv [p P Q R]

   299 	procbodytest::proc t {x y {z ZZ}} p

   300 	lappend rv [t S T U]

   301 	set rv

   302     } result

   303     catch {rename p ""}

   304     catch {rename t ""}

   305     set result

   306 } {procedure "t": formal parameter "z" has default value inconsistent with precompiled body}

   308 test proc-5.1 {Bytecompiling noop; test for correct argument substitution} {

   309     proc p args {} ; # this will be bytecompiled into t

   310     proc t {} {

   311 	set res {}

   312 	set a 0

   313 	set b 0

   314 	trace add variable a read {append res a ;#}

   315 	trace add variable b write {append res b ;#}

   316 	p $a ccccccw {bfe} {$a} [incr b] [incr a] {[incr b]} {$a} hello

   317 	set res

   318     }

   319     set result [t]

   320     catch {rename p ""}

   321     catch {rename t ""}

   322     set result

   323 } {aba}

   325 test proc-6.1 {ProcessProcResultCode: Bug 647307 (negative return code)} {

   326     proc a {} {return -code -5}

   327     proc b {} a

   328     set result [catch b]

   329     rename a {}

   330     rename b {}

   331     set result

   332 } -5

   334 # cleanup

   335 catch {rename p ""}

   336 catch {rename t ""}

   337 ::tcltest::cleanupTests

   338 return

author	sl@SLION-WIN7.fritz.box
	Fri, 15 Jun 2012 03:10:57 +0200
changeset 0	bde4ae8d615e
permissions	-rw-r--r--