dropsite.tcl

dropsite.tcl
This file is part of Unifix BWidget Toolkit
$Id: dropsite.tcl,v 1.5 2000/06/15 00:45:16 kuchler Exp $
Index of commands:
- DropSite::include
- DropSite::setdrop
- DropSite::register
- DropSite::setcursor
- DropSite::setoperation
- DropSite::_update_operation
- DropSite::_compute_operation
- DropSite::_draw_operation
- DropSite::_init_drag
- DropSite::_motion
- DropSite::_release


DropSite
Comments  
Arguments  
Used by  
Uses  
namespace eval DropSite {
    Widget::declare DropSite [list \
        [list -dropovercmd String "" 0] \
        [list -dropcmd     String "" 0] \
        [list -droptypes   String "" 0] \
        ]

    proc use {} {}

    variable _top  ".drag"
    variable _opw  ".drag.\#op"
    variable _target  ""
    variable _status  0
    variable _tabops
    variable _defops
    variable _source
    variable _type
    variable _data
    variable _evt
    # key       win    unix
    # shift       1   |   1    ->  1
    # control     4   |   4    ->  4
    # alt         8   |  16    -> 24
    # meta            |  64    -> 88

    array set _tabops {
        mod,none    0
        mod,shift   1
        mod,control 4
        mod,alt     24
        ops,copy    1
        ops,move    1
        ops,link    1
    }

    if { $tcl_platform(platform) == "unix" } {
        set _tabops(mod,alt) 8
    } else {
        set _tabops(mod,alt) 16
    }
    array set _defops \
        [list \
             copy,mod  shift   \
             move,mod  control \
             link,mod  alt     \
             copy,img  @[file join $::BWIDGET::LIBRARY "images" "opcopy.xbm"] \
             move,img  @[file join $::BWIDGET::LIBRARY "images" "opmove.xbm"] \
             link,img  @[file join $::BWIDGET::LIBRARY "images" "oplink.xbm"]]

    bind DragTop <KeyPress-Shift_L>     {DropSite::_update_operation [expr %s | 1]}
    bind DragTop <KeyPress-Shift_R>     {DropSite::_update_operation [expr %s | 1]}
    bind DragTop <KeyPress-Control_L>   {DropSite::_update_operation [expr %s | 4]}
    bind DragTop <KeyPress-Control_R>   {DropSite::_update_operation [expr %s | 4]}
    if { $tcl_platform(platform) == "unix" } {
        bind DragTop <KeyPress-Alt_L>       {DropSite::_update_operation [expr %s | 8]}
        bind DragTop <KeyPress-Alt_R>       {DropSite::_update_operation [expr %s | 8]}
    } else {
        bind DragTop <KeyPress-Alt_L>       {DropSite::_update_operation [expr %s | 16]}
        bind DragTop <KeyPress-Alt_R>       {DropSite::_update_operation [expr %s | 16]}
    }

    bind DragTop <KeyRelease-Shift_L>   {DropSite::_update_operation [expr %s & ~1]}
    bind DragTop <KeyRelease-Shift_R>   {DropSite::_update_operation [expr %s & ~1]}
    bind DragTop <KeyRelease-Control_L> {DropSite::_update_operation [expr %s & ~4]}
    bind DragTop <KeyRelease-Control_R> {DropSite::_update_operation [expr %s & ~4]}
    if { $tcl_platform(platform) == "unix" } {
        bind DragTop <KeyRelease-Alt_L>     {DropSite::_update_operation [expr %s & ~8]}
        bind DragTop <KeyRelease-Alt_R>     {DropSite::_update_operation [expr %s & ~8]}
    } else {
        bind DragTop <KeyRelease-Alt_L>     {DropSite::_update_operation [expr %s & ~16]}
        bind DragTop <KeyRelease-Alt_R>     {DropSite::_update_operation [expr %s & ~16]}
    }
}


DropSite::_compute_operation
Comments Command DropSite::_compute_operation
Arguments target
state
type
Used by  
Uses  
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
}


DropSite::_draw_operation
Comments Command DropSite::_draw_operation
Arguments target
type
Used by  
Uses  
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 compare $_curop "default"] } {
        catch {place forget $_opw}
    } else {
        catch {
            $_opw configure -bitmap $drop($type,img,$_curop)
            place $_opw -relx 1 -rely 1 -anchor se
        }
    }
}


DropSite::_init_drag
Comments Command DropSite::_init_drag
Arguments top
evt
source
state
X
Y
type
ops
data
Used by DragSite::_init_drag
Uses DropSite::_release
DropSite::_motion
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
}


DropSite::_motion
Comments Command DropSite::_motion
Arguments X
Y
Used by DropSite::_motion
DropSite::_init_drag
Uses DropSite::_release
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 compare $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}
    }
}


DropSite::_release
Comments Command DropSite::_release
Arguments X
Y
Used by DropSite::_motion
DropSite::_init_drag
Uses DragSite::_end_drag
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
    }
}


