Artifact 060467994d5f54fa58219ada78ec10cd436c7b82:

Attachment "xpm2image.tcl" to ticket [9a8b2ee42e] added by oehhar 2013-09-11 16:12:38.

---

# ----------------------------------------------------------------------------
#  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.
#  [email protected]
# 
# ----------------------------------------------------------------------------

proc 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..
    set lmap [string map {"  " " "} $lend]
    while { ![string equal $lend $lmap] } {
        set lend $lmap
        set lmap [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
        }
    }
    #
    # 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)] {
        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
                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
}