1
# ----------------------------------------------------------------------------
3
# Slightly modified xpm-to-image command
4
# $Id: xpm2image.tcl 606 2004-04-05 07:06:06Z mcourtoi $
5
# ------------------------------------------------------------------------------
7
# Copyright 1996 by Roger E. Critchlow Jr., San Francisco, California
8
# All rights reserved, fair use permitted, caveat emptor.
11
# ----------------------------------------------------------------------------
13
proc xpm-to-image { file } {
19
# parse the strings in the xpm data
22
foreach line [split $string "\n"] {
23
if {[regexp {^"([^\"]*)"} $line all meat]} {
24
if {[string first XPMEXT $meat] == 0} {
31
# extract the sizes in the xpm data
33
set sizes [lindex $xpm 0]
34
set nsizes [llength $sizes]
35
if { $nsizes == 4 || $nsizes == 6 || $nsizes == 7 } {
36
set data(width) [lindex $sizes 0]
37
set data(height) [lindex $sizes 1]
38
set data(ncolors) [lindex $sizes 2]
39
set data(chars_per_pixel) [lindex $sizes 3]
42
if {[llength $sizes] >= 6} {
43
set data(x_hotspot) [lindex $sizes 4]
44
set data(y_hotspot) [lindex $sizes 5]
47
error "size line {$sizes} in $file did not compute"
51
# extract the color definitions in the xpm data
53
foreach line [lrange $xpm 1 $data(ncolors)] {
54
set colors [split $line \t]
55
set cname [lindex $colors 0]
56
lappend data(cnames) $cname
57
if { [string length $cname] != $data(chars_per_pixel) } {
58
error "color definition {$line} in file $file has a bad size color name"
60
foreach record [lrange $colors 1 end] {
61
set key [lindex $record 0]
62
set color [string tolower [join [lrange $record 1 end] { }]]
63
set data(color-$key-$cname) $color
64
if { [string equal $color "none"] } {
65
set data(transparent) $cname
68
foreach key {c g g4 m} {
69
if {[info exists data(color-$key-$cname)]} {
70
set color $data(color-$key-$cname)
71
set data(color-$cname) $color
72
set data(cname-$color) $cname
73
lappend data(colors) $color
77
if { ![info exists data(color-$cname)] } {
78
error "color definition {$line} in $file failed to define a color"
83
# extract the image data in the xpm data
85
set image [image create photo -width $data(width) -height $data(height)]
87
foreach line [lrange $xpm [expr {1+$data(ncolors)}] [expr {1+$data(ncolors)+$data(height)}]] {
90
while { [string length $line] > 0 } {
91
set pixel [string range $line 0 [expr {$data(chars_per_pixel)-1}]]
92
set c $data(color-$pixel)
93
if { [string equal $c none] } {
94
if { [string length $pixels] } {
95
$image put [list $pixels] -to [expr {$x-[llength $pixels]}] $y
101
set line [string range $line $data(chars_per_pixel) end]
104
if { [llength $pixels] } {
105
$image put [list $pixels] -to [expr {$x-[llength $pixels]}] $y
added
removed
ASTK_CLIENT/lib/BWidget-1.7.0/xpm2image.tcl
