URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [tix/] [library/] [DragDrop.tcl] - Blame information for rev 1765

Details | Compare with Previous | View Log


# DragDrop.tcl ---
#
#       Implements drag+drop for Tix widgets.
#
# Copyright (c) 1996, Expert Interface Technologies
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
 
tixClass tixDragDropContext {
    -superclass {}
    -classname  TixDragDropContext
    -method {
        cget configure drag drop set startdrag
    }
    -flag {
        -command -source
    }
    -configspec {
        {-command ""}
        {-source ""}
    }
}
 
proc tixDragDropContext:Constructor {w} {
    upvar #0 $w data
}
 
#----------------------------------------------------------------------
# Private methods
#
#----------------------------------------------------------------------
proc tixDragDropContext:CallCommand {w target command X Y} {
    upvar #0 $w data
 
    set x [expr $X-[winfo rootx $target]]
    set y [expr $Y-[winfo rooty $target]]
 
    regsub %x $command $x command
    regsub %y $command $y command
    regsub %X $command $X command
    regsub %Y $command $Y command
    regsub %W $command $target command
    regsub %S $command [list $data(-command)] command
 
    eval $command
}
 
proc tixDragDropContext:Send {w target event X Y} {
    upvar #0 $w data
    global tixDrop
 
    foreach tag [tixDropBindTags $target] {
        if [info exists tixDrop($tag,$event)] {
            tixDragDropContext:CallCommand $w $target \
                $tixDrop($tag,$event) $X $Y
        }
    }
}
 
#----------------------------------------------------------------------
# set --
#
#       Set the "small data" of the type supported by the source widget
#----------------------------------------------------------------------
 
proc tixDragDropContext:set {w type data} {
 
}
 
#----------------------------------------------------------------------
# startdrag --
#
#       Start the dragging action
#----------------------------------------------------------------------
proc tixDragDropContext:startdrag {w x y} {
    upvar #0 $w data
 
    set data(oldTarget) ""
 
    $data(-source) config -cursor "[tix getbitmap drop] black"
    tixDragDropContext:drag $w $x $y
}
 
#----------------------------------------------------------------------
# drag --
#
#       Continue the dragging action
#----------------------------------------------------------------------
proc tixDragDropContext:drag {w X Y} {
    upvar #0 $w data
    global tixDrop
 
    set target [winfo containing $X $Y]
 
    if {$target != $data(oldTarget)} {
        if {$data(oldTarget) != ""} {
            tixDragDropContext:Send $w $data(oldTarget) <Out> $X $Y
        }
        if {$target != ""} {
            tixDragDropContext:Send $w $target <In> $X $Y
        }
        set data(oldTarget) $target
    }
    if {$target != ""} {
        tixDragDropContext:Send $w $target <Over> $X $Y
    }
}
 
proc tixDragDropContext:drop {w X Y} {
    upvar #0 $w data
    global tixDrop
 
    set target [winfo containing $X $Y]
    if {$target != ""} {
        tixDragDropContext:Send $w $target <Drop> $X $Y
    }
 
    if {$data(-source) != ""} {
        $data(-source) config -cursor ""
    }
    set data(-source) ""
}
 
#----------------------------------------------------------------------
# Public Procedures -- This is NOT a member of the tixDragDropContext
#                      class!
#
# parameters :
#       $w:     who wants to start dragging? (currently ignored)
#----------------------------------------------------------------------
proc tixGetDragDropContext {w} {
    global tixDD
    if {[info exists tixDD]} {
        return tixDD
    }
 
    return [tixDragDropContext tixDD]
}
 
proc tixDropBind {w event command} {
    global tixDrop
 
    set tixDrop($w) 1
    set tixDrop($w,$event) $command
}
 
proc tixDropBindTags {w args} {
    global tixDropTags
 
    if {$args == ""} {
        if [info exists tixDropTags($w)] {
            return $tixDropTags($w)
        } else {
            return [list [winfo class $w] $w]
        }
    } else {
        set tixDropTags($w) $args
    }
}

