Subversion Repositories or1k

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

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

# currently incomplete since it currently includes only new tests for

# code changed for the addition of Tcl namespaces. Other variable-

# related tests appear in several other test files including

# assocd.test, cmdInfo.test, eval.test, expr.test, interp.test,

# and trace.test.

#

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

# errors. No output means no errors were found.

#

# Copyright (c) 1997 Sun Microsystems, Inc.

#

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

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

#

# RCS: @(#) $Id: basic.test,v 1.1.1.1 2002-01-16 10:25:35 markom Exp $

#

if {[string compare test [info procs test]] == 1} then {source defs}

catch {namespace delete test_ns_basic}

catch {interp delete test_interp}

catch {rename p ""}

catch {rename q ""}

catch {rename cmd ""}

catch {unset x}

test basic-1.1 {Tcl_CreateInterp, creates interp's global namespace} {

    catch {interp delete test_interp}

    interp create test_interp

    interp eval test_interp {

        namespace eval test_ns_basic {

            proc p {} {

                return [namespace current]

            }

        }

    }

    list [interp eval test_interp {test_ns_basic::p}] \

         [interp delete test_interp]

} {::test_ns_basic {}}

test basic-2.1 {DeleteInterpProc, destroys interp's global namespace} {

    catch {interp delete test_interp}

    interp create test_interp

    interp eval test_interp {

        namespace eval test_ns_basic {

            namespace export p

            proc p {} {

                return [namespace current]

            }

        }

        namespace eval test_ns_2 {

            namespace import ::test_ns_basic::p

            variable v 27

            proc q {} {

                variable v

                return "[p] $v"

            }

        }

    }

    list [interp eval test_interp {test_ns_2::q}] \

         [interp eval test_interp {namespace delete ::}] \

         [catch {interp eval test_interp {set a 123}} msg] $msg \

         [interp delete test_interp]

} {{::test_ns_basic 27} {} 1 {invalid command name "set"} {}}

test basic-3.1 {HiddenCmdsDeleteProc, invalidate cached refs to deleted hidden cmd} {

    catch {interp delete test_interp}

    interp create test_interp

    interp eval test_interp {

        proc p {} {

            return 27

        }

    }

    interp alias {} localP test_interp p

    list [interp eval test_interp {p}] \

         [localP] \

         [test_interp hide p] \

         [catch {localP} msg] $msg \

         [interp delete test_interp] \

         [catch {localP} msg] $msg

} {27 27 {} 1 {invalid command name "p"} {} 1 {invalid command name "localP"}}

# NB: More tests about hide/expose are found in interp.test

test basic-4.1 {Tcl_HideCommand, names of hidden cmds can't have namespace qualifiers} {

    catch {interp delete test_interp}

    interp create test_interp

    interp eval test_interp {

        namespace eval test_ns_basic {

            proc p {} {

                return [namespace current]

            }

        }

    }

    list [catch {test_interp hide test_ns_basic::p x} msg] $msg \

         [catch {test_interp hide x test_ns_basic::p} msg1] $msg1 \

         [interp delete test_interp]

} {1 {can only hide global namespace commands (use rename then hide)} 1 {cannot use namespace qualifiers as hidden commandtoken (rename)} {}}

test basic-4.2 {Tcl_HideCommand, a hidden cmd remembers its containing namespace} {

    catch {namespace delete test_ns_basic}

    catch {rename cmd ""}

    proc cmd {} {   ;# note that this is global

        return [namespace current]

    }

    namespace eval test_ns_basic {

        proc hideCmd {} {

            interp hide {} cmd

        }

        proc exposeCmd {} {

            interp expose {} cmd

        }

        proc callCmd {} {

            cmd

        }

    }

    list [test_ns_basic::callCmd] \

         [test_ns_basic::hideCmd] \

         [catch {cmd} msg] $msg \

         [test_ns_basic::exposeCmd] \

         [test_ns_basic::callCmd] \

         [namespace delete test_ns_basic]

} {:: {} 1 {invalid command name "cmd"} {} :: {}}

