info.test

tcl是工具命令语言

# Commands covered:  info
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: info.test,v 1.24 2002/07/01 07:52:03 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

# Set up namespaces needed to test operation of "info args", "info body",
# "info default", and "info procs" with imported procedures.

catch {namespace delete test_ns_info1 test_ns_info2}

namespace eval test_ns_info1 {
    namespace export *
    proc p {x} {return "x=$x"}
    proc q {{y 27} {z {}}} {return "y=$y"}
}


test info-1.1 {info args option} {
    proc t1 {a bbb c} {return foo}
    info args t1
} {a bbb c}
test info-1.2 {info args option} {
    proc t1 {{a default1} {bbb default2} {c default3} args} {return foo}
    info a t1
} {a bbb c args}
test info-1.3 {info args option} {
    proc t1 "" {return foo}
    info args t1
} {}
test info-1.4 {info args option} {
    catch {rename t1 {}}
    list [catch {info args t1} msg] $msg
} {1 {"t1" isn't a procedure}}
test info-1.5 {info args option} {
    list [catch {info args set} msg] $msg
} {1 {"set" isn't a procedure}}
test info-1.6 {info args option} {
    proc t1 {a b} {set c 123; set d $c}
    t1 1 2
    info args t1
} {a b}
test info-1.7 {info args option} {
    catch {namespace delete test_ns_info2}
    namespace eval test_ns_info2 {
        namespace import ::test_ns_info1::*
        list [info args p] [info args q]
    }
} {x {y z}}

test info-2.1 {info body option} {
    proc t1 {} {body of t1}
    info body t1
} {body of t1}
test info-2.2 {info body option} {
    list [catch {info body set} msg] $msg
} {1 {"set" isn't a procedure}}
test info-2.3 {info body option} {
    list [catch {info args set 1} msg] $msg
} {1 {wrong # args: should be "info args procname"}}
test info-2.4 {info body option} {
    catch {namespace delete test_ns_info2}
    namespace eval test_ns_info2 {
        namespace import ::test_ns_info1::*
        list [info body p] [info body q]
    }
} {{return "x=$x"} {return "y=$y"}}
# Prior to 8.3.0 this would cause a crash because [info body]
# would return the bytecompiled version of foo, which the catch
# would then try and eval out of the foo context, accessing
# compiled local indices
test info-2.5 {info body option, returning bytecompiled bodies} {
    catch {unset args}
    proc foo {args} {
	foreach v $args {
	    upvar $v var
	    return "variable $v existence: [info exists var]"
	}
    }
    foo a
    list [catch [info body foo] msg] $msg
} {1 {can't read "args": no such variable}}
# Fix for problem tested for in info-2.5 caused problems when
# procedure body had no string rep (i.e. was not yet bytecode)
# causing an empty string to be returned [Bug #545644]
test info-2.6 {info body option, returning list bodies} {
    proc foo args [list subst bar]
    list [string bytelength [info body foo]] \
	    [foo; string bytelength [info body foo]]
} {9 9}

# "info cmdcount" is no longer accurate for compiled commands!
# The expected result for info-3.1 used to be "3" and is now "1"
# since the "set"s have been compiled away.  info-3.2 was corrected
# in 8.3 because the eval'ed body won't be compiled.
proc testinfocmdcount {} {
    set x [info cmdcount]
    set y 12345
    set z [info cm]
    expr $z-$x
}
test info-3.1 {info cmdcount compiled} {
    testinfocmdcount
} 1
test info-3.2 {info cmdcount evaled} {
    set x [info cmdcount]
    set y 12345
    set z [info cm]
    expr $z-$x
} 3
test info-3.3 {info cmdcount evaled} [info body testinfocmdcount] 3
test info-3.4 {info cmdcount option} {
    list [catch {info cmdcount 1} msg] $msg
} {1 {wrong # args: should be "info cmdcount"}}

test info-4.1 {info commands option} {
    proc t1 {} {}
    proc t2 {} {}
    set x " [info commands] "
    list [string match {* t1 *} $x] [string match {* t2 *} $x] \
            [string match {* set *} $x] [string match {* list *} $x]
} {1 1 1 1}
test info-4.2 {info commands option} {
    proc t1 {} {}
    rename t1 {}
    set x [info comm]
    string match {* t1 *} $x
} 0
test info-4.3 {info commands option} {
    proc _t1_ {} {}
    proc _t2_ {} {}
    info commands _t1_
} _t1_
test info-4.4 {info commands option} {
    proc _t1_ {} {}
    proc _t2_ {} {}
    lsort [info commands _t*]
} {_t1_ _t2_}
catch {rename _t1_ {}}
catch {rename _t2_ {}}
test info-4.5 {info commands option} {
    list [catch {info commands a b} msg] $msg
} {1 {wrong # args: should be "info commands ?pattern?"}}

test info-5.1 {info complete option} {
    list [catch {info complete} msg] $msg
} {1 {wrong # args: should be "info complete command"}}
test info-5.2 {info complete option} {
    info complete abc
} 1
test info-5.2 {info complete option} {
    info complete "\{abcd "
} 0
test info-5.3 {info complete option} {
    info complete {# Comment should be complete command}
} 1
test info-5.4 {info complete option} {
    info complete {[a [b] }
} 0
test info-5.5 {info complete option} {
    info complete {[a [b]}
} 0

test info-6.1 {info default option} {
    proc t1 {a b {c d} {e "long default value"}} {}
    info default t1 a value
} 0
test info-6.2 {info default option} {
    proc t1 {a b {c d} {e "long default value"}} {}
    set value 12345
    info d t1 a value
    set value
} {}
test info-6.3 {info default option} {
    proc t1 {a b {c d} {e "long default value"}} {}
    info default t1 c value
} 1
test info-6.4 {info default option} {
    proc t1 {a b {c d} {e "long default value"}} {}
    set value 12345
    info default t1 c value
    set value
} d
test info-6.5 {info default option} {
    proc t1 {a b {c d} {e "long default value"}} {}
    set value 12345
    set x [info default t1 e value]
    list $x $value
} {1 {long default value}}
test info-6.6 {info default option} {
    list [catch {info default a b} msg] $msg
} {1 {wrong # args: should be "info default procname arg varname"}}
test info-6.7 {info default option} {
    list [catch {info default _nonexistent_ a b} msg] $msg
} {1 {"_nonexistent_" isn't a procedure}}
test info-6.8 {info default option} {
    proc t1 {a b} {}
    list [catch {info default t1 x value} msg] $msg
} {1 {procedure "t1" doesn't have an argument "x"}}
test info-6.9 {info default option} {
    catch {unset a}
    set a(0) 88
    proc t1 {a b} {}
    list [catch {info default t1 a a} msg] $msg
} {1 {couldn't store default value in variable "a"}}
test info-6.10 {info default option} {
    catch {unset a}
    set a(0) 88
    proc t1 {{a 18} b} {}
    list [catch {info default t1 a a} msg] $msg
} {1 {couldn't store default value in variable "a"}}
test info-6.11 {info default option} {
    catch {namespace delete test_ns_info2}
    namespace eval test_ns_info2 {
        namespace import ::test_ns_info1::*
        list [info default p x foo] $foo [info default q y bar] $bar
    }
} {0 {} 1 27}
catch {unset a}

test info-7.1 {info exists option} {
    set value foo
    info exists value
} 1
catch {unset _nonexistent_}
test info-7.2 {info exists option} {
    info exists _nonexistent_
} 0
test info-7.3 {info exists option} {
    proc t1 {x} {return [info exists x]}
    t1 2
} 1
test info-7.4 {info exists option} {
    proc t1 {x} {
        global _nonexistent_
        return [info exists _nonexistent_]
    }
    t1 2
} 0
test info-7.5 {info exists option} {
    proc t1 {x} {
        set y 47
        return [info exists y]
    }
    t1 2
} 1
test info-7.6 {info exists option} {
    proc t1 {x} {return [info exists value]}
    t1 2
} 0
test info-7.7 {info exists option} {
    catch {unset x}
    set x(2) 44
    list [info exists x] [info exists x(1)] [info exists x(2)]
} {1 0 1}
catch {unset x}
test info-7.8 {info exists option} {
    list [catch {info exists} msg] $msg
} {1 {wrong # args: should be "info exists varName"}}
test info-7.9 {info exists option} {
    list [catch {info exists 1 2} msg] $msg
} {1 {wrong # args: should be "info exists varName"}}

test info-8.1 {info globals option} {
    set x 1
    set y 2
    set value 23
    set a " [info globals] "
    list [string match {* x *} $a] [string match {* y *} $a] \
            [string match {* value *} $a] [string match {* _foobar_ *} $a]
} {1 1 1 0}
test info-8.2 {info globals option} {
    set _xxx1 1
    set _xxx2 2
    lsort [info g _xxx*]
} {_xxx1 _xxx2}
test info-8.3 {info globals option} {
    list [catch {info globals 1 2} msg] $msg
} {1 {wrong # args: should be "info globals ?pattern?"}}

test info-9.1 {info level option} {
    info level
} 0
test info-9.2 {info level option} {
    proc t1 {a b} {
        set x [info le]
        set y [info level 1]
        list $x $y
    }
    t1 146 testString
} {1 {t1 146 testString}}
test info-9.3 {info level option} {
    proc t1 {a b} {
        t2 [expr $a*2] $b
    }
    proc t2 {x y} {
        list [info level] [info level 1] [info level 2] [info level -1] \
                [info level 0]
    }
    t1 146 {a {b c} {{{c}}}}
} {2 {t1 146 {a {b c} {{{c}}}}} {t2 292 {a {b c} {{{c}}}}} {t1 146 {a {b c} {{{c}}}}} {t2 292 {a {b c} {{{c}}}}}}
test info-9.4 {info level option} {
    proc t1 {} {
        set x [info level]
        set y [info level 1]
        list $x $y
    }
    t1
} {1 t1}