path: root/itcl/itcl/tests/old/basic.test

#
# Basic tests for class definition and method/proc access
# ----------------------------------------------------------------------
#   AUTHOR:  Michael J. McLennan
#            Bell Labs Innovations for Lucent Technologies
#            mmclennan@lucent.com
#            http://www.tcltk.com/itcl
#
#      RCS:  $Id$
# ----------------------------------------------------------------------
#            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.

# ----------------------------------------------------------------------
#  CLEAN THE SLATE
# ----------------------------------------------------------------------
foreach obj [itcl_info objects -class Foo] {
	$obj delete
}

# ----------------------------------------------------------------------
#  CREATING OBJECTS
# ----------------------------------------------------------------------
test {Create a simple object} {
	Foo x
} {
	$result == "x"
}

test {Make sure that object names cannot be duplicated} {
	catch "Foo x" errmsg
} {
	$result == 1
}

test {Create another object} {
	Foo xx
} {
	$result == "xx"
}

test {Create an object with an automatic name} {
	Foo #auto
} {
	[string match foo* $result]
}

test {Get list of objects in a class} {
	itcl_info objects -class Foo
} {
	[llength $result] == 3
}

# ----------------------------------------------------------------------
#  PUBLIC VARIABLES
# ----------------------------------------------------------------------
test {Info: all public variables} {
	x info public
} {
	[test_cmp_lists $result {Foo::blit Foo::blat Foo::blot}]
}

test {Info: public variable initial value} {
	x info public blit -init
} {
	$result == ""
}

test {Info: public variable initial value (undefined)} {
	x info public blit -value
} {
	$result == "<undefined>"
}

test {Info: public variable initial value} {
	x info public blat -init
} {
	$result == 0
}

test {Info: public variable current value} {
	x info public blot -value
} {
	$result == 1
}

test {Info: public variable config statement} {
	x info public blit -config
} {
	$result == ""
}

test {Info: public variable config statement} {
	x info public blot -config
} {
	$result == {global WATCH; set WATCH "blot=$blot"}
}

# ----------------------------------------------------------------------
#  CONFIG-ING PUBLIC VARIABLES
# ----------------------------------------------------------------------
test {Setting public variables via "config"} {
	x config -blit 27 -blat xyz
} {
	$result == "Foo::blit Foo::blat"
}

test {Info: public variable init/current value} {
	x info public blit -init -value
} {
	$result == {{} 27}
}

test {Info: public variable init/current value} {
	x info public blat -init -value
} {
	$result == {0 xyz}
}

test {"config" is ordinary arg if it is not last arg} {
	x configx -blit pdq
} {
	$result == {-blit|pdq}
}

test {Public variables with "config" code} {
	set WATCH ""
	concat [x config -blot abc] / $WATCH
} {
	$result == "Foo::blot / blot=abc"
}

test {Make sure object data is local to objects} {
	x config -blit abc
	xx config -blit xyz
	concat [x info public blit -value] / [xx info public blit -value]
} {
	$result == "abc / xyz"
}

# ----------------------------------------------------------------------
#  PROTECTED VARIABLES
# ----------------------------------------------------------------------
test {Info: all protected variables} {
	x info protected
} {
	[test_cmp_lists $result {Foo::_blit Foo::_blat Foo::this}]
}

test {Info: protected "this" variable} {
	x info protected this -value
} {
	$result == "::x"
}

test {Info: protected "this" variable} {
	xx info protected this -value
} {
	$result == "::xx"
}

test {Info: protected variable initial value} {
	x info protected _blit -init
} {
	$result == ""
}

test {Info: protected variable access/value} {
	x do {set _blit rst}
} {
	$result == "Foo says 'rst'" &&
	[x info protected _blit -value] == "rst"
}

# ----------------------------------------------------------------------
#  COMMON VARIABLES
# ----------------------------------------------------------------------
test {Info: all protected variables} {
	x info common
} {
	[test_cmp_lists $result {Foo::foos Foo::nfoo}]
}

test {Info: common variable initial value} {
	x info common foos -init
} {
	$result == ""
}

test {Info: common variable initial value} {
	x info common nfoo -init
} {
	$result == 0
}

test {Info: common variable access/value} {
	x do {set nfoo 999}
	x info common nfoo -value
} {
	$result == 999
}

