Skunkware 5/Skunkware 5.iso/tls/tls085.solintel.Z/tls085.solintel/lib/vtcl/tests/dlist.tcl

Text File | 1995-07-20 | 16.4 KB | 671 lines

# CVS $Id: dlist.tcl,v 1.3 1995/02/03 16:54:33 zibi Exp $
source tools.tcl

global DefaultList

#
# On error, just display, if no error then
# exit and yell.
#
proc doTestError {cmd lst args} {
    set args [join $args]
         Display 1 "Error Test <$cmd $args>"

    catch {
        eval "$cmd $lst $args"
    } msg

    if {$msg == ""} {
           error "No error was detected <$cmd $args>"
    }

    Display 1 "Passed Error Test <$cmd $args>\n$msg"
}

#
# Restores a list back to a know state
#
proc restoreList {dl} {
     global DefaultList

     lappend rl { 0         "" ""         "String one"   "Apple"    1}
     lappend rl { CONNECT_T  1 ""      "String two"     "Banna"    2}
     lappend rl { CONNECT_T  2 ""      "String three" "Coconut"  3}
     lappend rl { CONNECT_T  0 ""      "String four"     "Dogs"        4}
     lappend rl { CONNECT_I  CONNECT_L 0  "String five"     "Elephant" 5}
     lappend rl { CONNECT_L  0 ""      "String six"     "Frog"        6}

     set DefaultList $rl

     VtDrawnListDeleteItem $dl -all

     VtDrawnListAddItem $dl -recordList $rl -position 0
}

#
# Returns success if list all the items in list a and b are
#                 equal.
# Returns fail if they aren't
#
proc checkRecord {a b} {
         set i [llength $a]
    set j [llength $b]

    if {$i != $j} {
       echo "<$a><$b>"
       echo $i $j
       sleep 4
           error "Records don't match in size"
    }

    for {set k 0} {$k < $i} {incr k} {
        set f1 [lindex $a $k]
        set f2 [lindex $b $k]
        if {$f1 != $f2} {
       echo "<$a><$b>"
       sleep 4
            echo $f1 "==" $f2
               return fail
        }
    }
    return pass
}

#
# Checks that the list passed in recList match the positions in
# the global list DefaultList. If the list don't match this
# routine will call error, which will exit the script.
# The string parameter is the string to spit out on error conditions.
#
# Example
#     checkRecords $selectedList {1 2 3} "VtDrawnListGetSelected"
#
proc checkRecords {recList posList str} {
    global DefaultList

    if {[llength $recList] != [llength $posList]} {
           error "recList and posList don't match <$str> \n $recList\n $posList "
    }

    set i 0
         foreach r1 $recList {
        set p [lindex $posList $i]
        # posList is 1 based
        incr p -1
        set r2 [lindex $DefaultList $p]
        set ret [checkRecord $r1 $r2]
        if {$ret == "fail"} {
            error "records dont match <$str> \n  $r1\n  $r2"
        }
        incr i
    }

    return pass
}

#
# Callback to handle record selection.
# It displays the contents of the selected record in the display
# area.
#
proc recordSelectCB {cbs} {
    set itemPos [keylget cbs itemPosition]

    set retTxt "Single Click\nPosition is $itemPos"

    set dl [keylget cbs widget]
    set stuff [VtDrawnListGetItem $dl -position $itemPos]

    set retTxt "$retTxt\nList contains .. \n  "
    foreach item $stuff {
        set retTxt "$retTxt <$item>"
    }

    Display 1 $retTxt
}

#
# Just display the item you double clicked on
#
proc doubleCB {cbs} {
    set itemPos [keylget cbs itemPosition]

    set retTxt "Double Click\nPosition is $itemPos"

    set dl [keylget cbs widget]
    set stuff [VtDrawnListGetItem $dl -position $itemPos]

    set retTxt "$retTxt\nList contains .. \n  "
    foreach item $stuff {
        set retTxt "$retTxt <$item>"
    }

    Display 1 $retTxt
}


