Tk Library Source Code

Artifact 8a46e29008c91ecd07f6245f47f71b12cc49595a:

Attachment "tklib-w24.patch" to ticket [3007168fff] added by a_kovalenko 2010-05-26 09:33:31.

---

Index: tklib/modules/ico/ico.tcl
===================================================================
RCS file: /cvsroot/tcllib/tklib/modules/ico/ico.tcl,v
retrieving revision 1.30
diff -u -r1.30 ico.tcl
--- tklib/modules/ico/ico.tcl	13 Oct 2009 06:42:02 -0000	1.30
+++ tklib/modules/ico/ico.tcl	26 May 2010 00:49:48 -0000
@@ -272,10 +272,10 @@
 #
 proc ::ico::writeIcon {file name bpp data args} {
     parseOpts type $args
-    if {![file exists $file]} {
-        return -code error "couldn't open \"$file\": no such file or directory"
-    }
     gettype type $file
+    # if {![file exists $file]} {
+    #     return -code error "couldn't open \"$file\": no such file or directory"
+    # }
     if {![llength [info commands writeIcon$type]]} {
 	return -code error "unsupported file format $type"
     }
@@ -518,22 +518,22 @@
 
 # reads a 32 bit signed integer from the filehandle
 proc ::ico::getdword {fh} {
-    binary scan [read $fh 4] i* tmp
+    binary scan [read $fh 4] iu* tmp
     return $tmp
 }
 
 proc ::ico::getword {fh} {
-    binary scan [read $fh 2] s* tmp
+    binary scan [read $fh 2] su* tmp
     return $tmp
 }
 
 proc ::ico::getulong {fh} {
-    binary scan [read $fh 4] i tmp
+    binary scan [read $fh 4] iu tmp
     return [format %u $tmp]
 }
 
 proc ::ico::getushort {fh} {
-    binary scan [read $fh 2] s tmp
+    binary scan [read $fh 2] su tmp
     return [expr {$tmp & 0x0000FFFF}]
 }
 
@@ -651,7 +651,8 @@
     foreach line $colors {
 	set l {}
 	foreach x $line {append l [expr {$x eq ""}]}
-	append l [string repeat 0 [expr {[string length $l] % 32}]]
+	set curx [string length $l]
+	append l [string repeat 0 [expr {$curx == 24 ? 8 : $curx % 32}]]
 	foreach {a b c d e f g h} [split $l {}] {
 	    append and [binary format B8 $a$b$c$d$e$f$g$h]
 	}
@@ -770,8 +771,8 @@
 # calculate byte size of an icon.
 # often passed $w twice because $h is double $w in the binary data
 proc ::ico::calcSize {w h bpp {offset 0}} {
-    set s [expr {int(($w*$h) * ($bpp/8.0)) \
-		     + ((($w*$h) + ($h*($w%32)))/8) + $offset}]
+    set s [expr {($w*$h*$bpp)/8 \
+		     + ($w*$h+($h*($w==24?8:$w%32)))/8 + $offset}]
     if {$bpp <= 8} { set s [expr {$s + (1 << ($bpp + 2))}] }
     return $s
 }
@@ -795,8 +796,8 @@
 	return -code error "unsupported color depth: $bpp"
     }
 
-    set xor  [read $fh [expr {int(($w * $h) * ($bpp / 8.0))}]]
-    set and1 [read $fh [expr {(($w * $h) + ($h * ($w % 32))) / 8}]]
+    set xor  [read $fh [expr {$w*$h*$bpp/8}]]
+    set and1 [read $fh [expr {(($w * $h) + ($h * ($w==24? 8 : $w % 32))) / 8}]]
 
     set and {}
     set row [expr {((($w - 1) / 32) * 32 + 32) / 8}]
@@ -838,7 +839,7 @@
     set end  [expr {$cnt + int(($w * $h) * ($bpp / 8.0)) - 1}]
     set xor  [string range $data $cnt $end]
     set and1 [string range $data [expr {$end + 1}] \
-		  [expr {$end + ((($w * $h) + ($h * ($w % 32))) / 8) - 1}]]
+		  [expr {$end + ((($w * $h) + ($h * ($w==24 ? 8 : $w % 32))) / 8) - 1}]]
 
     set and {}
     set row [expr {((($w - 1) / 32) * 32 + 32) / 8}]
@@ -1196,7 +1197,7 @@
 	return -code error "icon format differs from original"
     }
     
-    set fh [open $file r+]
+    set fh [open $file rb+]
     fconfigure $fh -eofchar {} -encoding binary -translation lf
     seek $fh [expr {$RES($file,icon,$name,offset) + 40}] start
 
@@ -1211,7 +1212,7 @@
         return [llength $RES($file,group,names)]
     }
 
-    set fh [open $file]
+    set fh [open $file rb]
     fconfigure $fh -eofchar {} -encoding binary -translation lf
     if {[read $fh 2] ne "MZ"} {
 	close $fh