path: root/iwidgets/tests/menubar.test

# This file is a Tcl script to test out [incr Widgets] Menubar 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 Menubar-1.$c {Menubar construction} {
    iwidgets::Menubar .mb -menubuttons {
		menubutton file -text File -menu {
			options -tearoff no
			command ok -label "Ok"
			command quit -label "Quit"
		}
	}
    pack .mb 
    update 
    .mb add menubutton .other -text Other -menu {
		radiobutton r1 -label "Radio One"
		radiobutton r2 -label "Radio Two"
	}
    update 
	.mb add menubutton view -text View -menu {
		command uno -label Uno
		command dos -label Dos
	}
	update
	.mb add cascade .view.more -label More -menu {
		command one -label One
		command two -label Two
		cascade extra -label Extra -menu {
			radiobutton rad1 -label "Choice One"
			radiobutton rad2 -label "Choice Two"
			cascade somemore \
					-label "Some More" \
					-helpstr "Yet some more" \
					-menu {
				command triangle -label "Triangle" -command {puts TRIANGLE}
				command square -label "Square" -command {puts SQUARE}
				command octagon -label "Octagon" -command {puts OCTAGON}
			}
		}
	}
    update 
} {}

incr c

#
# Option tests which are successful.
#
test Menubar-2.$o {configuration option} {
    llength [.mb configure]
} {22}

incr o

