#!/bin/sh
# \
if (test -z "$WISH"); then WISH="wish"; fi
# \
exec "$WISH" "$0" -name wish ${1+"$@"}
# ==================================================================== #
# xcolors.tcl --
# Display all X colors.
# Version : 0.0.1
# Author : Mark G. Saye
# Email : [email protected]
# Copyright : Copyright (C) 2004
# Date : March 19, 2004
# See the file "license.txt" or "LICENSE.html" for information on usage
# and distribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# ==================================================================== #
proc bg {c t} {
set name [lindex [$c itemcget current -tags] 0]
$t configure -bg $name
}
# ==================================================================== #
proc fg {c t} {
set name [lindex [$c itemcget current -tags] 0]
$t configure -fg $name
}
# ==================================================================== #
proc import {file} {
global rgb
global rgbs
catch {array unset rgb}
set rgbs [list]
if { [catch {open $file r} f] } {
puts stderr "\[$::errorCode\] $f"
return
}
while { [gets $f line] > -1 } {
if { [string match !* $line] } { continue }
foreach {r g b} [string range $line 0 10] { break }
set name [string trim [string range $line 11 end]]
set rgb($name) [list $r $g $b]
lappend rgbs $name
}
close $f
}
# ==================================================================== #
proc resize {c w h} {
global dxexport
global rgb
global rgbs
global width
if { $width == $w } { return }
set width $w
$c delete all
set t 10
set dx 4
set dy 4
set x 0
set y $dy
set i -1
foreach name $rgbs {
incr i
incr x $dx
set text [$c create text 0 0 \
-text $name \
-anchor nw \
-font $c \
-tags [list $name] \
]
foreach {W N E S} [$c bbox $text] { break }
set tw [expr {$E - $W}]
set th [expr {$S - $N}]
set x1 [expr {$x+$t/2}]
set y1 [expr {$y+$t/2}]
set x2 [expr {$x1 + $tw + $t}]
set y2 [expr {$y1 + $th + $t}]
if { [expr {$x2+$t/2}] > $w } {
set x $dxexport
foreach {W N E S} [$c bbox all] { break }
set y [expr {$S+$dy}]
set x1 [expr {$x+$t/2}]
set y1 [expr {$y+$t/2}]
set x2 [expr {$x1 + $tw + $t}]
set y2 [expr {$y1 + $th + $t}]
}
try {
$c create rectangle $x1 $y1 $x2 $y2 \
-width $t -outline $name \
-tags [list $name]
$c move $text [expr {$x1+$t/2}] [expr {$y1+$t/2}]
set x [expr {$x2+$t/2}]
} on error {err} {
puts "Error loading colour '$name': $err"
}
# if { $i >= 2 } { break }
}
foreach {N W S E} [$c bbox all] { break }
$c configure -scrollregion [list 0 0 $S $E]
}
# ==================================================================== #
proc main {args} {
global dxexport ; set dxexport 10
global width ; set width 0
if { [llength $args] } {
set file [lindex $args 0]
} else {
if { [ file exists "/usr/share/X11/rgb.txt" ] == 1 } {
set file /usr/share/X11/rgb.txt
} else {
set file /usr/X11R6/lib/X11/rgb.txt
}
}
text .t -height 3
.t insert end \
"Button 1 sets the text color, button 2 sets the background.
Press q to quit. You can also type new text here.
Colours are read from $file"
canvas .c -yscrollcommand [list .y set]
scrollbar .y -orient vertical -command [list .c yview]
font create .c -family courier -size 7
pack .t -side top -expand 0 -fill x
pack .y -side left -expand 0 -fill y
pack .c -side right -expand 1 -fill both
import $file
bind . <Key-q> exit
bind .c <Configure> [list resize .c %w %h]
.c bind all <Button-1> [list fg .c .t]
.c bind all <Button-2> [list bg .c .t]
}
# ==================================================================== #
if { [info exists argv0] && [string equal [info script] $argv0] } {
eval [linsert $argv 0 main]
}
return
# ==================================================================== #Just for comparison, this weighs in at under 4 kb, whereas the compiled version is over 9 kb. Not that they're completely equivalent, of course. But it makes a good enough substitute.aspect: on my squeeze box, the script errored looking up "DebianRed" - I'm guessing the file it found (/usr/share/X11/rgb.txt) isn't canonical for whatever reason. I inserted a try block in the above code so it will continue to work and helpfully report the error on stdout. TIP154 should make this all redundant. Note that try needs 8.5 - it can be substituted with catch on older Tcl's.
See also:
