1#
2# Old test suite for [incr Tcl] v1.5
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: Foo.tcl,v 1.1 1998/07/27 18:41:22 stanton 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
16itcl_class Foo {
17	#
18	#  Constructor/destructor add their name to a global var for
19	#  tracking implicit constructors/destructors
20	#
21	constructor {config} {
22		global WATCH
23		lappend WATCH [namespace current]
24		set foos([namespace tail $this]) $this
25		incr nfoo
26	}
27	destructor {
28		global WATCH
29		lappend WATCH [namespace current]
30		unset foos([namespace tail $this])
31	}
32
33	method nothing {} {}
34
35	method do {cmds} {
36		return "Foo says '[eval $cmds]'"
37	}
38
39	#
40	#  Test formal arguments for methods/procs
41	#  (formal args should not clobber data members)
42	#
43	method testMethodArgs {blit _blit args} {
44		return "$blit, $_blit, and [llength $args] other args"
45	}
46	proc testProcArgs {nfoo args} {
47		return "$nfoo, and [llength $args] other args"
48	}
49
50	#
51	#  Test methods using the "config" argument
52	#
53	method config {{config "-blit auto -blat matic"}} {
54		return $config
55	}
56	method xconfig {x config} {
57		return "$x|$config"
58	}
59	method configx {config x} {
60		return "$config|$x"
61	}
62	method xecho {x args} {
63		return "$x | [llength $args]: $args"
64	}
65
66	#
67	#  Test procs and access to common vars
68	#
69	proc echo {x args} {
70		return "$x | [llength $args]: $args"
71	}
72	proc foos {{pattern *}} {
73		set retn {}
74		foreach i [array names foos] {
75			if {$i != "_ignore_" && [string match $pattern $i]} {
76				lappend retn $i
77			}
78		}
79		return $retn
80	}
81	proc nfoos {} {
82		return $nfoo
83	}
84
85	#
86	#  Test public/protected/common variable definitions
87	#
88	public blit
89	public blat 0
90	public blot 1 {global WATCH; set WATCH "blot=$blot"}
91
92	protected _blit
93	protected _blat 0
94
95	common foos
96	set foos(_ignore_) "foos-is-now-an-array"
97
98	common nfoo 0
99}
100