arcadia 0.1.1 → 0.1.2

data/tcl/BWidget-1.8.0/dropsite.tcl

@@ -0,0 +1,455 @@
+# ------------------------------------------------------------------------------
+#  dropsite.tcl
+#  This file is part of Unifix BWidget Toolkit
+#  $Id: dropsite.tcl,v 1.7 2003/10/20 21:23:52 damonc 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) {}
+            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
+
+        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
+    }
+}