Subversion Repositories or1k

# This file is a Tcl script to test out the procedures in the file

# tkUnixEmbed.c.  It is organized in the standard fashion for Tcl

# tests.

#

# Copyright (c) 1996-1997 Sun Microsystems, Inc.

#

# See the file "license.terms" for information on usage and redistribution

# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

#

# RCS: @(#) $Id: unixEmbed.test,v 1.1.1.1 2002-01-16 10:26:00 markom Exp $

if {$tcl_platform(platform) != "unix"} {

    return

}

if {[info procs test] != "test"} {

    source defs

}

eval destroy [winfo children .]

wm geometry . {}

raise .

setupbg

dobg {wm withdraw .}

# eatColors --

# Creates a toplevel window and allocates enough colors in it to

# use up all the slots in the colormap.

#

# Arguments:

# w -           Name of toplevel window to create.

proc eatColors {w} {

    catch {destroy $w}

    toplevel $w

    wm geom $w +0+0

    canvas $w.c -width 400 -height 200 -bd 0

    pack $w.c

    for {set y 0} {$y < 8} {incr y} {

        for {set x 0} {$x < 40} {incr x} {

            set color [format #%02x%02x%02x [expr $x*6] [expr $y*30] 0]

            $w.c create rectangle [expr 10*$x] [expr 20*$y] \

                    [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \

                    -fill $color

        }

    }

    update

}

# colorsFree --

#

# Returns 1 if there appear to be free colormap entries in a window,

# 0 otherwise.

#

# Arguments:

# w -                   Name of window in which to check.

# red, green, blue -    Intensities to use in a trial color allocation

#                       to see if there are colormap entries free.

proc colorsFree {w {red 31} {green 245} {blue 192}} {

    set vals [winfo rgb $w [format #%02x%02x%02x $red $green $blue]]

    expr ([lindex $vals 0]/256 == $red) && ([lindex $vals 1]/256 == $green) \

            && ([lindex $vals 2]/256 == $blue)

}

test unixEmbed-1.1 {TkpUseWindow procedure, bad window identifier} {

    catch {destroy .t}

    list [catch {toplevel .t -use xyz} msg] $msg

} {1 {expected integer but got "xyz"}}

test unixEmbed-1.2 {TkpUseWindow procedure, bad window identifier} {

    catch {destroy .t}

    list [catch {toplevel .t -use 47} msg] $msg

} {1 {couldn't create child of window "47"}}

test unixEmbed-1.3 {TkpUseWindow procedure, inheriting colormap} {

    catch {destroy .t}

    catch {destroy .x}

    toplevel .t -colormap new

    wm geometry .t +0+0

    eatColors .t.t

    frame .t.f -container 1

    toplevel .x -use [winfo id .t.f]

    set result [colorsFree .x]

    destroy .t

    set result

} {0}

test unixEmbed-1.4 {TkpUseWindow procedure, inheriting colormap} {

    catch {destroy .t}

    catch {destroy .t2}

    catch {destroy .x}

    toplevel .t -container 1 -colormap new

    wm geometry .t +0+0

    eatColors .t2

    toplevel .x -use [winfo id .t]

    set result [colorsFree .x]

    destroy .t

    set result

} {1}

if {[string compare testembed [info commands testembed]] != 0} {

    puts "This application hasn't been compiled with the testembed command,"

    puts "therefore I am skipping all of these tests."

    return

}

test unixEmbed-1.5 {TkpUseWindow procedure, creating Container records} {

    eval destroy [winfo child .]

    frame .f1 -container 1 -width 200 -height 50

    frame .f2 -container 1 -width 200 -height 50

    pack .f1 .f2

    dobg "set w [winfo id .f1]"

    dobg {

        eval destroy [winfo child .]

        toplevel .t -use $w

        list [testembed] [expr [lindex [lindex [testembed all] 0] 0] - $w]

    }

} {{{XXX {} {} .t}} 0}

test unixEmbed-1.6 {TkpUseWindow procedure, creating Container records} {

    eval destroy [winfo child .]

    frame .f1 -container 1 -width 200 -height 50

    frame .f2 -container 1 -width 200 -height 50

    pack .f1 .f2

    dobg "set w1 [winfo id .f1]"

    dobg "set w2 [winfo id .f2]"

    dobg {

        eval destroy [winfo child .]

        toplevel .t1 -use $w1

        toplevel .t2 -use $w2

        testembed

    }

} {{XXX {} {} .t2} {XXX {} {} .t1}}

test unixEmbed-1.7 {TkpUseWindow procedure, container and embedded in same app} {

    eval destroy [winfo child .]

    frame .f1 -container 1 -width 200 -height 50

    frame .f2 -container 1 -width 200 -height 50

    pack .f1 .f2

    toplevel .t1 -use [winfo id .f1]

    toplevel .t2 -use [winfo id .f2]

    testembed

} {{XXX .f2 {} .t2} {XXX .f1 {} .t1}}

# Can't think of any way to test the procedures TkpMakeWindow,

# TkpMakeContainer, or EmbedErrorProc.

test unixEmbed-2.1 {EmbeddedEventProc procedure} {

    foreach w [winfo child .] {

        catch {destroy $w}

    }

    frame .f1 -container 1 -width 200 -height 50

    pack .f1

    dobg "set w1 [winfo id .f1]"

    dobg {

        eval destroy [winfo child .]

        toplevel .t1 -use $w1

        testembed

    }

    destroy .f1

    update

    dobg {

        testembed

    }

} {}

test unixEmbed-2.2 {EmbeddedEventProc procedure} {

    foreach w [winfo child .] {

        catch {destroy $w}

    }

    frame .f1 -container 1 -width 200 -height 50

    pack .f1

    dobg "set w1 [winfo id .f1]"

    dobg {

        eval destroy [winfo child .]

        toplevel .t1 -use $w1

        testembed

        destroy .t1

        testembed

    }

} {}

test unixEmbed-2.3 {EmbeddedEventProc procedure} {

    foreach w [winfo child .] {

        catch {destroy $w}

    }

    frame .f1 -container 1 -width 200 -height 50

    pack .f1

    toplevel .t1 -use [winfo id .f1]

    update

    destroy .f1

    testembed

} {}

test unixEmbed-2.4 {EmbeddedEventProc procedure} {

    foreach w [winfo child .] {

        catch {destroy $w}

    }

    frame .f1 -container 1 -width 200 -height 50

    pack .f1

    toplevel .t1 -use [winfo id .f1]

    update

    destroy .t1

    set x [testembed]

    update

    list $x [testembed]

} {{{XXX .f1 {} {}}} {}}

test unixEmbed-3.1 {ContainerEventProc procedure, detect creation} {

    foreach w [winfo child .] {

        catch {destroy $w}

    }

    frame .f1 -container 1 -width 200 -height 50

    pack .f1

    dobg "set w1 [winfo id .f1]"

    set x [testembed]

    dobg {

        eval destroy [winfo child .]

        toplevel .t1 -use $w1

        wm withdraw .t1

    }

    list $x [testembed]

} {{{XXX .f1 {} {}}} {{XXX .f1 XXX {}}}}

test unixEmbed-3.2 {ContainerEventProc procedure, set size on creation} {

    foreach w [winfo child .] {

        catch {destroy $w}

    }

    toplevel .t1 -container 1

    wm geometry .t1 +0+0

    toplevel .t2 -use [winfo id .t1] -bg red

    update

    wm geometry .t2

} {200x200+0+0}

test unixEmbed-3.2 {ContainerEventProc procedure, disallow position changes} {

    foreach w [winfo child .] {

        catch {destroy $w}

    }

    frame .f1 -container 1 -width 200 -height 50

    pack .f1

    dobg "set w1 [winfo id .f1]"

    dobg {

        eval destroy [winfo child .]

        toplevel .t1 -use $w1 -bd 2 -relief raised

        update

        wm geometry .t1 +30+40

    }

    update

    dobg {

        wm geometry .t1

    }

} {200x200+0+0}

test unixEmbed-3.3 {ContainerEventProc procedure, disallow position changes} {

    foreach w [winfo child .] {

        catch {destroy $w}

    }

    frame .f1 -container 1 -width 200 -height 50

    pack .f1

    dobg "set w1 [winfo id .f1]"

    dobg {

        eval destroy [winfo child .]

        toplevel .t1 -use $w1

        update

        wm geometry .t1 300x100+30+40

    }

    update

    dobg {

        wm geometry .t1

    }

} {300x100+0+0}

test unixEmbed-3.4 {ContainerEventProc procedure, geometry requests} {

    foreach w [winfo child .] {

        catch {destroy $w}

    }

    frame .f1 -container 1 -width 200 -height 50

    pack .f1

    dobg "set w1 [winfo id .f1]"

    dobg {

        eval destroy [winfo child .]

        toplevel .t1 -use $w1

    }

    update

    dobg {

        .t1 configure -width 300 -height 80

    }

    update

    list [winfo width .f1] [winfo height .f1] [dobg {wm geometry .t1}]

} {300 80 300x80+0+0}

test unixEmbed-3.5 {ContainerEventProc procedure, map requests} {

    foreach w [winfo child .] {

        catch {destroy $w}

    }

    frame .f1 -container 1 -width 200 -height 50

    pack .f1

    dobg "set w1 [winfo id .f1]"

    dobg {

        eval destroy [winfo child .]

        toplevel .t1 -use $w1

        set x unmapped

        bind .t1 

    }

    update

    dobg {

        after 100

        update

        set x

    }

} {mapped}

test unixEmbed-3.6 {ContainerEventProc procedure, destroy events} {

    foreach w [winfo child .] {

        catch {destroy $w}

    }

    frame .f1 -container 1 -width 200 -height 50

    pack .f1

    dobg "set w1 [winfo id .f1]"

    bind .f1  {set x dead}

    set x alive

    dobg {

        eval destroy [winfo child .]

        toplevel .t1 -use $w1

    }

    update

    dobg {

        destroy .t1

    }

    update

    list $x [winfo exists .f1]

} {dead 0}

test unixEmbed-4.1 {EmbedStructureProc procedure, configure events} {

    foreach w [winfo child .] {

        catch {destroy $w}

    }

    frame .f1 -container 1 -width 200 -height 50

    pack .f1

    dobg "set w1 [winfo id .f1]"

    dobg {

        eval destroy [winfo child .]

        toplevel .t1 -use $w1

    }

    update

    dobg {

        .t1 configure -width 180 -height 100

    }

    update

    dobg {

        winfo geometry .t1

    }

} {180x100+0+0}

test unixEmbed-4.2 {EmbedStructureProc procedure, destroy events} {

    foreach w [winfo child .] {

        catch {destroy $w}

    }

    frame .f1 -container 1 -width 200 -height 50

    pack .f1

    dobg "set w1 [winfo id .f1]"

    dobg {

        eval destroy [winfo child .]

        toplevel .t1 -use $w1

    }

    update

    set x [testembed]

    destroy .f1

    list $x [testembed]

} {{{XXX .f1 XXX {}}} {}}

test unixEmbed-5.1 {EmbedFocusProc procedure, FocusIn events} {

    foreach w [winfo child .] {

        catch {destroy $w}

    }

    frame .f1 -container 1 -width 200 -height 50

    pack .f1

    dobg "set w1 [winfo id .f1]"

    dobg {

        eval destroy [winfo child .]

        toplevel .t1 -use $w1

        bind .t1  {lappend x "focus in %W"}

        bind .t1  {lappend x "focus out %W"}

        set x {}

    }

    focus -force .f1

    update

    dobg {set x}

} {{focus in .t1}}

test unixEmbed-5.2 {EmbedFocusProc procedure, focusing on dead window} {

    foreach w [winfo child .] {

        catch {destroy $w}

    }

    frame .f1 -container 1 -width 200 -height 50

    pack .f1

    dobg "set w1 [winfo id .f1]"

    dobg {

        eval destroy [winfo child .]

        toplevel .t1 -use $w1

    }

    update

    dobg {

        after 200 {destroy .t1}

    }

    after 400

    focus -force .f1

    update

} {}

test unixEmbed-5.3 {EmbedFocusProc procedure, FocusOut events} {

    foreach w [winfo child .] {

        catch {destroy $w}

    }

    frame .f1 -container 1 -width 200 -height 50

    pack .f1

    dobg "set w1 [winfo id .f1]"

    dobg {

        eval destroy [winfo child .]

        toplevel .t1 -use $w1

        bind .t1  {lappend x "focus in %W"}

        bind .t1  {lappend x "focus out %W"}

        set x {}

    }

    focus -force .f1

    update

    set x [dobg {update; set x}]

    focus .

    update

    list $x [dobg {update; set x}]

} {{{focus in .t1}} {{focus in .t1} {focus out .t1}}}

test unixEmbed-6.1 {EmbedGeometryRequest procedure, window changes size} {

    foreach w [winfo child .] {

        catch {destroy $w}

    }

    frame .f1 -container 1 -width 200 -height 50

    pack .f1

    dobg "set w1 [winfo id .f1]"

    dobg {

        eval destroy [winfo child .]

        toplevel .t1 -use $w1

    }

    update

    dobg {

        bind .t1  {lappend x {configure .t1 %w %h}}

        set x {}

        .t1 configure -width 300 -height 120

        update

        list $x [winfo geom .t1]

    }

} {{{configure .t1 300 120}} 300x120+0+0}

test unixEmbed-6.2 {EmbedGeometryRequest procedure, window changes size} {

    foreach w [winfo child .] {

        catch {destroy $w}

    }

    frame .f1 -container 1 -width 200 -height 50

    place .f1 -width 200 -height 200

    dobg "set w1 [winfo id .f1]"

    dobg {

        eval destroy [winfo child .]

        toplevel .t1 -use $w1

    }

    after 300 {set x done}

    vwait x

    dobg {

        bind .t1  {lappend x {configure .t1 %w %h}}

        set x {}

        .t1 configure -width 300 -height 120

        update

        list $x [winfo geom .t1]

    }

} {{{configure .t1 200 200}} 200x200+0+0}

# Can't think up any tests for TkpGetOtherWindow procedure.

test unixEmbed-7.1 {TkpRedirectKeyEvent procedure, forward keystroke} {

    foreach w [winfo child .] {

        catch {destroy $w}

    }

    frame .f1 -container 1 -width 200 -height 50

    pack .f1

    dobg "set w1 [winfo id .f1]"

    dobg {

        eval destroy [winfo child .]

        toplevel .t1 -use $w1

    }

    focus -force .

    bind .  {lappend x {key %A %E}}

    set x {}

    set y [dobg {

        update

        bind .t1  {lappend y {key %A}}

        set y {}

        event generate .t1  -keysym a

        set y

    }]

    update

    bind .  {}

    list $x $y

} {{{key a 1}} {}}

test unixEmbed-7.2 {TkpRedirectKeyEvent procedure, don't forward keystroke width} {

    foreach w [winfo child .] {

        catch {destroy $w}

    }

    frame .f1 -container 1 -width 200 -height 50

    pack .f1

    dobg "set w1 [winfo id .f1]"

    dobg {

        eval destroy [winfo child .]

        toplevel .t1 -use $w1

    }

    update

    focus -force .f1

    update

    bind .  {lappend x {key %A}}

    set x {}

    set y [dobg {

        update

        bind .t1  {lappend y {key %A}}

        set y {}

        event generate .t1  -keysym b

        set y

    }]

    update

    bind .  {}

    list $x $y

} {{} {{key b}}}

test unixEmbed-8.1 {TkpClaimFocus procedure} {

    foreach w [winfo child .] {

        catch {destroy $w}

    }

    frame .f1 -container 1 -width 200 -height 50

    frame .f2 -width 200 -height 50

    pack .f1 .f2

    dobg "set w1 [winfo id .f1]"

    dobg {

        eval destroy [winfo child .]

        toplevel .t1 -use $w1 -highlightthickness 2 -bd 2 -relief sunken

    }

    focus -force .f2

    update

    list [dobg {

        focus .t1

        set x [list [focus]]

        update

        after 500

        update

        lappend x [focus]

    }] [focus]

} {{{} .t1} .f1}

test unixEmbed-8.2 {TkpClaimFocus procedure} {

    catch {interp delete child}

    foreach w [winfo child .] {

        catch {destroy $w}

    }

    frame .f1 -container 1 -width 200 -height 50

    frame .f2 -width 200 -height 50

    pack .f1 .f2

    interp create child

    child eval "set argv {-use [winfo id .f1]}"

    load {} tk child

    child eval {

        . configure -bd 2 -highlightthickness 2 -relief sunken

    }

    focus -force .f2

    update

    list [child eval {

        focus .

        set x [list [focus]]

        update

        lappend x [focus]

    }] [focus]

} {{{} .} .f1}

catch {interp delete child}

test unixEmbed-9.1 {EmbedWindowDeleted procedure, check parentPtr} {

    foreach w [winfo child .] {

        catch {destroy $w}

    }

    frame .f1 -container 1 -width 200 -height 50

    frame .f2 -container 1 -width 200 -height 50

    frame .f3 -container 1 -width 200 -height 50

    frame .f4 -container 1 -width 200 -height 50

    pack .f1 .f2 .f3 .f4

    set x {}

    lappend x [testembed]

    foreach w {.f3 .f4 .f1 .f2} {

        destroy $w

        lappend x [testembed]

    }

    set x

} {{{XXX .f4 {} {}} {XXX .f3 {} {}} {XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f4 {} {}} {XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f2 {} {}}} {}}

test unixEmbed-9.2 {EmbedWindowDeleted procedure, check embeddedPtr} {

    foreach w [winfo child .] {

        catch {destroy $w}

    }

    frame .f1 -container 1 -width 200 -height 50

    pack .f1

    dobg "set w1 [winfo id .f1]"

    dobg {

        eval destroy [winfo child .]

        toplevel .t1 -use $w1 -highlightthickness 2 -bd 2 -relief sunken

        set x {}

        lappend x [testembed]

        destroy .t1

        lappend x [testembed]

    }

} {{{XXX {} {} .t1}} {}}

test unixEmbed-10.1 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} {

    foreach w [winfo child .] {

        catch {destroy $w}

    }

    frame .f1 -container 1 -width 200 -height 50

    pack .f1

    toplevel .t1 -use [winfo id .f1] -width 150 -height 80

    update

    wm geometry .t1 +40+50

    update

    wm geometry .t1

} {150x80+0+0}

test unixEmbed-10.2 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} {

    foreach w [winfo child .] {

        catch {destroy $w}

    }

    frame .f1 -container 1 -width 200 -height 50

    pack .f1

    toplevel .t1 -use [winfo id .f1] -width 150 -height 80

    update

    wm geometry .t1 70x300+10+20

    update

    wm geometry .t1

} {70x300+0+0}

foreach w [winfo child .] {

    catch {destroy $w}

}

cleanupbg