'''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: 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. '''2. Description''' '''2.1 tiff2raw''' '''2.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 Details''' 1. 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 * the offset to the values of the image file directory - may be "" (extracted from the image file directory), (a calculated value, not directly extracted from the file) 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 => photometric = RGB '''2.2 raw2tiff''' '''2.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 Details''' 1. 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 dumpTiff''' '''2.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 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 e.g. be read by IrfanView '''2.4 photo2raw''' '''2.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 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 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 Details''' 1. this proc will only write uncompressed TIFF RGB image files '''2.6 tiff2photo''' '''2.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 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. 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) ""; 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) ""; } } # 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 ""]; array unset ifd {.*}; array unset ifd {[0-9]*.*}; # reading the rgb data # if {[info exists stripOffset]} { set ifd(stripCount) [list [llength $stripOffset] Short 1 ""]; } else { set ifd(stripCount) [list 0 Short 1 ""]; 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::*; }