/usr/share/tcltk/bwidget1.9.12/xpm2image.tcl is in bwidget 1.9.12-1.
This file is owned by root:root, with mode 0o644.
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 | # ----------------------------------------------------------------------------
# xpm2image.tcl
# Slightly modified xpm-to-image command
# $Id: xpm2image.tcl,v 1.5 2004/09/09 22:17:03 hobbs Exp $
# ------------------------------------------------------------------------------
#
# Copyright 1996 by Roger E. Critchlow Jr., San Francisco, California
# All rights reserved, fair use permitted, caveat emptor.
# rec@elf.org
#
# ----------------------------------------------------------------------------
proc _xpm-to-image_process_line { line } {
upvar 1 data data
set line [string map {"\t" " "} $line]
set idx $data(chars_per_pixel)
incr idx -1
set cname [string range $line 0 $idx]
set lend [string trim [string range $line $data(chars_per_pixel) end]]
## now replace multiple spaces with just one..
while {-1 != [string first " " $lend]} {
set lend [string map {" " " "} $lend]
}
set cl [split $lend " "]
set idx 0
set clen [llength $cl]
## scan through the line, looking for records of type c, g or m
while { $idx < $clen } {
set key [lindex $cl $idx]
if { [string equal $key {}] } {
incr idx
continue
}
while { ![string equal $key "c"]
&& ![string equal $key "m"]
&& ![string equal $key "g"]
&& ![string equal $key "g4"]
&& ![string equal $key ""]
} {
incr idx
set key [lindex $cl $idx]
}
incr idx
set color [string tolower [lindex $cl $idx]]
## one file used opaque to mean black
if { [string equal -nocase $color "opaque"] } {
set color "black"
}
set data(color-$key-$cname) $color
if { [string equal -nocase $color "none"] } {
set data(transparent) $cname
}
incr idx
}
foreach key {c g g4 m} {
if {[info exists data(color-$key-$cname)]} {
set color $data(color-$key-$cname)
set data(color-$cname) $color
set data(cname-$color) $cname
lappend data(colors) $color
break
}
}
if { ![info exists data(color-$cname)] } {
error "color definition {$line} failed to define a color"
}
}
proc xpm-to-image { file } {
set f [open $file]
set string [read $f]
close $f
# parse the strings in the xpm data
#
set xpm {}
foreach line [split $string "\n"] {
## some files have blank lines in them, skip those
## also, some files indent each line with spaces - remove those
set line [string trim $line]
if { $line eq "" } { continue }
if {[regexp {^"([^\"]*)"} $line all meat]} {
if {[string first XPMEXT $meat] == 0} {
break
}
lappend xpm $meat
}
}
#
# extract the sizes in the xpm data
#
set sizes [lindex $xpm 0]
set nsizes [llength $sizes]
if { $nsizes == 4 || $nsizes == 6 || $nsizes == 7 } {
set data(width) [lindex $sizes 0]
set data(height) [lindex $sizes 1]
set data(ncolors) [lindex $sizes 2]
set data(chars_per_pixel) [lindex $sizes 3]
set data(x_hotspot) 0
set data(y_hotspot) 0
if {[llength $sizes] >= 6} {
set data(x_hotspot) [lindex $sizes 4]
set data(y_hotspot) [lindex $sizes 5]
}
} else {
error "size line {$sizes} in $file did not compute"
}
#
# extract the color definitions in the xpm data
#
foreach line [lrange $xpm 1 $data(ncolors)] {
_xpm-to-image_process_line $line
}
#
# extract the image data in the xpm data
#
set image [image create photo -width $data(width) -height $data(height)]
set y 0
set idx 0
foreach line [lrange $xpm [expr {1+$data(ncolors)}] [expr {1+$data(ncolors)+$data(height)}]] {
set x 0
set pixels {}
while { [string length $line] > 0 } {
set pixel [string range $line 0 [expr {$data(chars_per_pixel)-1}]]
## see if they lied about the number of colors by not counting
## "none" in the color count entry
set none 0
if { ($idx == 0) && ([info exists data(cname-none)]) && \
![info exists data(color-$pixel)] } {
## it appears that way - process this line as another
## color entry
_xpm-to-image_process_line $line
incr idx
set none 1
break;
}
incr idx
set c $data(color-$pixel)
if { [string equal $c none] } {
if { [string length $pixels] } {
$image put [list $pixels] -to [expr {$x-[llength $pixels]}] $y
set pixels {}
}
} else {
lappend pixels $c
}
set line [string range $line $data(chars_per_pixel) end]
incr x
}
if { $none == 1 } {
continue
}
if { [llength $pixels] } {
$image put [list $pixels] -to [expr {$x-[llength $pixels]}] $y
}
incr y
}
#
# return the image
#
return $image
}
|