Line No.	Rev	Author	Line
1	578	markom	`# DragDrop.tcl ---`
2			`#`
3			`# Implements drag+drop for Tix widgets.`
4			`#`
5			`# Copyright (c) 1996, Expert Interface Technologies`
6			`#`
7			`# See the file "license.terms" for information on usage and redistribution`
8			`# of this file, and for a DISCLAIMER OF ALL WARRANTIES.`
9			`#`
10
11			`tixClass tixDragDropContext {`
12			`-superclass {}`
13			`-classname TixDragDropContext`
14			`-method {`
15			`cget configure drag drop set startdrag`
16			`}`
17			`-flag {`
18			`-command -source`
19			`}`
20			`-configspec {`
21			`{-command ""}`
22			`{-source ""}`
23			`}`
24			`}`
25
26			`proc tixDragDropContext:Constructor {w} {`
27			`upvar #0 $w data`
28			`}`
29
30			`#----------------------------------------------------------------------`
31			`# Private methods`
32			`#`
33			`#----------------------------------------------------------------------`
34			`proc tixDragDropContext:CallCommand {w target command X Y} {`
35			`upvar #0 $w data`
36
37			`set x [expr $X-[winfo rootx $target]]`
38			`set y [expr $Y-[winfo rooty $target]]`
39
40			`regsub %x $command $x command`
41			`regsub %y $command $y command`
42			`regsub %X $command $X command`
43			`regsub %Y $command $Y command`
44			`regsub %W $command $target command`
45			`regsub %S $command [list $data(-command)] command`
46
47			`eval $command`
48			`}`
49
50			`proc tixDragDropContext:Send {w target event X Y} {`
51			`upvar #0 $w data`
52			`global tixDrop`
53
54			`foreach tag [tixDropBindTags $target] {`
55			`if [info exists tixDrop($tag,$event)] {`
56			`tixDragDropContext:CallCommand $w $target \`
57			`$tixDrop($tag,$event) $X $Y`
58			`}`
59			`}`
60			`}`
61
62			`#----------------------------------------------------------------------`
63			`# set --`
64			`#`
65			`# Set the "small data" of the type supported by the source widget`
66			`#----------------------------------------------------------------------`
67
68			`proc tixDragDropContext:set {w type data} {`
69
70			`}`
71
72			`#----------------------------------------------------------------------`
73			`# startdrag --`
74			`#`
75			`# Start the dragging action`
76			`#----------------------------------------------------------------------`
77			`proc tixDragDropContext:startdrag {w x y} {`
78			`upvar #0 $w data`
79
80			`set data(oldTarget) ""`
81
82			`$data(-source) config -cursor "[tix getbitmap drop] black"`
83			`tixDragDropContext:drag $w $x $y`
84			`}`
85
86			`#----------------------------------------------------------------------`
87			`# drag --`
88			`#`
89			`# Continue the dragging action`
90			`#----------------------------------------------------------------------`
91			`proc tixDragDropContext:drag {w X Y} {`
92			`upvar #0 $w data`
93			`global tixDrop`
94
95			`set target [winfo containing $X $Y]`
96
97			`if {$target != $data(oldTarget)} {`
98			`if {$data(oldTarget) != ""} {`
99			`tixDragDropContext:Send $w $data(oldTarget) <Out> $X $Y`
100			`}`
101			`if {$target != ""} {`
102			`tixDragDropContext:Send $w $target <In> $X $Y`
103			`}`
104			`set data(oldTarget) $target`
105			`}`
106			`if {$target != ""} {`
107			`tixDragDropContext:Send $w $target <Over> $X $Y`
108			`}`
109			`}`
110
111			`proc tixDragDropContext:drop {w X Y} {`
112			`upvar #0 $w data`
113			`global tixDrop`
114
115			`set target [winfo containing $X $Y]`
116			`if {$target != ""} {`
117			`tixDragDropContext:Send $w $target <Drop> $X $Y`
118			`}`
119
120			`if {$data(-source) != ""} {`
121			`$data(-source) config -cursor ""`
122			`}`
123			`set data(-source) ""`
124			`}`
125
126			`#----------------------------------------------------------------------`
127			`# Public Procedures -- This is NOT a member of the tixDragDropContext`
128			`# class!`
129			`#`
130			`# parameters :`
131			`# $w: who wants to start dragging? (currently ignored)`
132			`#----------------------------------------------------------------------`
133			`proc tixGetDragDropContext {w} {`
134			`global tixDD`
135			`if {[info exists tixDD]} {`
136			`return tixDD`
137			`}`
138
139			`return [tixDragDropContext tixDD]`
140			`}`
141
142			`proc tixDropBind {w event command} {`
143			`global tixDrop`
144
145			`set tixDrop($w) 1`
146			`set tixDrop($w,$event) $command`
147			`}`
148
149			`proc tixDropBindTags {w args} {`
150			`global tixDropTags`
151
152			`if {$args == ""} {`
153			`if [info exists tixDropTags($w)] {`
154			`return $tixDropTags($w)`
155			`} else {`
156			`return [list [winfo class $w] $w]`
157			`}`
158			`} else {`
159			`set tixDropTags($w) $args`
160			`}`
161			`}`

Browse

Tools

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [tix/] [library/] [DragDrop.tcl] - Blame information for rev 1765