How to Make Optimal Use of Drag & Drop with Tablelist

by

Csaba Nemethi

csaba.nemethi@t-online.de

Contents

  1. Abstract
  2. Drag Source Support in Tablelist
  3. Drop Target Support in Tablelist
  4. A Demo Script Using TkDND
  5. A Demo Script Using BWidget
  6. Handling the Drop in Both Scripts

1. Abstract

This is a short tutorial presenting the drag & drop support in the Tablelist package.  The relevant tablelist subcommands and default bindings are explained with the aid of two demo scripts showing how Tablelist, combined with the TkDND extension or BWidget's drag & drop framework, can make Tcl applications much more user-friendly.

2. Drag Source Support in Tablelist

Registering the body component of a tablelist widget as a TkDND drag source

package require tkdnd 2.7

set tblBody [$tbl bodypath]
tkdnd::drag_source register $tblBody DND_Text 1
bind $tblBody <<DragInitCmd>> { onTblDragInit %W }
bind $tblBody <<DragEndCmd>>  { onTblDragEnd %W %A }

proc onTblDragInit w { ... }
proc onTblDragEnd {w action} { ... }

Registering the body component of a tablelist widget as a BWidget drag source

package require BWidget

DragSite::register [$tbl bodypath] -dragevent 1 \
    -draginitcmd tblDragInitCmd -dragendcmd tblDragEndCmd

proc tblDragInitCmd {dragSrc rootX rootY top} { ... }
proc tblDragEndCmd {dragSrc dropTarget op dataType data result} { ... }

Automatic drag-friendly handling of the selection and of pointer movements with mouse button 1 down

DEFINITION:  A tablelist widget is viewed as a drag source for mouse button 1 if its body component was registered as such via the  tkdnd::drag_source register  or the BWidget DragSite::register command, or the tablelist's -customdragsource option was set to true.

DRAG SOURCE SUPPORT VIA THE DEFAULT BINDINGS:

3. Drop Target Support in Tablelist

Registering a tablelist widget as a TkDND drop target

package require tkdnd 2.7

tkdnd::drop_target register $tbl DND_Text

bind $tbl <<DropEnter>>    { onTblDropEnterOrPos %W %X %Y %a %b }
bind $tbl <<DropPosition>> { onTblDropEnterOrPos %W %X %Y %a %b }
bind $tbl <<DropLeave>>    { %W hidetargetmark }
bind $tbl <<Drop>>         { onTblDrop %W %A %D }

proc onTblDropEnterOrPos {tbl rootX rootY actions buttons} { ... }
proc onTblDrop {tbl action data} { ... }

Registering the body component of a tablelist widget as a BWidget drop target

package require BWidget