DropSite::_update_operation
Comments Command DropSite::_update_operation
Arguments state
Used by  
Uses  
proc DropSite::_update_operation { state } {
    variable _top
    variable _status
    variable _state

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


DropSite::include
Comments Command DropSite::include
Arguments class
types
Used by  
Uses Widget::declare
proc DropSite::include { class types } {
    set dropoptions [list \
        [list    -dropenabled    Boolean    0    0] \
        [list    -dropovercmd    String    ""    0] \
        [list    -dropcmd    String    ""    0] \
        [list    -droptypes    String    $types    0] \
        ]
    Widget::declare $class $dropoptions
}


DropSite::register
Comments Command DropSite::register
Arguments path
args
Used by  
Uses Widget::getMegawidgetOption
Widget::destroy
Widget::init
proc DropSite::register { path args } {
    variable _tabops
    variable _defops
    upvar \#0 DropSite::$path drop

    Widget::init DropSite .drop$path $args
    if { [info exists drop] } {
        unset drop
    }
    set dropcmd [Widget::getMegawidgetOption .drop$path -dropcmd]
    set types   [Widget::getMegawidgetOption .drop$path -droptypes]
    set overcmd [Widget::getMegawidgetOption .drop$path -dropovercmd]
    Widget::destroy .drop$path
    if { $dropcmd != "" && $types != "" } {
        set drop(dropcmd) $dropcmd
        set drop(overcmd) $overcmd
        foreach {type ops} $types {
            set drop($type,ops) {}
            foreach {descop lmod} $ops {
                if { ![llength $descop] || [llength $descop] > 3 } {
                    return -code error "invalid operation description \"$descop\""
                }
                foreach {subop baseop imgop} $descop {
                    set subop [string trim $subop]
                    if { ![string length $subop] } {
                        return -code error "sub operation is empty"
                    }
                    if { ![string length $baseop] } {
                        set baseop $subop
                    }
                    if { [info exists drop($type,ops,$subop)] } {
                        return -code error "operation \"$subop\" already defined"
                    }
                    if { ![info exists _tabops(ops,$baseop)] } {
                        return -code error "invalid base operation \"$baseop\""
                    }
                    if { [string compare $subop $baseop] &&
                         [info exists _tabops(ops,$subop)] } {
                        return -code error "sub operation \"$subop\" is a base operation"
                    }
                    if { ![string length $imgop] } {
                        set imgop $_defops($baseop,img)
                    }
                }
                if { ![string compare $lmod "program"] } {
                    set drop($type,ops,$subop) $baseop
                    set drop($type,img,$subop) $imgop
                } else {
                    if { ![string length $lmod] } {
                        set lmod $_defops($baseop,mod)
                    }
                    set mask 0
                    foreach mod $lmod {
                        if { ![info exists _tabops(mod,$mod)] } {
                            return -code error "invalid modifier \"$mod\""
                        }
                        set mask [expr {$mask | $_tabops(mod,$mod)}]
                    }
                    if { ($mask == 0) != ([string compare $subop "default"] == 0) } {
                        return -code error "sub operation default can only be used with modifier \"none\""
                    }
                    set drop($type,mod,$mask)  $subop
                    set drop($type,ops,$subop) $baseop
                    set drop($type,img,$subop) $imgop
                    lappend masklist $mask
                }
            }
            if { ![info exists drop($type,mod,0)] } {
                set drop($type,mod,0)       default
                set drop($type,ops,default) copy
                set drop($type,img,default) $_defops(copy,img)
                lappend masklist 0
            }
            set drop($type,ops,force) copy
            set drop($type,img,force) $_defops(copy,img)
            foreach mask [lsort -integer -decreasing $masklist] {
                lappend drop($type,ops) $mask $drop($type,mod,$mask)
            }
        }
    }
}


DropSite::setcursor
Comments Command DropSite::setcursor
Arguments cursor
Used by Tree::_over_cmd
ListBox::_auto_scroll
Entry::_over_cmd
Entry::_auto_scroll
ListBox::_over_cmd
ListBox::_scroll
Tree::_auto_scroll
Tree::_scroll
BWLabel::_over_cmd
Entry::_scroll
Uses  
proc DropSite::setcursor { cursor } {
    catch {.drag configure -cursor $cursor}
}


DropSite::setdrop
Comments Command DropSite::setdrop
Widget interface to register
Arguments path
subpath
dropover
drop
force
Used by BWLabel::create
BWLabel::configure
Tree::create
Entry::create
ListBox::configure
ListBox::create
Tree::configure
Entry::configure
Uses Widget::hasChanged
proc DropSite::setdrop { path subpath dropover drop {force 0}} {
    set cen    [Widget::hasChanged $path -dropenabled en]
    set ctypes [Widget::hasChanged $path -droptypes   types]
    if { $en } {
        if { $force || $cen || $ctypes } {
            register $subpath \
                -droptypes   $types \
                -dropcmd     $drop  \
                -dropovercmd $dropover
        }
    } else {
        register $subpath
    }
}


DropSite::setoperation
Comments Command DropSite::setoperation
Arguments op
Used by  
Uses  
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
    }
}
generated by zdoc.tcl on 2003-03-06 00:21:54