1# ico.tcl -- 2# 3# Win32 ico manipulation code 4# 5# Copyright (c) 2003 Aaron Faupell 6# Copyright (c) 2003-2004 ActiveState Corporation 7# 8# RCS: @(#) $Id: ico0.tcl,v 1.2 2007/02/23 23:28:33 hobbs Exp $ 9 10# JH: speed has been considered in these routines, although they 11# may not be fully optimized. Running EXEtoICO on explorer.exe, 12# which has nearly 100 icons, takes .2 secs on a P4/2.4ghz machine. 13# 14 15# Sample usage: 16# set file bin/wish.exe 17# set icos [::ico::getIconList $file] 18# set img [::ico::getIcon $file 1 -format image] 19 20package require Tcl 8.4 21 22# Instantiate vars we need for this package 23namespace eval ::ico { 24 namespace export getIconList getIcon writeIcon copyIcon transparentColor clearCache EXEtoICO 25 # stores cached indices of icons found 26 variable ICONS 27 array set ICONS {} 28 29 # used for 4bpp number conversion 30 variable BITS 31 array set BITS [list {} 0 0000 0 0001 1 0010 2 0011 3 0100 4 \ 32 0101 5 0110 6 0111 7 1000 8 1001 9 \ 33 1010 10 1011 11 1100 12 1101 13 1110 14 1111 15 \ 34 \ 35 00000 00 00001 0F 00010 17 00011 1F \ 36 00100 27 00101 2F 00110 37 00111 3F \ 37 01000 47 01001 4F 01010 57 01011 5F \ 38 01100 67 01101 6F 01110 77 01111 7F \ 39 10000 87 10001 8F 10010 97 10011 9F \ 40 10100 A7 10101 AF 10110 B7 10111 BF \ 41 11000 C7 11001 CF 11010 D7 11011 DF \ 42 11100 E7 11101 EF 11110 F7 11111 FF] 43} 44 45 46# getIconList -- 47# 48# List of icons in the file (each element a list of w h and bpp) 49# 50# ARGS: 51# file File to extra icon info from. 52# ?-type? Type of file. If not specified, it is derived from 53# the file extension. Currently recognized types are 54# EXE, DLL, ICO and ICL 55# 56# RETURNS: 57# list of icons' dimensions as tuples {width height bpp} 58# 59proc ::ico::getIconList {file args} { 60 parseOpts type $args 61 if {![info exists type]} { 62 # $type wasn't specified - get it from the extension 63 set type [fileext $file] 64 } 65 if {![llength [info commands getIconList$type]]} { 66 return -code error "unsupported file format $type" 67 } 68 getIconList$type [file normalize $file] 69} 70 71# getIcon -- 72# 73# Get pixel data or image of icon @ index in file 74# 75# ARGS: 76# file File to extra icon info from. 77# index Index of icon in the file to use. The ordering is the 78# same as returned by getIconList. (0-based) 79# ?-type? Type of file. If not specified, it is derived from 80# the file extension. Currently recognized types are 81# EXE, DLL, ICO and ICL 82# ?-format? Output format. Must be one of "image" or "colors" 83# 'image' will return the name of a Tk image. 84# 'colors' will return a list of pixel values 85# ?-name? If output is image, use this as the name of Tk image 86# created 87# 88# RETURNS: 89# pixel data as a list that could be passed to 'image create' 90# 91proc ::ico::getIcon {file index args} { 92 set name {} 93 set format image 94 parseOpts {type format name} $args 95 if {![info exists type]} { 96 # $type wasn't specified - get it from the extension 97 set type [fileext $file] 98 } 99 if {![llength [info commands getRawIconData$type]]} { 100 return -code error "unsupported file format $type" 101 } 102 # ICODATA is a pure data type - not a real file 103 if {$type ne "ICODATA"} { 104 set file [file normalize $file] 105 } 106 set colors [eval [linsert [getRawIconData$type $file $index] 0 getIconAsColorList]] 107 if {$format eq "image"} { 108 return [createImage $colors $name] 109 } 110 return $colors 111} 112 113# writeIcon -- 114# 115# Overwrite write icon @ index in file of specific type with depth/pixel data 116# 117# ARGS: 118# file File to extra icon info from. 119# index Index of icon in the file to use. The ordering is the 120# same as returned by getIconList. (0-based) 121# bpp bit depth of icon we are writing 122# data Either pixel color data (as returned by getIcon -format color) 123# or the name of a Tk image. 124# ?-type? Type of file. If not specified, it is derived from 125# the file extension. Currently recognized types are 126# EXE, DLL, ICO and ICL 127# 128# RETURNS: 129# Tk image based on the specified icon 130# 131proc ::ico::writeIcon {file index bpp data args} { 132 parseOpts type $args 133 if {![info exists type]} { 134 # $type wasn't specified - get it from the extension 135 set type [fileext $file] 136 } 137 if {![llength [info commands writeIcon$type]]} { 138 return -code error "unsupported file format $type" 139 } 140 if {[llength $data] == 1} { 141 set data [getColorListFromImage $data] 142 } elseif {[lsearch -glob [join $data] #*] > -1} { 143 set data [translateColors $data] 144 } 145 if {$bpp != 1 && $bpp != 4 && $bpp != 8 && $bpp != 24 && $bpp != 32} { 146 return -code error "invalid color depth" 147 } 148 set palette {} 149 if {$bpp <= 8} { 150 set palette [getPaletteFromColors $data] 151 if {[lindex $palette 0] > (1 << $bpp)} { 152 return -code error "specified color depth too low" 153 } 154 set data [lindex $palette 2] 155 set palette [lindex $palette 1] 156 append palette [string repeat \000 [expr {(1 << ($bpp + 2)) - [string length $palette]}]] 157 } 158 set and [getAndMaskFromColors $data] 159 set xor [getXORFromColors $bpp $data] 160 # writeIcon$type file index w h bpp palette xor and 161 writeIcon$type [file normalize $file] $index \ 162 [llength [lindex $data 0]] [llength $data] $bpp $palette $xor $and 163} 164 165 166# copyIcon -- 167# 168# Copies an icon directly from one file to another 169# 170# ARGS: 171# file File to extract icon info from. 172# index Index of icon in the file to use. The ordering is the 173# same as returned by getIconList. (0-based) 174# ?-fromtype? Type of source file. If not specified, it is derived from 175# the file extension. Currently recognized types are 176# EXE, DLL, ICO and ICL 177# ?-totype? Type of destination file. If not specified, it is derived from 178# the file extension. Currently recognized types are 179# EXE, DLL, ICO and ICL 180# 181# RETURNS: 182# nothing 183# 184proc ::ico::copyIcon {f1 i1 f2 i2 args} { 185 parseOpts {fromtype totype} $args 186 if {![info exists fromtype]} { 187 # $type wasn't specified - get it from the extension 188 set fromtype [fileext $f1] 189 } 190 if {![info exists totype]} { 191 # $type wasn't specified - get it from the extension 192 set totype [fileext $f2] 193 } 194 if {![llength [info commands writeIcon$totype]]} { 195 return -code error "unsupported file format $totype" 196 } 197 if {![llength [info commands getRawIconData$fromtype]]} { 198 return -code error "unsupported file format $fromtype" 199 } 200 set src [getRawIconData$fromtype $f1 $i1] 201 writeIcon $f2 $i2 [lindex $src 2] [eval getIconAsColorList $src] -type $totype 202} 203 204# 205# transparentColor -- 206# 207# Turns on transparency for all pixels in the image that match the color 208# 209# ARGS: 210# img Name of the Tk image to modify, or an image in color list format 211# color Color in #hex format which will be made transparent 212# 213# RETURNS: 214# the data or image after modification 215# 216proc ::ico::transparentColor {img color} { 217 if {[llength $img] == 1} { 218 package require Tk 219 if {[string match "#*" $color]} { 220 set color [scan $color "#%2x%2x%2x"] 221 } 222 set w [image width $img] 223 set h [image height $img] 224 for {set y 0} {$y < $h} {incr y} { 225 for {set x 0} {$x < $w} {incr x} { 226 if {[$img get $x $y] eq $color} {$img transparency set $x $y 1} 227 } 228 } 229 } else { 230 set y 0 231 foreach row $img { 232 set x 0 233 foreach px $row { 234 if {$px == $color} {lset img $y $x {}} 235 incr x 236 } 237 incr y 238 } 239 } 240 return $img 241} 242 243# 244# clearCache -- 245# 246# Clears the cache of icon offsets 247# 248# ARGS: 249# file optional filename 250# 251# 252# RETURNS: 253# nothing 254# 255proc ::ico::clearCache {{file {}}} { 256 variable ICONS 257 if {$file ne ""} { 258 array unset ICONS $file,* 259 } else { 260 unset ICONS 261 array set ICONS {} 262 } 263} 264 265# 266# EXEtoICO -- 267# 268# Convert all icons found in exefile into a regular icon file 269# 270# ARGS: 271# exeFile Input EXE filename 272# icoFile Output ICO filename 273# 274# RETURNS: 275# nothing 276# 277proc ::ico::EXEtoICO {exeFile icoFile} { 278 variable ICONS 279 280 set file [file normalize $exeFile] 281 set cnt [SearchForIcos $file] 282 set dir {} 283 set data {} 284 285 set fh [open $file] 286 fconfigure $fh -eofchar {} -encoding binary -translation lf 287 288 for {set i 0} {$i <= $cnt} {incr i} { 289 seek $fh $ICONS($file,$i) start 290 set ico $ICONS($file,$i,data) 291 eval [list lappend dir] $ico 292 append data [read $fh [eval calcSize $ico 40]] 293 } 294 close $fh 295 296 # write them out to a file 297 set ifh [open $icoFile w+] 298 fconfigure $ifh -eofchar {} -encoding binary -translation lf 299 300 bputs $ifh sss 0 1 [expr {$cnt + 1}] 301 set offset [expr {6 + (($cnt + 1) * 16)}] 302 foreach {w h bpp} $dir { 303 set colors 0 304 if {$bpp <= 8} {set colors [expr {1 << $bpp}]} 305 set s [calcSize $w $h $bpp 40] 306 lappend fix $offset $s 307 bputs $ifh ccccssii $w $h $colors 0 1 $bpp $s $offset 308 set offset [expr {$offset + $s}] 309 } 310 puts -nonewline $ifh $data 311 foreach {offset size} $fix { 312 seek $ifh [expr {$offset + 20}] start 313 bputs $ifh i $size 314 } 315 close $ifh 316} 317 318## 319## Internal helper commands. 320## Some may be appropriate for exposing later, but would need docs 321## and make sure they "fit" in the API. 322## 323 324# gets the file extension as we use it internally (upper case, no '.') 325proc ::ico::fileext {file} { 326 return [string trimleft [string toupper [file extension $file]] .] 327} 328 329# helper proc to parse optional arguments to some of the public procs 330proc ::ico::parseOpts {acc opts} { 331 foreach {key val} $opts { 332 set key [string trimleft $key -] 333 if {[lsearch -exact $acc $key] >= 0} { 334 upvar $key $key 335 set $key $val 336 } elseif {$key ne ""} { 337 return -code error "unknown option \"$key\": must be one of $acc" 338 } 339 } 340} 341 342# formats a single color from a binary decimal list format to the #hex format 343proc ::ico::formatColor {r g b} { 344 format "#%02X%02X%02X" [scan $r %c] [scan $g %c] [scan $b %c] 345} 346 347# translates a color list from the #hex format to the decimal list format 348# #0000FF {0 0 255} 349proc ::ico::translateColors {colors} { 350 set new {} 351 foreach line $colors { 352 set tline {} 353 foreach x $line { 354 if {$x eq ""} {lappend tline {}; continue} 355 lappend tline [scan $x "#%2x%2x%2x"] 356 } 357 set new [linsert $new 0 $tline] 358 } 359 return $new 360} 361 362proc ::ico::getdword {fh} { 363 binary scan [read $fh 4] i* tmp 364 return $tmp 365} 366 367proc ::ico::getword {fh} { 368 binary scan [read $fh 2] s* tmp 369 return $tmp 370} 371 372proc ::ico::getulong {fh} { 373 binary scan [read $fh 4] i tmp 374 return [format %u $tmp] 375} 376 377proc ::ico::getushort {fh} { 378 binary scan [read $fh 2] s tmp 379 return [expr {$tmp & 0x0000FFFF}] 380} 381 382# binary puts 383proc ::ico::bputs {fh format args} { 384 puts -nonewline $fh [eval [list binary format $format] $args] 385} 386 387# creates a Tk image from a list of colors in the #hex format 388proc ::ico::createImage {colors {name {}}} { 389 package require Tk 390 set h [llength $colors] 391 set w [llength [lindex $colors 0]] 392 if {$name ne ""} { 393 set img [image create photo $name -width $w -height $h] 394 } else { 395 set img [image create photo -width $w -height $h] 396 } 397 if {0} { 398 # if image supported "" colors as transparent pixels, 399 # we could use this much faster op 400 $img put -to 0 0 $colors 401 } else { 402 for {set x 0} {$x < $w} {incr x} { 403 for {set y 0} {$y < $h} {incr y} { 404 set clr [lindex $colors $y $x] 405 if {$clr ne ""} { 406 $img put -to $x $y $clr 407 } 408 } 409 } 410 } 411 return $img 412} 413 414# return a list of colors in the #hex format from raw icon data 415# returned by readDIB 416proc ::ico::getIconAsColorList {w h bpp palette xor and} { 417 # Create initial empty color array that we'll set indices in 418 set colors {} 419 set row {} 420 set empty {} 421 for {set x 0} {$x < $w} {incr x} { lappend row $empty } 422 for {set y 0} {$y < $h} {incr y} { lappend colors $row } 423 424 set x 0 425 set y [expr {$h-1}] 426 if {$bpp == 1} { 427 binary scan $xor B* xorBits 428 foreach i [split $xorBits {}] a [split $and {}] { 429 if {$x == $w} { set x 0; incr y -1 } 430 if {$a == 0} { 431 lset colors $y $x [lindex $palette $i] 432 } 433 incr x 434 } 435 } elseif {$bpp == 4} { 436 variable BITS 437 binary scan $xor B* xorBits 438 set i 0 439 foreach a [split $and {}] { 440 if {$x == $w} { set x 0; incr y -1 } 441 if {$a == 0} { 442 set bits [string range $xorBits $i [expr {$i+3}]] 443 lset colors $y $x [lindex $palette $BITS($bits)] 444 } 445 incr i 4 446 incr x 447 } 448 } elseif {$bpp == 8} { 449 foreach i [split $xor {}] a [split $and {}] { 450 if {$x == $w} { set x 0; incr y -1 } 451 if {$a == 0} { 452 lset colors $y $x [lindex $palette [scan $i %c]] 453 } 454 incr x 455 } 456 } elseif {$bpp == 16} { 457 variable BITS 458 binary scan $xor b* xorBits 459 set i 0 460 foreach a [split $and {}] { 461 if {$x == $w} { set x 0; incr y -1 } 462 if {$a == 0} { 463 set b1 [string range $xorBits $i [expr {$i+4}]] 464 set b2 [string range $xorBits [expr {$i+5}] [expr {$i+9}]] 465 set b3 [string range $xorBits [expr {$i+10}] [expr {$i+14}]] 466 lset colors $y $x "#$BITS($b3)$BITS($b2)$BITS($b1)" 467 } 468 incr i 16 469 incr x 470 } 471 } elseif {$bpp == 24} { 472 foreach {b g r} [split $xor {}] a [split $and {}] { 473 if {$x == $w} { set x 0; incr y -1 } 474 if {$a == 0} { 475 lset colors $y $x [formatColor $r $g $b] 476 } 477 incr x 478 } 479 } elseif {$bpp == 32} { 480 foreach {b g r n} [split $xor {}] a [split $and {}] { 481 if {$x == $w} { set x 0; incr y -1 } 482 if {$a == 0} { 483 lset colors $y $x [formatColor $r $g $b] 484 } 485 incr x 486 } 487 } 488 return $colors 489} 490 491# creates a binary formatted AND mask by reading a list of colors in the decimal list format 492# and checking for empty colors which designate transparency 493proc ::ico::getAndMaskFromColors {colors} { 494 set and {} 495 foreach line $colors { 496 set l {} 497 foreach x $line {append l [expr {$x eq ""}]} 498 append l [string repeat 0 [expr {[string length $l] % 32}]] 499 foreach {a b c d e f g h} [split $l {}] { 500 append and [binary format B8 $a$b$c$d$e$f$g$h] 501 } 502 } 503 return $and 504} 505 506# creates a binary formatted XOR mask in the specified depth format from 507# a list of colors in the decimal list format 508proc ::ico::getXORFromColors {bpp colors} { 509 set xor {} 510 if {$bpp == 1} { 511 foreach line $colors { 512 foreach {a b c d e f g h} $line { 513 foreach x {a b c d e f g h} { 514 if {[set $x] == ""} {set $x 0} 515 } 516 binary scan $a$b$c$d$e$f$g$h bbbbbbbb h g f e d c b a 517 append xor [binary format b8 $a$b$c$d$e$f$g$h] 518 } 519 } 520 } elseif {$bpp == 4} { 521 foreach line $colors { 522 foreach {a b} $line { 523 if {$a == ""} {set a 0} 524 if {$b == ""} {set b 0} 525 binary scan $a$b b4b4 b a 526 append xor [binary format b8 $a$b] 527 } 528 } 529 } elseif {$bpp == 8} { 530 foreach line $colors { 531 foreach x $line { 532 if {$x == ""} {set x 0} 533 append xor [binary format c $x] 534 } 535 } 536 } elseif {$bpp == 24} { 537 foreach line $colors { 538 foreach x $line { 539 if {![llength $x]} { 540 append xor [binary format ccc 0 0 0] 541 } else { 542 foreach {a b c n} $x { 543 append xor [binary format ccc $c $b $a] 544 } 545 } 546 } 547 } 548 } elseif {$bpp == 32} { 549 foreach line $colors { 550 foreach x $line { 551 if {![llength $x]} { 552 append xor [binary format cccc 0 0 0 0] 553 } else { 554 foreach {a b c n} $x { 555 if {$n == ""} {set n 0} 556 append xor [binary format cccc $c $b $a $n] 557 } 558 } 559 } 560 } 561 } 562 return $xor 563} 564 565# translates a Tk image into a list of colors in the {r g b} format 566# one element per pixel and {} designating transparent 567# used by writeIcon when writing from a Tk image 568proc ::ico::getColorListFromImage {img} { 569 package require Tk 570 set w [image width $img] 571 set h [image height $img] 572 set r {} 573 for {set y [expr $h - 1]} {$y > -1} {incr y -1} { 574 set l {} 575 for {set x 0} {$x < $w} {incr x} { 576 if {[$img transparency get $x $y]} { 577 lappend l {} 578 } else { 579 lappend l [$img get $x $y] 580 } 581 } 582 lappend r $l 583 } 584 return $r 585} 586 587# creates a palette from a list of colors in the decimal list format 588# a palette consists of 3 values, the number of colors, the palette entry itself, 589# and the color list transformed to point to palette entries instead of color names 590# the palette entry itself is stored as 32bpp in "G B R padding" order 591proc ::ico::getPaletteFromColors {colors} { 592 set palette "\x00\x00\x00\x00" 593 array set tpal {{0 0 0} 0} 594 set new {} 595 set i 1 596 foreach line $colors { 597 set tline {} 598 foreach x $line { 599 if {$x eq ""} {lappend tline {}; continue} 600 if {![info exists tpal($x)]} { 601 foreach {a b c n} $x { 602 append palette [binary format cccc $c $b $a 0] 603 } 604 set tpal($x) $i 605 incr i 606 } 607 lappend tline $tpal($x) 608 } 609 lappend new $tline 610 } 611 return [list $i $palette $new] 612} 613 614# calculate byte size of an icon. 615# often passed $w twice because $h is double $w in the binary data 616proc ::ico::calcSize {w h bpp {offset 0}} { 617 set s [expr {int(($w*$h) * ($bpp/8.0)) \ 618 + ((($w*$h) + ($h*($w%32)))/8) + $offset}] 619 if {$bpp <= 8} { set s [expr {$s + (1 << ($bpp + 2))}] } 620 return $s 621} 622 623# read a Device Independent Bitmap from the current offset, return: 624# {width height depth palette XOR_mask AND_mask} 625proc ::ico::readDIB {fh} { 626 binary scan [read $fh 16] x4iix2s w h bpp 627 set h [expr {$h / 2}] 628 seek $fh 24 current 629 630 set palette [list] 631 if {$bpp == 1 || $bpp == 4 || $bpp == 8} { 632 set colors [read $fh [expr {1 << ($bpp + 2)}]] 633 foreach {b g r x} [split $colors {}] { 634 lappend palette [formatColor $r $g $b] 635 } 636 } elseif {$bpp == 16 || $bpp == 24 || $bpp == 32} { 637 # do nothing here 638 } else { 639 return -code error "unsupported color depth: $bpp" 640 } 641 642 set xor [read $fh [expr {int(($w * $h) * ($bpp / 8.0))}]] 643 set and1 [read $fh [expr {(($w * $h) + ($h * ($w % 32))) / 8}]] 644 645 set and {} 646 set row [expr {((($w - 1) / 32) * 32 + 32) / 8}] 647 set len [expr {$row * $h}] 648 for {set i 0} {$i < $len} {incr i $row} { 649 binary scan [string range $and1 $i [expr {$i + $row}]] B$w tmp 650 append and $tmp 651 } 652 653 return [list $w $h $bpp $palette $xor $and] 654} 655 656# read a Device Independent Bitmap from raw data, return: 657# {width height depth palette XOR_mask AND_mask} 658proc ::ico::readDIBFromData {data loc} { 659 # Read info from location 660 binary scan $data @${loc}x4iix2s w h bpp 661 set h [expr {$h / 2}] 662 # Move over w/h/bpp info + magic offset to start of DIB 663 set cnt [expr {$loc + 16 + 24}] 664 665 set palette [list] 666 if {$bpp == 1 || $bpp == 4 || $bpp == 8} { 667 # Could do: [binary scan $data @${cnt}c$len colors] 668 # and iter over colors, but this is more consistent with $fh version 669 set len [expr {1 << ($bpp + 2)}] 670 set colors [string range $data $cnt [expr {$cnt + $len - 1}]] 671 foreach {b g r x} [split $colors {}] { 672 lappend palette [formatColor $r $g $b] 673 } 674 incr cnt $len 675 } elseif {$bpp == 16 || $bpp == 24 || $bpp == 32} { 676 # do nothing here 677 } else { 678 return -code error "unsupported color depth: $bpp" 679 } 680 681 # Use -1 to account for string range inclusiveness 682 set end [expr {$cnt + int(($w * $h) * ($bpp / 8.0)) - 1}] 683 set xor [string range $data $cnt $end] 684 set and1 [string range $data [expr {$end + 1}] \ 685 [expr {$end + ((($w * $h) + ($h * ($w % 32))) / 8) - 1}]] 686 687 set and {} 688 set row [expr {((($w - 1) / 32) * 32 + 32) / 8}] 689 set len [expr {$row * $h}] 690 for {set i 0} {$i < $len} {incr i $row} { 691 # Has to be decoded by row, in order 692 binary scan [string range $and1 $i [expr {$i + $row}]] B$w tmp 693 append and $tmp 694 } 695 696 return [list $w $h $bpp $palette $xor $and] 697} 698 699proc ::ico::getIconListICO {file} { 700 set fh [open $file r] 701 fconfigure $fh -eofchar {} -encoding binary -translation lf 702 703 # both words must be read to keep in sync with later reads 704 if {"[getword $fh] [getword $fh]" ne "0 1"} { 705 return -code error "not an icon file" 706 } 707 set num [getword $fh] 708 set r {} 709 for {set i 0} {$i < $num} {incr i} { 710 set info {} 711 lappend info [scan [read $fh 1] %c] [scan [read $fh 1] %c] 712 set bpp [scan [read $fh 1] %c] 713 if {$bpp == 0} { 714 set orig [tell $fh] 715 seek $fh 9 current 716 seek $fh [expr {[getdword $fh] + 14}] start 717 lappend info [getword $fh] 718 seek $fh $orig start 719 } else { 720 lappend info [expr {int(sqrt($bpp))}] 721 } 722 lappend r $info 723 seek $fh 13 current 724 } 725 close $fh 726 return $r 727} 728 729proc ::ico::getIconListICODATA {data} { 730 if {[binary scan $data sss h1 h2 num] != 3 || $h1 != 0 || $h2 != 1} { 731 return -code error "not icon data" 732 } 733 set r {} 734 set cnt 6 735 for {set i 0} {$i < $num} {incr i} { 736 if {[binary scan $data @${cnt}ccc w h bpp] != 3} { 737 return -code error "error decoding icon data" 738 } 739 incr cnt 3 740 set info [list $w $h] 741 if {$bpp == 0} { 742 set off [expr {$cnt + 9}] 743 binary scan $data @${off}i off 744 incr off 14 745 binary scan $data @${off}s bpp 746 lappend info $bpp 747 } else { 748 lappend info [expr {int(sqrt($bpp))}] 749 } 750 lappend r $info 751 incr cnt 13 752 } 753 return $r 754} 755 756proc ::ico::getIconListBMP {file} { 757 set fh [open $file] 758 if {[read $fh 2] != "BM"} { close $fh; return -code error "not a BMP file" } 759 seek $fh 14 start 760 binary scan [read $fh 16] x4iix2s w h bpp 761 close $fh 762 return [list $w $h $bpp] 763} 764 765proc ::ico::getIconListEXE {file} { 766 variable ICONS 767 768 set file [file normalize $file] 769 set cnt [SearchForIcos $file] 770 771 set icons [list] 772 for {set i 0} {$i <= $cnt} {incr i} { 773 lappend icons $ICONS($file,$i,data) 774 } 775 776 return $icons 777} 778 779# returns an icon in the form: 780# {width height depth palette xor_mask and_mask} 781proc ::ico::getRawIconDataICO {file index} { 782 set fh [open $file r] 783 fconfigure $fh -eofchar {} -encoding binary -translation lf 784 785 # both words must be read to keep in sync with later reads 786 if {"[getword $fh] [getword $fh]" ne "0 1"} { 787 close $fh 788 return -code error "not an icon file" 789 } 790 if {$index < 0 || $index >= [getword $fh]} { 791 return -code error "index out of range" 792 } 793 794 seek $fh [expr {(16 * $index) + 12}] current 795 seek $fh [getdword $fh] start 796 797 # readDIB returns: {w h bpp palette xor and} 798 set dib [readDIB $fh] 799 800 close $fh 801 return $dib 802} 803 804proc ::ico::getRawIconDataICODATA {data index} { 805 if {[binary scan $data sss h1 h2 num] != 3 || $h1 != 0 || $h2 != 1} { 806 return -code error "not icon data" 807 } 808 if {$index < 0 || $index >= $num} { 809 return -code error "index out of range: must be between 0 and $num" 810 } 811 # Move to ico location 812 set cnt [expr {6 + (16 * $index) + 12}] 813 binary scan $data @${cnt}i loc 814 815 # readDIB returns: {w h bpp palette xor and} 816 set dib [readDIBFromData $data $loc] 817 818 return $dib 819} 820 821# returns an icon in the form: 822# {width height depth palette xor_mask and_mask} 823proc ::ico::getRawIconDataBMP {file {index 0}} { 824 if {$index != 0} {return -code error "index out of range"} 825 set fh [open $file] 826 if {[read $fh 2] != "BM"} { close $fh; return -code error "not a BMP file" } 827 seek $fh 14 start 828 binary scan [read $fh 16] x4iix2s w h bpp 829 seek $fh 24 current 830 831 set palette [list] 832 if {$bpp == 1 || $bpp == 4 || $bpp == 8} { 833 set colors [read $fh [expr {1 << ($bpp + 2)}]] 834 foreach {b g r x} [split $colors {}] { 835 lappend palette [formatColor $r $g $b] 836 } 837 } elseif {$bpp == 16 || $bpp == 24 || $bpp == 32} { 838 # do nothing here 839 } else { 840 return -code error "unsupported color depth: $bpp" 841 } 842 843 set xor [read $fh [expr {int(($w * $h) * ($bpp / 8.0))}]] 844 set and [string repeat 0 [expr {$w * $h}]] 845 close $fh 846 847 return [list $w $h $bpp $palette $xor $and] 848} 849 850# returns an icon in the form: 851# {width height depth palette xor_mask and_mask} 852proc ::ico::getRawIconDataEXE {file index} { 853 variable ICONS 854 855 set file [file normalize $file] 856 set cnt [SearchForIcos $file $index] 857 858 if {$cnt < $index} { return -code error "index out of range" } 859 860 set fh [open $file] 861 fconfigure $fh -eofchar {} -encoding binary -translation lf 862 seek $fh $ICONS($file,$index) start 863 864 # readDIB returns: {w h bpp palette xor and} 865 set dib [readDIB $fh] 866 close $fh 867 return $dib 868} 869 870proc ::ico::writeIconICO {file index w h bpp palette xor and} { 871 if {![file exists $file]} { 872 set fh [open $file w+] 873 fconfigure $fh -eofchar {} -encoding binary -translation lf 874 bputs $fh sss 0 1 0 875 seek $fh 0 start 876 } else { 877 set fh [open $file r+] 878 fconfigure $fh -eofchar {} -encoding binary -translation lf 879 } 880 if {[file size $file] > 4 && "[getword $fh] [getword $fh]" ne "0 1"} { 881 close $fh 882 return -code error "not an icon file" 883 } 884 set num [getword $fh] 885 if {$index eq "end"} { set index $num } 886 if {$index < 0 || $index > $num} { 887 close $fh 888 return -code error "index out of range" 889 } 890 set colors 0 891 if {$bpp <= 8} {set colors [expr {1 << $bpp}]} 892 set size [expr {[string length $palette] + [string length $xor] + [string length $and]}] 893 894 # if we are adding a new icon at the end 895 if {$index == $num} { 896 # increment the icon count 897 seek $fh -2 current 898 bputs $fh s [expr {$num + 1}] 899 # save all the data past the icon dir entries 900 seek $fh [expr {$num * 16}] current 901 set olddata [read $fh] 902 # increment all the offsets in the existing dir entries by 16 to account for our new entry 903 set cur 0 904 while {$cur < $num} { 905 seek $fh [expr {($cur * 16) + 18}] start 906 set toff [getdword $fh] 907 seek $fh -4 current 908 bputs $fh i [expr {$toff + 16}] 909 incr cur 910 } 911 # insert new icon dir entry 912 bputs $fh ccccss $w $h $colors 0 0 $bpp 913 bputs $fh ii [expr {$size + 40}] [expr {[string length $olddata] + [tell $fh] + 8}] 914 # put all the icon data back 915 puts -nonewline $fh $olddata 916 # put our new icon at the end 917 bputs $fh iiissiiiiii 40 $w [expr {$h * 2}] 1 $bpp 0 $size 0 0 0 0 918 puts -nonewline $fh $palette 919 puts -nonewline $fh $xor 920 puts -nonewline $fh $and 921 } else { 922 # we are overwriting an icon - not necesarily the same size 923 # get existing icon offset and length 924 seek $fh [expr {($index * 16) + 8}] current 925 set len [getdword $fh] 926 set offset [getdword $fh] 927 # adjust offset in existing icon dir entries higher than our new icon to account 928 # for new icon length 929 set cur [expr {$index + 1}] 930 while {$cur < $num} { 931 seek $fh [expr {($cur * 16) + 18}] start 932 set toff [getdword $fh] 933 seek $fh -4 current 934 bputs $fh i [expr {$toff + (($size + 40) - $len)}] 935 incr cur 936 } 937 # save all data after new icon 938 seek $fh [expr {$offset + $len}] start 939 set olddata [read $fh] 940 # overwrite icon dir entry 941 seek $fh [expr {($index * 16) + 6}] start 942 bputs $fh ccccssi $w $h $colors 0 0 $bpp [expr {$size + 40}] 943 # insert new icon and saved data 944 seek $fh $offset start 945 bputs $fh iiissiiiiii 40 $w [expr {$h * 2}] 1 $bpp 0 $size 0 0 0 0 946 puts -nonewline $fh $palette 947 puts -nonewline $fh $xor 948 puts -nonewline $fh $and 949 puts -nonewline $fh $olddata 950 } 951 close $fh 952} 953 954proc ::ico::writeIconICODATA {file index w h bpp palette xor and} { 955 if {$index != 0} {return -code error "index out of range"} 956 upvar 2 [file tail $file] data 957 set data [binary format sss 0 1 1] 958 set colors 0 959 if {$bpp <= 8} {set colors [expr {1 << $bpp}]} 960 set size [expr {[string length $palette] + [string length $xor] + [string length $and]}] 961 append data [binary format ccccssii $w $h $colors 0 0 $bpp [expr {$size + 40}] 22] 962 append data [binary format iiissiiiiii 40 $w [expr {$h * 2}] 1 $bpp 0 $size 0 0 0 0] 963 append data $palette $xor $and 964} 965 966proc ::ico::writeIconBMP {file index w h bpp palette xor and} { 967 if {$index != 0} {return -code error "index out of range"} 968 set fh [open $file w+] 969 fconfigure $fh -eofchar {} -encoding binary -translation lf 970 set size [expr {[string length $palette] + [string length $xor]}] 971 # bitmap header: magic, file size, reserved, reserved, offset of bitmap data 972 bputs $fh a2issi BM [expr {14 + 40 + $size}] 0 0 54 973 bputs $fh iiissiiiiii 40 $w $h 1 $bpp 0 $size 0 0 0 0 974 puts -nonewline $fh $palette$xor 975 close $fh 976} 977 978proc ::ico::writeIconEXE {file index w h bpp palette xor and} { 979 variable ICONS 980 981 set file [file normalize $file] 982 set cnt [SearchForIcos $file $index] 983 984 if {$index eq "end"} {set index $cnt} 985 if {$cnt < $index} { return -code error "index out of range" } 986 987 if {[list $w $h $bpp] != $ICONS($file,$index,data)} { 988 return -code error "icon format differs from original" 989 } 990 991 set fh [open $file r+] 992 fconfigure $fh -eofchar {} -encoding binary -translation lf 993 seek $fh [expr {$ICONS($file,$index) + 40}] start 994 995 puts -nonewline $fh $palette$xor$and 996 close $fh 997} 998 999proc ::ico::SearchForIcos {file {index -1}} { 1000 variable ICONS ; # stores icos offsets by index, and [list w h bpp] 1001 1002 if {[info exists ICONS($file,$index)]} { 1003 return $ICONS($file,$index) 1004 } 1005 set fh [open $file] 1006 fconfigure $fh -eofchar {} -encoding binary -translation lf 1007 if {[read $fh 2] ne "MZ"} { 1008 close $fh 1009 return -code error "unknown file format" 1010 } 1011 seek $fh 60 start 1012 seek $fh [getword $fh] start 1013 set sig [read $fh 4] 1014 seek $fh -4 current 1015 if {$sig eq "PE\000\000"} { 1016 return [SearchForIcosPE $fh $file $index] 1017 } elseif {[string match NE* $sig]} { 1018 return [SearchForIcosNE $fh $file $index] 1019 } else { 1020 return -code error "unknown file format" 1021 } 1022} 1023 1024# parse the resource table of 16 bit windows files for icons 1025proc ::ico::SearchForIcosNE {fh file index} { 1026 variable ICONS ; # stores icos offsets by index, and [list w h bpp] 1027 set idx -1 ; # index of icos found 1028 1029 seek $fh 36 current 1030 seek $fh [expr {[getword $fh] - 38}] current 1031 1032 set base [tell $fh] 1033 set shift [expr {int(pow(2, [getushort $fh]))}] 1034 while {[set type [expr {[getushort $fh] & 0x7fff}]] != 0} { 1035 set num [getushort $fh] 1036 if {$type != 3} { 1037 seek $fh [expr {($num * 12) + 4}] current 1038 continue 1039 } 1040 seek $fh 4 current 1041 for {set i 0} {$i < $num} {incr i} { 1042 incr idx 1043 set ICONS($file,$idx) [expr {[getushort $fh] * $shift}] 1044 seek $fh 10 current 1045 set cur [tell $fh] 1046 1047 seek $fh $ICONS($file,$idx) start 1048 binary scan [read $fh 16] x4iix2s w h bpp 1049 set ICONS($file,$idx,data) [list $w [expr {$h / 2}] $bpp] 1050 1051 seek $fh $cur start 1052 } 1053 close $fh 1054 return $idx 1055 } 1056 close $fh 1057 return -1 1058} 1059 1060# parse the resource tree of 32 bit windows files for icons 1061proc ::ico::SearchForIcosPE {fh file index} { 1062 variable ICONS ; # stores icos offsets by index, and [list w h bpp] 1063 set idx -1 ; # index of icos found 1064 1065 # find the .rsrc section by reading the coff header 1066 binary scan [read $fh 24] x6sx12s sections headersize 1067 seek $fh $headersize current 1068 for {set i 0} {$i < $sections} {incr i} { 1069 binary scan [read $fh 40] a8x4ix4i type baserva base 1070 if {[string match .rsrc* $type]} {break} 1071 } 1072 # no resource section found = no icons 1073 if {![string match .rsrc* $type]} { 1074 close $fh 1075 return -1 1076 } 1077 seek $fh $base start 1078 1079 seek $fh 12 current 1080 set entries [expr {[getushort $fh] + [getushort $fh]}] 1081 for {set i 0} {$i < $entries} {incr i} { 1082 set name [getulong $fh] 1083 set offset [expr {[getulong $fh] & 0x7fffffff}] 1084 if {$name != 3} {continue} 1085 seek $fh [expr {$base + $offset + 12}] start 1086 1087 set entries2 [expr {[getushort $fh] + [getushort $fh]}] 1088 for {set i2 0} {$i2 < $entries2} {incr i2} { 1089 seek $fh 4 current 1090 set offset [expr {[getulong $fh] & 0x7fffffff}] 1091 set cur2 [tell $fh] 1092 seek $fh [expr {$offset + $base + 12}] start 1093 1094 set entries3 [expr {[getushort $fh] + [getushort $fh]}] 1095 for {set i3 0} {$i3 < $entries3} {incr i3} { 1096 seek $fh 4 current 1097 set offset [expr {[getulong $fh] & 0x7fffffff}] 1098 set cur3 [tell $fh] 1099 seek $fh [expr {$offset + $base}] start 1100 1101 set rva [getulong $fh] 1102 incr idx 1103 set ICONS($file,$idx) [expr {$rva - $baserva + $base}] 1104 seek $fh $ICONS($file,$idx) start 1105 binary scan [read $fh 16] x4iix2s w h bpp 1106 set ICONS($file,$idx,data) [list $w [expr {$h / 2}] $bpp] 1107 1108 seek $fh $cur3 start 1109 } 1110 seek $fh $cur2 start 1111 } 1112 close $fh 1113 return $idx 1114 } 1115 close $fh 1116 return -1 1117} 1118 1119interp alias {} ::ico::getIconListDLL {} ::ico::getIconListEXE 1120interp alias {} ::ico::getRawIconDataDLL {} ::ico::getRawIconDataEXE 1121interp alias {} ::ico::writeIconDLL {} ::ico::writeIconEXE 1122interp alias {} ::ico::getIconListICL {} ::ico::getIconListEXE 1123interp alias {} ::ico::getRawIconDataICL {} ::ico::getRawIconDataEXE 1124interp alias {} ::ico::writeIconICL {} ::ico::writeIconEXE 1125 1126proc ::ico::showaux {files} { 1127 if {[llength $files]} { 1128 set file [lindex $files 0] 1129 Show $f 1130 update 1131 after 50 [list ::ico::showaux [lrange $files 1 end]] 1132 } 1133} 1134 1135# Application level command: Find icons in a file and show them. 1136proc ::ico::Show {file args} { 1137 package require BWidget 1138 1139 set parent . 1140 parseOpts {type parent} $args 1141 if {![info exists type]} { 1142 # $type wasn't specified - get it from the extension 1143 set type [fileext $file] 1144 } 1145 1146 set file [file normalize $file] 1147 set icos [getIconList $file -type $type] 1148 set wname [string map {. _ : _} $file] 1149 1150 if {$parent eq "."} { set w ""} else { set w $parent } 1151 1152 set mf $w.mainsw 1153 if {![winfo exists $mf]} { 1154 set sw [ScrolledWindow $mf] 1155 set sf [ScrollableFrame $mf.sf -constrainedwidth 1] 1156 $sw setwidget $sf 1157 pack $sw -fill both -expand 1 1158 grid columnconfigure [$mf.sf getframe] 0 -weight 1 1159 } 1160 set mf [$mf.sf getframe] 1161 1162 set lf $mf.f$wname 1163 if {[winfo exists $lf]} { destroy $lf } 1164 if {![llength $icos]} { 1165 label $lf -text "No icons in '$file'" -anchor w 1166 grid $lf -sticky ew 1167 } else { 1168 labelframe $lf -text "[llength $icos] Icons in '$file'" 1169 grid $lf -sticky news 1170 set sw [ScrolledWindow $lf.sw$wname] 1171 set height 48 1172 set fh [expr {[font metrics [$lf cget -font] -linespace] + 4}] 1173 set sf [ScrollableFrame $lf.sf$wname -constrainedheight 1 \ 1174 -height [expr {$height + $fh}]] 1175 $sw setwidget $sf 1176 set sf [$sf getframe] 1177 pack $sw -fill both -expand 1 1178 set col 0 1179 for {set x 0} {$x < [llength $icos]} {incr x} { 1180 # catch in case theres any icons with unsupported color 1181 if {[catch {getIcon $file $x -type $type} img]} { 1182 set txt "ERROR: $img" 1183 set lbl [label $sf.lbl$wname-$x -anchor w -text $txt] 1184 grid $lbl -sticky s -row 0 -column [incr col] 1185 } else { 1186 set txt [eval {format "$x: %sx%s %sbpp"} [lindex $icos $x]] 1187 set lbl [label $sf.lbl$wname-$x -anchor w -text $txt \ 1188 -compound top -image $img] 1189 if {[image height $img] > $height} { 1190 set height [image height $img] 1191 $lf.sf$wname configure -height [expr {$height + $fh}] 1192 } 1193 grid $lbl -sticky s -row 0 -column [incr col] 1194 } 1195 update idletasks 1196 } 1197 } 1198 grid rowconfigure $parent 0 -weight 1 1199 grid columnconfigure $parent 0 -weight 1 1200} 1201 1202package provide ico 0.3.1 1203