Changeset 1649 for branches/blt4/gui/scripts

Timestamp:

Jan 31, 2010, 8:39:13 PM (15 years ago)

Author:

gah

Message:

 

File:

• branches/blt4/gui/scripts/icons.tcl (modified) (3 diffs)

branches/blt4/gui/scripts/icons.tcl

@@ -50 +50 @@
     if {"" != $file} {
         switch -- [file extension $file] {
-            .gif - .jpg - .png {
+            .gif - .jpg - .png - .xpm - .tif {
                 set imh [image create picture -file $file]
             }
@@ -75 +75 @@
 # ----------------------------------------------------------------------
 proc Rappture::icon::data {image {format "gif"}} {
-    if {[catch {$image data -format $format} result]} {
-        if {"too many colors" == $result && "" != [auto_execok djpeg]} {
-            #
-            # HACK ALERT!  We should use "blt::winop quantize" to
-            #   reduce the number of colors for GIF format.  But
-            #   it has a bug right now, so we work around it like this.
-            #
-            set tmpfile /tmp/image[pid].dat
-            $image write $tmpfile -format "jpeg -quality 100"
-            set fid [open "| djpeg -gif -quantize 250 $tmpfile" r]
-            fconfigure $fid -encoding binary -translation binary
-            set result [read $fid]
-            close $fid
-            file delete -force $tmpfile
-        } else {
-            set result ""
+    switch -- $format {
+        "gif" {
+            $image export gif -data bytes
         }
-    }
-    return $result
+        "jpeg" - "jpg" {
+            $image export jpg -data bytes -quality 100
+        }
+        default {
+            return ""
+        }
+    }       
+    return $bytes
 }
 
@@ -108 +101 @@
     }
     set delay [expr {round($delay*0.01)}] ;# convert to 1/100s of second
-
-    set imh [lindex $args 0]
-    set bytes [data $imh gif]
-    if {[string length $bytes] == 0} {
-        return ""  ;# can't query image data -- bail out!
-    }
-    gif_parse $bytes first
-
-    set final "GIF89a"
-    gif_put_short final $first(screen-w)
-    gif_put_short final $first(screen-h)
-    gif_put_byte final $first(screen-packed)
-    gif_put_byte final $first(screen-bg)
-    gif_put_byte final $first(screen-aspect)
-    gif_put_block final $first(colors)
-
-    gif_put_byte final 0x21  ;# looping block
-    gif_put_byte final 0xFF
-    gif_put_byte final 11
-    gif_put_block final "NETSCAPE2.0"
-    gif_put_byte final 3     ;# 3 bytes in this block
-    gif_put_byte final 1     ;# turn looping on
-    gif_put_short final 0    ;# number of loops (forever)
-    gif_put_byte final 0     ;# block terminator
-
-    gif_put_byte final 0x21  ;# graphic control block
-    gif_put_byte final 0xF9
-    gif_put_byte final 4     ;# 4 bytes in this block
-    gif_put_byte final 0     ;# packed bits
-    gif_put_short final [expr {5*$delay}]  ;# delay time *0.01s
-    gif_put_byte final 0     ;# transparency index
-    gif_put_byte final 0     ;# block terminator
-
-    gif_put_byte final 0x2C  ;# image block
-    gif_put_short final $first(im-0-left)
-    gif_put_short final $first(im-0-top)
-    gif_put_short final $first(im-0-wd)
-    gif_put_short final $first(im-0-ht)
-    gif_put_byte final $first(im-0-packed)
-    if {($first(im-0-packed) & 0x80) != 0} {
-        gif_put_block final $first(im-0-colors)
-    }
-    gif_put_block final $first(im-0-data)
-
-    foreach imh [lrange $args 1 end] {
-        catch {unset gif}
-        gif_parse [data $imh gif] gif
-
-        gif_put_byte final 0x21     ;# graphic control block
-        gif_put_byte final 0xF9
-        gif_put_byte final 4        ;# 4 bytes in this block
-        gif_put_byte final 0        ;# packed bits
-        gif_put_short final $delay  ;# delay time *0.01s
-        gif_put_byte final 0        ;# transparency index
-        gif_put_byte final 0        ;# block terminator
-
-        gif_put_byte final 0x2C     ;# image block
-        gif_put_short final $gif(im-0-left)
-        gif_put_short final $gif(im-0-top)
-        gif_put_short final $gif(im-0-wd)
-        gif_put_short final $gif(im-0-ht)
-
-        if {[string length $gif(im-0-colors)] > 0} {
-            gif_put_byte final $gif(im-0-packed)
-            gif_put_block final $gif(im-0-colors)
-        } else {
-            set packed [expr {($gif(im-0-packed) & 0xF8)
-                | ($gif(screen-packed) & 0x87)}]
-            gif_put_byte final $packed
-            gif_put_block final $gif(colors)
-        }
-        gif_put_block final $gif(im-0-data)
-    }
-
-    gif_put_byte final 0x3B  ;# terminate GIF
-
-    return $final
-}
-
-# ----------------------------------------------------------------------
-# USAGE: Rappture::icon::gif_parse <gifImageData> <array>
-#
-# Takes the data from a GIF image, parses it into various components,
-# and returns the information in the <array> in the calling scope.
-# ----------------------------------------------------------------------
-proc Rappture::icon::gif_parse {gifImageData arrayVar} {
-    upvar $arrayVar data
-    if {[string range $gifImageData 0 2] != "GIF"} {
-        error "not GIF data"
-    }
-    set data(version) [string range $gifImageData 0 5]
-    set pos 6
-
-    set data(screen-w) [gif_get_short $gifImageData pos]
-    set data(screen-h) [gif_get_short $gifImageData pos]
-    set data(screen-packed) [gif_get_byte $gifImageData pos]
-    set data(screen-bg) [gif_get_byte $gifImageData pos]
-    set data(screen-aspect) [gif_get_byte $gifImageData pos]
-
-    set ctsize [expr {3*(1 << ($data(screen-packed) & 0x07)+1)}]
-    set data(colors) [gif_get_block $gifImageData pos $ctsize]
-
-    set n 0
-    while {1} {
-        set ctrl [gif_get_byte $gifImageData pos]
-        switch -- [format "0x%02X" $ctrl] {
-          0x21 {
-            set ext [gif_get_byte $gifImageData pos]
-            switch -- [format "0x%02X" $ext] {
-              0xF9 {
-                # graphic control
-                set bsize [gif_get_byte $gifImageData pos]
-                set data(gc-$n-packed) [gif_get_byte $gifImageData pos]
-                set data(gc-$n-delay) [gif_get_short $gifImageData pos]
-                set data(gc-$n-transp) [gif_get_byte $gifImageData pos]
-                set bterm [gif_get_byte $gifImageData pos]
-                if {$bterm != 0} { error "bad magic $bterm" }
-              }
-              0xFE {
-                # comment extension -- skip and ignore
-                while {1} {
-                    set count [gif_get_byte $gifImageData pos]
-                    if {$count == 0} {
-                        break
-                    }
-                    incr pos $count
-                }
-              }
-              0xFF {
-                set bsize [gif_get_byte $gifImageData pos]
-                set data(app-name) [gif_get_block $gifImageData pos $bsize]
-                set data(app-bytes) ""
-                while {1} {
-                    set count [gif_get_byte $gifImageData pos]
-                    gif_put_byte data(app-bytes) $count
-                    if {$count == 0} {
-                        break
-                    }
-                    gif_put_block data(app-bytes) \
-                        [gif_get_block $gifImageData pos $count]
-                }
-              }
-              default {
-                error [format "unknown extension code 0x%02X" $ext]
-              }
-            }
-          }
-          0x2C {
-            # image data
-            set data(im-$n-left) [gif_get_short $gifImageData pos]
-            set data(im-$n-top) [gif_get_short $gifImageData pos]
-            set data(im-$n-wd) [gif_get_short $gifImageData pos]
-            set data(im-$n-ht) [gif_get_short $gifImageData pos]
-            set data(im-$n-packed) [gif_get_byte $gifImageData pos]
-            set data(im-$n-colors) ""
-            if {($data(im-$n-packed) & 0x80) != 0} {
-                set ctsize [expr {3*(1 << ($data(im-$n-packed) & 0x07)+1)}]
-                set data(im-$n-colors) [gif_get_block $gifImageData pos $ctsize]
-            }
-   
-            set data(im-$n-data) ""
-            gif_put_byte data(im-$n-data) \
-                [gif_get_byte $gifImageData pos] ;# lwz min code size
-            while {1} {
-                set count [gif_get_byte $gifImageData pos]
-                gif_put_byte data(im-$n-data) $count
-                if {$count == 0} {
-                    break
-                }
-                gif_put_block data(im-$n-data) \
-                    [gif_get_block $gifImageData pos $count]
-            }
-            incr n
-          }
-          0x3B {
-            # end of image data
-            break
-          }
-          default {
-            error [format "unexpected control byte 0x%02X" $ctrl]
-          }
-        }
-    }
-}
-
-# ----------------------------------------------------------------------
-# USAGE: Rappture::icon::gif_get_byte <buffer> <posVar>
-#
-# Extracts one byte of information from the <buffer> at the index
-# specified by <posVar> in the calling scope.  Increments <posVar>
-# to move past the byte and returns the byte of information.
-# ----------------------------------------------------------------------
-proc Rappture::icon::gif_get_byte {buffer posVar} {
-    upvar $posVar pos
-    set byte [string range $buffer $pos $pos]
-    incr pos 1
-
-    binary scan $byte c rval
-    if {$rval < 0} {incr rval 256}
-    return $rval
-}
-
-# ----------------------------------------------------------------------
-# USAGE: Rappture::icon::gif_get_short <buffer> <posVar>
-#
-# Extracts one short int of information from the <buffer> at the index
-# specified by <posVar> in the calling scope.  Increments <posVar>
-# to move past the int and returns the information.
-# ----------------------------------------------------------------------
-proc Rappture::icon::gif_get_short {buffer posVar} {
-    upvar $posVar pos
-    set bytes [string range $buffer $pos [expr {$pos+1}]]
-    incr pos 2
-
-    binary scan $bytes s rval
-    if {$rval < 0} {incr rval 65536}
-    return $rval
-}
-
-# ----------------------------------------------------------------------
-# USAGE: Rappture::icon::gif_get_block <buffer> <posVar> <size>
-#
-# Extracts <size> bytes of information from the <buffer> at the index
-# specified by <posVar> in the calling scope.  Increments <posVar>
-# to move past the byte and returns the byte of information.
-# ----------------------------------------------------------------------
-proc Rappture::icon::gif_get_block {buffer posVar size} {
-    upvar $posVar pos
-    set bytes [string range $buffer $pos [expr {$pos+$size-1}]]
-    incr pos $size
+    set img [image create picture]
+    $img copy [lindex $args 0]
+    eval $img append [lrange $args 1 end]
+    $img export gif -animated -data bytes -delay $delay
+    image delete $img
     return $bytes
 }
 
-# ----------------------------------------------------------------------
-# USAGE: Rappture::icon::gif_put_byte <buffer> <charVal>
-#
-# Appends one byte of information onto the <buffer> in the calling
-# scope.  The <charVal> is an integer in the range 0-255.  It is
-# formated as a single byte and appended onto the buffer.
-# ----------------------------------------------------------------------
-proc Rappture::icon::gif_put_byte {bufferVar char} {
-    upvar $bufferVar buffer
-    append buffer [binary format c $char]
-}
-
-# ----------------------------------------------------------------------
-# USAGE: Rappture::icon::gif_put_short <buffer> <shortVal>
-#
-# Appends one byte of information onto the <buffer> in the calling
-# scope.  The <shortVal> is an integer in the range 0-65535.  It is
-# formated as a 2-byte short integer and appended onto the buffer.
-# ----------------------------------------------------------------------
-proc Rappture::icon::gif_put_short {bufferVar short} {
-    upvar $bufferVar buffer
-    append buffer [binary format s $short]
-}
-
-# ----------------------------------------------------------------------
-# USAGE: Rappture::icon::gif_put_block <buffer> <val>
-#
-# Appends a string <val> onto the <buffer> in the calling scope.
-# ----------------------------------------------------------------------
-proc Rappture::icon::gif_put_block {bufferVar val} {
-    upvar $bufferVar buffer
-    append buffer $val
-}