foreach test {
	{-anchor center center }
	{-disabledforeground #a3a3a3 #a3a3a3 }
	{-menubuttons {} {} }
	{-highlightthickness 0 0 }
	{-borderwidth 2 2 }
	{-helpvariable {} {} }
	{-highlightcolor Black Black }
	{-font -Adobe-Helvetica-Bold-R-Normal--*-120-*-*-*-*-*-* -Adobe-Helvetica-Bold-R-Normal--*-120-*-*-*-*-*-* }
	{-background #CDCDB7B7B5B5 #CDCDB7B7B5B5 }
	{-highlightbackground #d9d9d9 #d9d9d9 }
	{-activeborderwidth 2 2 }
	{-wraplength 0 0 }
	{-activebackground #ececec #ececec }
	{-padx 4 4 }
	{-pady 4 4 }
	{-justify center center }
	{-cursor {} {} }
	{-activeforeground black black }
	{-width 0 0 }
	{-height 0 0 }
	} {
	set option [lindex $test 0]
	test Menubar-2.$o "configuration options, $option" {
	    .mb configure $option [lindex $test 1] 
		.mb cget $option
	} [lindex $test 2]
	update 
	incr o
}

#
# Menuconfigure Option tests which are successful.
#
# This happens to be for a command...
test Menubar-3.$o {menubar menuconfiguration option} {
    llength [.mb menuconfigure .file.quit]
} {15}

# do menuconfigure tests also...
foreach test {
	{ .file.quit -activebackground red red }
	{ .file.quit -activeforeground red red }
	{ .file.quit -accelerator {} {}  }
	{ .file.quit -background red red }
	{ .file.quit -bitmap {} {} }
	{ .file.quit -command {} {}   }
	{ .file.quit -font fixed fixed  }
	{ .file.quit -foreground  red red }
	{ .file.quit -image {} {} }
	{ .file.quit -label hello hello }
	{ .file.quit -state normal normal }
	{ .file.quit -underline -1 -1 }
	{ .file.quit -helpstr {} {} }
	} {
		set index  [lindex $test 0]
		set option [lindex $test 1]
		test Menubar-2.$o "tab configuration options, $option" {
			.mb menuconfigure $index $option [lindex $test 2] 
			.mb menucget $index $option
		} [lindex $test 3]
	update 
	incr o
}

# test on cascade item
# This happens to be for a cascade...
test Menubar-3.$o {menubar menuconfiguration option} {
    llength [.mb menuconfigure .view.more]
} {17}

# do menuconfigure tests also...
foreach test {
	{ .view.more -activebackground red red }
	{ .view.more -activeforeground red red }
	{ .view.more -accelerator {} {}  }
	{ .view.more -background  red red}
	{ .view.more -bitmap {} {}  }
	{ .view.more -command {} {}  }
	{ .view.more -font   }
	{ .view.more -foreground   }
	{ .view.more -image {} {}  }
	{ .view.more -label {} {}  }
	{ .view.more -state normal normal }
	{ .view.more -underline -1 -1 }
	{ .view.more -helpstr {} {} }
	} {
		set index  [lindex $test 0]
		set option [lindex $test 1]
		test Menubar-2.$o "tab configuration options, $option" {
			.mb menuconfigure $index $option [lindex $test 2] 
			.mb menucget $index $option
		} [lindex $test 3]
	update 
	incr o
}

#
# Option tests which fail and produce errors.
#
#foreach test {
#	{ -OPTION BADVALUE {ERROR_MESSAGE} }
#	} {
#	set option [lindex $test 0]
#        test Menubar-2.$o "configuration options, $option" {
#	    list [catch {.bb configure $option [lindex $test 1]} msg] $msg
#	} [list 1 [lindex $test 2]]
#	incr o
#}

#
# Method tests which are successful.
#
foreach test {
    {{.mb delete 0 end}
		{}}
	{{.mb add menubutton .help -text Help}
		{}}
	{{.mb add command .help.context -label "On Context..."}
		{}}
	{{.mb insert .help.context command index -label "By Index..."}
		{}}
	{{.mb delete .help}
		{}}
	{{.mb add menubutton .help -text HELP -menu {
			command index -label "By Index..."
			command context -label "By Context..."
			separator sep1
			command keyword -label "By Keyword..."
		}}
		{}}
	{{.mb delete .help.sep1 .help.keyword}
		{}}
	{{.mb menuconfigure .help -text HeLp -menu {
			command index -label "By Index..."
			command context -label "By Context..."
			separator sep1
			command keyword -label "By Keyword..."
		}}
		{}}
	{{.mb configure -menubuttons {
		menubutton file -text File -menu {
			options -tearoff on
			command ok -label "OK"
			command quit -label "Quit"
			}
		}}
		{}}
	{{.mb add menubutton .other -text Other -menu {
		radiobutton r1 -label "Radio One"
		radiobutton r2 -label "Radio Two"
	}}
		{}}
	{{.mb insert .other menubutton view -text View -menu {
		command uno -label Uno
		command dos -label Dos
	}}
		{}}
	{{.mb add cascade .view.more -label More -menu {
		command one -label One
		command two -label Two
		cascade extra -label Extra -menu {
			radiobutton rad1 -label "Choice One"
			radiobutton rad2 -label "Choice Two"
			cascade somemore \
					-label "Some More" \
					-helpstr "Yet some more" \
					-menu {
				command triangle -label "Triangle" -command {puts TRIANGLE}
				command square -label "Square" -command {puts SQUARE}
				command octagon -label "Octagon" -command {puts OCTAGON}
			}
		}
	}}
		{}}
	{{.mb insert .view.uno cascade before -label Before -menu {
		command red -label Red
		command green -label Green
		command blue -label Blue
	}}
		{}}
	{{.mb add menubutton .help -text Help}
		{}}
	{{.mb add command .help.context -label "On Context..."}
		{}}
	{{.mb insert .help.context command index -label "By Index..."}
		{}}
	{{.mb insert .view.before.green cascade colors -label Colors -menu {
		command orange -label Orange -command "puts ORANGE" -helpstr "orange"
		separator sep1
		command purple -label Purple
	}}

		{}}
	{{.mb insert .view.before.colors.purple cascade morecolors -label "More Colors" -menu {}}
		{}}
	{{.mb add command .view.before.colors.morecolors.pink -label Pink}
		{}}
	{{.mb add command .view.before.colors.morecolors.peach -label Peach}
		{}}
	{{.mb add command .view.before.colors.morecolors.yellow -label Yellow}
		{}}
	{{.mb menuconfigure .view -text VIEW -menu {
		command o -label OH -command {puts OH}
		cascade negative -label Negative -menu {
			command print -label Print
			command save -label Save
		}
		# Comments are supported.
#		command dummy -label PlaceHolder
		cascade plus -label Plus -menu {
			command yep -label Yep
			command nope -label Nope
		}
	}}
		{}}
	{{.mb menuconfigure .view.negative -label NEGATIVE -menu {
		command print -label PRINT
		command save -label SAVE
	}}
		{}}
	{{.mb delete .0 .end}
		{}}
	} {
	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 Menubar-4.$m "\[$method_invoke\]" $testContents \
		[list 0 1]
	update 
	incr m
}

#
# Method tests which fail and produce errors or results
# Specifically, deals with method invocation on empty menubar.
#
foreach test {
		{1 {.mb delete .0 .last} 
			{bad path:}}
		{0 {.mb index .0} 
			{-1}}
		{0 {.mb index .end} 
			{-1}}
		{0 {.mb index .last} 
			{-1}}
		{0 {.mb index .help} 
			{-1}}
		{1 {.mb delete .0} 
			{bad path:}}
		{1 {.mb delete .end} 
			{bad path:}}
		{1 {.mb delete .last} 
			{bad path:}}
		{1 {.mb delete .help} 
			{bad path:}}
		{1 {.mb insert .0 menubutton file -text File} 
			{bad path:}}
		{1 {.mb insert .end menubutton file -text File} 
			{bad path:}}
		{1 {.mb insert .last menubutton file -text File} 
			{bad path:}}
		{1 {.mb insert .help menubutton file -text File} 
			{bad path:}}
		{1 {.mb invoke .0.0} 
			{bad path:}}
		{1 {.mb invoke .end.0} 
			{bad path:}}
		{1 {.mb invoke .last.0} 
			{bad path:}}
		{1 {.mb invoke .help.0} 
			{bad path:}}
		{1 {.mb menucget .0 -text} 
			{bad path:}}
		{1 {.mb menucget .end -text} 
			{bad path:}}
		{1 {.mb menucget .last -text} 
			{bad path:}}
		{1 {.mb menucget .help -text} 
			{bad path:}}
		{1 {.mb menuconfigure .0 -text} 
			{bad path:}}
		{1 {.mb menuconfigure .end -text} 
			{bad path:}}
		{1 {.mb menuconfigure .last -text} 
			{bad path:}}
		{1 {.mb menuconfigure .help -text} 
			{bad path:}}
		{0 {.mb path *quit} 
			{}}
		{1 {.mb type .0.0} 
			{bad path:}}
		{1 {.mb type .0.end} 
			{bad path:}}
		{1 {.mb type .0.last} 
			{bad path:}}
		{1 {.mb type .0.new} 
			{bad path:}}
		{1 {.mb yposition .0.new} 
			{bad path:}}
	} {
		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 Menubar-5.$m "\[$method_invoke\]" $testContents \
			[list $method_status 1]
	incr m
	}

#
# Method tests which fail and produce errors or results
# On a non-empty menubar...
foreach test {
		{0 {.mb configure -menubuttons {
			menubutton file -text File -menu {
				options -tearoff no
				command ok -label "Ok"
				command quit -label "Quit"
			}
		}}
			{}}
		{1 {.mb delete .file.hello} 
			{bad path}}
		{0 {.mb index .0.hello} 
			{-1}}
		{0 {.mb index .0.quit} 
			{1}}
		{0 {.mb index 0.end} 
			{1}}
		{0 {.mb index .file.last} 
			{1}}
		{0 {.mb index .file.ok} 
			{0}}
		{1 {.mb delete .view .file}
			{bad path:}}
		{1 {.mb delete .file .help}
			{bad path:}}
		{1 {.mb add command .file.menu}
			{bad name}}
		{1 {.mb add command .file.last}
			{bad name}}
		{1 {.mb add command .file.end}
			{bad name}}
		{1 {.mb add command .file.2}
			{bad name}}
		{1 {.mb insert .0 menu view -text View} 
			{bad type}}
		{1 {.mb insert .file command view -text View} 
			{bad entry path}}
		{0 {.mb insert .file menubutton view -text View} 
			{[.]mb[.]menubar[.]view}}
		{1 {.mb invoke .0.quit} 
			{bad path}}
		{0 {.mb menucget .0 -text} 
			{View}}
		{0 {.mb menucget .end -text} 
			{File}}
		{0 {.mb menucget .last -text} 
			{File}}
		{1 {.mb menucget .help -text} 
			{bad path}}
		{0 {.mb menuconfigure .0 -text} 
			{-text text Text {} View}}
		{0 {.mb menuconfigure .end.last -label} 
			{-label {} {} {} Quit}}
		{0 {.mb menuconfigure .last -text} 
			{-text text Text {} File}}
		{1 {.mb menuconfigure .help -text} 
			{bad path}}
		{0 {.mb path *quit} 
			{[.]file[.]quit}}
		{0 {.mb type .end.0} 
			{command}}
		{0 {.mb type .end.end} 
			{command}}
		{0 {.mb type .end.last} 
			{command}}
		{1 {.mb type .0.new} 
			{bad path}}
	} {
		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 Menubar-5.$m "\[$method_invoke\]" $testContents \
			[list $method_status 1]
	incr m
	}

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

incr c

test Menubar-1.$c {Menubar construction} {
    iwidgets::Menubar .mb -menubuttons {
		menubutton file -text File -menu {
			options -tearoff no
			command ok -label "Ok"
			command quit -label "Quit"
		}
	}
    pack .mb 
    update 
    .mb add menubutton .other -text Other -menu {
		radiobutton r1 -label "Radio One"
		radiobutton r2 -label "Radio Two"
	}
    update 
	.mb add menubutton view -text View -menu {
		command uno -label Uno
		command dos -label Dos
	}
	update
	.mb add cascade .view.more -label More -menu {
		command one -label One
		command two -label Two
		cascade extra -label Extra -menu {
			radiobutton rad1 -label "Choice One"
			radiobutton rad2 -label "Choice Two"
			cascade somemore \
					-label "Some More" \
					-helpstr "Yet some more" \
					-menu {
				command triangle -label "Triangle" -command {puts TRIANGLE}
				command square -label "Square" -command {puts SQUARE}
				command octagon -label "Octagon" -command {puts OCTAGON}
			}
		}
	}
    update 
} {}

incr c

test Menubar-1.$c {Menubar destruction} {
	destroy .mb
    update 
} {}

::tcltest::cleanupTests
exit