path: root/itcl/iwidgets/tests/toolbar.test

# This file is a Tcl script to test out [incr Widgets] Toolbar class.
# It is organized in the standard fashion for Tcl tests with the following
# notation for test case labels:
#
#   1.x - Construction/Destruction tests
#   2.x - Configuration option tests
#   3.x - Method tests
#
# Copyright (c) 1995 DSC Technologies Corporation
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# @(#) $Id$

package require tcltest
namespace import -force ::tcltest::*

if [catch {package require Iwidgets 4.0}] {
  # Let's try modifying the auto_path.  Note that the IWIDGETS_LIBRARY
  # env var is initialized in the Makefile when doing a 'make test'.
  # If sourcing this file independently, this variable must be set manually.
  if ![info exists env(IWIDGETS_LIBRARY)] {
    error "Unable to locate Iwidgets package.  Set your IWIDGETS_LIBRARY\
      environment\nvariable to the directory that contains iwidgets.tcl"
  }
  lappend auto_path $env(IWIDGETS_LIBRARY)
  package require Iwidgets 4.0
}

if {[string compare test [info procs test]] == 1} {
    source defs
}

wm geometry . {}
raise .

set c 1
set o 1
set m 1

#
# Initial construction test
#
test Toolbar-1.$c {Toolbar construction} {
    iwidgets::Toolbar .tb
    pack .tb 
    update 
    .tb add button item1 -text item1 
    update 
    .tb add button item2 -text item2
    update 
    .tb add button item3 -text item3
    update 
} {}

incr c

#
# Option tests which are successful.
#
test Toolbar-2.$o {configuration option} {
    llength [.tb configure]
} {27}

incr o

