tk/tests/bitmap.test

   1 # This file is a Tcl script to test out the procedures in the file
   2 # tkBitmap.c.  It is organized in the standard white-box fashion for
   3 # Tcl tests.
   4 #
   5 # Copyright (c) 1998 Sun Microsystems, Inc.
   6 # Copyright (c) 1998-1999 by Scriptics Corporation.
   7 # All rights reserved.
   8 #
   9 # RCS: @(#) $Id$
  10
  11 package require tcltest 2.1
  12 namespace import -force tcltest::configure
  13 namespace import -force tcltest::testsDirectory
  14 configure -testdir [file join [pwd] [file dirname [info script]]]
  15 configure -loadfile [file join [testsDirectory] constraints.tcl]
  16 tcltest::loadTestedCommands
  17
  18 testConstraint testbitmap [llength [info commands testbitmap]]
  19
  20 test bitmap-1.1 {Tk_AllocBitmapFromObj - converting internal reps} testbitmap {
  21     set x gray25
  22     lindex $x 0
  23     destroy .b1
  24     button .b1 -bitmap $x
  25     lindex $x 0
  26     testbitmap gray25
  27 } {{1 0}}
  28 test bitmap-1.2 {Tk_AllocBitmapFromObj - discard stale bitmap} testbitmap {
  29     set x gray25
  30     destroy .b1 .b2
  31     button .b1 -bitmap $x
  32     destroy .b1
  33     set result {}
  34     lappend result [testbitmap gray25]
  35     button .b2 -bitmap $x
  36     lappend result [testbitmap gray25]
  37 } {{} {{1 1}}}
  38 test bitmap-1.3 {Tk_AllocBitmapFromObj - reuse existing bitmap} testbitmap {
  39     set x gray25
  40     destroy .b1 .b2
  41     button .b1 -bitmap $x
  42     set result {}
  43     lappend result [testbitmap gray25]
  44     button .b2 -bitmap $x
  45     pack .b1 .b2 -side top
  46     lappend result [testbitmap gray25]
  47 } {{{1 1}} {{2 1}}}
  48
  49 test bitmap-2.1 {Tk_GetBitmap procedure} {
  50     destroy .b1
  51     list [catch {button .b1 -bitmap bad_name} msg] $msg
  52 } {1 {bitmap "bad_name" not defined}}
  53 test bitmap-2.2 {Tk_GetBitmap procedure} {
  54     destroy .b1
  55     list [catch {button .b1 -bitmap @xyzzy} msg] $msg
  56 } {1 {error reading bitmap file "xyzzy"}}
  57
  58 test bitmap-3.1 {Tk_FreeBitmapFromObj - reference counts} testbitmap {
  59     set x questhead
  60     destroy .b1 .b2 .b3
  61     button .b1 -bitmap $x
  62     button .b3 -bitmap $x
  63     button .b2 -bitmap $x
  64     set result {}
  65     lappend result [testbitmap questhead]
  66     destroy .b1
  67     lappend result [testbitmap questhead]
  68     destroy .b2
  69     lappend result [testbitmap questhead]
  70     destroy .b3
  71     lappend result [testbitmap questhead]
  72 } {{{3 1}} {{2 1}} {{1 1}} {}}
  73
  74 test bitmap-4.1 {FreeBitmapObjProc} testbitmap {
  75     destroy .b
  76     set x [format questhead]
  77     button .b -bitmap $x
  78     set y [format questhead]
  79     .b configure -bitmap $y
  80     set z [format questhead]
  81     .b configure -bitmap $z
  82     set result {}
  83     lappend result [testbitmap questhead]
  84     set x red
  85     lappend result [testbitmap questhead]
  86     set z 32
  87     lappend result [testbitmap questhead]
  88     destroy .b
  89     lappend result [testbitmap questhead]
  90     set y bogus
  91     set result
  92 } {{{1 3}} {{1 2}} {{1 1}} {}}
  93
  94 destroy .t
  95
  96 # cleanup
  97 ::tcltest::cleanupTests
  98 return
  99
 100
 101
 102
 103
 104
 105
 106
 107
 108
 109
 110
 111