[Sciviews-commits] r475 - in pkg/tcltk2/inst/tklibs: . ico1.0
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue May 1 23:13:00 CEST 2012
Author: phgrosjean
Date: 2012-05-01 23:13:00 +0200 (Tue, 01 May 2012)
New Revision: 475
Added:
pkg/tcltk2/inst/tklibs/ico1.0/
pkg/tcltk2/inst/tklibs/ico1.0/ChangeLog
pkg/tcltk2/inst/tklibs/ico1.0/ico.man
pkg/tcltk2/inst/tklibs/ico1.0/ico.tcl
pkg/tcltk2/inst/tklibs/ico1.0/ico0.tcl
pkg/tcltk2/inst/tklibs/ico1.0/pkgIndex.tcl
Log:
Readding ico1.0 in tcltk2
Added: pkg/tcltk2/inst/tklibs/ico1.0/ChangeLog
===================================================================
--- pkg/tcltk2/inst/tklibs/ico1.0/ChangeLog (rev 0)
+++ pkg/tcltk2/inst/tklibs/ico1.0/ChangeLog 2012-05-01 21:13:00 UTC (rev 475)
@@ -0,0 +1,137 @@
+2009-01-21 Andreas Kupries <andreas_kupries at users.sourceforge.net>
+
+ *
+ * Released and tagged Tklib 0.5 ========================
+ *
+
+2008-03-12 Jeff Hobbs <jeffh at ActiveState.com>
+
+ * ico.tcl (::ico::writeIconICODATA, ::ico::writeIconICO): correct the
+ * pkgIndex.tcl: icon table header height info (was doubling),
+ update version to 1.0.3.
+
+2007-5-17 Aaron Faupell <afaupell at users.sourceforge.net>
+
+ * ico.tcl: fixed problem with reading BMPs and updated
+ getFileIcon to search for additional icons (read CLSID)
+ * ico.man: updated example and added verbage to getFileIcon
+
+2007-02-23 Jeff Hobbs <jeffh at ActiveState.com>
+
+ * ico0.tcl (::ico::readDIBFromData): correct row calc for edge
+ case. Bump version to 0.3.1
+
+ * ico.tcl (::ico::getFileIcon): fixed for better overall support.
+ [Bug 1660234] (Griffiths).
+ Bumped version to 1.0.2
+
+2006-12-14 Aaron Faupell <afaupell at users.sourceforge.net>
+
+ * ico.tcl: fixed problem in EXEtoICO and incremented version to 1.0.1
+
+2006-12-12 Jeff Hobbs <jeffh at ActiveState.com>
+
+ * ico.tcl (::ico::getFileIcon): fixed missing close ]
+
+2006-08-04 Jeff Hobbs <jeffh at ActiveState.com>
+
+ * ico0.tcl: added back ico 0.3 for compatibility
+ * pkgIndex.tcl: note both 0.3 and 1.0 exist
+
+2006-07-18 Andreas Kupries <andreask at gactivestate.com>
+
+ * ico.man: Fixed syntax problems in the manpage.
+
+2006-07-11 Aaron Faupell <afaupell at users.sourceforge.net>
+
+ * ico.tcl: many changes to add support for icon groups
+ * ico.man: many changes to reflect new commands and usage
+ **** update to v1.0 POTENTIAL INCOMPATIBILITY ****
+
+2005-11-10 Andreas Kupries <andreas_kupries at users.sourceforge.net>
+
+ *
+ * Released and tagged Tklib 0.4.1 ========================
+ *
+
+2005-11-02 Andreas Kupries <andreas_kupries at users.sourceforge.net>
+
+ *
+ * Released and tagged Tklib 0.4 ========================
+ *
+
+2005-05-28 Aaron Faupell <afaupell at users.sourceforge.net>
+
+ * ico.tcl fixed padding algorithm to handle icons >48px
+
+2005-05-27 Jeff Hobbs <jeffh at ActiveState.com>
+
+ * ico.tcl (::ico::Show): handle >48px icons by resizing the frame.
+ Currently >48px icons are not decoded properly by ico though.
+
+2004-08-20 Aaron Faupell <afaupell at users.sourceforge.net>
+
+ * ico.tcl bugfix in writeIconEXE, called SearchForIcos
+ with wrong args
+
+2004-08-20 Aaron Faupell <afaupell at users.sourceforge.net>
+
+ * ico.tcl: added writing of BMP and ICODATA types.
+
+2004-08-18 Aaron Faupell <afaupell at users.sourceforge.net>
+
+ * ico.tcl: added support for reading from BMP files
+ Modified transparentColor to work on pixel list also.
+ * ico.man: updated with the new functionality
+
+2004-08-18 Andreas Kupries <andreask at activestate.com>
+
+ * ico.man: Fixed problems with formatting of ico manpage.
+
+2004-08-17 Aaron Faupell <afaupell at users.sourceforge.net>
+
+ * ico.tcl: CheckEXE removed and replaced by new SearchForIcos which
+ calls SearchForIcosNE or SearchForIcosPE which atually parse the
+ window resource tables resulting in a nice speed improvement
+ over the old linear search. Also corrected all usage of fconfigure.
+
+2004-07-27 Aaron Faupell <afaupell at users.sourceforge.net>
+
+ * ico.tcl: undocumented windows feature: if the first palette entry
+ isnt black, the transparent background displays in odd colors. fixed
+ getPaletteFromColors to initialize palette with black. changed header
+ writing to use 0 for planes to be consistant with windows.
+
+2004-07-26 Aaron Faupell <afaupell at users.sourceforge.net>
+
+ * ico.tcl: renamed some of the private API to be more descriptive.
+ bugfix in writeIcon and translateColors and CopyIcon. simplified
+ writeIconEXE.
+
+2004-07-26 Andreas Kupries <andreas_kupries at users.sourceforge.net>
+
+ * ico.man: Reworked the documentation a bit (fixed bugs, reordered
+ stuff a bit).
+
+2004-07-26 Jeff Hobbs <jeffh at ActiveState.com>
+
+ * pkgIndex.tcl, ico.man, ico.tcl: add -type ICODATA as a way pass
+ ICO data instead of a filename. Currently supports read, not write.
+ Made 'package require Tk' only get called as necessary for the api.
+ Code cleanup, update to v0.3.
+
+ * ico.man (new):
+ * ico.tcl: revamp of API from Aaron, more public APIs.
+
+2004-07-24 Jeff Hobbs <jeffh at ActiveState.com>
+
+ * ico.tcl (::ico::getIconImageFromData): add call to retrive icon
+ image from ICO info as data (not "official", may change).
+
+2004-07-22 Jeff Hobbs <jeffh at ActiveState.com>
+
+ * ico.tcl: added to tklib as v0.2.
+ Primary usage is like so:
+ set file bin/wish.exe
+ set icos [::ico::getIcons $file]
+ set img [::ico::getIconImage $file -index 1]
Added: pkg/tcltk2/inst/tklibs/ico1.0/ico.man
===================================================================
--- pkg/tcltk2/inst/tklibs/ico1.0/ico.man (rev 0)
+++ pkg/tcltk2/inst/tklibs/ico1.0/ico.man 2012-05-01 21:13:00 UTC (rev 475)
@@ -0,0 +1,224 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin ico n 1.0]
+[moddesc {Windows ICO handling}]
+[titledesc {Reading and writing windows icons}]
+[require Tcl 8.4]
+[require ico [opt 1.0]]
+[description]
+
+This package provides functions for reading and writing Windows icons
+from ICO, EXE, DLL, ICL, and BMP files.
+
+As used in this module an icon is a visual representation of an object.
+An icon consists of one or more images usually with varying resolution
+and color depth. Each icon and image has a resource identifier which
+may be a text string or a positive integer value. Most commands use this
+identifier to specify which icon or image to operate on.
+
+
+[section API]
+
+[list_begin definitions]
+
+[call [cmd ::ico::icons] [arg file] [opt "[arg option] [arg value]..."]]
+
+Returns a list of icons found in [arg file] where each element is the
+name or numeric ID. Recognizes the following options:
+
+[list_begin opt]
+[opt_def -type fileFormat]
+[list_end]
+[nl]
+
+
+[call [cmd ::ico::iconMembers] [arg file] [arg name] [opt "[arg option] [arg value]..."]]
+
+Returns a list of images that make up the icon with ID [arg name]. Each element is itself a
+sublist in the format {name width height bpp}. Recognizes the following options:
+
+[list_begin opt]
+[opt_def -type fileFormat]
+[list_end]
+[nl]
+
+[call [cmd ::ico::getIcon] [arg file] [arg name] [opt "[arg option] [arg value]..."]]
+
+Extracts the icon with ID [arg name] from [arg file].
+
+The default [option -format] is [const image] which will return the
+name of a Tk image containing the icon. The resolution and color depth
+are selected with the [opt -res], [opt -bpp], and [opt -exact] options.
+
+If -exact is specified and there is no exact match, an error is thrown.
+
+Optionally [option -image] may be used to specify the name of the Tk
+image that is created. If [option -format] is [const colors] then a
+list of color names in the #RRGGBB format is returned. Each list element
+is a horizontal row. Each horizontal row contains a list of colors for
+all the pixels in that row from left to right. If [option -format] is
+[const name] then the resource name of the image chosen is returned.
+This is useful for calling writeIcon or getIconByName.
+
+Recognizes the following [arg option]s.
+
+[list_begin opt]
+[opt_def -type fileFormat]
+[opt_def -format value]
+[opt_def -image value]
+[opt_def -res value]
+[opt_def -bpp value]
+[opt_def -exact value]
+[list_end]
+[nl]
+
+[call [cmd ::ico::getIconByName] [arg file] [arg name] [opt "[arg option] [arg value]..."]]
+
+Extracts the image with ID [arg name] from [arg file]. This name should be the name of a
+specific image as returned by [cmd ::ico::iconMembers], not an icon name returned from
+[cmd ::ico::icons]. If there is no matching resource ID
+in [arg file] an error is thrown. Recognizes the following options:
+
+[list_begin opt]
+[opt_def -type fileFormat]
+[opt_def -format value]
+[list_end]
+[nl]
+
+[call [cmd ::ico::getFileIcon] [arg file] [opt "[arg option] [arg value]..."]]
+
+This command is only functional when running under Windows. It reads the Windows
+registry to determine the display icon for [arg file] as it would appear in Explorer
+or similar. [arg file] does not need to exist and may also be specified as a file
+extension with a leading dot. If [arg file] is a directory or you specify the
+special name [const Folder] then the icon representing a folder is returned. This
+command takes the same arguments and usage as [cmd getIcon]:
+
+[list_begin opt]
+[opt_def -format value]
+[opt_def -image value]
+[opt_def -res value]
+[opt_def -bpp value]
+[opt_def -exact value]
+[list_end]
+[nl]
+
+[call [cmd ::ico::writeIcon] [arg file] [arg name] [arg depth] [arg data] [opt "[arg option] [arg value]..."]]
+
+Writes an image to [arg file]. [arg name] is the resource identifier of the
+image in [arg file] to write.
+When writing to an EXE, DLL, or ICL file you may only overwrite existing icons with an
+icon of the same dimensions and color depth. No icons may be added to these file types.
+[nl]
+When writing to BMP the name is ignored as this type can contain only one image. This means
+if the file already existed it is completely overwritten.
+[nl]
+When writing to an ICO or ICODATA file if the name
+specified does not exist then an image is appended and will be named the next in sequence
+(the specified name is ignored). Images in ICO and ICODATA files may be overwritten with differing
+dimensions or color depths.
+
+Note that you will get strange results when displaying icons if you fail to change every image
+which makes up a given icon.
+
+[list_begin arg]
+[arg_def integer depth in]
+
+This argument must have a value of [const 1], [const 4], [const 8],
+[const 24], or [const 32]. If [arg data] has more colors than the
+color depth allows an error will be generated.
+
+
+[arg_def options data in]
+
+This argument is either a list of colors in the format returned by
+[cmd {::ico::getIcon -format colors}] or the name of a Tk image.
+
+
+[list_end]
+[nl]
+
+Recognizes the following [arg option]s.
+
+[list_begin opt]
+[opt_def -type fileFormat]
+[list_end]
+[nl]
+
+
+[call [cmd ::ico::copyIcon] [arg file] [arg index] [arg file2] [arg index2] [opt "[arg option] [arg value]..."]]
+
+Copies the icon at [arg index] in [arg file] to [arg index2] in [arg file2].
+
+[list_begin opt]
+[opt_def -fromtype fileFormat]
+[opt_def -totype fileFormat]
+[list_end]
+[nl]
+
+
+[call [cmd ::ico::EXEtoICO] [arg file] [opt dir]]
+
+Extracts all icons from the executable [arg file] to ICO files placed in [arg dir]. [opt dir] defaults to the directory [arg file] is located in. Icon files will be named in the form [arg file]-ID.ico where ID is the icon resource identifier.
+
+[list_begin opt]
+[opt_def -type fileFormat]
+[list_end]
+[nl]
+
+
+[call [cmd ::ico::clearCache] [opt file]]
+
+The [cmd ::ico::getIconList] command caches icon offsets inside EXE, DLL, ICL,
+and ICO files in order to speed up extraction. This command clears that
+cache for the specific [opt file] or all files.
+
+
+[call [cmd ::ico::transparentColor] [arg image] [arg color]]
+
+If [arg image] is a single word it is assumed to be the name of a Tk image.
+All pixels matching [arg color] in the [arg image] will be set transparent.
+Alternatively, [arg image] may be a color list in which case a modified list
+is returned.
+
+
+[call [cmd ::ico::Show] [arg file] [opt "[arg option] [arg value]..."]]
+
+Application level command which displays a window showing all the
+icons in [arg file] and their name.
+
+[list_begin opt]
+[opt_def -type fileFormat]
+[opt_def -parent pathName]
+[list_end]
+[list_end]
+
+
+[section EXAMPLE]
+
+[example {
+ button .explore -image [::ico::getIcon explorer.exe 0 -name explore -res 16 -bpp 8]
+
+ set i [lsearch -inline [::ico::iconMembers tclkit.exe 0] {* 32 32 8}]
+ set colorlist [::ico::getIconByName tclkit.exe [lindex $i 0] -format colors]
+}]
+
+[section LIMITATIONS]
+
+Icons may not be added or removed from file types other than ICO. Icons in these files
+may only be replaced with icons of the same dimensions and color depth.
+[para]
+
+Icons of 8bpp or lower must include black in the pallete, this means if your icon does
+not have black in it, you will need to leave a color free so that it may be included by
+writeIcon.
+[para]
+
+There is currently no way to read alpha channel information from 32bpp icons.
+[para]
+
+Tk images do not have an alpha channel so the only way to write a true 32bpp icon is from
+a color list. writing a 32bpp icon from a Tkimage is identical to writing a 24bpp icon.
+
+[keywords entry icon ico exe dll]
+[manpage_end]
+
Added: pkg/tcltk2/inst/tklibs/ico1.0/ico.tcl
===================================================================
--- pkg/tcltk2/inst/tklibs/ico1.0/ico.tcl (rev 0)
+++ pkg/tcltk2/inst/tklibs/ico1.0/ico.tcl 2012-05-01 21:13:00 UTC (rev 475)
@@ -0,0 +1,1391 @@
+# ico.tcl --
+#
+# Win32 ico manipulation code
+#
+# Copyright (c) 2003-2007 Aaron Faupell
+# Copyright (c) 2003-2004 ActiveState Corporation
+#
+# RCS: @(#) $Id: ico.tcl,v 1.28 2008/03/12 07:25:49 hobbs Exp $
+
+# Sample usage:
+# set file bin/wish.exe
+# set icos [::ico::icons $file]
+# set img [::ico::getIcon $file [lindex $icos 1] -format image -res 32]
+
+package require Tcl 8.4
+
+# Instantiate vars we need for this package
+namespace eval ::ico {
+ namespace export icons iconMembers getIcon getIconByName writeIcon copyIcon transparentColor clearCache EXEtoICO
+ # stores cached indices of icons found
+ variable RES
+ array set RES {}
+
+ # used for 4bpp number conversion
+ variable BITS
+ array set BITS [list {} 0 0000 0 0001 1 0010 2 0011 3 0100 4 \
+ 0101 5 0110 6 0111 7 1000 8 1001 9 \
+ 1010 10 1011 11 1100 12 1101 13 1110 14 1111 15 \
+ \
+ 00000 00 00001 0F 00010 17 00011 1F \
+ 00100 27 00101 2F 00110 37 00111 3F \
+ 01000 47 01001 4F 01010 57 01011 5F \
+ 01100 67 01101 6F 01110 77 01111 7F \
+ 10000 87 10001 8F 10010 97 10011 9F \
+ 10100 A7 10101 AF 10110 B7 10111 BF \
+ 11000 C7 11001 CF 11010 D7 11011 DF \
+ 11100 E7 11101 EF 11110 F7 11111 FF]
+}
+
+
+# icons --
+#
+# List of icons in a file
+#
+# ARGS:
+# file File to extract icon info from.
+# ?-type? Type of file. If not specified, it is derived from
+# the file extension. Currently recognized types are
+# EXE, DLL, ICO, ICL, BMP, and ICODATA
+#
+# RETURNS:
+# list of icon names or numerical IDs
+#
+proc ::ico::icons {file args} {
+ parseOpts type $args
+ if {![info exists type]} {
+ # $type wasn't specified - get it from the extension
+ set type [fileext $file]
+ }
+ if {![llength [info commands getIconList$type]]} {
+ return -code error "unsupported file format $type"
+ }
+ getIconList$type [file normalize $file]
+}
+
+# iconMembers --
+#
+# Get info on images which make up an icon
+#
+# ARGS:
+# file File containing icon
+# name Name of the icon in the file
+# ?-type? Type of file. If not specified, it is derived from
+# the file extension. Currently recognized types are
+# EXE, DLL, ICO, ICL, BMP, and ICODATA
+#
+# RETURNS:
+# list of icons as tuples {name width height bpp}
+#
+proc ::ico::iconMembers {file name args} {
+ parseOpts type $args
+ if {![info exists type]} {
+ # $type wasn't specified - get it from the extension
+ set type [fileext $file]
+ }
+ if {![llength [info commands getIconMembers$type]]} {
+ return -code error "unsupported file format $type"
+ }
+ getIconMembers$type [file normalize $file] $name
+}
+
+# getIcon --
+#
+# Get pixel data or image of icon
+#
+# ARGS:
+# file File to extract icon info from.
+# name Name of image in the file to use. The name is the first element
+# in the sublists returned by iconMembers.
+# ?-res? Set the preferred resolution.
+# ?-bpp? Set the preferred color depth in bits per pixel.
+# ?-exact? Accept only exact matches for res and bpp. Returns
+# an error if there is no exact match.
+# ?-type? Type of file. If not specified, it is derived from
+# the file extension. Currently recognized types are
+# EXE, DLL, ICO, ICL, BMP, and ICODATA
+# ?-format? Output format. Must be one of "image" or "colors"
+# 'image' will return the name of a Tk image.
+# 'colors' will return a list of pixel values
+# ?-image? If output is image, use this as the name of Tk image
+# created
+#
+# RETURNS:
+# pixel data as a list that could be passed to 'image create'
+# or the name of a Tk image
+#
+proc ::ico::getIcon {file name args} {
+ set image {}
+ set format image
+ set exact 0
+ set bpp 24
+ parseOpts {type format image res bpp exact} $args
+ if {![info exists type]} {
+ # $type wasn't specified - get it from the extension
+ set type [fileext $file]
+ }
+ if {![llength [info commands getRawIconData$type]]} {
+ return -code error "unsupported file format $type"
+ }
+ # ICODATA is a pure data type - not a real file
+ if {$type ne "ICODATA"} {
+ set file [file normalize $file]
+ }
+
+ set mem [getIconMembers$type $file $name]
+
+ if {![info exists res]} {
+ set icon [lindex $mem 0 0]
+ } elseif {$exact} {
+ set icon [lsearch -inline -glob $mem "* $res $bpp"]
+ if {$icon == ""} { return -code error "No matching icon" }
+ } else {
+ set mem [lsort -integer -index 1 $mem]
+ set match ""
+ foreach x $mem {
+ if {[lindex $x 1] == [lindex $res 0]} { lappend match $x }
+ }
+ if {$match == ""} {
+ # todo: resize a larger icon
+ #return -code error "No matching icon"
+ set match [list [lindex $mem end]]
+ }
+ set match [lsort -integer -decreasing -index 3 $match]
+ foreach x $match {
+ if {[lindex $x 3] <= $bpp} { set icon [lindex $x 0]; break }
+ }
+ if {![info exists icon]} { set icon [lindex $match end 0]}
+ }
+ if {$format eq "name"} {
+ return $icon
+ }
+ set colors [eval [linsert [getRawIconData$type $file $icon] 0 getIconAsColorList]]
+ if {$format eq "image"} {
+ return [createImage $colors $image]
+ }
+ return $colors
+}
+
+# getIconByName --
+#
+# Get pixel data or image of icon name in file. The icon name
+# is the first element of the sublist from [iconMembers].
+#
+# ARGS:
+# file File to extract icon info from.
+# name Name of image in the file to use. The name is the first element
+# in the sublists returned by iconMembers.
+# ?-type? Type of file. If not specified, it is derived from
+# the file extension. Currently recognized types are
+# EXE, DLL, ICO, ICL, BMP, and ICODATA
+# ?-format? Output format. Must be one of "image" or "colors"
+# 'image' will return the name of a Tk image.
+# 'colors' will return a list of pixel values
+# ?-image? If output is image, use this as the name of Tk image
+# created
+#
+# RETURNS:
+# pixel data as a list that could be passed to 'image create'
+#
+proc ::ico::getIconByName {file name args} {
+ set format image
+ set image {}
+ parseOpts {type format image} $args
+ if {![info exists type]} {
+ # $type wasn't specified - get it from the extension
+ set type [fileext $file]
+ }
+ if {![llength [info commands getRawIconData$type]]} {
+ return -code error "unsupported file format $type"
+ }
+ # ICODATA is a pure data type - not a real file
+ if {$type ne "ICODATA"} {
+ set file [file normalize $file]
+ }
+ set colors [eval [linsert [getRawIconData$type $file $name] 0 getIconAsColorList]]
+ if {$format eq "image"} {
+ return [createImage $colors $image]
+ }
+ return $colors
+}
+
+# getFileIcon --
+#
+# Get the registered icon for the file under Windows
+#
+# ARGS:
+# file File to get icon for.
+#
+# optional arguments and return values are the same as getIcon
+#
+proc ::ico::getFileIcon {file args} {
+ set icon "%SystemRoot%\\System32\\shell32.dll,0"
+ if {[file isdirectory $file] || $file == "Folder"} {
+ if {![catch {registry get HKEY_CLASSES_ROOT\\Folder\\DefaultIcon ""} reg]} {
+ set icon $reg
+ }
+ } else {
+ set ext [file extension $file]
+ if {![catch {registry get HKEY_CLASSES_ROOT\\$ext ""} doctype]} {
+ if {![catch {registry get HKEY_CLASSES_ROOT\\$doctype\\CLSID ""} clsid] && \
+ ![catch {registry get HKEY_CLASSES_ROOT\\CLSID\\$clsid\\DefaultIcon ""} reg]} {
+ set icon $reg
+ } elseif {![catch {registry get HKEY_CLASSES_ROOT\\$doctype\\DefaultIcon ""} reg]} {
+ set icon $reg
+ }
+ }
+ }
+ set index [lindex [split $icon ,] 1]
+ set icon [lindex [split $icon ,] 0]
+ if {$index == ""} { set index 0 }
+ set icon [string trim $icon "@'\" "]
+ while {[regexp -nocase {%([a-z]+)%} $icon -> var]} {
+ set icon [string map [list %$var% $::env($var)] $icon]
+ }
+ set icon [string map [list %1 $file] $icon]
+ if {$index < 0} {
+ if {![catch {eval [list getIcon $icon [string trimleft $index -]] $args} output]} {
+ return $output
+ }
+ set index 0
+ }
+ return [eval [list getIcon $icon [lindex [icons $icon] $index]] $args]
+}
+
+# writeIcon --
+#
+# Overwrite write image in file with depth/pixel data
+#
+# ARGS:
+# file File to extract icon info from.
+# name Name of image in the file to use. The name is the first element
+# in the sublists returned by iconMembers.
+# bpp bit depth of icon we are writing
+# data Either pixel color data (as returned by getIcon -format color)
+# or the name of a Tk image.
+# ?-type? Type of file. If not specified, it is derived from
+# the file extension. Currently recognized types are
+# EXE, DLL, ICO and ICL
+#
+# RETURNS:
+# nothing
+#
+proc ::ico::writeIcon {file name bpp data args} {
+ parseOpts type $args
+ if {![info exists type]} {
+ # $type wasn't specified - get it from the extension
+ set type [fileext $file]
+ }
+ if {![llength [info commands writeIcon$type]]} {
+ return -code error "unsupported file format $type"
+ }
+ if {[llength $data] == 1} {
+ set data [getColorListFromImage $data]
+ } elseif {[lsearch -glob [join $data] #*] > -1} {
+ set data [translateColors $data]
+ }
+ if {$bpp != 1 && $bpp != 4 && $bpp != 8 && $bpp != 24 && $bpp != 32} {
+ return -code error "invalid color depth"
+ }
+ set palette {}
+ if {$bpp <= 8} {
+ set palette [getPaletteFromColors $data]
+ if {[lindex $palette 0] > (1 << $bpp)} {
+ return -code error "specified color depth too low"
+ }
+ set data [lindex $palette 2]
+ set palette [lindex $palette 1]
+ append palette [string repeat \000 [expr {(1 << ($bpp + 2)) - [string length $palette]}]]
+ }
+ set and [getAndMaskFromColors $data]
+ set xor [getXORFromColors $bpp $data]
+ # writeIcon$type file index w h bpp palette xor and
+ writeIcon$type [file normalize $file] $name \
+ [llength [lindex $data 0]] [llength $data] $bpp $palette $xor $and
+}
+
+
+# copyIcon --
+#
+# Copies an icon directly from one file to another
+#
+# ARGS:
+# file1 File to extract icon info from.
+# name1 Name of image in the file to use. The name is the first element
+# in the sublists returned by iconMembers.
+# file2 File to write icon to.
+# name2 Name of image in the file to use. The name is the first element
+# in the sublists returned by iconMembers.
+# ?-fromtype? Type of source file. If not specified, it is derived from
+# the file extension. Currently recognized types are
+# EXE, DLL, ICO, ICL, BMP, and ICODATA
+# ?-totype? Type of destination file. If not specified, it is derived from
+# the file extension. Currently recognized types are
+# EXE, DLL, ICO, ICL, BMP, and ICODATA
+#
+# RETURNS:
+# nothing
+#
+proc ::ico::copyIcon {file1 name1 file2 name2 args} {
+ parseOpts {fromtype totype} $args
+ if {![info exists fromtype]} {
+ # $type wasn't specified - get it from the extension
+ set fromtype [fileext $file1]
+ }
+ if {![info exists totype]} {
+ # $type wasn't specified - get it from the extension
+ set totype [fileext $file2]
+ }
+ if {![llength [info commands writeIcon$totype]]} {
+ return -code error "unsupported file format $totype"
+ }
+ if {![llength [info commands getRawIconData$fromtype]]} {
+ return -code error "unsupported file format $fromtype"
+ }
+ set src [getRawIconData$fromtype $file1 $name1]
+ writeIcon $file2 $name2 [lindex $src 2] [eval getIconAsColorList $src] -type $totype
+}
+
+#
+# transparentColor --
+#
+# Turns on transparency for all pixels in the image that match the color
+#
+# ARGS:
+# img Name of the Tk image to modify, or an image in color list format
+# color Color in #hex format which will be made transparent
+#
+# RETURNS:
+# the data or image after modification
+#
+proc ::ico::transparentColor {img color} {
+ if {[llength $img] == 1} {
+ package require Tk
+ if {[string match "#*" $color]} {
+ set color [scan $color "#%2x%2x%2x"]
+ }
+ set w [image width $img]
+ set h [image height $img]
+ for {set y 0} {$y < $h} {incr y} {
+ for {set x 0} {$x < $w} {incr x} {
+ if {[$img get $x $y] eq $color} {$img transparency set $x $y 1}
+ }
+ }
+ } else {
+ set y 0
+ foreach row $img {
+ set x 0
+ foreach px $row {
+ if {$px == $color} {lset img $y $x {}}
+ incr x
+ }
+ incr y
+ }
+ }
+ return $img
+}
+
+#
+# clearCache --
+#
+# Clears the cache of icon offsets
+#
+# ARGS:
+# file optional filename
+#
+#
+# RETURNS:
+# nothing
+#
+proc ::ico::clearCache {{file {}}} {
+ variable RES
+ if {$file ne ""} {
+ array unset RES $file,*
+ } else {
+ unset RES
+ array set RES {}
+ }
+}
+
+#
+# EXEtoICO --
+#
+# Convert all icons found in exefile into regular icon files
+#
+# ARGS:
+# exeFile Input EXE filename
+# ?icoDir? Output ICO directory. Default is the
+# same directory exeFile is located in
+#
+# RETURNS:
+# nothing
+#
+proc ::ico::EXEtoICO {exeFile {icoDir {}}} {
+ variable RES
+
+ set file [file normalize $exeFile]
+ FindResources $file
+
+ if {$icoDir == ""} { set icoDir [file dirname $file] }
+
+ set fh [open $file]
+ fconfigure $fh -eofchar {} -encoding binary -translation lf
+
+ foreach group $RES($file,group,names) {
+ set dir {}
+ set data {}
+ foreach icon $RES($file,group,$group,members) {
+ seek $fh $RES($file,icon,$icon,offset) start
+ set ico $RES($file,icon,$icon,data)
+ eval [list lappend dir] $ico
+ append data [read $fh [eval calcSize $ico 40]]
+ }
+
+ # write them out to a file
+ set ifh [open [file join $icoDir [file tail $exeFile]-$group.ico] w+]
+ fconfigure $ifh -eofchar {} -encoding binary -translation lf
+
+ bputs $ifh sss 0 1 [llength $RES($file,group,$group,members)]
+ set offset [expr {6 + ([llength $RES($file,group,$group,members)] * 16)}]
+ foreach {w h bpp} $dir {
+ set len [calcSize $w $h $bpp 40]
+ lappend fix $offset $len
+ bputs $ifh ccccssii $w $h [expr {$bpp <= 8 ? 1 << $bpp : 0}] 0 1 $bpp $len $offset
+ set offset [expr {$offset + $len}]
+ }
+ puts -nonewline $ifh $data
+ foreach {offset size} $fix {
+ seek $ifh [expr {$offset + 20}] start
+ bputs $ifh i $size
+ }
+ close $ifh
+ }
+ close $fh
+}
+
+
+
+##
+## Internal helper commands.
+## Some may be appropriate for exposing later, but would need docs
+## and make sure they "fit" in the API.
+##
+
+# gets the file extension as we use it internally (upper case, no '.')
+proc ::ico::fileext {file} {
+ return [string trimleft [string toupper [file extension $file]] .]
+}
+
+# helper proc to parse optional arguments to some of the public procs
+proc ::ico::parseOpts {acc opts} {
+ foreach {key val} $opts {
+ set key [string trimleft $key -]
+ if {[lsearch -exact $acc $key] >= 0} {
+ upvar $key $key
+ set $key $val
+ } elseif {$key ne ""} {
+ return -code error "unknown option \"$key\": must be one of $acc"
+ }
+ }
+}
+
+# formats a single color from a binary decimal list format to the #hex format
+proc ::ico::formatColor {r g b} {
+ format "#%02X%02X%02X" [scan $r %c] [scan $g %c] [scan $b %c]
+}
+
+# translates a color list from the #hex format to the decimal list format
+# #0000FF {0 0 255}
+proc ::ico::translateColors {colors} {
+ set new {}
+ foreach line $colors {
+ set tline {}
+ foreach x $line {
+ if {$x eq ""} {lappend tline {}; continue}
+ lappend tline [scan $x "#%2x%2x%2x"]
+ }
+ set new [linsert $new 0 $tline]
+ }
+ return $new
+}
+
+# reads a 32 bit signed integer from the filehandle
+proc ::ico::getdword {fh} {
+ binary scan [read $fh 4] i* tmp
+ return $tmp
+}
+
+proc ::ico::getword {fh} {
+ binary scan [read $fh 2] s* tmp
+ return $tmp
+}
+
+proc ::ico::getulong {fh} {
+ binary scan [read $fh 4] i tmp
+ return [format %u $tmp]
+}
+
+proc ::ico::getushort {fh} {
+ binary scan [read $fh 2] s tmp
+ return [expr {$tmp & 0x0000FFFF}]
+}
+
+proc ::ico::bputs {fh format args} {
+ puts -nonewline $fh [eval [list binary format $format] $args]
+}
+
+proc ::ico::createImage {colors {name {}}} {
+ package require Tk
+ set h [llength $colors]
+ set w [llength [lindex $colors 0]]
+ if {$name ne ""} {
+ set img [image create photo $name -width $w -height $h]
+ } else {
+ set img [image create photo -width $w -height $h]
+ }
+ if {0} {
+ # if image supported "" colors as transparent pixels,
+ # we could use this much faster op
+ $img put -to 0 0 $colors
+ } else {
+ for {set x 0} {$x < $w} {incr x} {
+ for {set y 0} {$y < $h} {incr y} {
+ set clr [lindex $colors $y $x]
+ if {$clr ne ""} {
+ $img put -to $x $y $clr
+ }
+ }
+ }
+ }
+ return $img
+}
+
+# return a list of colors in the #hex format from raw icon data
+# returned by readDIB
+proc ::ico::getIconAsColorList {w h bpp palette xor and} {
+ # Create initial empty color array that we'll set indices in
+ set colors {}
+ set row {}
+ set empty {}
+ for {set x 0} {$x < $w} {incr x} { lappend row $empty }
+ for {set y 0} {$y < $h} {incr y} { lappend colors $row }
+
+ set x 0
+ set y [expr {$h-1}]
+ if {$bpp == 1} {
+ binary scan $xor B* xorBits
+ foreach i [split $xorBits {}] a [split $and {}] {
+ if {$x == $w} { set x 0; incr y -1 }
+ if {$a == 0} {
+ lset colors $y $x [lindex $palette $i]
+ }
+ incr x
+ }
+ } elseif {$bpp == 4} {
+ variable BITS
+ binary scan $xor B* xorBits
+ set i 0
+ foreach a [split $and {}] {
+ if {$x == $w} { set x 0; incr y -1 }
+ if {$a == 0} {
+ set bits [string range $xorBits $i [expr {$i+3}]]
+ lset colors $y $x [lindex $palette $BITS($bits)]
+ }
+ incr i 4
+ incr x
+ }
+ } elseif {$bpp == 8} {
+ foreach i [split $xor {}] a [split $and {}] {
+ if {$x == $w} { set x 0; incr y -1 }
+ if {$a == 0} {
+ lset colors $y $x [lindex $palette [scan $i %c]]
+ }
+ incr x
+ }
+ } elseif {$bpp == 16} {
+ variable BITS
+ binary scan $xor b* xorBits
+ set i 0
+ foreach a [split $and {}] {
+ if {$x == $w} { set x 0; incr y -1 }
+ if {$a == 0} {
+ set b1 [string range $xorBits $i [expr {$i+4}]]
+ set b2 [string range $xorBits [expr {$i+5}] [expr {$i+9}]]
+ set b3 [string range $xorBits [expr {$i+10}] [expr {$i+14}]]
+ lset colors $y $x "#$BITS($b3)$BITS($b2)$BITS($b1)"
+ }
+ incr i 16
+ incr x
+ }
+ } elseif {$bpp == 24} {
+ foreach {b g r} [split $xor {}] a [split $and {}] {
+ if {$x == $w} { set x 0; incr y -1 }
+ if {$a == 0} {
+ lset colors $y $x [formatColor $r $g $b]
+ }
+ incr x
+ }
+ } elseif {$bpp == 32} {
+ foreach {b g r n} [split $xor {}] a [split $and {}] {
+ if {$x == $w} { set x 0; incr y -1 }
+ if {$a == 0} {
+ lset colors $y $x [formatColor $r $g $b]
+ }
+ incr x
+ }
+ }
+ return $colors
+}
+
+# creates a binary formatted AND mask by reading a list of colors in the decimal list format
+# and checking for empty colors which designate transparency
+proc ::ico::getAndMaskFromColors {colors} {
+ set and {}
+ foreach line $colors {
+ set l {}
+ foreach x $line {append l [expr {$x eq ""}]}
+ append l [string repeat 0 [expr {[string length $l] % 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]
+ }
+ }
+ return $and
+}
+
+# creates a binary formatted XOR mask in the specified depth format from
+# a list of colors in the decimal list format
+proc ::ico::getXORFromColors {bpp colors} {
+ set xor {}
+ if {$bpp == 1} {
+ foreach line $colors {
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/sciviews -r 475
More information about the Sciviews-commits
mailing list