test basic-5.1 {Tcl_ExposeCommand, a command stays in the global namespace and can not go to another namespace} {

    catch {namespace delete test_ns_basic}

    catch {rename cmd ""}

    proc cmd {} {   ;# note that this is global

        return [namespace current]

    }

    namespace eval test_ns_basic {

        proc hideCmd {} {

            interp hide {} cmd

        }

        proc exposeCmdFailing {} {

            interp expose {} cmd ::test_ns_basic::newCmd

        }

        proc exposeCmdWorkAround {} {

            interp expose {} cmd;

            rename cmd ::test_ns_basic::newCmd;

        }

        proc callCmd {} {

            cmd

        }

    }

    list [test_ns_basic::callCmd] \

         [test_ns_basic::hideCmd] \

         [catch {test_ns_basic::exposeCmdFailing} msg] $msg \

         [test_ns_basic::exposeCmdWorkAround] \

         [test_ns_basic::newCmd] \

         [namespace delete test_ns_basic]

} {:: {} 1 {can not expose to a namespace (use expose to toplevel, then rename)} {} ::test_ns_basic {}}

test basic-5.2 {Tcl_ExposeCommand, invalidate cached refs to cmd now being exposed} {

    catch {rename p ""}

    catch {rename cmd ""}

    proc p {} {

        cmd

    }

    proc cmd {} {

        return 42

    }

    list [p] \

         [interp hide {} cmd] \

         [proc cmd {} {return Hello}] \

         [cmd] \

         [rename cmd ""] \

         [interp expose {} cmd] \

         [p]

} {42 {} {} Hello {} {} 42}

if {[info commands testcreatecommand] != {}} {

    test basic-6.1 {Tcl_CreateCommand, new cmd goes into a namespace specified in its name, if any} {

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

        list [testcreatecommand create] \

             [test_ns_basic::createdcommand] \

             [testcreatecommand delete]

    } {{} {CreatedCommandProc in ::test_ns_basic} {}}

    test basic-6.2 {Tcl_CreateCommand, namespace code ignore single ":"s in middle or end of names} {

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

        catch {rename value:at: ""}

        list [testcreatecommand create2] \

             [value:at:] \

             [testcreatecommand delete2]

    } {{} {CreatedCommandProc2 in ::} {}}

}

test basic-6.3 {Tcl_CreateObjCommand, new cmd goes into a namespace specified in its name, if any} {

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

    namespace eval test_ns_basic {}

    proc test_ns_basic::cmd {} {  ;# proc requires that ns already exist

        return [namespace current]

    }

    list [test_ns_basic::cmd] \

         [namespace delete test_ns_basic]

} {::test_ns_basic {}}

test basic-7.1 {TclRenameCommand, name of existing cmd can have namespace qualifiers} {

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

    catch {rename cmd ""}

    namespace eval test_ns_basic {

        proc p {} {

            return "p in [namespace current]"

        }

    }

    list [test_ns_basic::p] \

         [rename test_ns_basic::p test_ns_basic::q] \

         [test_ns_basic::q]

} {{p in ::test_ns_basic} {} {p in ::test_ns_basic}}

test basic-7.2 {TclRenameCommand, existing cmd must be found} {

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

    list [catch {rename test_ns_basic::p test_ns_basic::q} msg] $msg

} {1 {can't rename "test_ns_basic::p": command doesn't exist}}

test basic-7.3 {TclRenameCommand, delete cmd if new name is empty} {

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

    namespace eval test_ns_basic {

        proc p {} {

            return "p in [namespace current]"

        }

    }

    list [info commands test_ns_basic::*] \

         [rename test_ns_basic::p ""] \

         [info commands test_ns_basic::*]

} {::test_ns_basic::p {} {}}

test basic-7.4 {TclRenameCommand, bad new name} {

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

    namespace eval test_ns_basic {

        proc p {} {

            return "p in [namespace current]"

        }

    }

    rename test_ns_basic::p :::george::martha

} {}

