home *** CD-ROM | disk | FTP | other *** search
/ Il CD di internet / CD.iso / SOURCE / TCL / ITCL / _ITCL.TAR / usr / lib / itcl / tests / Foo.tcl < prev    next >
Encoding:
Text File  |  1994-04-25  |  3.0 KB  |  113 lines
  1. #
  2. # Test class for [incr Tcl] test suite
  3. # ----------------------------------------------------------------------
  4. #   AUTHOR:  Michael J. McLennan       Phone: (610)712-2842
  5. #            AT&T Bell Laboratories   E-mail: michael.mclennan@att.com
  6. #
  7. #      RCS:  Foo.tcl,v 1.2 1994/04/25 19:15:06 mmc Exp
  8. # ----------------------------------------------------------------------
  9. #               Copyright (c) 1993  AT&T Bell Laboratories
  10. # ======================================================================
  11. # Permission to use, copy, modify, and distribute this software and its
  12. # documentation for any purpose and without fee is hereby granted,
  13. # provided that the above copyright notice appear in all copies and that
  14. # both that the copyright notice and warranty disclaimer appear in
  15. # supporting documentation, and that the names of AT&T Bell Laboratories
  16. # any of their entities not be used in advertising or publicity
  17. # pertaining to distribution of the software without specific, written
  18. # prior permission.
  19. #
  20. # AT&T disclaims all warranties with regard to this software, including
  21. # all implied warranties of merchantability and fitness.  In no event
  22. # shall AT&T be liable for any special, indirect or consequential
  23. # damages or any damages whatsoever resulting from loss of use, data or
  24. # profits, whether in an action of contract, negligence or other
  25. # tortuous action, arising out of or in connection with the use or
  26. # performance of this software.
  27. # ======================================================================
  28.  
  29. itcl_class Foo {
  30.     #
  31.     #  Constructor/destructor add their name to a global var for
  32.     #  tracking implicit constructors/destructors
  33.     #
  34.     constructor {config} {
  35.         global WATCH
  36.         lappend WATCH [info class]
  37.         set foos($this) $this
  38.         incr nfoo
  39.     }
  40.     destructor {
  41.         global WATCH
  42.         lappend WATCH [info class]
  43.         unset foos($this)
  44.     }
  45.  
  46.     method nothing {} {}
  47.  
  48.     method do {cmds} {
  49.         return "Foo says '[eval $cmds]'"
  50.     }
  51.  
  52.     #
  53.     #  Test formal arguments for methods/procs
  54.     #  (formal args should not clobber data members)
  55.     #
  56.     method testMethodArgs {blit _blit args} {
  57.         return "$blit, $_blit, and [llength $args] other args"
  58.     }
  59.     proc testProcArgs {nfoo args} {
  60.         return "$nfoo, and [llength $args] other args"
  61.     }
  62.  
  63.     #
  64.     #  Test methods using the "config" argument
  65.     #
  66.     method config {{config -blit auto -blat matic}} {
  67.         return $config
  68.     }
  69.     method xconfig {x config} {
  70.         return "$x|$config"
  71.     }
  72.     method configx {config x} {
  73.         return "$config|$x"
  74.     }
  75.     method xecho {x args} {
  76.         return "$x | [llength $args]: $args"
  77.     }
  78.  
  79.     #
  80.     #  Test procs and access to common vars
  81.     #
  82.     proc echo {x args} {
  83.         return "$x | [llength $args]: $args"
  84.     }
  85.     proc foos {{pattern *}} {
  86.         set retn {}
  87.         foreach i [array names foos] {
  88.             if {$i != "_ignore_" && [string match $pattern $foos($i)]} {
  89.                 lappend retn $foos($i)
  90.             }
  91.         }
  92.         return $retn
  93.     }
  94.     proc nfoos {} {
  95.         return $nfoo
  96.     }
  97.  
  98.     #
  99.     #  Test public/protected/common variable definitions
  100.     #
  101.     public blit
  102.     public blat 0
  103.     public blot 1 {global WATCH; set WATCH "blot=$blot"}
  104.  
  105.     protected _blit
  106.     protected _blat 0
  107.  
  108.     common foos
  109.     set foos(_ignore_) "foos-is-now-an-array"
  110.  
  111.     common nfoo 0
  112. }
  113.