# This file is a Tcl script to test out the procedures in the file # tkBitmap.c. It is organized in the standard white-box fashion for # Tcl tests. # # Copyright (c) 1998 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # # RCS: @(#) $Id: bitmap.test,v 1.1.1.1 2007/07/10 15:05:18 duncan Exp $ package require tcltest 2.1 namespace import -force tcltest::configure namespace import -force tcltest::testsDirectory configure -testdir [file join [pwd] [file dirname [info script]]] configure -loadfile [file join [testsDirectory] constraints.tcl] tcltest::loadTestedCommands testConstraint testbitmap [llength [info commands testbitmap]] test bitmap-1.1 {Tk_AllocBitmapFromObj - converting internal reps} testbitmap { set x gray25 lindex $x 0 destroy .b1 button .b1 -bitmap $x lindex $x 0 testbitmap gray25 } {{1 0}} test bitmap-1.2 {Tk_AllocBitmapFromObj - discard stale bitmap} testbitmap { set x gray25 destroy .b1 .b2 button .b1 -bitmap $x destroy .b1 set result {} lappend result [testbitmap gray25] button .b2 -bitmap $x lappend result [testbitmap gray25] } {{} {{1 1}}} test bitmap-1.3 {Tk_AllocBitmapFromObj - reuse existing bitmap} testbitmap { set x gray25 destroy .b1 .b2 button .b1 -bitmap $x set result {} lappend result [testbitmap gray25] button .b2 -bitmap $x pack .b1 .b2 -side top lappend result [testbitmap gray25] } {{{1 1}} {{2 1}}} test bitmap-2.1 {Tk_GetBitmap procedure} { destroy .b1 list [catch {button .b1 -bitmap bad_name} msg] $msg } {1 {bitmap "bad_name" not defined}} test bitmap-2.2 {Tk_GetBitmap procedure} { destroy .b1 list [catch {button .b1 -bitmap @xyzzy} msg] $msg } {1 {error reading bitmap file "xyzzy"}} test bitmap-3.1 {Tk_FreeBitmapFromObj - reference counts} testbitmap { set x questhead destroy .b1 .b2 .b3 button .b1 -bitmap $x button .b3 -bitmap $x button .b2 -bitmap $x set result {} lappend result [testbitmap questhead] destroy .b1 lappend result [testbitmap questhead] destroy .b2 lappend result [testbitmap questhead] destroy .b3 lappend result [testbitmap questhead] } {{{3 1}} {{2 1}} {{1 1}} {}} test bitmap-4.1 {FreeBitmapObjProc} testbitmap { destroy .b set x [format questhead] button .b -bitmap $x set y [format questhead] .b configure -bitmap $y set z [format questhead] .b configure -bitmap $z set result {} lappend result [testbitmap questhead] set x red lappend result [testbitmap questhead] set z 32 lappend result [testbitmap questhead] destroy .b lappend result [testbitmap questhead] set y bogus set result } {{{1 3}} {{1 2}} {{1 1}} {}} destroy .t # cleanup ::tcltest::cleanupTests return