#
# This is a visual test of adding elements with
# a different formatting string
#
proc testAddCB {lst cbs} {
         global oldLabel

    if {[info exists oldLabel] == 0} {
        set oldLabel ""
    }

    if {$oldLabel == ""} {
        VtSetValues [keylget cbs widget] -label "Test Add Lots"
    } else {
        VtSetValues [keylget cbs widget] -label $oldLabel
    }


        VtDrawnListDeleteItem $lst -all

    if {$oldLabel == ""} {
             VtDrawnListAddItem $lst \
        -formatList {{ICON 5} {STRING 20 5}}\
        -CHARM_formatList {{ICON 5} {STRING 20 1}}\
        -fieldList {"CONNECT_I NO_ICON 1 CONNECT_H  2"
                "Multiple icons" }

             VtDrawnListAddItem $lst \
        -formatList {{ICON 1} {STRING 20 5}}\
        -CHARM_formatList {{ICON 1} {STRING 20 1}}\
        -fieldList { 0 "One Icon" }

             VtDrawnListAddItem $lst \
        -formatList {{ICON 1} {ICON 1} {STRING 20 5}}\
        -CHARM_formatList {{ICON 1} {ICON 1} {STRING 20 1}}\
        -fieldList { 0 0 "Two Icons" }

             VtDrawnListAddItem $lst \
        -formatList {{STRING 20 5} {ICON 1}}\
        -CHARM_formatList {{STRING 20 0} {ICON 1}}\
        -fieldList { "One Icon on End" 0 }

             VtDrawnListAddItem $lst \
        -formatList {{ICON 1} {STRING 20 5 5} {ICON 1}}\
        -CHARM_formatList {{ICON 1} {STRING 20 1 1} {ICON 1}}\
        -fieldList { 0 "Icon Sandwich" 0 }

             VtDrawnListAddItem $lst \
        -formatList {{STRING 20 0 5} {ICON 1} {STRING 20 5}}\
        -CHARM_formatList {{STRING 20 0 1} {ICON 1} {STRING 20 1}}\
        -fieldList {"Sandwiched Icon" 0 "Sandwiched Icon" }

        # multiple icons in a field
             VtDrawnListAddItem $lst \
        -formatList {{ICON 5} {STRING 20 5}}\
        -CHARM_formatList {{ICON 5} {STRING 20 1}}\
        -fieldList {"CONNECT_I 0 CONNECT_L 1 2" "Multiple icons" }

        # multiple icons with one null icon
             VtDrawnListAddItem $lst \
        -formatList {{ICON 5} {STRING 20 5}}\
        -CHARM_formatList {{ICON 5} {STRING 20 1}}\
        -fieldList {"CONNECT_I NO_ICON 1 CONNECT_H  2"
                "Multiple icons" }
    } else {
        set recordList ""
        Display 0 "Making List (Speed is not my fault)..."
        VtSetValues $lst -labelFormatList {{STRING 30 5 5} {ICON 3}}
        VtSetValues $lst -labelList {"Left of label" "Icons"}
        for {set i 0} {$i < 600} {incr i} {
            set recordList [lappend recordList \
                    [list $i "Bunches of right icons ($i)" 0 0] ]
        }
        Display 0 "Done making list.\nAbout to Send the command"
             VtDrawnListAddItem $lst \
        -formatList {{DATA} {STRING 30 5 5} {ICON 1} {ICON 1}}\
        -CHARM_formatList {{DATA} {STRING 50 0 1} {ICON 1} {ICON 1}}\
        -recordList $recordList
        Display 0 "Done sending command (fast huh?)"
    }

    if {$oldLabel == ""} {
        set oldLabel "Test Add"
    } else {
        set oldLabel ""
    }
}

#
# This test setting of the topItemPosition
#
proc testTopItemCB {lst cbs} {
    global DefaultList

           restoreList $lst

        set rows [llength $DefaultList]

    for {set i 1} { $i <= $rows } {incr i} {
        VtSetValues $lst -topItemPosition $i
        set ret [VtGetValues $lst -topItemPosition]
        Display 1 "Setting top to $i"
        if { $i != $ret } {
        error "Top Item Broken i is $i ret is $ret"
        }
    }

    sleep 1

    for {incr i -1} { $i > 0 } {incr i -1} {
        Display 1 "Setting top to $i"
        VtSetValues $lst -topItemPosition $i
    }

    Display 0 "Done, Testing topItemPosition"
}