test basic-7.5 {TclRenameCommand, new name must not already exist} {

    namespace eval test_ns_basic {

        proc q {} {

            return 42

        }

    }

    list [catch {rename test_ns_basic::q :::george::martha} msg] $msg

} {1 {can't rename to ":::george::martha": command already exists}}

test basic-7.6 {TclRenameCommand, check for command shadowing by newly renamed cmd} {

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

    catch {rename p ""}

    catch {rename q ""}

    proc p {} {

        return "p in [namespace current]"

    }

    proc q {} {

        return "q in [namespace current]"

    }

    namespace eval test_ns_basic {

        proc callP {} {

            p

        }

    }

    list [test_ns_basic::callP] \

         [rename q test_ns_basic::p] \

         [test_ns_basic::callP]

} {{p in ::} {} {q in ::test_ns_basic}}

if {[info command testcmdtoken] != {}} {

test basic-8.1 {Tcl_GetCommandInfo, names for commands created inside namespaces} {

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

    catch {rename p ""}

    catch {rename q ""}

    catch {unset x}

    set x [namespace eval test_ns_basic::test_ns_basic2 {

        # the following creates a cmd in the global namespace

        testcmdtoken create p

    }]

    list [testcmdtoken name $x] \

         [rename ::p q] \

         [testcmdtoken name $x]

} {{p ::p} {} {q ::q}}

test basic-8.2 {Tcl_GetCommandInfo, names for commands created outside namespaces} {

    catch {rename q ""}

    set x [testcmdtoken create test_ns_basic::test_ns_basic2::p]

    list [testcmdtoken name $x] \

         [rename test_ns_basic::test_ns_basic2::p q] \

         [testcmdtoken name $x]

} {{p ::test_ns_basic::test_ns_basic2::p} {} {q ::q}}

}

test basic-9.1 {Tcl_GetCommandFullName} {

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

    namespace eval test_ns_basic1 {

        namespace export cmd*

        proc cmd1 {} {}

        proc cmd2 {} {}

    }

    namespace eval test_ns_basic2 {

        namespace export *

        namespace import ::test_ns_basic1::*

        proc p {} {}

    }

    namespace eval test_ns_basic3 {

        namespace import ::test_ns_basic2::*

        proc q {} {}

        list [namespace which -command foreach] \

             [namespace which -command q] \

             [namespace which -command p] \

             [namespace which -command cmd1] \

             [namespace which -command ::test_ns_basic2::cmd2]

    }

} {::foreach ::test_ns_basic3::q ::test_ns_basic3::p ::test_ns_basic3::cmd1 ::test_ns_basic2::cmd2}

test basic-10.1 {Tcl_DeleteCommandFromToken, invalidate all compiled code if cmd has compile proc} {

    catch {interp delete test_interp}

    catch {unset x}

    interp create test_interp

    interp eval test_interp {

        proc useSet {} {

            return [set a 123]

        }

    }

    set x [interp eval test_interp {useSet}]

    interp eval test_interp {

        rename set ""

        proc set {args} {

            return "set called with $args"

        }

    }

    list $x \

         [interp eval test_interp {useSet}] \

         [interp delete test_interp]

} {123 {set called with a 123} {}}

test basic-10.2 {Tcl_DeleteCommandFromToken, deleting commands changes command epoch} {

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

    catch {rename p ""}

    proc p {} {

        return "global p"

    }

    namespace eval test_ns_basic {

        proc p {} {

            return "namespace p"

        }

        proc callP {} {

            p

        }

    }

    list [test_ns_basic::callP] \

         [rename test_ns_basic::p ""] \

         [test_ns_basic::callP]

} {{namespace p} {} {global p}}

test basic-10.3 {Tcl_DeleteCommandFromToken, delete imported cmds that refer to a deleted cmd} {

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

    catch {rename p ""}

    namespace eval test_ns_basic {

        namespace export p

        proc p {} {return 42}

    }

    namespace eval test_ns_basic2 {

        namespace import ::test_ns_basic::*

        proc callP {} {

            p

        }

    }

    list [test_ns_basic2::callP] \

         [info commands test_ns_basic2::*] \

         [rename test_ns_basic::p ""] \

         [catch {test_ns_basic2::callP} msg] $msg \

         [info commands test_ns_basic2::*]

} {42 {::test_ns_basic2::callP ::test_ns_basic2::p} {} 1 {invalid command name "p"} ::test_ns_basic2::callP}

test basic-11.1 {TclObjInvoke, lookup of "unknown" command} {

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

    catch {interp delete test_interp}

    interp create test_interp

    interp eval test_interp {

        proc unknown {args} {

            return "global unknown"

        }

        namespace eval test_ns_basic {

            proc unknown {args} {

                return "namespace unknown"

            }

        }

    }

    list [interp alias test_interp newAlias test_interp doesntExist] \

         [catch {interp eval test_interp {newAlias}} msg] $msg \

         [interp delete test_interp]

} {newAlias 0 {global unknown} {}}

if {[info command testcmdtrace] != {}} {

test basic-12.1 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {

    testcmdtrace tracetest {set stuff [info tclversion]}

} {{info tclversion} {info tclversion} {set stuff [info tclversion]} {set stuff 8.0}}

test basic-12.2 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {

    testcmdtrace deletetest {set stuff [info tclversion]}

} 8.0

}

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

catch {namespace delete george}

catch {interp delete test_interp}

catch {rename p ""}

catch {rename q ""}

catch {rename cmd ""}

catch {rename value:at: ""}

catch {unset x}

set x 0

unset x