# This file is a Tcl script to test out the procedures in the file
# tkCursor.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: cursor.test,v 1.8.2.1 2004/01/28 23:37:23 patthoyts 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 testcursor [llength [info commands testcursor]]

test cursor-1.1 {Tk_AllocCursorFromObj - converting internal reps} {testcursor} {
    set x watch
    lindex $x 0
    destroy .b1
    button .b1 -cursor $x
    lindex $x 0
    testcursor watch
} {{1 0}}
test cursor-1.2 {Tk_AllocCursorFromObj - discard stale cursor} {testcursor} {
    set x watch
    destroy .b1 .b2
    button .b1 -cursor $x
    destroy .b1
    set result {}
    lappend result [testcursor watch]
    button .b2 -cursor $x
    lappend result [testcursor watch]
} {{} {{1 1}}}
test cursor-1.3 {Tk_AllocCursorFromObj - reuse existing cursor} {testcursor} {
    set x watch
    destroy .b1 .b2
    button .b1 -cursor $x
    set result {}
    lappend result [testcursor watch]
    button .b2 -cursor $x
    pack .b1 .b2 -side top
    lappend result [testcursor watch]
} {{{1 1}} {{2 1}}}

test cursor-2.1 {Tk_GetCursor procedure} {
    destroy .b1
    list [catch {button .b1 -cursor bad_name} msg] $msg
} {1 {bad cursor spec "bad_name"}}
test cursor-2.2 {Tk_GetCursor procedure} {
    destroy .b1
    list [catch {button .b1 -cursor @xyzzy} msg] $msg
} {1 {bad cursor spec "@xyzzy"}}
# Next two tests need a helper file with a very specific name and
# controlled format.
set wincur(data_octal) {
    000 000 002 000 001 000 040 040 000 000 007 000 007 000 060 001
    000 000 026 000 000 000 050 000 000 000 040 000 000 000 100 000
    000 000 001 000 001 000 000 000 000 000 000 000 000 000 000 000
    000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000
    000 000 377 377 377 000 000 000 000 000 000 000 000 000 000 000
    000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000
    000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000
    000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000
    000 000 000 000 000 000 000 000 000 000 160 016 000 000 170 036
    000 000 174 076 000 000 076 174 000 000 037 370 000 000 017 360
    000 000 007 340 000 000 007 340 000 000 017 360 000 000 037 370
    000 000 076 174 000 000 174 076 000 000 170 036 000 000 160 016
    000 000 000 000 000 000 377 377 377 377 377 377 377 377 377 377
    377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377
    377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377
    377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377
    377 377 377 377 377 377 017 360 377 377 007 340 377 377 003 300
    377 377 001 200 377 377 200 001 377 377 300 003 377 377 340 007
    377 377 360 017 377 377 360 017 377 377 340 007 377 377 300 003
    377 377 200 001 377 377 001 200 377 377 003 300 377 377 007 340
    377 377 017 360 377 377
}
set wincur(data_binary) {}
foreach wincur(num) $wincur(data_octal) {
    append wincur(data_binary) [binary format c 0$wincur(num)]
}
set wincur(dir) [::tcltest::makeDirectory {dir with spaces}]
set wincur(file) [::tcltest::makeFile $wincur(data_binary) "test file.cur" $wincur(dir)]
test cursor-2.3 {Tk_GetCursor procedure: cursor specs are lists} {pcOnly} {
    destroy .b1
    button .b1 -cursor [list @$wincur(file)]
} {.b1}
test cursor-2.4 {Tk_GetCursor procedure: cursor specs are lists} {pcOnly} {
    destroy .b1
    button .b1 -cursor @[regsub -all {[][ \\{}""$#]} $wincur(file) {\\&}]
} {.b1}
::tcltest::removeDirectory $wincur(dir)
unset wincur

test cursor-3.1 {Tk_FreeCursorFromObj - reference counts} {testcursor} {
    set x heart
    destroy .b1 .b2 .b3
    button .b1 -cursor $x
    button .b3 -cursor $x
    button .b2 -cursor $x
    set result {}
    lappend result [testcursor heart]
    destroy .b1
    lappend result [testcursor heart]
    destroy .b2
    lappend result [testcursor heart]
    destroy .b3
    lappend result [testcursor heart]
} {{{3 1}} {{2 1}} {{1 1}} {}}

test cursor-4.1 {FreeCursorObjProc} {testcursor} {
    destroy .b
    set x [format heart]
    button .b -cursor $x
    set y [format heart]
    .b configure -cursor $y
    set z [format heart]
    .b configure -cursor $z
    set result {}
    lappend result [testcursor heart]
    set x red
    lappend result [testcursor heart]
    set z 32
    lappend result [testcursor heart]
    destroy .b
    lappend result [testcursor heart]
    set y bogus
    set result
} {{{1 3}} {{1 2}} {{1 1}} {}}

# -------------------------------------------------------------------------

test cursor-5.1 {assert consistent cursor configuration command} \
    -setup { button .b } \
    -body {
        list [catch {.b configure -cursor {watch red black}} msg] $msg
    } \
    -cleanup {destroy .b} \
    -result {0 {}}

# -------------------------------------------------------------------------
# Check for the standard set of cursors.

set n 0
foreach cursor {
    X_cursor
    arrow
    based_arrow_down
    based_arrow_up
    boat
    bogosity
    bottom_left_corner
    bottom_right_corner
    bottom_side
    bottom_tee
    box_spiral
    center_ptr
    circle
    clock
    coffee_mug
    cross
    cross_reverse
    crosshair
    diamond_cross
    dot
    dotbox
    double_arrow
    draft_large
    draft_small
    draped_box
    exchange
    fleur
    gobbler
    gumby
    hand1
    hand2
    heart
    icon
    iron_cross
    left_ptr
    left_side
    left_tee
    leftbutton
    ll_angle
    lr_angle
    man
    middlebutton
    mouse
    pencil
    pirate
    plus
    question_arrow
    right_ptr
    right_side
    right_tee
    rightbutton
    rtl_logo
    sailboat
    sb_down_arrow
    sb_h_double_arrow
    sb_left_arrow
    sb_right_arrow
    sb_up_arrow
    sb_v_double_arrow
    shuttle
    sizing
    spider
    spraycan
    star
    target
    tcross
    top_left_arrow
    top_left_corner
    top_right_corner
    top_side
    top_tee
    trek
    ul_angle
    umbrella
    ur_angle
    watch
    xterm
} {
    test cursor-6.$n {check cursor $cursor} \
        -setup {button .b -text $cursor} \
        -body {
            list [catch {.b configure -cursor $cursor} msg] $msg
        } \
        -cleanup {destroy .b} \
        -result {0 {}}
    incr n
}
unset n

# -------------------------------------------------------------------------
# Check the Windows specific cursors
set n 0
foreach cursor {
    no
    starting
    size
    size_ne_sw
    size_ns
    size_nw_se
    size_we
    uparrow
    wait
} {
    test cursor-7.$n {check cursor $cursor} \
        -constraints {pcOnly} \
        -setup {button .b -text $cursor} \
        -body {
            list [catch {.b configure -cursor $cursor} msg] $msg
        } \
        -cleanup {destroy .b} \
        -result {0 {}}
    incr n
}
unset n

# -------------------------------------------------------------------------
# Check the Mac specific cursors
set n 0
foreach cursor {
    text
    cross-hair
} {
    test cursor-8.$n {check cursor $cursor} \
        -constraints {macOnly} \
        -setup {button .b -text $cursor} \
        -body {
            list [catch {.b configure -cursor $cursor} msg] $msg
        } \
        -cleanup {destroy .b} \
        -result {0 {}}
    incr n
}
unset n

# -------------------------------------------------------------------------

destroy .t

# cleanup
::tcltest::cleanupTests
return