foreach test {
	{-disabledforeground #a3a3a3 #a3a3a3 }
	{-highlightthickness 0 0 }
	{-selectborderwidth 4 4  }
	{-balloonfont 6x10 6x10 }
	{-balloondelay1 1000 1000 }
	{-balloondelay2 200 200 }
	{-borderwidth 2 2 }
	{-selectcolor #CDCDB7B7B5B5 #CDCDB7B7B5B5 }
	{-highlightcolor Black Black }
	{-font -Adobe-Helvetica-Bold-R-Normal--*-120-*-*-*-*-*-* -Adobe-Helvetica-Bold-R-Normal--*-120-*-*-*-*-*-* }
	{-balloonbackground yellow yellow }
	{-helpvariable testing testing}
	{-troughcolor #c3c3c3 #c3c3c3 }
	{-selectbackground #c3c3c3 #c3c3c3 }
	{-highlightbackground #d9d9d9 #d9d9d9 }
	{-background #CDCDB7B7B5B5 #CDCDB7B7B5B5 }
	{-state normal normal }
	{-balloonforeground black black }
	{-selectforeground Black Black }
	{-foreground #000000000000 #000000000000 }
	{-activebackground #ececec #ececec }
	{-insertbackground Black Black }
	{-cursor crosshair crosshair  }
	{-activeforeground Black Black }
	{-insertforeground Black Black }
	{-orient horizontal horizontal }
	} {
	set option [lindex $test 0]
	test Toolbar-2.$o "configuration options, $option" {
	    .tb configure $option [lindex $test 1] 
		.tb cget $option
	} [lindex $test 2]
	update 
	incr o
}

#
# Itemconfigure Option tests which are successful.
#
# This happens to be for a button.  Note that the configuration options for
# the Tk button changed in 8.4.  Four new options were added.
set newoptions [list -compound -overrelief -repeatdelay -repeatinterval]
set o 0
if {$::tk_version < 8.4} {
  test Toolbar-3.$o {tab configuration option} {
      llength [.tb itemconfigure 0]
  } {33}
} else {
  test Toolbar-3.$o {tab configuration option} {
      llength [.tb itemconfigure 0]
  } {37}
}

# do itemconfigure tests also...
foreach test {
	{0 -activebackground #ececec #ececec }
	{0 -activeforeground Black Black }
	{0 -anchor center center }
	{0 -background #d9d9d9 #d9d9d9 }
	{0 -bd 0 0 }
	{0 -bg #d9d9d9 #d9d9d9  }
	{0 -bitmap {} {} }
	{0 -borderwidth 2 2 }
	{0 -command {} {} }
	{0 -compound none none }
	{0 -cursor {} {} }
	{0 -default disabled disabled }
	{0 -disabledforeground #a3a3a3 #a3a3a3 }
	{0 -fg Black Black }
	{0 -font -Adobe-Helvetica-Bold-R-Normal--*-120-*-*-*-*-*-* -Adobe-Helvetica-Bold-R-Normal--*-120-*-*-*-*-*-* }
	{0 -foreground Black Black }
	{0 -height 0 0 }
	{0 -highlightbackground #d9d9d9 #d9d9d9 }
	{0 -highlightcolor Black Black }
	{0 -highlightthickness 2 2 }
	{0 -image  {} {} }
	{0 -justify center center }
	{0 -overrelief {} {} }
	{0 -padx 4 4 }
	{0 -pady 4 4 }
	{0 -relief raised raised }
	{0 -repeatdelay 0 0 }
	{0 -repeatinterval 0 0 }
	{0 -state normal normal }
	{0 -takefocus false false  }
	{0 -text {} {} }
	{0 -textvariable {} {}  }
	{0 -underline -1 -1 }
	{0 -width 0 0 }
	{0 -wraplength 0 0 }
	{0 -helpstr {} {} }
	{0 -balloonstr {} {} }
	} {
	  set option [lindex $test 1]
	  if {$::tk_version < 8.4} {
	    if {[lsearch $newoptions $option] != -1} {
	      # Skip it.
	      continue
	    }
	  }
	  set index  [lindex $test 0]
	  test Toolbar-2.$o "tab configuration options, $option" {
		.tb itemconfigure $index $option [lindex $test 2] 
		.tb itemcget $index $option
	  } [lindex $test 3]
	update 
	incr o
}


#
# Method tests which are successful.
#
foreach test {
    {{.tb delete 0 end}
		{}}
    {{.tb add radiobutton one} 
		{.tb.one}}
    {{.tb index end} 
		{0}}
    {{.tb add checkbutton two} 
		{.tb.two}}
    {{.tb index end} 
		{1}}
    {{.tb index one} 
		{0}}
    {{.tb insert end button oneandhalf -text "One & half"} 
		{.tb.oneandhalf}}
    {{.tb index oneandhalf} 
		{1}}
    {{.tb delete oneandhalf} 
		{}}
    {{.tb index two} 
		{1}}
    {{.tb delete 0 end} 
		{}}
    {{.tb index 0} 
		{-1}}
	} {
	set method [lindex [lindex $test 0] 1]
	set method_invoke [lindex $test 0]

	set testContents "set msg {}\n"
	append testContents \
	    "set result \[catch \{[lindex $test 0]\} msg\]\n"
	append testContents \
	    "lappend result \[regexp -- \{[lindex $test 1]\} \$msg\] \n"
	append testContents "set result\n"
	test Toolbar-4.$m "\[$method_invoke\]" $testContents \
		[list 0 1]
	update 
	incr m
}

#
# Method tests which fail and produce errors
#
foreach test {
		{1 {.tb delete 0 end} {}}
		{0 {.tb add button item1} {}}
		{0 {.tb delete 0} {}}
		{1 {.tb delete 0} {can't delete widget, no widgets in the Toolbar}}
		{0 {.tb add button item1} {}}
		{1 {.tb delete 1} {bad Toolbar widget index in delete method}}
		{0 {.tb delete 0} {}}
		{0 {.tb add button item1} {}}
		{1 {.tb delete 0 1} {bad Toolbar widget index2 in delete method}}
		{1 {.tb delete 1 4} {bad Toolbar widget index1 in delete method}}
		{0 {.tb add button item2} {}}
		{1 {.tb delete 1 0} {bad Toolbar widget index1 in delete method}}
		{0 {.tb delete 0 1} {}}
		{0 {.tb add button item1} {}}
		{1 {.tb delete 0 1 4 5 6} {wrong # args}}
		{1 {.tb delete} {wrong # args}}
		{0 {.tb delete 0} {}}
		{1 {.tb delete 0} {can't delete widget, no widgets in the Toolbar}}
		{1 {.tb insert 0 button itemA} {}}
		{0 {.tb add button item1} {}}
		{0 {.tb add button item2} {}}
		{0 {.tb insert 0 button itemAA} {}}
		{1 {.tb insert -1 button bogus} {bad toolbar entry index -1}}
		{0 {.tb delete 0 end} {}}
	} {
		set method_status [lindex $test 0]
		set method_invoke [lindex $test 1]
		set method [lindex $method_invoke 1]

		set testContents "set msg {}\n"
		append testContents \
		    "set result \[catch \{$method_invoke\} msg\]\n"
		append testContents \
		    "lappend result \[regexp -- \{[lindex $test 2]\} \$msg\] \n"
		append testContents "set result\n"
		test Toolbar-5.$m "\[$method_invoke\]" $testContents \
			[list $method_status 1]
	incr m
	}

#
# Conclusion of constrcution/destruction tests
#
test Toolbar-1.$c {Toolbar destruction} {
    destroy .tb
    update 
} {}

incr c

test Toolbar-1.$c {Toolbar construction} {
    iwidgets::Toolbar .tb 
    pack .tb 
    update 
    .tb add iwidgets::optionmenu opt
    update 
    .tb add button b
    update 
    .tb add frame filler
    update 
} {}

incr c

test Toolbar-1.$c {Toolbar destruction} {
	destroy .tb
    update 
} {}

::tcltest::cleanupTests
exit