foreach w [list [$tbl bodypath] [$tbl targetmarkpath]] {
    DropSite::register $w -dropovercmd tblDropOverCmd -dropcmd tblDropCmd \
        -droptypes [list TABLELIST_DATA {copy {}}]

proc tblDropOverCmd {dropTarget dragSrc event rootX rootY op dataType data} { ... }
proc tblDropCmd {dropTarget dragSrc rootX rootY op dataType data} { ... }

Tablelist subcommands for drop target support

4. A Demo Script Using TkDND

Live presentation of the script EU_TkDND.tcl ...

Registering the bodies of tblStates and tblCaps as drag sources

set tblStatesBody [$tblStates bodypath]
tkdnd::drag_source register $tblStatesBody DND_Text 1
bind $tblStatesBody <<DragInitCmd>> { onTblStatesDragInit %W }
bind $tblStatesBody <<DragEndCmd>>  { onTblDragEnd %W %A }

set tblCapsBody [$tblCaps bodypath]
tkdnd::drag_source register $tblCapsBody DND_Text 1
bind $tblCapsBody <<DragInitCmd>> { onTblCapsDragInit %W }
bind $tblCapsBody <<DragEndCmd>>  { onTblDragEnd %W %A }

proc onTblStatesDragInit w {
    set tbl [tablelist::getTablelistPath $w]
    set rows [$tbl curselection]
    if {[llength $rows] == 1} {
        set items [list [$tbl get $rows]]
    } else {
        set items [$tbl get $rows]
    }
    foreach item $items {
        lappend states [lindex $item 0]
    }

    # Remember the drag source
    global dragSrc
    set dragSrc $w

    return [list {copy} {DND_Text} $states]
}

proc onTblCapsDragInit w {
    set tbl [tablelist::getTablelistPath $w]
    set rows [$tbl curselection]
    set item [$tbl get $rows]
    set capital [lindex $item 0]

    # Remember the drag source
    global dragSrc
    set dragSrc $w

    return [list {copy} {DND_Text} $capital]
}

proc onTblDragEnd {w action} {
    # Forget the drag source
    global dragSrc
    unset dragSrc

    if {![string equal $action "refuse_drop"]} {                ;# accepted
        set tbl [tablelist::getTablelistPath $w]
        set rows [$tbl curselection]
        $tbl selection clear $rows
        foreach row $rows {
            $tbl rowconfigure $row -foreground red3
        }
    }
}

Registering tblEU as a drop target

tkdnd::drop_target register $tblEU DND_Text

bind $tblEU <<DropEnter>>    { onTblEUDropEnterOrPos %W %X %Y %a %b }
bind $tblEU <<DropPosition>> { onTblEUDropEnterOrPos %W %X %Y %a %b }
bind $tblEU <<DropLeave>>    { %W hidetargetmark }
bind $tblEU <<Drop>>         { onTblEUDrop %W %A %D }

proc onTblEUDropEnterOrPos {tbl rootX rootY actions buttons} {
    # Refuse the drop if the drag source is not
    # the body component of tblStates or tblCaps
    global dragSrc tblStates tblCaps
    if {![info exists dragSrc] ||
        (![string equal $dragSrc [$tblStates bodypath]] &&
         ![string equal $dragSrc [$tblCaps bodypath]])} {
        return refuse_drop
    }

    global place row
    set y [expr {$rootY - [winfo rooty $tbl]}]

    if {[string equal $dragSrc [$tblStates bodypath]]} {
        # Dragging a list of states.
        # The following line will set place to "inside":
        foreach {place row} [$tbl targetmarkpos $y -vertical] {}

        if {$row >= 0 && [$tbl depth $row] == 2} {
            # The y-position is inside a state item - enforce "before"
            foreach {place row} [$tbl targetmarkpos $y -horizontal] {}
        }

        if {$row < 0 || $row >= [$tbl size] || 
            ([string equal $place "before"] && [$tbl depth $row] == 1)} {
            # The y-position is outside all rows or before a year item
            $tbl hidetargetmark
            return refuse_drop
        } else {
            $tbl showtargetmark $place $row
            return copy
        }
    } else {
        # Dragging a capital city.
        # The following line will set place to "inside":
        foreach {place row} [$tbl targetmarkpos $y -vertical] {}

        if {$row < 0 || [$tbl depth $row] == 1} {
            # The y-position is outside all rows or is inside a year item
            $tbl hidetargetmark
            return refuse_drop
        } else {
            $tbl showtargetmark $place $row
            return copy
        }
    }
}

proc onTblEUDrop {tbl action data} {
    handleTblEUDrop $tbl $data                          ;# see EU_common.tcl
    return $action
}

5. A Demo Script Using BWidget

Live presentation of the script EU_BWidget.tcl ...

Registering the bodies of tblStates and tblCaps as drag sources

DragSite::register [$tblStates bodypath] -dragevent 1 \
    -draginitcmd tblStatesDragInitCmd -dragendcmd tblDragEndCmd

DragSite::register [$tblCaps bodypath] -dragevent 1 \
    -draginitcmd tblCapsDragInitCmd -dragendcmd tblDragEndCmd

proc tblStatesDragInitCmd {dragSrc rootX rootY top} {
    set tbl [tablelist::getTablelistPath $dragSrc]
    set rows [$tbl curselection]
    if {[llength $rows] == 1} {
        set items [list [$tbl get $rows]]
    } else {
        set items [$tbl get $rows]
    }
    foreach item $items {
        lappend states [lindex $item 0]
    }

    return [list TABLELIST_DATA {copy} $states]
}

proc tblCapsDragInitCmd {dragSrc rootX rootY top} {
    set tbl [tablelist::getTablelistPath $dragSrc]
    set rows [$tbl curselection]
    set item [$tbl get $rows]
    set capital [lindex $item 0]

    return [list TABLELIST_DATA {copy} $capital]
}

proc tblDragEndCmd {dragSrc dropTarget op dataType data result} {
    if {$result != 0} {                                         ;# accepted
        set tbl [tablelist::getTablelistPath $dragSrc]
        set rows [$tbl curselection]
        $tbl selection clear $rows
        foreach row $rows {
            $tbl rowconfigure $row -foreground red3
        }
    }
}

Registering the body and target indicator of tblEU as drop targets

foreach w [list [$tblEU bodypath] [$tblEU targetmarkpath]] {
    DropSite::register $w -dropovercmd tblEUDropOverCmd -dropcmd tblEUDropCmd \
    -droptypes [list TABLELIST_DATA {copy {}}]
}

proc tblEUDropOverCmd {dropTarget dragSrc event rootX rootY op dataType data} {
    # Refuse the drop if the drag source is not
    # the body component of tblStates or tblCaps
    global tblStates tblCaps
    if {![string equal $dragSrc [$tblStates bodypath]] &&
        ![string equal $dragSrc [$tblCaps bodypath]]} {
        return 0                                        ;# refuse the drop
    }

    # $event may be "enter", "motion", or "leave"
    set tbl [tablelist::getTablelistPath $dropTarget]
    if {[string equal $event "leave"]} {
        set newWidget [winfo containing -displayof $dropTarget $rootX $rootY]
        if {![string equal $newWidget [$tbl targetmarkpath]] &&
            ![string equal $newWidget [$tbl bodypath]]} {
            $tbl hidetargetmark
            return 2  ;# refuse the drop and re-invoke the callback on motion
        }
    }

    global place row
    set y [expr {$rootY - [winfo rooty $tbl]}]

    if {[string equal $dragSrc [$tblStates bodypath]]} {
        # Dragging a list of states.
        # The following line will set place to "inside":
        foreach {place row} [$tbl targetmarkpos $y -vertical] {}

        if {$row >= 0 && [$tbl depth $row] == 2} {
            # The y-position is inside a state item - enforce "before"
            foreach {place row} [$tbl targetmarkpos $y -horizontal] {}
        }

        if {$row < 0 || $row >= [$tbl size] || 
            ([string equal $place "before"] && [$tbl depth $row] == 1)} {
            # The y-position is outside all rows or before a year item
            $tbl hidetargetmark
            DropSite::setcursor dot
            return 2  ;# refuse the drop and re-invoke the callback on motion
        } else {
            $tbl showtargetmark $place $row
            DropSite::setcursor based_arrow_down
            return 3  ;# accept the drop and re-invoke the callback on motion
        }
    } else {
        # Dragging a capital city.
        # The following line will set place to "inside":
        foreach {place row} [$tbl targetmarkpos $y -vertical] {}

        if {$row < 0 || [$tbl depth $row] == 1} {
            # The y-position is outside all rows or is inside a year item
            $tbl hidetargetmark
            DropSite::setcursor dot
            return 2  ;# refuse the drop and re-invoke the callback on motion
        } else {
            $tbl showtargetmark $place $row
            DropSite::setcursor based_arrow_down
            return 3  ;# accept the drop and re-invoke the callback on motion
        }
    }
}

proc tblEUDropCmd {dropTarget dragSrc rootX rootY op dataType data} {
    set tbl [tablelist::getTablelistPath $dropTarget]
    handleTblEUDrop $tbl $data                          ;# see EU_common.tcl
    return 1                                            ;# accept the drop
}

6. Handling the Drop in Both Scripts

The procedure handleTblEUDrop

proc handleTblEUDrop {tbl data} {
    $tbl hidetargetmark
    global place row

    if {[string equal $place "before"]} {
        # Dropping before a state item: Insert new state
        # items as siblings before the one indicated by $row
        set parent [$tbl parentkey $row]
        set childIdx [$tbl childindex $row]
        foreach state $data {
            $tbl insertchild $parent $childIdx [list $state ""]
            incr childIdx
        }
    } elseif {[$tbl depth $row] == 1} {
        # Dropping inside a year item: Append new state items to
        # the list of children of the year item indicated by $row
        foreach state $data {
            $tbl insertchild $row end [list $state ""]
        }
        $tbl expand $row -partly
    } else {
        # Dropping inside a state item: Update the
        # capital city of the state indicated by $row
        $tbl cellconfigure $row,end -text $data
    }
}