#
# This tests the VtDrawnListSetItem call.
# It excercises the following options
#        -position
#    -field
#    -formatList
#    -fieldList
#
proc doSetItem {lst pos rec args} {

    set args [join $args]

         Display 1 "Set Test\n   $args"
    eval "VtDrawnListSetItem $lst $args"
    set recordList [VtDrawnListGetItem $lst -position $pos]
    set record [lindex $recordList 0]

    set ret [checkRecord $record $rec]
    if {$ret == "fail"} {
           error "Records don't match <$args>"
    }
    Display 1 "Set Test \nPassed $args"
}

proc testSetCB {lst cbs} {



    set rec {0 0 0 {New String} "data"}

         restoreList $lst
    doSetItem $lst 1 $rec "-position 1 -fieldList {$rec}"
    doSetItem $lst 2 $rec "-position 2 -fieldList {$rec}"
    doSetItem $lst 6 $rec "-position 0 -fieldList {$rec}"

    restoreList $lst
    doSetItem $lst 1 $rec "-field 3 {String one} -fieldList {$rec}"
    doSetItem $lst 4 $rec "-field 3 {String four} -fieldList {$rec}"
    doSetItem $lst 6 $rec "-field 3 {String six} -fieldList {$rec}"

    Display 0 "VtDrawnListSetItem test DONE"
}

#
# This tests the VtDrawnListDeselectItem call.
# It excercises the following options
#        -position
#    -positionList
#    -field
#    -all
#
# This tests relies on the procedure doDeselect to actual
# select of the items.
#
proc doDeselect {lst posList args} {

    set args [join $args]
         Display 1 "Deselect test \n  $args"
    eval "VtDrawnListDeselectItem $lst $args"
    set recordList [VtDrawnListGetSelectedItem $lst -byRecordList]
    checkRecords $recordList $posList $args
    Display 1 "Deselect test \n  Passed $args"
}


proc testDeselectCB {lst cbs} {
         restoreList $lst

    VtDrawnListSelectItem $lst -all

    # -positon
    doDeselect $lst {1 2 3 4 5} "-position 0"
    doDeselect $lst {2 3 4 5}  "-position 1"
    doDeselect $lst {3 4 5}  "-position 2"
    doDeselect $lst {3 5} "-position 4"

    # -positionList 1 3 5
    VtDrawnListSelectItem $lst -all
    doDeselect $lst {2 4 6} "-positionList {1 3 5}"
    doDeselect $lst {} "-positionList {2 4 6}"

    # -field 3 String one
    VtDrawnListSelectItem $lst -all
    doDeselect $lst {2 3 4 5 6} "-field 3 {String one}"
    doDeselect $lst {2 4 5 6} "-field 3 {String three}"
    doDeselect $lst {2 4 5}  "-field 3 {String six}"

    # -all
    doDeselect $lst {} "-all"
    VtDrawnListSelectItem $lst -all
    doDeselect $lst {} "-all"


    # Now test deselect of things not selected
    doDeselect $lst {} "-all"
    doDeselect $lst {}  "-position 3"
    doDeselect $lst {}  "-positionList {1 4}"
    doDeselect $lst {}  "-field 3 {String six}"

    # Tests for some things selected, some not
    # in this test items 2-5 are selected and we're going to
    # deselect items 1 and 2.
    VtDrawnListSelectItem $lst -all
    VtDrawnListDeselectItem $lst -positionList {1 6}
    doDeselect $lst {3 4 5} "-positionList {1 2}"

    # now test error conditions
    doTestError "VtDrawnListDeselectItem"  $lst "-position 9"
    doTestError "VtDrawnListDeselectItem"  $lst "-position -1"
    doTestError "VtDrawnListDeselectItem"  $lst "-field 3 {Meat Loaf}"
    doTestError "VtDrawnListDeselectItem"  $lst "-field 99 {beefhart}"

    Display 0 "VtDrawnListDeselectItem test DONE"
}

#
# This tests the VtDrawnListSelectItem call.
# It excercises the following options
#        -position
#    -positionList
#    -field
#    -all
#
# This tests relies on the procedure doSelect to actual
# select of the items.  It also relies on doSelectError
# which does testing of error conditions on drawnlist.
#
proc doSelect {lst posList args} {

    set args [join $args]
         Display 1 "Selected Test \n  $args"
    eval "VtDrawnListSelectItem $lst $args"
#sleep 4xxx
    set recordList [VtDrawnListGetSelectedItem $lst -byRecordList]
    checkRecords $recordList $posList $args
    Display 1 "Select Test \n  Passed $args"
}