test {Make sure common data is really common} {
	x do {set nfoo 0}
	x info common nfoo -value
} {
	$result == [xx info common nfoo -value]
}

test {Access common data in proc} {
	x do {set nfoo 10}
	Foo :: nfoos
} {
	$result == 10
}

test {Common variables can be initialized within class definition} {
	x do {if {[info exists foos(_ignore_)]} {set foos(_ignore_)}}
} {
	$result == "Foo says 'foos-is-now-an-array'"
}

test {Arrays as common data} {
	Foo :: foos
} {
	[test_cmp_lists $result [itcl_info objects -class Foo]]
}

# ----------------------------------------------------------------------
#  METHODS
# ----------------------------------------------------------------------
test {Info: all methods} {
	x info method
} {
	[test_cmp_lists $result {
		Foo::constructor Foo::destructor
		Foo::nothing Foo::do Foo::xecho
		Foo::config Foo::xconfig Foo::configx
		Foo::testMethodArgs
		Foo::configure Foo::delete Foo::cget Foo::isa
	}]
}

test {Info: method args} {
	x info method nothing -args
} {
	$result == ""
}

test {Info: method args} {
	x info method xconfig -args
} {
	$result == "x config"
}

test {Info: method body} {
	x info method nothing -body
} {
	$result == ""
}

test {Info: method body} {
	x info method xconfig -body
} {
	$result == {
		return "$x|$config"
	}
}

# ----------------------------------------------------------------------
#  PROCS
# ----------------------------------------------------------------------
test {Info: all procs} {
	x info proc
} {
	[test_cmp_lists $result {
		Foo::echo Foo::foos Foo::nfoos Foo::testProcArgs
	}]
}

test {Info: proc args} {
	x info proc nfoos -args
} {
	$result == ""
}

test {Info: proc args} {
	x info proc foos -args
} {
	$result == "{pattern *}"
}

test {Info: proc body} {
	x info proc nfoos -body
} {
	$result == {
		return $nfoo
	}
}

test {Info: proc body} {
	x info body nfoos
} {
	$result == {
		return $nfoo
	}
}

# ----------------------------------------------------------------------
#  ARGUMENT LISTS
# ----------------------------------------------------------------------
test {Default arguments can get assigned a proper value} {
	Foo :: foos x*
} {
	[test_cmp_lists $result {x xx}]
}

test {Default value for "config" argument} {
	x config
} {
	$result == "Foo::blit Foo::blat" &&
	[x info public blit -value] == "auto" &&
	[x info public blat -value] == "matic"
}

test {"args" formal argument absorbs extra arguments} {
	Foo :: echo abc 1 2 3
} {
	$result == "abc | 3: 1 2 3"
}

test {"args" formal argument absorbs extra arguments} {
	Foo :: echo def
} {
	$result == "def | 0: "
}

test {"args" formal argument absorbs extra arguments} {
	x xecho abc 1 2 3
} {
	$result == "abc | 3: 1 2 3"
}

test {"args" formal argument absorbs extra arguments} {
	x xecho def
} {
	$result == "def | 0: "
}

test {Extra args cause an error} {
	catch "x configx arg arg error"
} {
	$result != 0
}

test {Extra args cause an error} {
	catch "x nothing error"
} {
	$result != 0
}

test {Formal arguments don't clobber public/protected variables} {
	x do {
		set blit okay
		set _blit no-problem
	}
	x testMethodArgs yuck puke etc.
} {
	$result == "yuck, puke, and 1 other args" &&
	[x info public blit -value] == "okay" &&
	[x info protected _blit -value] == "no-problem"
}

test {Formal arguments don't clobber common variables} {
	Foo :: testProcArgs yuck etc.
} {
	$result == "yuck, and 1 other args" &&
	[x info common nfoo -value] != "yuck"
}

# ----------------------------------------------------------------------
#  DELETING OBJECTS
# ----------------------------------------------------------------------
test {Delete an object} {
	x delete
} {
	$result == ""
}

test {Delete an object} {
	xx delete
} {
	$result == ""
}

test {Destructor is properly invoked} {
	Foo :: foos
} {
	[test_cmp_lists $result [itcl_info objects -class Foo]]
}

test {Object names are removed as commands} {
	expr {[info commands x] == "" && [info commands xx] == ""}
} {
	$result == 1
}