You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
461 lines
16 KiB
461 lines
16 KiB
# ------------------------------------------------------------------------------ |
|
# 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 <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]} |
|
} |
|
} |
|
|
|
|
|
# ---------------------------------------------------------------------------- |
|
# 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 <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 |
|
|
|
# Ticket [1ef1f56cd1] wke/amc 2022-10-12 |
|
# Prevent motion events to be handled as |
|
# drop events when handler calls update and causes pending |
|
# motion events to fire. |
|
set _status [expr {$_status & ~1}]; |
|
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 |
|
} |
|
}
|
|
|