dropsite.tcl

The BWidget Toolkit is a high-level Widget Set for Tcl/Tk built using native Tcl/Tk 8.x namespaces.

proc DropSite::setoperation { op } {
    variable _curop
    variable _dragops
    variable _target
    variable _type
    upvar \#0 DropSite::$_target drop

    if { [info exist drop($_type,ops,$op)] &&
         $_dragops($drop($_type,ops,$op)) } {
        set _curop $op
    } else {
        # force to a copy operation
        set _curop force
    }
}


# ----------------------------------------------------------------------------
#  Command DropSite::_init_drag
# ----------------------------------------------------------------------------
proc DropSite::_init_drag { top evt source state X Y type ops data } {
    variable _top
    variable _source
    variable _type
    variable _data
    variable _target
    variable _status
    variable _state
    variable _dragops
    variable _opw
    variable _evt

    if {[info exists _dragops]} {
        unset _dragops
    }
    array set _dragops {copy 1 move 0 link 0}
    foreach op $ops {
        set _dragops($op) 1
    }
    set _target ""
    set _status  0
    set _top     $top
    set _source  $source
    set _type    $type
    set _data    $data

    label $_opw -relief flat -bd 0 -highlightthickness 0 \
        -foreground black -background white

    bind $top <ButtonRelease-$evt> {DropSite::_release %X %Y}
    bind $top <B$evt-Motion>       {DropSite::_motion  %X %Y}
    bind $top <Motion>             {DropSite::_release %X %Y}
    set _state $state
    set _evt   $evt
    _motion $X $Y
}


# ----------------------------------------------------------------------------
#  Command DropSite::_update_operation
# ----------------------------------------------------------------------------
proc DropSite::_update_operation { state } {
    variable _top
    variable _status
    variable _state

    if { $_status & 3 } {
        set _state $state
        _motion [winfo pointerx $_top] [winfo pointery $_top]
    }
}


# ----------------------------------------------------------------------------
#  Command DropSite::_compute_operation
# ----------------------------------------------------------------------------
proc DropSite::_compute_operation { target state type } {
    variable  _curop
    variable  _dragops
    upvar \#0 DropSite::$target drop

    foreach {mask op} $drop($type,ops) {
        if { ($state & $mask) == $mask } {
            if { $_dragops($drop($type,ops,$op)) } {
                set _curop $op
                return
            }
        }
    }
    set _curop force
}


# ----------------------------------------------------------------------------
#  Command DropSite::_draw_operation
# ----------------------------------------------------------------------------
proc DropSite::_draw_operation { target type } {
    variable _opw
    variable _curop
    variable _dragops
    variable _tabops
    variable _status

    upvar \#0 DropSite::$target drop

    if { !($_status & 1) } {
        catch {place forget $_opw}
        return
    }

    if { 0 } {
    if { ![info exist drop($type,ops,$_curop)] ||
         !$_dragops($drop($type,ops,$_curop)) } {
        # force to a copy operation
        set _curop copy
        catch {
            $_opw configure -bitmap $_tabops(img,copy)
            place $_opw -relx 1 -rely 1 -anchor se
        }
    }
    } elseif { [string equal $_curop "default"] } {
        catch {place forget $_opw}
    } else {
        catch {
            $_opw configure -bitmap $drop($type,img,$_curop)
            place $_opw -relx 1 -rely 1 -anchor se
        }
    }
}


# ----------------------------------------------------------------------------
#  Command DropSite::_motion
# ----------------------------------------------------------------------------
proc DropSite::_motion { X Y } {
    variable _top
    variable _target
    variable _status
    variable _state
    variable _curop
    variable _type
    variable _data
    variable _source
    variable _evt

    set script [bind $_top <B$_evt-Motion>]
    bind $_top <B$_evt-Motion> {}
    bind $_top <Motion>        {}
    wm geometry $_top "+[expr {$X+1}]+[expr {$Y+1}]"
    update
    if { ![winfo exists $_top] } {
        return
    }
    set path [winfo containing $X $Y]
    if { ![string equal $path $_target] } {
        # path != current target
        if { $_status & 2 } {
            # current target is valid and has recall status
            # generate leave event
            upvar   \#0 DropSite::$_target drop
            uplevel \#0 $drop(overcmd) [list $_target $_source leave $X $Y $_curop $_type $_data]
        }
        set _target $path
        upvar \#0 DropSite::$_target drop
        if { [info exists drop($_type,ops)] } {
            # path is a valid target
            _compute_operation $_target $_state $_type
            if { $drop(overcmd) != "" } {
                set arg     [list $_target $_source enter $X $Y $_curop $_type $_data]
                set _status [uplevel \#0 $drop(overcmd) $arg]
            } else {
                set _status 1
                catch {$_top configure -cursor based_arrow_down}
            }
            _draw_operation $_target $_type
            update
            catch {
                bind $_top <B$_evt-Motion> {DropSite::_motion  %X %Y}
                bind $_top <Motion>        {DropSite::_release %X %Y}
            }
            return
        } else {
            set _status 0
            catch {$_top configure -cursor dot}
            _draw_operation "" ""
        }
    } elseif { $_status & 2 } {
        upvar \#0 DropSite::$_target drop
        _compute_operation $_target $_state $_type
        set arg     [list $_target $_source motion $X $Y $_curop $_type $_data]
        set _status [uplevel \#0 $drop(overcmd) $arg]
        _draw_operation $_target $_type
    }
    update
    catch {
        bind $_top <B$_evt-Motion> {DropSite::_motion  %X %Y}
        bind $_top <Motion>        {DropSite::_release %X %Y}
    }
}



# ----------------------------------------------------------------------------
#  Command DropSite::_release
# ----------------------------------------------------------------------------
proc DropSite::_release { X Y } {
    variable _target
    variable _status
    variable _curop
    variable _source
    variable _type
    variable _data

    if { $_status & 1 } {
        upvar \#0 DropSite::$_target drop

        set res [uplevel \#0 $drop(dropcmd) [list $_target $_source $X $Y $_curop $_type $_data]]
        DragSite::_end_drag $_source $_target $drop($_type,ops,$_curop) $_type $_data $res
    } else {
        if { $_status & 2 } {
            # notify leave event
            upvar \#0 DropSite::$_target drop
            uplevel \#0 $drop(overcmd) [list $_target $_source leave $X $Y $_curop $_type $_data]
        }
        DragSite::_end_drag $_source "" "" $_type $_data 0
    }
}