proc testSelectCB {lst cbs} {
         restoreList $lst

    # -positon 0 1 2 6
    doSelect $lst 6 "-position 0"
    doSelect $lst 1 "-position 1"
    doSelect $lst 2 "-position 2"
    doSelect $lst 6 "-position 6"

    # -positionList 1 3 5
    doSelect $lst {1 3 5} "-positionList {1 3 5}"

    # -field 3 String one
    doSelect $lst 1 "-field 3 {String one}"
    doSelect $lst 3 "-field 3 {String three}"
    doSelect $lst 6 "-field 3 {String six}"

    # -next
    doSelect $lst 1 "-position 1"
    doSelect $lst 2 "-next"
    doSelect $lst 6 "-position 6"
    doSelect $lst 6 "-next"

    # -previous
    doSelect $lst 6 "-position 6"
    doSelect $lst 5 "-previous"
    doSelect $lst 1 "-position 1"
    doSelect $lst 1 "-previous"

    # -all
    doSelect $lst {1 2 3 4 5 6} "-all"

    # now test error conditions
    doTestError VtDrawnListSelectItem $lst "-position 9"
    doTestError VtDrawnListSelectItem $lst "-position -1"
    doTestError VtDrawnListSelectItem $lst "-field 3 {Meat Loaf}"
    doTestError VtDrawnListSelectItem $lst "-field 99 {beefhart}"

    Display 0 "VtDrawnListSelectItem test DONE"
}

#
# This tests the VtDrawnListGetSelectItem call.
# It excercises the following options
#        -byPositionList
#    -byRecordList
#
#
proc doGetSelect {lst posList args} {

    set args [join $args]
         Display 1 "GetSelected Test \n  $args"
    eval "VtDrawnListSelectItem $lst $args"
#sleep 4
    set recordList [VtDrawnListGetSelectedItem $lst -byRecordList]
    checkRecords $recordList $posList $args
    Display 1 "GetSelected Test \n  Passed $args"

    set pList [VtDrawnListGetSelectedItem $lst -byPositionList]
    if {[checkRecord $pList $posList] == "fail"} {
        echo "<$pList> <$posList>"
        error "Records don't match <$args>"
    }

    Display 1 "GetSelected Test \n  Passed $args"
}

proc testGetSelectCB {lst cbs} {
         restoreList $lst

    # -positon 0 1 2 6
    doGetSelect $lst 6 "-position 0"
    doGetSelect $lst 1 "-position 1"
    doGetSelect $lst 2 "-position 2"
    doGetSelect $lst 6 "-position 6"

    # -positionList 1 3 5
    doGetSelect $lst {1 3 5} "-positionList {1 3 5}"

    # -field 3 String one
    doGetSelect $lst 1 "-field 3 {String one}"
    doGetSelect $lst 3 "-field 3 {String three}"
    doGetSelect $lst 6 "-field 3 {String six}"

    # -all
    doGetSelect $lst {1 2 3 4 5 6} "-all"

    # now test error conditions
    doTestError VtDrawnListGetSelectItem $lst \
        "-byPositionList -byRecordList"

    Display 0 "VtDrawnListSelectItem test DONE"
}

#
# This tests the VtDrawnListGetItems call.
# It excercises the following options
#        -position
#    -positionList
#    -field
#    -all
#
# This tests relies on the procedure doGet to actual
# get of the items.
#
proc doGet {lst posList args} {

    set args [join $args]
         Display 1 "Get Test \n   $args"
    set recordList [eval "VtDrawnListGetItem $lst $args"]
    checkRecords $recordList $posList $args
    Display 1 "Get Test \n   Passed $args"
}

proc testGetCB {lst cbs} {
         restoreList $lst

    # -positon 5
    doGet $lst 5 "-position 5"

    # -position 0
    doGet $lst 6 "-position 0"

    # check that -positionList works
    doGet $lst {1 3} "-positionList {1 3}"

    # check that field works
    doGet $lst 3 "-field 3 {String three}"

    #
    doTestError VtDrawnListGetItem $lst "-position 33"
    doTestError VtDrawnListGetItem $lst "-field 3 {beefhart}"
    doTestError VtDrawnListGetItem $lst "-position 2 -field 3 {String two}"



    # check that -all work
    doGet $lst {1 2 3 4 5 6} "-all"

    Display 0 "VtDrawnListGetItem test DONE"
}

