1# tiff.tcl -- 2# 3# Querying and modifying TIFF image files. 4# 5# Copyright (c) 2004 Aaron Faupell <afaupell@users.sourceforge.net> 6# 7# See the file "license.terms" for information on usage and redistribution 8# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 9# 10# RCS: @(#) $Id: tiff.tcl,v 1.5 2008/03/24 03:48:59 andreas_kupries Exp $ 11 12package provide tiff 0.2.1 13 14namespace eval ::tiff {} 15 16proc ::tiff::openTIFF {file {mode r}} { 17 variable byteOrder 18 set fh [open $file $mode] 19 fconfigure $fh -encoding binary -translation binary -eofchar {} 20 binary scan [read $fh 2] H4 byteOrder 21 if {$byteOrder == "4949"} { 22 set byteOrder little 23 } elseif {$byteOrder == "4d4d"} { 24 set byteOrder big 25 } else { 26 close $fh 27 return -code error "not a tiff file" 28 } 29 _scan $byteOrder [read $fh 6] si version offset 30 if {$version != "42"} { 31 close $fh 32 return -code error "not a tiff file" 33 } 34 seek $fh $offset start 35 return $fh 36} 37 38proc ::tiff::isTIFF {file} { 39 set is [catch {openTIFF $file} fh] 40 catch {close $fh} 41 return [expr {!$is}] 42} 43 44proc ::tiff::byteOrder {file} { 45 variable byteOrder 46 set fh [openTIFF $file] 47 close $fh 48 return $byteOrder 49} 50 51proc ::tiff::nametotag {names} { 52 variable tiff_sgat 53 set out {} 54 foreach x $names { 55 set y [lindex $x 0] 56 if {[info exists tiff_sgat($y)]} { 57 set y $tiff_sgat($y) 58 } elseif {![string match {[0-9a-f][0-9a-f][0-9a-f][0-9a-f]} $x]} { 59 error "unknown tag $y" 60 } 61 lappend out [lreplace $x 0 0 $y] 62 } 63 return $out 64} 65 66proc ::tiff::tagtoname {tags} { 67 variable tiff_tags 68 set out {} 69 foreach x $tags { 70 set y [lindex $x 0] 71 if {[info exists tiff_tags($y)]} { set y $tiff_tags($y) } 72 lappend out [lreplace $x 0 0 $y] 73 } 74 return $out 75} 76 77proc ::tiff::numImages {file} { 78 variable byteOrder 79 set fh [openTIFF $file] 80 set images [llength [_ifds $fh]] 81 close $fh 82 return $images 83} 84 85proc ::tiff::dimensions {file {image 0}} { 86 array set tmp [getEntry $file {0100 0101} $image] 87 return [list $tmp(0100) $tmp(0101)] 88} 89 90proc ::tiff::imageInfo {file {image 0}} { 91 return [getEntry $file {ImageWidth ImageLength BitsPerSample Compression \ 92 PhotometricInterpretation ImageDescription Orientation XResolution \ 93 YResolution ResolutionUnit DateTime Artist HostComputer} $image] 94} 95 96proc ::tiff::entries {file {image 0}} { 97 variable byteOrder 98 set fh [openTIFF $file] 99 set ret {} 100 if {[set ifd [lindex [_ifds $fh] $image]] != ""} { 101 seek $fh $ifd 102 foreach e [tagtoname [_entries $fh]] { 103 lappend ret [lindex $e 0] 104 } 105 } 106 close $fh 107 return $ret 108} 109 110proc ::tiff::getEntry {file entry {image 0}} { 111 variable byteOrder 112 set fh [openTIFF $file] 113 set ret {} 114 if {[set ifd [lindex [_ifds $fh] $image]] != ""} { 115 seek $fh $ifd 116 set ent [_entries $fh] 117 foreach e $entry { 118 if {[set x [lsearch -inline $ent "[nametotag $e] *"]] != ""} { 119 seek $fh [lindex $x 1] 120 lappend ret $e [lindex [_getEntry $fh] 1] 121 } else { 122 lappend ret $e {} 123 } 124 } 125 } 126 close $fh 127 return $ret 128} 129 130proc ::tiff::addEntry {file entry {image 0}} { 131 variable byteOrder 132 set fh [openTIFF $file] 133 set new [_new $file.tmp $byteOrder] 134 set ifds [_ifds $fh] 135 for {set i 0} {$i < [llength $ifds]} {incr i} { 136 seek $fh [lindex $ifds $i] 137 _readifd $fh ifd 138 if {$i == $image || $image == "all"} { 139 foreach e [nametotag $entry] { 140 set ifd($e) [eval [linsert $e 0 _unformat $byteOrder]] 141 } 142 } 143 _copyData $fh $new ifd 144 } 145 close $fh 146 close $new 147 file rename -force $file.tmp $file 148} 149 150proc ::tiff::deleteEntry {file entry {image 0}} { 151 variable byteOrder 152 set fh [openTIFF $file] 153 set new [_new $file.tmp $byteOrder] 154 set ifds [_ifds $fh] 155 for {set i 0} {$i < [llength $ifds]} {incr i} { 156 seek $fh [lindex $ifds $i] 157 _readifd $fh ifd 158 if {$i == $image || $image == "all"} { 159 foreach e [nametotag $entry] { unset -nocomplain ifd($e) } 160 } 161 _copyData $fh $new ifd 162 } 163 close $fh 164 close $new 165 file rename -force $file.tmp $file 166} 167 168proc ::tiff::writeImage {image file {entry {}}} { 169 variable byteOrder 170 set byteOrder big 171 set fh [_new $file $byteOrder] 172 set w [$image cget -width] 173 set h [$image cget -height] 174 set ifd(0100) [_unformat $byteOrder 0100 4 $w] ;# width 175 set ifd(0101) [_unformat $byteOrder 0101 4 $h] ;# height 176 set ifd(0102) [_unformat $byteOrder 0102 3 {8 8 8}] ;# color depth 177 set ifd(0103) [_unformat $byteOrder 0103 3 1] ;# compression = none 178 set ifd(0106) [_unformat $byteOrder 0106 3 2] ;# photometric interpretation = rgb 179 set ifd(0115) [_unformat $byteOrder 0115 3 3] ;# 3 samples per pixel r, g, and b 180 set ifd(011c) [_unformat $byteOrder 011c 3 1] ;# planar configuration = rgb 181 foreach {tag format value} $entry { 182 set ifd($tag) [_unformat $byteOrder $tag $format $value] 183 } 184 185 set rowsPerStrip 2 186 while {$w * 3 * $rowsPerStrip < 8000} { incr rowsPerStrip } 187 incr rowsPerStrip -1 188 set strips [expr {int(ceil($h / double($rowsPerStrip)))}] 189 set stripSize [expr {$w * $rowsPerStrip * 3}] 190 set lastStripSize [expr {3 * $w * ($h - (($strips - 1) * $rowsPerStrip))}] 191 192 for {set i $strips} {$i > 1} {incr i -1} { lappend sizes $stripSize } 193 lappend sizes $lastStripSize 194 195 set ifd(0116) [_unformat $byteOrder 0116 4 $rowsPerStrip] 196 set ifd(0111) [_unformat $byteOrder 0111 4 $sizes] 197 # dummy data, to get ifd size, real value inserted later 198 set ifd(0117) [_unformat $byteOrder 0117 4 $sizes] 199 200 # add 8 bytes for file header 201 set start [expr {[_ifdsize ifd] + 8}] 202 for {set i $strips} {$i > 0} {incr i -1} { 203 lappend offsets $start 204 incr start $stripSize 205 } 206 set ifd(0111) [_unformat $byteOrder 0111 4 $offsets] 207 208 _writeifd $fh ifd 209 210 for {set y 0} {$y < $h} {incr y} { 211 for {set x 0} {$x < $w} {incr x} { 212 foreach {r g b} [$image get $x $y] { 213 puts -nonewline $fh [_unscan $byteOrder ccc [expr {$r & 0xFF}] [expr {$g & 0xFF}] [expr {$b & 0xFF}]] 214 } 215 } 216 } 217 218 close $fh 219} 220 221proc ::tiff::getImage {file {image 0}} { 222 array set tags [getEntry $file {0100 0101 0102 0103 0106 011c 0115 0111 0117 0140} $image] 223 if {$tags(0102) == "8 8 8" && $tags(0103) == 1 && $tags(0106) == 2 && $tags(0115) == 3 && $tags(011c) == 1} { 224 set w $tags(0100) 225 set h $tags(0101) 226 set i [image create photo -height $h -width $w] 227 set fh [open $file] 228 fconfigure $fh -translation binary -encoding binary -eofchar {} 229 230 set y 0 231 set x 0 232 set row {} 233 set block {} 234 foreach offset $tags(0111) len $tags(0117) { 235 seek $fh $offset start 236 binary scan [read $fh $len] c* buf 237 foreach {r g b} $buf { 238 lappend row [format "#%02X%02X%02X" [expr {$r & 0xFF}] [expr {$g & 0xFF}] [expr {$b & 0xFF}]] 239 incr x 240 if {$x == $w} { lappend block $row; set row {}; set x 0 } 241 } 242 $i put $block -to 0 $y 243 incr y [llength $block] 244 set block {} 245 } 246 close $fh 247 } elseif {$tags(0102) == 8 && $tags(0103) == 1 && $tags(0106) == 3 && $tags(0115) == 1 && $tags(011c) == 1} { 248 set w $tags(0100) 249 set h $tags(0101) 250 set i [image create photo -height $h -width $w] 251 set fh [open $file] 252 fconfigure $fh -translation binary -encoding binary -eofchar {} 253 254 set map {} 255 set third [expr {[llength $tags(0140)] / 3}] 256 set rs [lrange $tags(0140) 0 [expr {$third - 1}]] 257 set gs [lrange $tags(0140) $third [expr {($third * 2) - 1}]] 258 set bs [lrange $tags(0140) [expr {$third * 2}] end] 259 foreach r $rs g $gs b $bs { 260 set r [expr {int($r / 256) & 0xFF}] 261 set g [expr {int($g / 256) & 0xFF}] 262 set b [expr {int($b / 256) & 0xFF}] 263 lappend map [format "#%02X%02X%02X" $r $g $b] 264 } 265 266 set y 0 267 set x 0 268 set row {} 269 set block {} 270 271 foreach offset $tags(0111) len $tags(0117) { 272 seek $fh $offset start 273 binary scan [read $fh $len] c* buf 274 foreach index $buf { 275 lappend row [lindex $map [expr {$index & 0xFF}]] 276 incr x 277 if {$x == $w} { lappend block $row; set row {}; set x 0 } 278 } 279 $i put $block -to 0 $y 280 incr y [llength $block] 281 set block {} 282 } 283 close $fh 284 } else { 285 error "I cant read that image format" 286 } 287 return $i 288} 289 290proc ::tiff::_copyData {fh new var} { 291 variable byteOrder 292 upvar $var ifd 293 294 set fix {} 295 # strips, free bytes, tiles, and their sizes 296 foreach f_off {0111 0120 0143} f_len {0117 0121 0144} { 297 if {![info exists ifd($f_len)] || ![info exists ifd($f_off)]} { continue } 298 set n 0 299 # put everything into a list 300 foreach x [_value $ifd($f_len)] y [_value $ifd($f_off)] { 301 lappend fix [list $n $f_len $x $f_off $y] 302 incr n 303 } 304 } 305 set offset [expr {[tell $new] + [_ifdsize ifd]}] 306 set new_fix {} 307 # sort the list by offset 308 foreach x [lsort -integer -index 4 $fix] { 309 lappend new_fix [lreplace $x 4 4 $offset] 310 incr offset [lindex $x 2] 311 } 312 foreach x [lsort -integer -index 0 $new_fix] { 313 lappend blah([lindex $x 3]) [lindex $x 4] 314 } 315 foreach x [array names blah] { 316 _scan $byteOrder [lindex $ifd($x) 0] x2s format 317 set ifd($x) [_unformat $byteOrder $x $format $blah($x)] 318 } 319 if {[info exists ifd(8769)]} { 320 seek $fh [_value $ifd(8769)] 321 _readifd $fh exif 322 _scan $byteOrder [lindex $ifd($x) 0] x2s format 323 set ifd(8769) [_unformat $byteOrder 8769 $format $offset] 324 } 325 _writeifd $new ifd 326 327 foreach x $fix { 328 seek $fh [lindex $x 4] start 329 fcopy $fh $new -size [lindex $x 2] 330 } 331 if {[info exists ifd(8769)]} { 332 _writeifd $new exif 333 } 334} 335 336# returns a list of offsets of all the IFDs 337proc ::tiff::_ifds {fh} { 338 variable byteOrder 339 340 # number of entries in this ifd 341 _scan $byteOrder [read $fh 2] s num 342 # subract 2 to account for reading the number 343 set ret [list [expr {[tell $fh] - 2}]] 344 # skip the entries, 12 bytes each 345 seek $fh [expr {$num * 12}] current 346 # 4 byte offset to next ifd after entries 347 _scan $byteOrder [read $fh 4] i next 348 349 while {$next > 0} { 350 seek $fh $next start 351 _scan $byteOrder [read $fh 2] s num 352 lappend ret [expr {[tell $fh] - 2}] 353 seek $fh [expr {$num * 12}] current 354 _scan $byteOrder [read $fh 4] i next 355 } 356 return $ret 357} 358 359# takes fh at start of IFD and returns entries, offset, and size 360proc ::tiff::_entries {fh} { 361 variable byteOrder 362 variable formats 363 set ret {} 364 _scan $byteOrder [read $fh 2] s num 365 for {} {$num > 0} {incr num -1} { 366 set offset [tell $fh] 367 binary scan [read $fh 2] H2H2 t1 t2 368 _scan $byteOrder [read $fh 6] si format components 369 seek $fh 4 current 370 if {$byteOrder == "big"} { 371 set tag $t1$t2 372 } else { 373 set tag $t2$t1 374 } 375 #puts "$tag $format $components" 376 set size [expr {$formats($format) * $components}] 377 lappend ret [list $tag $offset $size] 378 } 379 return $ret 380} 381 382# takes fh at start of dir entry and returns tag and value(s) 383proc ::tiff::_getEntry {fh} { 384 variable byteOrder 385 variable formats 386 binary scan [read $fh 2] H2H2 t1 t2 387 _scan $byteOrder [read $fh 6] si format components 388 if {$byteOrder == "big"} { 389 set tag $t1$t2 390 } else { 391 set tag $t2$t1 392 } 393 set value [read $fh 4] 394 set size [expr {$formats($format) * $components}] 395 #puts "entry $tag $format $components $size" 396 # if the data is over 4 bytes, its stored later in the file 397 if {$size > 4} { 398 set pos [tell $fh] 399 _scan $byteOrder $value i value 400 seek $fh $value start 401 set value [read $fh $size] 402 seek $fh $pos start 403 } 404 return [list $tag [_format $byteOrder $value $format $components]] 405} 406 407proc ::tiff::_value {data} { 408 variable byteOrder 409 _scan $byteOrder [lindex $data 0] x2si format components 410 return [_format $byteOrder [lindex $data 1] $format $components] 411} 412 413proc ::tiff::_new {file byteOrder} { 414 set fh [open $file w] 415 fconfigure $fh -encoding binary -translation binary -eofchar {} 416 if {$byteOrder == "big"} { 417 puts -nonewline $fh [binary format H4 4d4d] 418 } else { 419 puts -nonewline $fh [binary format H4 4949] 420 } 421 puts -nonewline $fh [_unscan $byteOrder si 42 8] 422 return $fh 423} 424 425proc ::tiff::_readifd {fh var} { 426 variable byteOrder 427 variable formats 428 upvar $var ifd 429 array set ifd {} 430 _scan $byteOrder [read $fh 2] s num 431 for {} {$num > 0} {incr num -1} { 432 set one [read $fh 8] 433 binary scan $one H2H2 t1 t2 434 _scan $byteOrder $one x2si format components 435 if {$byteOrder == "big"} { 436 set tag $t1$t2 437 } else { 438 set tag $t2$t1 439 } 440 set ifd($tag) [list $one] 441 set value [read $fh 4] 442 set size [expr {$formats($format) * $components}] 443 if {$size > 4} { 444 set pos [tell $fh] 445 _scan $byteOrder $value i value 446 seek $fh $value start 447 lappend ifd($tag) [read $fh $size] 448 seek $fh $pos start 449 } else { 450 lappend ifd($tag) $value 451 } 452 } 453} 454 455proc ::tiff::_writeifd {new var} { 456 variable byteOrder 457 upvar $var ifd 458 set num [llength [array names ifd]] 459 puts -nonewline $new [_unscan $byteOrder s $num] 460 set dataOffset [expr {[tell $new] + ($num * 12) + 4}] 461 set data {} 462 foreach tag [lsort [array names ifd]] { 463 set entry $ifd($tag) 464 puts -nonewline $new [lindex $entry 0] 465 if {[string length [lindex $entry 1]] > 4} { 466 puts -nonewline $new [_unscan $byteOrder i $dataOffset] 467 append data [lindex $entry 1] 468 incr dataOffset [string length [lindex $entry 1]] 469 } else { 470 puts -nonewline $new [lindex $entry 1] 471 } 472 } 473 set next [tell $new] 474 puts -nonewline $new [binary format i 0] 475 puts -nonewline $new $data 476 return $next 477} 478 479proc ::tiff::_ifdsize {var} { 480 upvar $var ifd 481 # 2 bytes for number of entries and 4 bytes for pointer to next ifd 482 set size 6 483 foreach x [array names ifd] { 484 incr size 12 485 # include data that doesnt fit in entry 486 if {[string length [lindex $ifd($x) 1]] > 4} { 487 incr size [string length [lindex $ifd($x) 1]] 488 } 489 } 490 return $size 491} 492 493proc ::tiff::debug {file} { 494 variable byteOrder 495 variable tiff_tags 496 set fh [openTIFF $file] 497 set n 0 498 foreach ifd [_ifds $fh] { 499 seek $fh $ifd start 500 set entries [_entries $fh] 501 puts "IFD $n ([llength $entries] entries)" 502 foreach ent $entries { 503 if {[info exists tiff_tags([lindex $ent 0])]} { 504 puts -nonewline " $tiff_tags([lindex $ent 0])" 505 } else { 506 puts -nonewline " [lindex $ent 0]" 507 } 508 if {[lindex $ent 2] < 200} { 509 seek $fh [lindex $ent 1] start 510 puts ": [lindex [_getEntry $fh] 1]" 511 } else { 512 puts " offset [lindex $ent 1] size [lindex $ent 2] bytes" 513 } 514 if {[lindex $ent 0] == "8769"} { 515 seek $fh [lindex $ent 1] start 516 seek $fh [lindex [_getEntry $fh] 1] 517 foreach x [_entries $fh] { 518 seek $fh [lindex $x 1] 519 puts " [_getEntry $fh]" 520 } 521 } 522 } 523 incr n 524 } 525} 526 527array set ::tiff::tiff_tags { 528 00fe NewSubfileType 529 00ff SubfileType 530 0100 ImageWidth 531 0101 ImageLength 532 0102 BitsPerSample 533 0103 Compression 534 0106 PhotometricInterpretation 535 0107 Threshholding 536 0108 CellWidth 537 0109 CellLength 538 010a FillOrder 539 010e ImageDescription 540 010f Make 541 0110 Model 542 0111 StripOffsets 543 0112 Orientation 544 0115 SamplesPerPixel 545 0116 RowsPerStrip 546 0117 StripByteCounts 547 0118 MinSampleValue 548 0119 MaxSampleValue 549 011a XResolution 550 011b YResolution 551 011c PlanarConfiguration 552 0120 FreeOffsets 553 0121 FreeByteCounts 554 0122 GrayResponseUnit 555 0123 GrayResponseCurve 556 0128 ResolutionUnit 557 0131 Software 558 0132 DateTime 559 013b Artist 560 013c HostComputer 561 0140 ColorMap 562 0152 ExtraSamples 563 8298 Copyright 564 565 010d DocumentName 566 011d PageName 567 011e XPosition 568 011f YPosition 569 0124 T4Options 570 0125 T6Options 571 0129 PageNumber 572 012d TransferFunction 573 013d Predictor 574 013e WhitePoint 575 013f PrimaryChromaticities 576 0141 HalftoneHints 577 0142 TileWidth 578 0143 TileLength 579 0144 TileOffsets 580 0145 TileByteCounts 581 0146 BadFaxLines 582 0147 CleanFaxData 583 0148 ConsecutiveBadFaxLines 584 014a SubIFDs 585 014c InkSet 586 014d InkNames 587 014e NumberOfInks 588 0150 DotRange 589 0151 TargetPrinter 590 0153 SampleFormat 591 0154 SMinSampleValue 592 0155 SMaxSampleValue 593 0156 TransferRange 594 0157 ClipPath 595 0158 XClipPathUnits 596 0159 YClipPathUnits 597 015a Indexed 598 015b JPEGTables 599 015f OPIProxy 600 0190 GlobalParametersIFD 601 0191 ProfileType 602 0192 FaxProfile 603 0193 CodingMethods 604 0194 VersionYear 605 0195 ModeNumber 606 01b1 Decode 607 01b2 DefaultImageColor 608 0200 JPEGProc 609 0201 JPEGInterchangeFormat 610 0202 JPEGInterchangeFormatLength 611 0203 JPEGRestartInterval 612 0205 JPEGLosslessPredictors 613 0206 JPEGPointTransforms 614 0207 JPEGQTables 615 0208 JPEGDCTables 616 0209 JPEGACTables 617 0211 YCbCrCoefficients 618 0212 YCbCrSubSampling 619 0213 YCbCrPositioning 620 0214 ReferenceBlackWhite 621 022f StripRowCounts 622 02bc XMP 623 800d ImageID 624 87ac ImageLayer 625 626 8649 Photoshop 627 8769 ExifIFD 628 8773 ICCProfile 629} 630 631if {![info exists ::tiff::tiff_sgat]} { 632 foreach {x y} [array get ::tiff::tiff_tags] { 633 set ::tiff::tiff_sgat($y) $x 634 } 635} 636 637array set ::tiff::data_types { 638 1 BYTE 639 2 ASCII 640 3 SHORT 641 4 LONG 642 5 RATIONAL 643 6 SBYTE 644 7 UNDEFINED 645 8 SSHORT 646 9 SLONG 647 10 SRATIONAL 648 11 FLOAT 649 12 DOUBLE 650 BYTE 1 651 ASCII 2 652 SHORT 3 653 LONG 4 654 RATIONAL 5 655 SBYTE 6 656 UNDEFINED 7 657 SSHORT 8 658 SLONG 9 659 SRATIONAL 10 660 FLOAT 11 661 DOUBLE 12 662} 663 664# for mapping the format types to byte lengths 665array set ::tiff::formats [list 1 1 2 1 3 2 4 4 5 8 6 1 7 1 8 2 9 4 10 8 11 4 12 8] 666 667proc ::tiff::_seek {chan offset {origin start}} { 668 if {$origin == "start"} { 669 variable start 670 seek $chan [expr {$offset + $start}] start 671 } else { 672 seek $chan $offset $origin 673 } 674} 675 676# [binary scan], in the byte order indicated by $e 677proc ::tiff::_scan {e v f args} { 678 foreach x $args { upvar 1 $x $x } 679 if {$e == "big"} { 680 eval [list binary scan $v [string map {b B h H s S i I} $f]] $args 681 } else { 682 eval [list binary scan $v $f] $args 683 } 684} 685 686# [binary format], in the byte order indicated by $e 687proc ::tiff::_unscan {e f args} { 688 if {$e == "big"} { 689 return [eval [list binary format [string map {b B h H s S i I} $f]] $args] 690 } else { 691 return [eval [list binary format $f] $args] 692 } 693} 694 695# formats values, the numbers correspond to data types 696# values may be either byte order, as indicated by $end 697# see the tiff spec for more info 698proc ::tiff::_format {end value type num} { 699 if {$num > 1 && $type != 2 && $type != 7} { 700 variable formats 701 set r {} 702 for {set i 0} {$i < $num} {incr i} { 703 set len $formats($type) 704 lappend r [_format $end [string range $value [expr {$len * $i}] [expr {($len * $i) + $len - 1}]] $type 1] 705 } 706 #return [join $r ,] 707 return $r 708 } 709 switch -exact -- $type { 710 1 { _scan $end $value c value } 711 2 { set value [string trimright $value \x00] } 712 3 { 713 _scan $end $value s value 714 set value [format %u $value] 715 } 716 4 { 717 _scan $end $value i value 718 set value [format %u $value] 719 } 720 5 { 721 _scan $end $value ii n d 722 set n [format %u $n] 723 set d [format %u $d] 724 if {$d == 0} {set d 1} 725 #set value [string trimright [string trimright [format %5.4f [expr {double($n) / $d}]] 0] .] 726 set value [string trimright [string trimright [expr {double($n) / $d}] 0] .] 727 #set value "$n/$d" 728 } 729 6 { _scan $end $value c value } 730 8 { _scan $end $value s value } 731 9 { _scan $end $value i value } 732 10 { 733 _scan $end $value ii n d 734 if {$d == 0} {set d 1} 735 #set value [string trimright [string trimright [format %5.4f [expr {double($n) / $d}]] 0] .] 736 set value [string trimright [string trimright [expr {double($n) / $d}] 0] .] 737 #set value "$n/$d" 738 } 739 11 { _scan $end $value i value } 740 12 { _scan $end $value w value } 741 } 742 return $value 743} 744 745proc ::tiff::_unformat {end tag type value} { 746 set packed_val {} 747 set count [llength $value] 748 if {$type == 2 || $type == 7} { set value [list $value] } 749 foreach val $value { 750 switch -exact -- $type { 751 1 { set val [_unscan $end c $val] } 752 2 { 753 append val \x00 754 set count [string length $val] 755 } 756 3 { set val [_unscan $end s $val] } 757 4 { set val [_unscan $end i $val] } 758 5 { 759 set val [split $val /] 760 set val [_unscan $end i [lindex $val 0]][_unscan $end i [lindex $val 1]] 761 } 762 6 { set val [_unscan $end c $val] } 763 7 { set count [string length $val] } 764 8 { set val [_unscan $end s $val] } 765 9 { set val [_unscan $end i $val] } 766 10 { 767 set val [split $val /] 768 set val [_unscan $end i [lindex $val 0]][_unscan $end i [lindex $val 1]] 769 } 770 11 { set val [_unscan $end $value i value] } 771 12 { set val [_unscan $end $value w value] } 772 default { error "unknown data type $type" } 773 } 774 append packed_val $val 775 } 776 if {$tag != ""} { 777 if {$end == "big"} { 778 set tag [binary format H2H2 [string range $tag 0 1] [string range $tag 2 3]] 779 } else { 780 set tag [binary format H2H2 [string range $tag 2 3] [string range $tag 0 1]] 781 } 782 } 783 if {[string length $packed_val] < 4} { set packed_val [binary format a4 $packed_val] } 784 return [list $tag[_unscan $end si $type $count] $packed_val] 785} 786 787 788