Updated 2012-05-06 04:47:26 by aspect

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     : markgsaye@gmail.com
 # 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: