1#
2# Tests for "auto_import" and autoloading facility
3# ----------------------------------------------------------------------
4#   AUTHOR:  Michael J. McLennan
5#            Bell Labs Innovations for Lucent Technologies
6#            mmclennan@lucent.com
7#            http://www.tcltk.com/itcl
8#
9#      RCS:  $Id: import.test,v 1.6 2004/04/29 05:57:42 davygrvy Exp $
10# ----------------------------------------------------------------------
11#            Copyright (c) 1993-1998  Lucent Technologies, Inc.
12# ======================================================================
13# See the file "license.terms" for information on usage and
14# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
15
16if {[lsearch [namespace children] ::tcltest] == -1} {
17    package require tcltest 2.1
18    namespace import -force ::tcltest::test
19}
20
21::tcltest::loadTestedCommands
22
23# ----------------------------------------------------------------------
24#  Test "itcl::import::stub" command
25# ----------------------------------------------------------------------
26test import-1.1 {basic syntax for "stub" command} {
27    list [catch {itcl::import::stub} result] $result
28} {1 {wrong # args: should be one of...
29  stub create name
30  stub exists name}}
31
32test import-1.2 {"stub create" requires one argument} {
33    list [catch {itcl::import::stub create} result] $result \
34         [catch {itcl::import::stub create x y} result] $result
35} {1 {wrong # args: should be "itcl::import::stub create name"} 1 {wrong # args: should be "itcl::import::stub create name"}}
36
37test import-1.3 {"stub exists" requires one argument} {
38    list [catch {itcl::import::stub exists} result] $result \
39         [catch {itcl::import::stub exists x y} result] $result
40} {1 {wrong # args: should be "itcl::import::stub exists name"} 1 {wrong # args: should be "itcl::import::stub exists name"}}
41
42set interp [interp create]
43$interp eval [subst -novariables {
44    [::tcltest::configure -load]
45    proc auto_load {cmd {namespace {}}} {
46        global debug
47        proc $cmd {args} \[format {return "%s: $args"} $cmd\]
48        append debug "(auto_load: $cmd)"
49        return 1
50    }
51}]
52
53test import-1.4 {"stub create" creates a stub that triggers autoloading} {
54    $interp eval {
55        set debug ""
56        list [itcl::import::stub create foo::bar::test] \
57             [info commands ::foo::bar::test] \
58             [::foo::bar::test 1 2 3] \
59             $debug
60    }
61} {{} ::foo::bar::test {::foo::bar::test: 1 2 3} {(auto_load: ::foo::bar::test)}}
62
63test import-1.5 {"stub exists" recognizes stubs created by "stub create"} {
64    $interp eval {
65        set debug ""
66        itcl::import::stub create foo::bar::stub1
67        proc foo::bar::proc1 {{args {}}} {return "proc1: $args"}
68        list [itcl::import::stub exists foo::bar::stub1] \
69             [itcl::import::stub exists foo::bar::proc1]
70    }
71} {1 0}
72
73test import-1.6 {stubs can be autoloaded and replaced} {
74    $interp eval {
75        set debug ""
76        itcl::import::stub create foo::bar::stub2
77        list [itcl::import::stub exists foo::bar::stub2] \
78             [::foo::bar::stub2 a b c] \
79             [itcl::import::stub exists foo::bar::stub2] \
80             [::foo::bar::stub2 a b c] \
81             $debug
82    }
83} {1 {::foo::bar::stub2: a b c} 0 {::foo::bar::stub2: a b c} {(auto_load: ::foo::bar::stub2)}}
84
85catch {interp delete $interp}
86
87# ----------------------------------------------------------------------
88#  Test "itcl::import::stub" command
89# ----------------------------------------------------------------------
90set interp [interp create]
91$interp eval [subst -novariables {
92    [::tcltest::configure -load]
93    proc auto_load {cmd {namespace {}}} {
94        proc $cmd {args} \[format {return "%s: $args"} $cmd\]
95        return 1
96    }
97}]
98
99test import-2.1 {initialize some commands for autoloading} {
100    $interp eval {
101        namespace eval test {
102            namespace export foo*
103        }
104        itcl::import::stub create ::test::foo1
105        itcl::import::stub create ::test::foo2
106        lsort [info commands ::test::*]
107    }
108} {::test::foo1 ::test::foo2}
109
110test import-2.2 {stubs can be imported into other namespaces} {
111    $interp eval {
112        namespace eval user1 { namespace import ::test::* }
113        namespace eval user2 { namespace import ::test::* }
114        namespace eval user3 { namespace import ::test::* }
115        list [lsort [info commands ::user1::*]] \
116             [namespace origin ::user1::foo1] \
117             [namespace origin ::user1::foo2]
118    }
119} {{::user1::foo1 ::user1::foo2} ::test::foo1 ::test::foo2}
120
121test import-2.3 {stubs can be autoloaded and imported links remain} {
122    $interp eval {
123        list [::user1::foo1 1 2 3 4] \
124             [namespace origin ::user1::foo1] \
125             [namespace origin ::user2::foo1] \
126             [namespace origin ::user3::foo1] \
127             [itcl::import::stub exists ::test::foo1]
128    }
129} {{::test::foo1: 1 2 3 4} ::test::foo1 ::test::foo1 ::test::foo1 0}
130
131test import-2.3 {itcl::class handles stubs correctly} {
132    $interp eval {
133        proc auto_load {cmd {namespace {}}} {
134            itcl::class $cmd { }
135            return 1
136        }
137        list [::user2::foo2 x] \
138             [x info class] \
139             [namespace origin ::user1::foo2] \
140             [namespace origin ::user2::foo2] \
141             [namespace origin ::user3::foo2] \
142             [itcl::import::stub exists ::test::foo2]
143    }
144} {x ::test::foo2 ::test::foo2 ::test::foo2 ::test::foo2 0}
145
146test import-2.3 {itcl::class will overwrite stubs in an existing namespace} {
147    $interp eval {
148        namespace eval test::buried { }
149        itcl::import::stub create ::test::buried
150        itcl::import::stub create ::test::buried::stub
151        list [catch {::test::buried xx} result] $result [xx info class]
152    }
153} {0 xx ::test::buried}
154
155catch {interp delete $interp}
156
157::tcltest::cleanupTests
158return
159