1. IntroductionDue 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:
- tiff2raw
- this proc reads a TIFF image file, returns its image file header, its first image file directory containing all needed information to handle the returned raw data from the TIFF image file. The raw data is not decompressed or decoded. So if a LZW compressed TIFF image file is read, the raw data contains the LZW data. "all needed information" must be read carefully, because tiled images are not supported and even TIFF JPEG image files contains some en/decode information the package don't read yet. The returned raw data is a list of all strips read from the TIFF image file.
- raw2tiff
- this proc takes raw data, the width, height, horizontal and vertical resolution, a description to write a TIFF uncompressed RGB image file. So the raw data must be plain RGB data. All RGB data will be written into one strip.
- dumpTiff
- this proc dumps a TIFF image file by writing the information from the image file header and the first image file directory to a channel or a file. Optional the proc saves the raw data into a file too.
- photo2raw
- this proc converts data given by the data command of a tk image (type photo) object into plain RGB data.
- photo2tiff
- this proc converts a given image (type photo) into a TIFF uncompressed RGB image file, using the given description and the horizontal and vertical resolution.
- tiff2photo
- this proc converts if possible a TIFF image file into a tk image (type photo) object. Only uncompressed RGB, RGB palette, Grayscaled and Black/White image files are accepted.
Some irregularies or simples irritations are following behaviour of tk image photo objects in tcl/tk v8.4.3:
- changing the option -palette of a tk image photo does not change the data of the tk image photo. So changing the tk image photo to black/white doesn't change the data to reflect this change. Extracted data, saved as TIFF image file contains still all previously seen colours
- using "$photo put $data" on a tk image photo causes the options -width and -height to return zero if ask for using "$photo cget -width" or "$photo cget -height"
- the -data option during the creation of the tk image photo does not accept the typical data returned by "$photo data"
Perhabs somebody could clear these irritations of mine?
2. Description2.1 tiff2raw2.1.1 Syntax
tiff2raw fileName ifhVar ifdVar ?bufferVar?
- fileName
- path to the TIFF image file to be read (with extension)
- ifhVar
- image file header array variable to contain all per header element an array element with the corresponding value/information.
- ifdVar
- image file directory array variable to contain all read directory entries describing the TIFF image file or respectively the raw data belonging to this first image file directory of the TIFF image file
- bufferVar
- the variable to contain the raw data, a list of strips, referenced by the first image file directory
2.1.2 Details1. in the image file header array variable are only stored following elements:
- byteOrder contains "MM" (big endian) or "II" (little endian)
- version contains 42 (always)
- ifd.offset contains the offset inside the TIFF image file to the first image file directory (ifd)
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:
- if the image file directory entry has a known tag (identifier) its known name will be used
- if the tag is not known, the tag value (integer) will be used as array element identifier
4. the data belonging to a image file directory entry is a list collecting following data:
- the value of the image file directory entry - may be a list, binary, ASCII or numerical data
- the type of the image file directory entry - may be Byte, Ascii, Short, Long, Rational (two Longs), SByte, Undefined, SShort, SLong, SRational, Float or Double
- the count of values belonging to the image file directory entry
- the offset to the values of the image file directory - may be "<ifd>" (extracted from the image file directory), <calculated> (a calculated value, not directly extracted from the file), <out of range> (if an invalid offset was read) or the offset in the format "0x.../..." (hexadecimal / decimal)
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 raw2tiff2.2.1 Syntax
raw2tiff fileName description width height xdpi ydpi bufferVar
- fileName
- path to the TIFF image file to be written (with extension)
- description
- a string used to be stored as description inside the TIFF image file
- width
- width of the image described by the raw data in pixels
- height
- height of the image described by the raw data in pixels
- xdpi
- horizontal resolution of the image described by the raw data in dpi (dots per inch)
- ydpi
- vertical resolution (like xdpi)
- bufferVar
- variable containing binary data describing the plain RGB values to be written into a TIFF RGB image file.
2.3 Details1. the length of the raw/binary data must be:
- samplesPerPixel = 3
- bitsPerSample = 8
- countOfBytes = height * ( width * samplesPerPixel * bitsPerSample ) / 8
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 dumpTiff2.3.1 Syntax
dumpTiff fileName ?out? ?saveRawData?
- fileName
- path to the TIFF image file to be read (with extension)
- out
- a channel name or a filename to write to. if omitted the output filename will be "filename.dump.txt"
- saveRawData
- boolean flag, signalizing if the raw data referenced by the first image file directory should be saved into a file named "filename.raw"
2.3.2 Details1. 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 photo2raw2.4.1 Syntax
photo2raw photo rawDataVar
- photo
- name of a tk image (type photo) or of the name of a variable containing the tk image data (if tk is not present)
- rawDataVar
- the name of a variable to contain the generated raw data
2.4.2 Details1. 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 photo2tiff2.5.1 Syntax
photo2tiff photo fileName description xdpi ydpi
- photo
- name of a tk image (type photo) or of the name of a variable containing the tk image data (if tk is not present)
- fileName
- path to the TIFF image file to be written (with extension)
- description
- a string used to be stored as description inside the TIFF image file
- xdpi
- horizontal resolution of the tk image in dpi (dots per inch)
- ydpi
- vertical resolution (like xdpi)
2.5.2 Details1. this proc will only write uncompressed TIFF RGB image files
2.6 tiff2photo2.5.1 Syntax
tiff2photo fileName photo ?ifdVar?
- fileName
- path to the TIFF image file to be read (with extension)
- photo
- name of a tk image (type photo) or of the name of a variable to the tk image data (if tk is not present)
- ifdVar
- image file directory array variable to contain all read directory entries describing the TIFF image file or respectively the raw data belonging to this first image file directory of the TIFF image file
2.5.2 Details1. 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- introducing callbacks to enable the de/compression of raw data
- to read values like the DTables, ACTables for JPEG as values of the image file directory and not only their offsets
- extend to read all image file directories and their raw data
- extend to extract extra samples per pixel (extra data, alpha channel or transparency samples)
4. SourcePlease 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::*;
}
