Bwidget Source Code
Check-in [f7299663b4]
Not logged in
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:xpm2image.tcl: many issues fixed in xpm import by Mattias Hembruch. Ticket [9a8b2ee42e]
Timelines: family | ancestors | descendants | both | bwidget
Files: files | file ages | folders
SHA1: f7299663b47503fb48a361d4e2c2679136a30fa9
User & Date: oehhar 2013-09-11 16:20:17
References
2014-01-21
13:16 Closed ticket [9a8b2ee42e]: xpm2image failing with qt generated xpm files plus 7 other changes artifact: 2025d77931 user: oehhar
Context
2013-09-11
16:23
Fixed undefined variable check-in: e1a66296d3 user: oehhar tags: bwidget
16:20
xpm2image.tcl: many issues fixed in xpm import by Mattias Hembruch. Ticket [9a8b2ee42e] check-in: f7299663b4 user: oehhar tags: bwidget
2013-09-02
09:39
notebook.tcl: cured error in _resize, that data($p,width) is not (jet) present. Ticket [a4cbba655d] check-in: 3e24e1b646 user: oehhar tags: bwidget
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ChangeLog.

1
2





3
4
5
6
7
8
9
2013-08-14 Harald Oehlmann <[email protected]>






	* notebook.tcl: cured error in _resize, that
	data($p,width) is not (jet) present. Ticket [a4cbba655d].

2013-06-28 Harald Oehlmann <[email protected]>

	* mainframe.tcl: Included Patch [9f67a66609]
	curing issues of Shift-Accellerators with Shift-Lock

>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
2013-08-14 Harald Oehlmann <[email protected]>

	xpm2image.tcl: many issues fixed in xpm import
	by Mattias Hembruch. Ticket [9a8b2ee42e]
	
2013-08-14 Harald Oehlmann <[email protected]>

	* notebook.tcl: cured error in _resize, that
	data($p,width) is not (jet) present. Ticket [a4cbba655d].

2013-06-28 Harald Oehlmann <[email protected]>

	* mainframe.tcl: Included Patch [9f67a66609]
	curing issues of Shift-Accellerators with Shift-Lock

Changes to xpm2image.tcl.

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
..
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
# ------------------------------------------------------------------------------
#
#  Copyright 1996 by Roger E. Critchlow Jr., San Francisco, California
#  All rights reserved, fair use permitted, caveat emptor.
#  [email protected]
# 
# ----------------------------------------------------------------------------




































































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"] {





        if {[regexp {^"([^\"]*)"} $line all meat]} {
            if {[string first XPMEXT $meat] == 0} {
                break
            }
            lappend xpm $meat
        }
    }
................................................................................
	    error "size line {$sizes} in $file did not compute"
    }

    #
    # extract the color definitions in the xpm data
    #
    foreach line [lrange $xpm 1 $data(ncolors)] {
        set colors [split $line \t]
        set cname  [lindex $colors 0]
        lappend data(cnames) $cname
        if { [string length $cname] != $data(chars_per_pixel) } {
            error "color definition {$line} in file $file has a bad size color name"
        }
        foreach record [lrange $colors 1 end] {
            set key [lindex $record 0]
            set color [string tolower [join [lrange $record 1 end] { }]]
            set data(color-$key-$cname) $color
            if { [string equal -nocase $color "none"] } {
                set data(transparent) $cname
            }
        }
        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} in $file failed to define a color"
        }
    }

    #
    # extract the image data in the xpm data
    #
    set image [image create photo -width $data(width) -height $data(height)]
    set y 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}]]













            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 { [llength $pixels] } {
            $image put [list $pixels] -to [expr {$x-[llength $pixels]}] $y
        }
        incr y
    }

    #
    # return the image
    #
    return $image
}








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>





<




>
>
>
>
>







 







|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







>





>
>
>
>
>
>
>
>
>
>
>
>
>











>
>
>












<
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
...
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

# ------------------------------------------------------------------------------
#
#  Copyright 1996 by Roger E. Critchlow Jr., San Francisco, California
#  All rights reserved, fair use permitted, caveat emptor.
#  [email protected]
# 
# ----------------------------------------------------------------------------

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} in $file 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
        }
    }
................................................................................
	    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
}