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