Subversion Repositories or1k

# dirbox.tcl --

#

#       Tests the DirSelectBox and DirSelectDialog widgets.

#

# Copyright (c) 1996, Expert Interface Technologies

#

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

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

#

proc About {} {

    return "Testing the DirSelectBox and DirSelectDialog widgets."

}

# Try to configure the directory of a widget and see if it satisfy all

# the requirements:

#

#       1: Should return error for non-existant directory, preserving

#          the old directory

#

#       2: When given a non-normalized path, it should normalize it.

#

proc TestConfigDirectory {class spec pack} {

    global errorInfo

    set w .w

    if [winfo exists $w] {

        destroy $w

    }

    TestBlock config-dir-1.1 "Simple creating of $class" {

        # Creation without the spec. The default value should be normalized

        #

        # The default value should always be an absolute path

        #

        $class .w

        set value [$w cget $spec]

        Assert {[tixFSIsNorm_os $value]} 0 cont

    }

    catch {

        destroy .w

    }

    TestBlock config-dir-1.2 "Creation with arbitrary (perhaps invalid) path" {

        foreach item [GetCases_FsNormDir] {

            if [info exists errorInfo] {

                set errorInfo ""

            }

            set text    [lindex $item 0]

            set want    [lindex $item 1]

            set wanterr [lindex $item 2]

            set err [catch {

                set w [$class .w $spec $text]

                set got [$w cget -value]

            }]

            Assert {$err == $wanterr}

            if {!$err} {

                set want [tixFSDisplayName $want]

                Assert {[tixStrEq $want $got]}

            }

            catch {

                destroy .w

            }

        }

    }

    catch {

        destroy .w

    }

    TestBlock config-dir-1.2 "Config with arbitrary (perhaps invalid) path" {

        set w [$class .w]

        foreach item [GetCases_FsNormDir] {

            if [info exists errorInfo] {

                set errorInfo ""

            }

            set text    [lindex $item 0]

            set want    [lindex $item 1]

            set wanterr [lindex $item 2]

            set err [catch {

                $w config $spec $text

                set got [$w cget -value]

            }]

            Assert {$err == $wanterr}

            if $err {

                # Should hold the previous -value

                #

                set value [$w cget $spec]

                Assert {[tixFSIsNorm_os $value]} 0 cont

            } else {

                set value [$w cget $spec]

                Assert {[tixFSIsNorm_os $value]} 0 cont

                set want [tixFSDisplayName $want]

                Assert {[tixStrEq $want $got]}

            }

            if $pack {

                pack $w -expand yes -fill both -padx 10 -pady 10

                update idletasks

            }

        }

    }

    catch {

        destroy $w

    }

}

proc TestRand {max} {

    global testRandSeed

    if ![info exists testRandSeed] {

        set testRandSeed [expr [lindex [time {cd [pwd]}] 0] * 47 + 147]

    }

    set x [expr ($testRandSeed + 47) * [lindex [time {cd [pwd]}] 0]]

    set x [expr $x + 7 * $max]

    set testRandSeed [expr ($x % $max) + $max]

    return [expr $testRandSeed % $max]

}

# TestHListWildClick --

#

#       Randomly click around an hlist widget

#

# Args:

#       hlist:widget    The HList widget.

#       mode:           Either "single" or "double", indicating which type

#                       of mouse click is desired.

#       cmd:            Command to call after each click.

#

proc TestHListWildClick {hlist mode cmd} {

    # The percentage chance that we sould traverse to a child node

    #

    set chance 40

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

        set node [$hlist info children ""]

        if [tixStrEq $node ""] {

            return

        }

        while 1 {

            set ran [TestRand 100]

            if {$ran >= $chance} {

                break

            }

            set children [$hlist info children $node]

            if [tixStrEq $children ""] {

                break

            }

            set node [lindex $children [expr $ran % [llength $children]]]

        }

        TestBlock wild-click-1.1 "clicking \"$node\" of HList" {

            if {![regexp -nocase alex [$hlist info data $node]]} {

                #

                # dirty fix: "alex" may be an AFS mounted file. Reading this

                # directory may start an FTP session, which may be slow like

                # hell

                #

                ClickHListEntry $hlist $node $mode

                eval $cmd [list $node]

            }

        }

    }

}

proc DirboxTest_Cmd {args} {

    global dirboxTest_selected

    set dirboxTest_selected [tixEvent value]

}

proc DirboxTest_Compare {isDirBox w h node} {

    global dirboxTest_selected

    set selFile [$h info data $node]

    Assert {[tixStrEq "$dirboxTest_selected" "$selFile"]}

    set dirboxTest_selected ""

    if {$isDirBox} {

        set entry [$w subwidget dircbx subwidget combo subwidget entry]

        set entText [$entry get]

        Assert {[tixStrEq "$entText" "$selFile"]}

    }

}

proc Test {} {

    global dirboxTest_selected

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

    # (1) DirList

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

    TestBlock dirbox-1.1 {Generic testing of tixDirList} {

        TestConfigDirectory tixDirList -value 1

    }

    TestBlock dirbox-1.2 {Wild click on the hlist subwidget} {

        set dirboxTest_selected ""

        set w [tixDirList .c -command DirboxTest_Cmd]

        set h [$w subwidget hlist]

        pack $w -expand yes -fill both

        TestHListWildClick $h double "DirboxTest_Compare 0 $w $h"

    }

    catch {

        destroy $w

    }

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

    # (2) DirTree

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

    TestBlock dirbox-2.1 {Generic testing of tixDirTree} {

#       TestConfigDirectory tixDirTree -value 1

    }

    TestBlock dirbox-2.2 {Wild click on the hlist subwidget} {

        set dirboxTest_selected ""

        set w [tixDirTree .c -command DirboxTest_Cmd]

        set h [$w subwidget hlist]

        pack $w -expand yes -fill both

#       TestHListWildClick $h double "DirboxTest_Compare 0 $w $h"

    }

    catch {

        destroy $w

    }

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

    # (3) DirBox

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

    TestBlock dirbox-3.1 {Generic testing of tixDirSelectBox} {

#       TestConfigDirectory tixDirSelectBox -value 1

    }

    TestBlock dirbox-3.2 {Wild click on the hlist subwidget} {

        set dirboxTest_selected ""

        set w [tixDirSelectBox .c -command DirboxTest_Cmd]

        set h [$w subwidget dirlist subwidget hlist]

        pack $w -expand yes -fill both

#       TestHListWildClick $h double "DirboxTest_Compare 0 $w $h"

    }

    catch {

        destroy $w

    }

    TestBlock dirbox-4.1 {-disablecallback option} {

        global dirbox_called

        tixDirList .c -command dirbox_callback

        pack .c

        set dirbox_called 0

        .c config -disablecallback 1

        .c config -value [pwd]

        .c config -disablecallback 0

        Assert {$dirbox_called == 0}

    }

    catch {

        destroy .c

    }

}

proc dirbox_callback {args} {

    global dirbox_called

    set dirbox_called 1

}