import.test

linux 下的源代码分析阅读器 red hat公司新版

#
# Tests for "auto_import" and autoloading facility
# ----------------------------------------------------------------------
#   AUTHOR:  Michael J. McLennan
#            Bell Labs Innovations for Lucent Technologies
#            [e-mail]
#            http://www.tcltk.com/itcl
#
#      RCS:  $Id: import.test 144 2003-02-05 10:56:26Z mdejong $
# ----------------------------------------------------------------------
#            Copyright (c) 1993-1998  Lucent Technologies, Inc.
# ======================================================================
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.

package require tcltest
namespace import -force ::tcltest::*

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

package require Itcl

# ----------------------------------------------------------------------
#  Test "itcl::import::stub" command
# ----------------------------------------------------------------------
test import-1.1 {basic syntax for "stub" command} {
    list [catch {itcl::import::stub} result] $result
} {1 {wrong # args: should be one of...
  stub create name
  stub exists name}}

test import-1.2 {"stub create" requires one argument} {
    list [catch {itcl::import::stub create} result] $result \
         [catch {itcl::import::stub create x y} result] $result
} {1 {wrong # args: should be "itcl::import::stub create name"} 1 {wrong # args: should be "itcl::import::stub create name"}}

test import-1.3 {"stub exists" requires one argument} {
    list [catch {itcl::import::stub exists} result] $result \
         [catch {itcl::import::stub exists x y} result] $result
} {1 {wrong # args: should be "itcl::import::stub exists name"} 1 {wrong # args: should be "itcl::import::stub exists name"}}

set interp [interp create]
$interp eval {
    package require Itcl
    proc auto_load {cmd {namespace {}}} {
        global debug
        proc $cmd {args} [format {return "%s: $args"} $cmd]
        append debug "(auto_load: $cmd)"
        return 1
    }
}

test import-1.4 {"stub create" creates a stub that triggers autoloading} {
    $interp eval {
        set debug ""
        list [itcl::import::stub create foo::bar::test] \
             [info commands ::foo::bar::test] \
             [::foo::bar::test 1 2 3] \
             $debug
    }
} {{} ::foo::bar::test {::foo::bar::test: 1 2 3} {(auto_load: ::foo::bar::test)}}

test import-1.5 {"stub exists" recognizes stubs created by "stub create"} {
    $interp eval {
        set debug ""
        itcl::import::stub create foo::bar::stub1
        proc foo::bar::proc1 {args} {return "proc1: $args"}
        list [itcl::import::stub exists foo::bar::stub1] \
             [itcl::import::stub exists foo::bar::proc1]
    }
} {1 0}

test import-1.6 {stubs can be autoloaded and replaced} {
    $interp eval {
        set debug ""
        itcl::import::stub create foo::bar::stub2
        list [itcl::import::stub exists foo::bar::stub2] \
             [::foo::bar::stub2 a b c] \
             [itcl::import::stub exists foo::bar::stub2] \
             [::foo::bar::stub2 a b c] \
             $debug
    }
} {1 {::foo::bar::stub2: a b c} 0 {::foo::bar::stub2: a b c} {(auto_load: ::foo::bar::stub2)}}

catch {interp delete $interp}

# ----------------------------------------------------------------------
#  Test "itcl::import::stub" command
# ----------------------------------------------------------------------
set interp [interp create]
$interp eval {
    package require Itcl
    proc auto_load {cmd {namespace {}}} {
        proc $cmd {args} [format {return "%s: $args"} $cmd]
        return 1
    }
}

test import-2.1 {initialize some commands for autoloading} {
    $interp eval {
        namespace eval test {
            namespace export foo*
        }
        itcl::import::stub create ::test::foo1
        itcl::import::stub create ::test::foo2
        lsort [info commands ::test::*]
    }
} {::test::foo1 ::test::foo2}

test import-2.2 {stubs can be imported into other namespaces} {
    $interp eval {
        namespace eval user1 { namespace import ::test::* }
        namespace eval user2 { namespace import ::test::* }
        namespace eval user3 { namespace import ::test::* }
        list [lsort [info commands ::user1::*]] \
             [namespace origin ::user1::foo1] \
             [namespace origin ::user1::foo2]
    }
} {{::user1::foo1 ::user1::foo2} ::test::foo1 ::test::foo2}

test import-2.3 {stubs can be autoloaded and imported links remain} {
    $interp eval {
        list [::user1::foo1 1 2 3 4] \
             [namespace origin ::user1::foo1] \
             [namespace origin ::user2::foo1] \
             [namespace origin ::user3::foo1] \
             [itcl::import::stub exists ::test::foo1]
    }
} {{::test::foo1: 1 2 3 4} ::test::foo1 ::test::foo1 ::test::foo1 0}

test import-2.3 {itcl::class handles stubs correctly} {
    $interp eval {
        proc auto_load {cmd {namespace {}}} {
            itcl::class $cmd { }
            return 1
        }
        list [::user2::foo2 x] \
             [x info class] \
             [namespace origin ::user1::foo2] \
             [namespace origin ::user2::foo2] \
             [namespace origin ::user3::foo2] \
             [itcl::import::stub exists ::test::foo2]
    }
} {x ::test::foo2 ::test::foo2 ::test::foo2 ::test::foo2 0}

test import-2.3 {itcl::class will overwrite stubs in an existing namespace} {
    $interp eval {
        namespace eval test::buried { }
        itcl::import::stub create ::test::buried
        itcl::import::stub create ::test::buried::stub
        list [catch {::test::buried xx} result] $result [xx info class]
    }
} {0 xx ::test::buried}

catch {interp delete $interp}

::tcltest::cleanupTests
return