/usr/share/blt2.5/demos/dnd1.tcl is in blt-demo 2.5.3+dfsg-1.
This file is owned by root:root, with mode 0o755.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 | #!/usr/bin/wish8.6
if {[lindex $argv end] != "spawn"} {
exec [info nameofexecutable] [info script] spawn &
}
package require BLT
# --------------------------------------------------------------------------
# Starting with Tcl 8.x, the BLT commands are stored in their own
# namespace called "blt". The idea is to prevent name clashes with
# Tcl commands and variables from other packages, such as a "table"
# command in two different packages.
#
# You can access the BLT commands in a couple of ways. You can prefix
# all the BLT commands with the namespace qualifier "blt::"
#
# blt::graph .g
# blt::table . .g -resize both
#
# or you can import all the command into the global namespace.
#
# namespace import blt::*
# graph .g
# table . .g -resize both
#
# --------------------------------------------------------------------------
if { $tcl_version >= 8.0 } {
namespace import blt::*
namespace import -force blt::tile::*
}
source scripts/demo.tcl
if { ([info exists tcl_platform]) && ($tcl_platform(platform) == "windows") } {
source scripts/send.tcl
SendInit
SendVerify
}
proc OnEnter { widget args } {
array set info $args
$widget configure -highlightbackground red
return 1
}
proc OnMotion { widget args } {
array set info $args
set x1 [$widget cget -bd]
set x1 20
set y1 $x1
set x2 [expr [winfo width $widget] - $x1]
set y2 [expr [winfo height $widget] - $y1]
if { ($info(x) >= $x1) && ($info(x) <= $x2) &&
($info(y) >= $y1) && ($info(y) <= $y2) } {
$widget configure -highlightbackground red
return 1
}
$widget configure -highlightbackground grey
return 0
}
proc OnLeave { widget args } {
$widget configure -highlightbackground grey
return 0
}
option add *OnEnter OnEnter
option add *OnLeave OnLeave
option add *OnMotion OnMotion
# ----------------------------------------------------------------------
# This procedure is invoked each time a token is grabbed from the
# sample window. It configures the token to display the current
# color, and returns the color value that is later passed to the
# target handler.
# ----------------------------------------------------------------------
proc PackageSample { widget args } {
array set info $args
set bg [.sample cget -background]
set fg [.sample cget -foreground]
$info(token).label configure -background $bg -foreground $fg
return 1
}
proc ShowResult { widget args } {
array set info $args
puts "drop transaction($info(timestamp)) completed: result was $info(action)"
}
# ----------------------------------------------------------------------
# Main application window...
# ----------------------------------------------------------------------
image create photo openFolder -format gif -data {
R0lGODdhEAAOAPIAAP///wAAAH9/f9nZ2f//AAAAAAAAAAAAACwAAAAAEAAOAAADOwgqzPoQ
iDjjAoPkIZuTgCZykBCA2ziaXusRrFUGQ5zeRMCcE76xvJBPozuBVCmT0eUKGAHOqFQqqwIS
ADs=
}
label .sample -text "Color" -height 12 -width 20 -bd 2 -relief raised \
-highlightthickness 2
set cursors {
{ @bitmaps/hand/hand01.xbm bitmaps/hand/hand01m.xbm black white }
{ @bitmaps/hand/hand02.xbm bitmaps/hand/hand02m.xbm black white }
{ @bitmaps/hand/hand03.xbm bitmaps/hand/hand03m.xbm black white }
{ @bitmaps/hand/hand04.xbm bitmaps/hand/hand04m.xbm black white }
{ @bitmaps/hand/hand05.xbm bitmaps/hand/hand05m.xbm black white }
{ @bitmaps/hand/hand06.xbm bitmaps/hand/hand06m.xbm black white }
{ @bitmaps/hand/hand07.xbm bitmaps/hand/hand07m.xbm black white }
{ @bitmaps/hand/hand08.xbm bitmaps/hand/hand08m.xbm black white }
{ @bitmaps/hand/hand09.xbm bitmaps/hand/hand09m.xbm black white }
{ @bitmaps/hand/hand10.xbm bitmaps/hand/hand10m.xbm black white }
{ @bitmaps/hand/hand11.xbm bitmaps/hand/hand11m.xbm black white }
{ @bitmaps/hand/hand12.xbm bitmaps/hand/hand12m.xbm black white }
{ @bitmaps/hand/hand13.xbm bitmaps/hand/hand13m.xbm black white }
{ @bitmaps/hand/hand14.xbm bitmaps/hand/hand14m.xbm black white }
}
# Set up the color sample as a drag&drop source and target for "color" values:
dnd register .sample -source yes -target yes \
-package PackageSample \
-result ShowResult \
-cursors $cursors
dnd getdata .sample color GetColor
dnd setdata .sample color SetColor
# Establish the appearance of the token window:
set token [dnd token window .sample]
label $token.label -text "Color" -bd 2 -highlightthickness 1
pack $token.label
dnd token configure .sample -borderwidth 2 \
-relief raised -activerelief raised \
-outline pink -fill red \
-anchor s
if 1 {
scale .redScale -label "Red" -orient horizontal \
-from 0 -to 255 -command adjust_color
frame .red -width 20 -height 20 -borderwidth 3 -relief sunken
scale .greenScale -label "Green" -orient horizontal \
-from 0 -to 255 -command adjust_color
frame .green -width 20 -height 20 -borderwidth 3 -relief sunken
scale .blueScale -label "Blue" -orient horizontal \
-from 0 -to 255 -command adjust_color
frame .blue -width 20 -height 20 -borderwidth 3 -relief sunken
# ----------------------------------------------------------------------
# This procedure loads a new color value into this editor.
# ----------------------------------------------------------------------
proc GetColor { widget args } {
return [$widget cget -bg]
}
proc SetColor { widget args } {
array set info $args
set rgb [winfo rgb . $info(value)]
set r [lindex $rgb 0]
set g [lindex $rgb 1]
set b [lindex $rgb 2]
.redScale set [expr round($r/65535.0 * 255)]
.greenScale set [expr round($g/65535.0 * 255)]
.blueScale set [expr round($b/65535.0 * 255)]
}
# ----------------------------------------------------------------------
# This procedure is invoked whenever an RGB slider changes to
# update the color samples in this display.
# ----------------------------------------------------------------------
proc adjust_color {args} {
set rval [.redScale get]
.red configure -background [format "#%.2x0000" $rval]
set gval [.greenScale get]
.green configure -background [format "#00%.2x00" $gval]
set bval [.blueScale get]
.blue configure -background [format "#0000%.2x" $bval]
.sample configure -background \
[format "#%.2x%.2x%.2x" $rval $gval $bval]
if {$rval+$gval+$bval < 1.5*255} {
.sample configure -foreground white
} else {
.sample configure -foreground black
}
}
table . .redScale 1,0 -fill both
table . .red 1,1 -fill both
table . .greenScale 2,0 -fill both
table . .green 2,1 -fill both
table . .blueScale 3,0 -fill both
table . .blue 3,1 -fill both
}
table . .sample 0,0 -columnspan 2 -fill both -pady {0 4}
proc random {{max 1.0} {min 0.0}} {
global randomSeed
set randomSeed [expr (7141*$randomSeed+54773) % 259200]
set num [expr $randomSeed/259200.0*($max-$min)+$min]
return $num
}
set randomSeed [clock clicks]
.redScale set [expr round([random 255.0])]
.blueScale set [expr round([random 255.0])]
.greenScale set [expr round([random 255.0])]
bind .sample <KeyPress-Escape> { dnd cancel .sample }
focus .sample
|