#
# This tests the VtDrawnListDeleteItems call.
# It excercises the following options
#        -position
#    -positionList
#    -field
#    -all
#
# it relies on a procedure which generates the display
# and delete commands doDelete.  Which in turn relies
# on VtDrawnListGetItems VtDrawnListAddItems.
#
proc doDelete {lst posList args} {

         restoreList $lst

    set args [join $args]
         Display 1 "Delete Test \n   $args"
    eval "VtDrawnListDeleteItem $lst $args"
    set recordList [VtDrawnListGetItem $lst -all]
    checkRecords $recordList $posList $args
    Display 1 "Delete Test \n   Passed $args"
}

proc testDelCB {lst cbs} {

    # check that -position works
    doDelete $lst {1 2 4 5 6} "-position 3"

    doDelete $lst {2 4 5 6} "-positionList {1 3}"

    doDelete $lst {1 3 4 5 6} "-field 3 {String two}"

    doDelete $lst {} "-all"

    # Test some error conditions
    doTestError VtDrawnListDeleteItem $lst "-position 9"
    doTestError VtDrawnListDeleteItem $lst "-field 3 {shark}"

    Display 0 "DONE testing VtDrawnListDeleteItem"
}

proc testAllCB {lst cbs} {
     testGetCB $lst $cbs
     testDelCB $lst $cbs
     testSetCB $lst $cbs
     testSelectCB $lst $cbs
     testDeselectCB $lst $cbs

     Display 0 "Done Testing everything"
}

proc dontCloseCB {cbs} {
    set target [keylget cbs dialog]

    set mb [VtMessageDialog $target.err -message "You can't do that :) " -ok]
    VtShow $mb
}

#
# ----------------------------------------------------------------
# main
#
set ap [VtOpen dd]

set fn [VtFormDialog $ap.form \
    -wmDecoration ALL -MOTIF_marginWidth 5 -MOTIF_marginHeight 5 \
    -wmCloseCallback dontCloseCB ]

set displayTxt [VtText $fn.txt \
    -rows  4\
    -wordWrap \
    -topSide FORM -leftSide FORM -rightSide FORM -MOTIF_rightOffset 25 ]

#
# This sets the global display area for the tools.tcl routines
#
InitDisplay $displayTxt

set dl [VtDrawnList $fn.dl \
        -iconList {./dir.px exec.px file.px} \
    -CHARM_iconList {a b c} \
    -formatList { \
        {ICON 1} \
        {ICON 1} \
        {ICON 1} \
        {STRING 25 5} \
        {STRING 30 5} \
        {DATA } } \
    -CHARM_formatList { \
        {ICON 1} \
        {ICON 1} \
        {ICON 1} \
        {STRING 25 2} \
        {STRING 30 2} \
        {DATA } } \
    -leftSide FORM -rightSide FORM -topSide $DisplayTxt  \
    -labelFormatList { {ICON 3 5} {STRING 25 5} {STRING 30 5}} \
    -labelList {Icons "Label Above Columns" "Object"} \
    -columns 30 \
    -rows 6\
    -selection MULTIPLE \
    -callback recordSelectCB -defaultCallback doubleCB]

restoreList $dl

set rc [VtRowColumn $fn.rc -horizontal -packing COLUMN -numColumns 3 \
        -topSide NONE -leftSide FORM -bottomSide FORM ]

VtSetValues $dl -bottomSide $rc

MakeCenteredButton $rc.tstAll   "Test All"      "testAllCB $dl"
MakeCenteredButton $rc.tstGet   "Test Get"      "testGetCB $dl"
MakeCenteredButton $rc.tstDel   "Test Delete"   "testDelCB $dl"
MakeCenteredButton $rc.tstSet   "Test Set"      "testSetCB $dl"
MakeCenteredButton $rc.tstSel   "Test Select"   "testSelectCB $dl"
MakeCenteredButton $rc.tstGSel  "Test Get Select"   "testGetSelectCB $dl"
MakeCenteredButton $rc.tstDsel  "Test Deselect" "testDeselectCB $dl"
MakeCenteredButton $rc.tstTopItem "Test TopItem"    "testTopItemCB $dl"
MakeCenteredButton $rc.tstAdd   "Test Add"    "testAddCB $dl"
MakeCenteredButton $rc.quit    "Exit"         QuitCB

VtSetValues $dl -bottomSide $rc

VtShowDialog $fn

VtMainLoop