MGS [2004/03/19] - A quick implementation of the X11 xcolors program.
#!/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: