1. Introduction
Due to the need to get rid of libtiff, I needed to write tiff images without it and started to write a simple tiff RGB image writer in tcl using the tiff v6.0 specification documentation. Afterwards I transfered the functionality into C++ and I was happy to have no libtiff anymore.
The reasons to get rid of libtiff were, that we only needed to write tiff RGB images and that we have 5 platforms to support - 4 UNIX platforms with 32/64bit, ... - so we don't wanted to built more external libraries than needed.
The tiff package provides following functionality:
Some irregularies or simples irritations are following behaviour of tk image photo objects in tcl/tk v8.4.3:
Perhabs somebody could clear these irritations of mine?
2. Description
2.1 tiff2raw
2.1.1 Syntax
tiff2raw fileName ifhVar ifdVar ?bufferVar?
2.1.2 Details
1. in the image file header array variable are only stored following elements:
2. a TIFF image file can store multiple pages, images or image extending data like alpha channel or transparency data. The proc tiff2raw only supports the first image file directory and extracts only raw data referenced by this image file directory!
3. the image file directory array variable elements are named like following:
4. the data belonging to a image file directory entry is a list collecting following data:
5. every image file directory entry value, that could be translated into a token will be translated - e.g. "photometric = 2" will be translated into "photometric = RGB"
2.2 raw2tiff
2.2.1 Syntax
raw2tiff fileName description width height xdpi ydpi bufferVar
2.3 Details
1. the length of the raw/binary data must be:
2. the format of the raw/binary data must be "...RGBRGBRGBRGB..." - one byte per colour, red, green following red, blue following green, and so on
3. the resolution of the image is not important, although it would be used to determine the WYSIWYG size, the size, when to be printed
2.3 dumpTiff
2.3.1 Syntax
dumpTiff fileName ?out? ?saveRawData?
2.3.2 Details
1. the written text file contains the information about the byte order inside the TIFF image file and the image file directory with its entries and the corresponding values
2. the eventually saved raw data could be read by e.g. IrfanView
2.4 photo2raw
2.4.1 Syntax
photo2raw photo rawDataVar
2.4.2 Details
1. if tk is not present the first argument must be a variable containing the data returned by the command:
$photo data
2. if tk is present the first argument will be taken as name of a tk image of the type photo and the needed data will be requested by:
$photo data
2.5 photo2tiff
2.5.1 Syntax
photo2tiff photo fileName description xdpi ydpi
2.5.2 Details
1. this proc will only write uncompressed TIFF RGB image files
2.6 tiff2photo
2.5.1 Syntax
tiff2photo fileName photo ?ifdVar?
2.5.2 Details
1. this proc will only read uncompressed TIFF RGB/RGB Palette/Grayscaled/Bilevel (= black/white) image files
2. black/white and white/black pictures are handled like this ... white or black background
3. some grayscaled TIFF image files were suddenly shown as inversed image, even if the have a white background specified in the image file header - I don't know why!
4. Halftone dithering and threshhold or similar things are not applied, so the tk image could differ from the TIFF image file seen in a viewer or editor
5. if the tk image of the type photo is not created yet, this proc will create this tk image
6. if tk is not present, the second argument will be taken as variable name to contain the tk image photo data need to be used with the command:
$photo put $data
3. Enhancements eventuall future plans
4. Source
Please reap the first code and save it as the pkgIndex.tcl file:
package ifneeded tiff 1.0 [list source [file join $dir tiff.1.0.tcl]]
Please reap the second code and save it as tiff.1.0.tcl file:
uplevel #0 {
package provide tiff 1.0;
lappend ::auto_path [file dirname [info script]];
}
namespace eval ::tiff {
proc this {} "return [namespace current];";
proc parent {} "return [namespace parent [this]];";
variable TIFF_IFD_TAG_NAMES;
array set TIFF_IFD_TAG_NAMES {
254 newSubfileType
255 subfileType
256 width
257 height
258 bitsPerSample
259 compression
262 photometric
263 threshholding
264 cellWidth
265 cellLength
266 fillOrder
269 documentName
270 imageDescription
271 make
272 model
273 stripOffset
274 orientation
277 samplesPerPixel
278 rowsPerStrip
279 stripByteCount
280 minSampleValue
281 maxSampleValue
282 xResolution
283 yResolution
284 planarConfiguration
285 pageName
286 xPosition
287 yPosition
288 freeOffsets
289 freeByteCounts
290 grayResponseUnit
291 grayResponseCurve
292 t4Options
292 t6Options
296 resolutionUnit
297 pageNumber
301 transferFunction
305 software
306 dateTime
315 artist
316 hostName
317 predictor
318 whitePoint
319 primaryChormaticities
320 colorMap
321 halftoneHints
322 tileWidth
323 tileLength
324 tileOffsets
325 tileByteCounts
332 inkSet
333 inkNames
334 numberOfInks
336 dotRange
337 targetPrinter
338 extraSamples
339 sampleFormat
340 sMinSampleValue
341 sMaxSampleValue
342 transferRange
512 jpegProc
513 jpegInterchangeFormat
514 jpegInterchangeFormatLength
515 jpegRestartInterval
517 jpegLosslessPredictors
518 jpegPointTransforms
519 jpegQTables
520 jpegDCTables
521 jpegACTables
529 yCbCrCoefficients
530 yCbCrSubSampling
531 yCbCrPositioning
532 referenceBlackWhite
33432 copyright
}
proc tiffIfdTags {token} {
variable TIFF_IFD_TAG_NAMES;
if {![info exists TIFF_IFD_TAG_NAMES($token)]} {
set types {};
foreach name [lsort -dictionary [array names TIFF_IFD_TAG_NAMES {[A-Z]*}]] {
lappend types "$name ($TIFF_IFD_TAG_NAMES(name))";
}
if {[string is integer -strict $token]} {
return $token;
}
error "bad image file directory tag name \"$token\": must be [join $types {, }]";
}
return $TIFF_IFD_TAG_NAMES($token);
}
variable TIFF_IFD_TAG_TYPES;
array set TIFF_IFD_TAG_TYPES {
Byte 1
Ascii 2
Short 3
Long 4
Rational 5
SByte 6
Undefined 7
SShort 8
SLong 9
SRational 10
Float 11
Double 12
1 Byte
2 Ascii
3 Short
4 Long
5 Rational
6 SByte
7 Undefined
8 SShort
9 SLong
10 SRational
11 Float
12 Double
};
proc tiffIfdTagTypes {token} {
variable TIFF_IFD_TAG_TYPES;
if {![info exists TIFF_IFD_TAG_TYPES($token)]} {
set types {};
foreach name [lsort -dictionary [array names TIFF_IFD_TAG_TYPES {[A-Z]*}]] {
lappend types "$name ($TIFF_IFD_TAG_TYPES(name))";
}
error "bad image file directory tag type \"$token\": must be [join $types {, }]";
}
return $TIFF_IFD_TAG_TYPES($token);
}
variable TIFF_IFD_TAG_BYTES ;
array set TIFF_IFD_TAG_BYTES {
1 1
Byte 1
2 1
Ascii 1
3 2
Short 2
4 4
Long 4
5 8
Rational 8
6 1
SByte 1
7 1
Undefined 1
8 2
SShort 2
9 4
SLong 4
10 8
SRational 8
11 4
Float 4
12 8
Double 8
};
proc tiffIfdTagBytes {token} {
variable TIFF_IFD_TAG_BYTES;
if {![info exists TIFF_IFD_TAG_BYTES($token)]} {
set types {};
foreach name [lsort -dictionary [array names TIFF_IFD_TAG_BYTES {[A-Z]*}]] {
lappend types "$name ($TIFF_IFD_TAG_BYTES(name)B)";
}
error "bad image file directory tag type \"$token\": must be [join $types {, }]";
}
return $TIFF_IFD_TAG_BYTES($token);
}
variable TIFF_SIZES;
array set TIFF_SIZES [list \
ifd.entry.value [tiffIfdTagBytes Long] \
ifh [expr {2*[tiffIfdTagBytes Short] + [tiffIfdTagBytes Long]}] \
ifd.entry [expr {2*[tiffIfdTagBytes Short] + 2*[tiffIfdTagBytes Long]}] \
];
proc tiffSizes {token args} {
variable TIFF_SIZES;
if {$token == "ifd"} {
if {[llength $args] != 1} {
error "wrong # args: should be \"tiffSizes ifd ifdEntryCount\"";
}
return [expr {[tiffIfdTagBytes Short] + [lindex $args 0]*$TIFF_SIZES(ifd.entry) + [tiffIfdTagBytes Long]}];
}
if {$args != {}} {
error "wrong # args: should be \"tiffSizes token\"";
}
if {![info exists TIFF_SIZES($token)]} {
error "bad image file directory tag type \"$token\": must be [join [lsort -dictionary [array names TIFF_SIZES {[A-Z]*}]] {, }]";
}
return $TIFF_SIZES($token);
}
proc compression {token} {
if {[string is integer $token]} {
switch -exact -- $token {
1 {return "Uncompressed";}
2 {return "CCITT 1D";}
3 {return "Group 3 Fax";}
4 {return "Group 4 Fax";}
5 {return "LZW";}
6 {return "JPEG";}
32773 {return "PackBits";}
default {return "Unknown \"$token\"";}
}
}
switch -exact -- $token {
"Uncompressed" {return 1;}
"CCITT 1D" {return 2;}
"Group 3 Fax" {return 3;}
"Group 4 Fax" {return 4;}
"LZW" {return 5;}
"JPEG" {return 6;}
"PackBits" {return 32773;}
}
error "bad compression mode \"$token\": must be Uncompressed, CCITT 1D, Group 3 Fax, Group 4 Fax, LZW, JPEG or PackBits";
}
proc photometric {token} {
if {[string is integer $token]} {
switch -exact -- $token {
0 {return "whiteIsZero";}
1 {return "blackIsZero";}
2 {return "RGB";}
3 {return "RGB Palette";}
4 {return "Transparency Mask";}
5 {return "CMYK";}
6 {return "YCbCr";}
8 {return "CIELab";}
default {return "Unknown \"$token\"";}
}
}
switch -exact -- $token {
whiteIsZero {return 0;}
blackIsZero {return 1;}
RGB {return 2;}
"RGB Palette" {return 3;}
"Transparency Mask" {return 4;}
CMYK {return 5;}
YCbCr {return 6;}
CIELab {return 8;}
}
error "bad photometric interpretation mode \"$token\": must be whiteIsZero, blackIsZero, RGB, RGB Palette, Transparency Mask, CMYK, YCbCr or CIELab";
}
proc resolutionUnit {token} {
if {[string is integer $token]} {
switch -exact -- $token {
1 {return "None";}
2 {return "Inch";}
3 {return "Centimeter";}
default {return "Unknown \"$token\"";}
}
}
switch -exact -- $token {
"None" {return 1;}
"Inch" {return 2;}
"Centimeter" {return 3;}
}
error "bad resolution unit \"$token\": must be None, Inch, or Centimeter";
}
proc extraSamples {token} {
if {[string is integer $token]} {
switch -exact -- $token {
0 {return "Unspecified";}
1 {return "AssociatedAlpha";}
2 {return "UnassociatedAlpha";}
default {return "Unknown \"$token\"";}
}
}
switch -exact -- $token {
"Unspecified" {return 0;}
"AssociatedAlpha" {return 1;}
"UnassociatedAlpha" {return 2;}
}
error "bad extra sample type \"$token\": must be Unspecified, AssociatedAlpha, or UnassociatedAlpha";
}
proc getb {byteOrder channel type args} {
if {[llength $args] > 2} {
error "wrong # args: should be \"getb channel type ?count? ?fieldSize?\"";
}
set count "";
set fieldSize "";
foreach {count fieldSize} $args {break;};
if {$count == ""} {
set count 1;
}
switch -glob -- $type {
Undefined -
*Byte {
if {$count == 1} {
set format "c";
} else {
set format "a$count";
}
}
Ascii {set format "A*";}
*Short -
*Long {
if {[string match {*Short} $type]} {
set format "S";
} else {
set format "I";
}
if {$byteOrder == "II"} {
set format [string tolower $format];
}
}
Float {set format "f";}
Double {set format "d";}
default {
error "bad type \"$type\": must be Ascii, (S)Byte, Double, Float, (S)Long, (S)Short, or Undefined";
}
}
set byteCount [expr {$count * [tiffIfdTagBytes $type]}];
if {$fieldSize == ""} {
set fieldSize [tiffIfdTagBytes $type];
}
if {$fieldSize < $byteCount} {
set fillByteCount 0;
} else {
set fillByteCount [expr {$fieldSize - $byteCount}];
set byteCount $fieldSize;
}
set value {};
set position [tell $channel];
set binaryValue [read $channel $byteCount];
if {![binary scan $binaryValue ${format}x$fillByteCount value]} {
puts \n[info level [info level]];
binary scan $binaryValue c* bValue;
puts "$bValue => ${format}x$fillByteCount => $value @ $position";
error "couldn't get $type value at [expr {[tell $channel] - $byteCount}] with $byteCount bytes: binary value = $value" $::errorInfo $::errorCode;
}
switch -glob -- $type {
Undefined -
*Byte {set add 0xFF;}
*Short {set add 0xFFFF;}
*Long {set add 0xFFFFFFFF;}
}
switch -glob -- $type {
Undefined -
*Byte -
*Short -
*Long {
if {!((($type == "Undefined") || [string match {*Byte} $type]) && ($byteCount != 1))} {
set idx 0;
foreach subValue $value {
set value [lreplace $value $idx $idx [expr {$subValue & $add}]];
}
}
}
}
return $value;
}
proc putb {byteOrder channel type value args} {
if {[llength $args] > 1} {
error "wrong # args: should be \"putb byteOrder channel type value ?fieldSize?\"";
}
switch -exact -- $type {
Ascii -
Byte {
set fieldSize [lindex $args 0];
set byteCount [string length $value];
if {$type == "Ascii"} {
incr byteCount;
set format "a$byteCount";
} else {
if {$byteCount == ""} {
set byteCount 1;
set format "c";
} else {
set format "a*";
}
}
}
Short -
Long {
set fieldSize [lindex $args 0];
set byteCount [tiffIfdTagBytes $type];
if {$type == "Short"} {
set format "S";
} else {
set format "I";
}
if {$byteOrder == "II"} {
set format [string tolower $format];
}
}
default {
error "bad type \"$type\": must be Ascii, Byte, Long, or Short";
}
}
if {$fieldSize == ""} {
set fieldSize [tiffIfdTagBytes $type];
}
if {$fieldSize < $byteCount} {
set fillByteCount 0;
} else {
set fillByteCount [expr {$fieldSize - $byteCount}];
}
puts -nonewline $channel [binary format ${format}x$fillByteCount $value];
return;
}
# ========================================================================== #
# raw2tiff #
# ========================================================================== #
# - writes a full RGB TIFF image file from the given RGB data in 'buffer' #
# - writes a TIFF image file containing only one strip of data #
# - writes all data in big endian byte order #
# ========================================================================== #
#
proc raw2tiff {fileName description width height xdpi ydpi bufferVar} {
# opening the TIFF image file to write as binary
#
if {[catch {set fid [open $fileName w];} reason]} {
error "couldn't write TIFF image file \"$fileName\": $reason" $::errorInfo $::errorCode;
}
fconfigure $fid -translation binary -buffersize 1000000 -buffering full;
upvar $bufferVar buffer;
# filling the image file header
#
binary scan "MM" s ifhByteOrder; # big endian byteorder (M = Motorola)
set ifhVersion 42; # magic number ;-)
set ifhIfdOffset [tiffSizes ifh]; # let the image file directory start right behind the header
# writing the image file header
#
putb $ifhByteOrder $fid Short $ifhByteOrder;
putb $ifhByteOrder $fid Short $ifhVersion;
putb $ifhByteOrder $fid Long $ifhIfdOffset;
# building the image file directory
#
set ifdEntryCount 18;
set ifdNextIfdOffset 0;
set ifdSize [tiffSizes ifd $ifdEntryCount];
# presetting the image file directory entry values
#
set compression [compression Uncompressed];
set photometric [photometric RGB];
set resolutionUnit [resolutionUnit Inch];
set bitsPerSample {8 8 8};
set samplesPerPixel 3;
set stripOffset [expr {
[tiffSizes ifh]
+ [tiffIfdTagBytes Short]
+ $ifdSize
+ [tiffIfdTagBytes Long]
+ (( [tiffIfdTagBytes Short]
+ $ifdSize
+ [tiffIfdTagBytes Long]) % 4)
}];
set stripByteCount [expr {$width * $height * $samplesPerPixel}];
set rowsPerStrip $height;
set xResolution [list [list $xdpi 1]];
set yResolution [list [list $ydpi 1]];
set make "EDS PLM solutions/Manifacturing Planing Solutions/simulation & analysis products/Berlin (Germany)";
set software "eds/toolkit v3.40";
set dateTime [clock format [clock scan now] -format {%Y:%m:%d %H:%M:%S}];
set artist $::tcl_platform(user);
set hostName [info hostname];
# filling the image file directory entries
#
array set ifdEntries [list \
0.name "ImageWidth" \
0.tag 256 \
0.type Long \
0.count 1 \
0.value $width \
0.offset 0 \
1.name "ImageHeight" \
1.tag 257 \
1.type Long \
1.count 1 \
1.value $height \
1.offset 0 \
2.name "BitsPerSample" \
2.tag 258 \
2.type Short \
2.count 3 \
2.value $bitsPerSample \
2.offset 0 \
3.name "Compression" \
3.tag 259 \
3.type Short \
3.count 1 \
3.value $compression \
3.offset 0 \
4.name "PhotometricInterpretation" \
4.tag 262 \
4.type Short \
4.count 1 \
4.value $photometric \
4.offset 0 \
5.name "ImageDescription" \
5.tag 270 \
5.type Ascii \
5.count [expr {[string length $description] + 1}] \
5.value $description \
5.offset 0 \
6.name "Make" \
6.tag 271 \
6.type Ascii \
6.count [expr {[string length $make] + 1}] \
6.value $make \
6.offset 0 \
7.name "StripOffset" \
7.tag 273 \
7.type Long \
7.count 1 \
7.value $stripOffset \
7.offset 0 \
8.name "SamplesPerPixel" \
8.tag 277 \
8.type Short \
8.count 1 \
8.value $samplesPerPixel \
8.offset 0 \
9.name "RowsPerStrip" \
9.tag 278 \
9.type Long \
9.count 1 \
9.value $rowsPerStrip \
9.offset 0 \
10.name "StripByteCount" \
10.tag 279 \
10.type Long \
10.count 1 \
10.value $stripByteCount \
10.offset 0 \
11.name "XResolution" \
11.tag 282 \
11.type Rational \
11.count 1 \
11.value $xResolution \
11.offset 0 \
12.name "YResolution" \
12.tag 283 \
12.type Rational \
12.count 1 \
12.value $yResolution \
12.offset 0 \
13.name "ResolutionUnit" \
13.tag 296 \
13.type Short \
13.count 1 \
13.value $resolutionUnit \
13.offset 0 \
14.name "Software" \
14.tag 305 \
14.type Ascii \
14.count [expr {[string length $software] + 1}] \
14.value $software \
14.offset 0 \
15.name "DateTime" \
15.tag 306 \
15.type Ascii \
15.count [expr {[string length $dateTime] + 1}] \
15.value $dateTime \
15.offset 0 \
16.name "Artist" \
16.tag 315 \
16.type Ascii \
16.count [expr {[string length $artist] + 1}] \
16.value $artist \
16.offset 0 \
17.name "Hostname" \
17.tag 316 \
17.type Ascii \
17.count [expr {[string length $hostName] + 1}] \
17.value $hostName \
17.offset 0 \
];
for {set i 0} {$i < $ifdEntryCount} {incr i} {
set ifdEntries($i.bytes) [tiffIfdTagBytes $ifdEntries($i.type)];
set ifdEntries($i.size) [expr {$ifdEntries($i.bytes) * $ifdEntries($i.count)}];
}
# finding all image file directory entry needing an offset
#
set ifdEntryValueOffset [expr {$stripOffset + $stripByteCount + (($stripOffset + $stripByteCount) % 4)}];
for {set i 0} {$i < $ifdEntryCount} {incr i} {
if {$ifdEntries($i.size) > [tiffSizes ifd.entry.value]} {
set ifdEntries($i.offset) $ifdEntryValueOffset;
incr ifdEntryValueOffset [expr {int(pow(2, int(ceil(log($ifdEntries($i.size))/log(2)))))}];
} else {
set ifdEntries($i.offset) 0;
}
}
# writing the image file directory
#
seek $fid $ifhIfdOffset;
putb $ifhByteOrder $fid Short $ifdEntryCount;
for {set i 0} {$i < $ifdEntryCount} {incr i} {
putb $ifhByteOrder $fid Short $ifdEntries($i.tag);
putb $ifhByteOrder $fid Short [tiffIfdTagTypes $ifdEntries($i.type)];
putb $ifhByteOrder $fid Long $ifdEntries($i.count);
# test if image file directory entry value must be offsetted
#
if {!$ifdEntries($i.offset)} {
# image file directory entry value can be stored inside the
# image file directory entry
#
switch -exact -- $ifdEntries($i.type) {
Byte {putb $ifhByteOrder $fid Byte $ifdEntries($i.value) [tiffSizes ifd.entry.value];}
Ascii {putb $ifhByteOrder $fid Ascii $ifdEntries($i.value) [tiffSizes ifd.entry.value];}
Short {putb $ifhByteOrder $fid Short $ifdEntries($i.value) [tiffSizes ifd.entry.value];}
Long {putb $ifhByteOrder $fid Long $ifdEntries($i.value) [tiffSizes ifd.entry.value];}
}
} else {
# the offset to the image file directory entry value
# is stored inside the image file directory entry
#
putb $ifhByteOrder $fid Long $ifdEntries($i.offset);
}
}
putb $ifhByteOrder $fid Long $ifdNextIfdOffset [tiffIfdTagBytes Long];
# writing the rgb data
#
seek $fid $stripOffset;
putb $ifhByteOrder $fid Byte $buffer;
# writing the offsetted image file directory entry values
#
for {set i 0} {$i < $ifdEntryCount} {incr i} {
if {$ifdEntries($i.offset) > 0} {
seek $fid $ifdEntries($i.offset);
switch -glob -- $ifdEntries($i.type) {
Ascii {putb $ifhByteOrder $fid Ascii $ifdEntries($i.value);}
*Rational {
# writing each rational as two following unsigned longs
#
foreach rational $ifdEntries($i.value) {
foreach {numerator denominator} $rational {break;}
putb $ifhByteOrder $fid Long $numerator;
putb $ifhByteOrder $fid Long $denominator;
}
}
default {
foreach value $ifdEntries($i.value) {
putb $ifhByteOrder $fid $ifdEntries($i.type) $value;
}
}
}
}
}
# finishing and closing the TIFF image file
#
close $fid;
return;
}
# ========================================================================== #
# tiff2raw #
# ========================================================================== #
# - reads a TIFF image and extracts its data into the given variables #
# - the image file header (ifh) will be stored into the array given with #
# ifhVar #
# - the image file directory (ifh) will be stored into the array given with #
# ifdVar #
# - the image file directory array will contain one element per found entry #
# holding a list: value type count offset #
# - the raw data, representing the image data no matter if compressed, in #
# JPEG style or what ever, will be stored as list of stripes into the #
# variable given wiht bufferVar #
# ========================================================================== #
#
proc tiff2raw {fileName ifhVar ifdVar {bufferVar ""}} {
upvar $ifhVar ifh;
upvar $ifdVar ifd;
if {$bufferVar != ""} {
upvar $bufferVar buffer;
}
catch {unset ifh ifd buffer;};
array set ifh {};
array set ifd {};
# opening the TIFF image file to read as binary
#
if {[catch {set fid [open $fileName r];} reason]} {
error "couldn't load TIFF image file \"$fileName\": $reason" $::errorInfo $::errorCode;
}
fconfigure $fid -translation binary -buffersize 1000000 -buffering full;
# reading the image file header
#
binary scan [binary format s [getb MM $fid Short]] a2 ifh(byteOrder);
set ifh(version) [getb $ifh(byteOrder) $fid Short];
set ifh(ifd.offset) [getb $ifh(byteOrder) $fid Long];
# reading the image file directory
#
seek $fid $ifh(ifd.offset) start;
set ifd(.entryCount) [getb $ifh(byteOrder) $fid Short];
for {set i 0} {$i < $ifd(.entryCount)} {incr i} {
set ifd($i.tag) [getb $ifh(byteOrder) $fid Short];
set ifd($i.type) [tiffIfdTagTypes [getb $ifh(byteOrder) $fid Short]];
set ifd($i.count) [getb $ifh(byteOrder) $fid Long];
set ifd($i.bytes) [tiffIfdTagBytes $ifd($i.type)];
set ifd($i.size) [expr {$ifd($i.bytes) * $ifd($i.count)}];
if {$ifd($i.size) <= [tiffSizes ifd.entry.value]} {
switch -glob -- $ifd($i.type) {
Ascii {
set ifd($i.value) [getb $ifh(byteOrder) $fid Ascii [tiffSizes ifd.entry.value]];
}
*Byte -
*Short -
*Long {
set ifd($i.value) {};
for {set ii 0} {$ii < $ifd($i.count)} {incr ii} {
lappend ifd($i.value) [getb $ifh(byteOrder) $fid $ifd($i.type) $ifd($i.count) [tiffSizes ifd.entry.value]];
}
}
}
} else {
# value is the offset to the original value
#
set ifd($i.value) [getb $ifh(byteOrder) $fid Long];
}
}
set ifd(.nextIfdOffset) [getb $ifh(byteOrder) $fid Long];
# reading all image file directory entry having an offset
#
for {set i 0} {$i < $ifd(.entryCount)} {incr i} {
if {$ifd($i.size) > [tiffSizes ifd.entry.value]} {
set ifd($i.offset) $ifd($i.value);
if {($ifd($i.offset) < [tiffSizes ifh]) || (($ifd($i.offset) > $ifh(ifd.offset)) && ($ifd($i.offset) < $ifh(ifd.offset) + [tiffSizes ifd $ifd(.entryCount)])) || ($ifd($i.offset) > [file size $fileName])} {
puts stderr "warning: unable to get offsetted tag $ifd($i.tag) value @ $ifd($i.offset): offset out of range";
set ifd($i.offset) "<out of range>";
continue;
}
seek $fid $ifd($i.offset) start;
switch -glob -- $ifd($i.type) {
Ascii {
set ifd($i.value) [getb $ifh(byteOrder) $fid Ascii $ifd($i.count)];
}
Float -
Double -
*Byte -
*Short -
*Long {
set ifd($i.value) {};
for {set ii 0} {$ii < $ifd($i.count)} {incr ii} {
lappend ifd($i.value) [getb $ifh(byteOrder) $fid $ifd($i.type)];
}
}
*Rational {
set ifd($i.value) {};
for {set ii 0} {$ii < $ifd($i.count)} {incr ii} {
set rational {}
lappend rational [getb $ifh(byteOrder) $fid Long];
lappend rational [getb $ifh(byteOrder) $fid Long];
lappend ifd($i.value) $rational;
}
}
}
set ifd($i.offset) [format "0x%X/%ld" $ifd($i.offset) $ifd($i.offset)];
} else {
set ifd($i.offset) "<ifd>";
}
}
# reading/collecting image file directory tag values
#
for {set i 0} {$i < $ifd(.entryCount)} {incr i} {
set varName [tiffIfdTags $ifd($i.tag)];
switch -exact -- $varName {
compression {set value [compression $ifd($i.value)];}
photometric {set value [photometric $ifd($i.value)];}
xResolution -
yResolution {
set value {};
foreach fraction $ifd($i.value) {
foreach {numerator denominator} $fraction {break;};
if {!$denominator} {
lappend value "$numerator / $denominator => divide by zero";
} else {
lappend value [expr {$numerator / $denominator}];
}
}
}
resolutionUnit {set value [resolutionUnit $ifd($i.value)];}
default {set value $ifd($i.value);}
}
set $varName $value;
set ifd($varName) [list $value $ifd($i.type) $ifd($i.count) $ifd($i.offset)];
}
set bitsPerPixel 0;
foreach sampleBits $bitsPerSample {
incr bitsPerPixel $sampleBits;
}
set ifd(bitsPerPixel) [list $bitsPerPixel Short 1 "<calculated>"];
array unset ifd {.*};
array unset ifd {[0-9]*.*};
# reading the rgb data
#
if {[info exists stripOffset]} {
set ifd(stripCount) [list [llength $stripOffset] Short 1 "<calculated>"];
} else {
set ifd(stripCount) [list 0 Short 1 "<calculated>"];
set stripOffset {};
set stripByteCount {};
}
if {$bufferVar != ""} {
set buffer {};
foreach offset $stripOffset byteCount $stripByteCount {
seek $fid $offset start;
lappend buffer [getb $ifh(byteOrder) $fid Byte $byteCount];
}
}
# finishing and closing the TIFF image file
#
close $fid;
return;
}
proc dumpTiff {tiffFileName {out ""} {saveRawData 0}} {
if {$saveRawData} {
set rawDataVar rawData
} else {
set rawDataVar "";
}
if {[catch {tiff2raw $tiffFileName ifh ifd $rawDataVar;} reason]} {
error "couldn't dump TIFF image file \"$tiffFileName\": $reason" $::errorInfo $::errorCode;
}
if {$saveRawData} {
set f [open $tiffFileName.raw w];
fconfigure $f \
-translation binary \
-buffering full \
-buffersize 1000000;
puts -nonewline $f [join $rawData ""];
close $f;
}
set names [linsert [lsort -dictionary [array names ifd]] -1 "fileName" "byteOrder"];
set ifd(fileName) $tiffFileName;
if {$ifh(byteOrder) == "MM"} {
set ifd(byteOrder) "big endian";
} else {
set ifd(byteOrder) "little endian";
}
set nameWidth 0;
foreach name $names {
if {[string length $name] > $nameWidth} {
set nameWidth [string length $name];
}
}
set labelWidth 0;
foreach name $names {
if {($name == "fileName") || ($name == "byteOrder")} {
continue;
}
foreach {value type count offset} $ifd($name) {break;};
set ifd($name) [list [set label [format "%-${nameWidth}s <%s\[%s\]> @ %s" $name $type $count $offset]] $value];
if {[string length $label] > $labelWidth} {
set labelWidth [string length $label];
}
}
if {$out == ""} {
set out $tiffFileName.dump.txt;
}
if {[file channels $out] == ""} {
if {[catch {set out [open $out w];} reason]} {
error "couldn't dump TIFF image file \"$tiffFileName\": $reason" $::errorInfo $::errorCode;
}
}
foreach name $names {
if {($name == "fileName") || ($name == "byteOrder")} {
set label $name;
set value $ifd($name);
} else {
foreach {label value} $ifd($name) {break;};
}
puts $out [format "%-${labelWidth}s = '%s'" $label $value];
}
close $out;
return;
}
proc photo2raw {photo rawDataVar} {
if {[info commands tk] == {}} {
upvar $photo imgPhotoData;
} elseif {[lsearch -exact [image names] $photo] < 0} {
error "couldn't convert the tk photo \"$photo\" to raw image data: no such photo";
} else {
set imgPhotoData [$photo data];
}
upvar $rawDataVar rawData;
set rawData "";
set width [llength [lindex $imgPhotoData 0]];
set height [llength $imgPhotoData];
foreach row $imgPhotoData {
foreach pixel $row {
scan $pixel "#%02x%02x%02x" red green blue;
append rawData [binary format ccc $red $green $blue]
}
}
return [list $width $height];
}
proc photo2tiff {photo tiffFileName description xdpi ydpi} {
if {[info commands tk] == {}} {
upvar $photo imgPhotoData;
if {[catch {foreach {width height} [photo2raw imgPhotoData buffer] {break;};} reason]} {
error "couldn't convert the tk photo \"$photo\" to TIFF image file \"$tiffFileName\": $reason";
}
} elseif {[lsearch -exact [image names] $photo] < 0} {
error "couldn't convert the tk photo \"$photo\" to TIFF image file \"$tiffFileName\": no such photo";
} else {
if {[catch {foreach {width height} [photo2raw $photo buffer] {break;};} reason]} {
error "couldn't convert the tk photo \"$photo\" to TIFF image file \"$tiffFileName\": $reason";
}
}
if {[catch {raw2tiff $tiffFileName $description $width $height $xdpi $ydpi buffer;} reason]} {
error "couldn't convert the tk photo \"$photo\" to TIFF image file \"$tiffFileName\": $reason" $::errorInfo $::errorCode;
}
return;
}
proc tiff2photo {tiffFileName photo {ifdVar ""}} {
if {[catch {tiff2raw $tiffFileName ifh ifd rawData;} reason]} {
error "couldn't convert TIFF image file \"$tiffFileName\" to the tk photo \"$photo\": $reason" $::errorInfo $::errorCode;
}
set bitsPerSample [lindex $ifd(bitsPerSample) 0];
set samplesPerPixel [lindex $ifd(samplesPerPixel) 0];
switch -exact -- [lindex $ifd(photometric) 0] {
RGB {
if {($samplesPerPixel == 3) &&
($bitsPerSample == "8 8 8")} {
set export 1;
} else {
set export 0;
}
}
"RGB Palette" {
if {($samplesPerPixel == 1) &&
($bitsPerSample == 8)} {
set export 2;
} else {
set export 0;
}
set colourMap [lindex $ifd(colorMap) 0];
}
whiteIsZero {
if {($samplesPerPixel == 1) &&
(($bitsPerSample == 1) ||
($bitsPerSample == 8))} {
set export 3;
} else {
set export 0;
}
set bitNotZero "#000000";
set bitZero "#FFFFFF";
}
blackIsZero {
if {($samplesPerPixel == 1) &&
(($bitsPerSample == 1) ||
($bitsPerSample == 8))} {
set export 4;
} else {
set export 0;
}
set bitNotZero "#FFFFFF";
set bitZero "#000000";
}
default {set export 0;}
}
if {$export &&
([lindex $ifd(compression) 0] == "Uncompressed") &&
![info exists ifd(tileLength)]} {
set bytesPerRow [expr {int(ceil([lindex $ifd(bitsPerPixel) 0] * [lindex $ifd(width) 0] / 8))}];
set rowsPerStrip [lindex $ifd(rowsPerStrip) 0];
set imgPhotoData {};
set stripIdx 0;
foreach stripData $rawData stripByteCount [lindex $ifd(stripByteCount) 0] {
for {set rowIdx 0; set byteCount 0} {($rowIdx < $rowsPerStrip) && ($byteCount < $stripByteCount)} {incr rowIdx; incr byteCount $bytesPerRow} {
set strip1stIdx [expr {$rowIdx*$bytesPerRow}];
set strip2ndIdx [expr {$strip1stIdx + $bytesPerRow - 1}];
set imgPhotoRowData {};
switch -exact -- $export {
1 {
binary scan [string range $stripData $strip1stIdx $strip2ndIdx] c* rowData;
foreach {red green blue} $rowData {
set red [expr {$red & 0xFF}];
set green [expr {$green & 0xFF}];
set blue [expr {$blue & 0xFF}];
lappend imgPhotoRowData [format "#%02X%02X%02X" $red $green $blue];
}
}
2 {
binary scan [string range $stripData $strip1stIdx $strip2ndIdx] c* rowData;
foreach colourIdx $rowData {
foreach {red green blue} [lrange $colourMap [set colourIdx [expr {($colourIdx & 0xFF) * 3}]] [incr colourIdx 2]] {break;};
set red [expr {int($red / 256) & 0xFF}];
set green [expr {int($green / 256) & 0xFF}];
set blue [expr {int($blue / 256) & 0xFF}];
lappend imgPhotoRowData [format "#%02X%02X%02X" $red $green $blue];
}
}
3 -
4 {
switch -exact -- $bitsPerSample {
1 {
binary scan [string range $stripData $strip1stIdx $strip2ndIdx] b* rowData;
foreach bit [split $rowData {}] {
if {$bit} {
lappend imgPhotoRowData $bitNotZero;
} else {
lappend imgPhotoRowData $bitZero
}
}
}
8 {
binary scan [string range $stripData $strip1stIdx $strip2ndIdx] c* rowData;
foreach gray $rowData {
set gray [expr {$gray & 0xFF}];
# if black backround is set, invert colour value
#
if {$export == 4} {
set gray [expr {0xFF - $gray}];
}
lappend imgPhotoRowData [format "#%02X%02X%02X" $gray $gray $gray];
}
}
}
}
}
lappend imgPhotoData $imgPhotoRowData;
}
incr stripIdx;
}
if {[info commands tk] == {}} {
upvar $photo var;
set var $imgPhotoData;
return;
}
if {[lsearch -exact [image names] $photo] >= 0} {
$photo blank;
} else {
image create photo $photo;
}
$photo put $imgPhotoData;
upvar $ifdVar newIfd;
array set newIfd [array get ifd];
} else {
error "couldn't convert TIFF image file \"$tiffFileName\" to the tk photo \"$photo\": non-exportable TIFF image file, must be an uncompressed black/white-, grayscale-, or RGB(-Palette) image, with maximum 24bit colour depth, without extra samples and not tiled";
}
return;
}
namespace export -clear tiff2raw raw2tiff dumpTiff photo2raw photo2tiff tiff2photo;
}
uplevel #0 {
namespace import -force ::tiff::*;
}