# ------------------------------------------------------------------------------ # dropsite.tcl # This file is part of Unifix BWidget Toolkit # $Id: dropsite.tcl,v 1.8 2009/06/30 16:17:37 oehhar 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 # ---------------------------------------------------------------------------- namespace eval DropSite { Widget::define DropSite dropsite -classonly 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 {DropSite::_update_operation [expr %s | 1]} bind DragTop {DropSite::_update_operation [expr %s | 1]} bind DragTop {DropSite::_update_operation [expr %s | 4]} bind DragTop {DropSite::_update_operation [expr %s | 4]} if { $tcl_platform(platform) == "unix" } { bind DragTop {DropSite::_update_operation [expr %s | 8]} bind DragTop {DropSite::_update_operation [expr %s | 8]} } else { bind DragTop {DropSite::_update_operation [expr %s | 16]} bind DragTop {DropSite::_update_operation [expr %s | 16]} } bind DragTop {DropSite::_update_operation [expr %s & ~1]} bind DragTop {DropSite::_update_operation [expr %s & ~1]} bind DragTop {DropSite::_update_operation [expr %s & ~4]} bind DragTop {DropSite::_update_operation [expr %s & ~4]} if { $tcl_platform(platform) == "unix" } { bind DragTop {DropSite::_update_operation [expr %s & ~8]} bind DragTop {DropSite::_update_operation [expr %s & ~8]} } else { bind DragTop {DropSite::_update_operation [expr %s & ~16]} bind DragTop {DropSite::_update_operation [expr %s & ~16]} } } # ---------------------------------------------------------------------------- # Command DropSite::include # ---------------------------------------------------------------------------- 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 } # ---------------------------------------------------------------------------- # Command DropSite::setdrop # Widget interface to register # ---------------------------------------------------------------------------- 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 } } # ---------------------------------------------------------------------------- # Command DropSite::register # ---------------------------------------------------------------------------- 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) {} set masklist {} 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 equal $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 equal $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 equal $subop "default"]) } { 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) } } } } # ---------------------------------------------------------------------------- # Command DropSite::setcursor # ---------------------------------------------------------------------------- proc DropSite::setcursor { cursor } { catch {.drag configure -cursor $cursor} } # ---------------------------------------------------------------------------- # Command DropSite::setoperation # ---------------------------------------------------------------------------- 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 {DropSite::_release %X %Y} bind $top {DropSite::_motion %X %Y} bind $top {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 ] bind $_top {} bind $_top {} 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 {DropSite::_motion %X %Y} bind $_top {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 {DropSite::_motion %X %Y} bind $_top {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 } }