1# png.tcl -- 2# 3# Querying and modifying PNG 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: png.tcl,v 1.10 2007/08/20 22:06:58 andreas_kupries Exp $ 11 12package provide png 0.1.2 13 14namespace eval ::png {} 15 16proc ::png::_openPNG {file {mode r}} { 17 set fh [open $file $mode] 18 fconfigure $fh -encoding binary -translation binary -eofchar {} 19 if {[read $fh 8] != "\x89PNG\r\n\x1a\n"} { close $fh; return -code error "not a png file" } 20 return $fh 21} 22 23proc ::png::isPNG {file} { 24 if {[catch {_openPNG $file} fh]} { return 0 } 25 close $fh 26 return 1 27} 28 29proc ::png::validate {file} { 30 package require crc32 31 if {[catch {_openPNG $file} fh]} { return SIG } 32 set num 0 33 set idat 0 34 set last {} 35 36 while {[set r [read $fh 8]] != ""} { 37 binary scan $r Ia4 len type 38 if {$len < 0} { close $fh; return BADLEN } 39 set r [read $fh $len] 40 binary scan [read $fh 4] I crc 41 if {$crc < 0} {set crc [format %u [expr {$crc & 0xffffffff}]]} 42 if {[eof $fh]} { close $fh; return EOF } 43 if {($num == 0) && ($type != "IHDR")} { close $fh; return NOHDR } 44 if {$type == "IDAT"} { set idat 1 } 45 if {[::crc::crc32 $type$r] != $crc} { close $fh; return CKSUM } 46 set last $type 47 incr num 48 } 49 close $fh 50 if {!$idat} { return NODATA } 51 if {$last != "IEND"} { return NOEND } 52 return OK 53} 54 55proc ::png::imageInfo {file} { 56 set fh [_openPNG $file] 57 binary scan [read $fh 8] Ia4 len type 58 set r [read $fh $len] 59 if {![eof $fh] && $type == "IHDR"} { 60 binary scan $r IIccccc width height depth color compression filter interlace 61 binary scan [read $fh 4] I check 62 if {$check < 0} {set check [format %u [expr {$check & 0xffffffff}]]} 63 if {[::crc::crc32 IHDR$r] != $check} { 64 return -code error "header checksum failed" 65 } 66 close $fh 67 return [list width $width height $height depth $depth color $color \ 68 compression $compression filter $filter interlace $interlace] 69 } 70 close $fh 71 return 72} 73 74proc ::png::getTimestamp {file} { 75 set fh [_openPNG $file] 76 77 while {[set r [read $fh 8]] != ""} { 78 binary scan $r Ia4 len type 79 if {$type == "tIME"} { 80 set r [read $fh [expr {$len + 4}]] 81 binary scan $r Sccccc year month day hour minute second 82 close $fh 83 return [clock scan "$month/$day/$year $hour:$minute:$second" -gmt 1] 84 } 85 seek $fh [expr {$len + 4}] current 86 } 87 close $fh 88 return 89} 90 91proc ::png::setTimestamp {file time} { 92 set fh [_openPNG $file r+] 93 94 set time [eval binary format Sccccc [string map {" 0" " "} [clock format $time -format "%Y %m %d %H %M %S" -gmt 1]]] 95 if {![catch {package present crc32}]} { 96 append time [binary format I [::crc::crc32 tIME$time]] 97 } else { 98 append time [binary format I 0] 99 } 100 101 while {[set r [read $fh 8]] != ""} { 102 binary scan $r Ia4 len type 103 if {[eof $fh]} { close $fh; return } 104 if {$type == "tIME"} { 105 seek $fh 0 current 106 puts -nonewline $fh $time 107 close $fh 108 return 109 } 110 if {$type == "IDAT" && ![info exists idat]} { set idat [expr {[tell $fh] - 8}] } 111 seek $fh [expr {$len + 4}] current 112 } 113 if {![info exists idat]} { close $fh; return -code error "no timestamp or data chunk found" } 114 seek $fh $idat start 115 set data [read $fh] 116 seek $fh $idat start 117 puts -nonewline $fh [binary format I 7]tIME$time$data 118 close $fh 119 return 120} 121 122proc ::png::getComments {file} { 123 set fh [_openPNG $file] 124 set text {} 125 126 while {[set r [read $fh 8]] != ""} { 127 binary scan $r Ia4 len type 128 set pos [tell $fh] 129 if {$type == "tEXt"} { 130 set r [read $fh $len] 131 lappend text [split $r \x00] 132 } elseif {$type == "iTXt"} { 133 set r [read $fh $len] 134 set keyword [lindex [split $r \x00] 0] 135 set r [string range $r [expr {[string length $keyword] + 1}] end] 136 binary scan $r cc comp method 137 if {$comp == 0} { 138 lappend text [linsert [split [string range $r 2 end] \x00] 0 $keyword] 139 } 140 } 141 seek $fh [expr {$pos + $len + 4}] start 142 } 143 close $fh 144 return $text 145} 146 147proc ::png::removeComments {file} { 148 set fh [_openPNG $file r+] 149 set data "\x89PNG\r\n\x1a\n" 150 while {[set r [read $fh 8]] != ""} { 151 binary scan $r Ia4 len type 152 if {$type == "zTXt" || $type == "iTXt" || $type == "tEXt"} { 153 seek $fh [expr {$len + 4}] current 154 } else { 155 seek $fh -8 current 156 append data [read $fh [expr {$len + 12}]] 157 } 158 } 159 close $fh 160 set fh [open $file w] 161 fconfigure $fh -encoding binary -translation binary -eofchar {} 162 puts -nonewline $fh $data 163 close $fh 164} 165 166proc ::png::addComment {file keyword arg1 args} { 167 if {[llength $args] > 0 && [llength $args] != 2} { close $fh; return -code error "wrong number of arguments" } 168 set fh [_openPNG $file r+] 169 170 if {[llength $args] > 0} { 171 set comment "iTXt$keyword\x00\x00\x00$arg1\x00[encoding convertto utf-8 [lindex $args 0]]\x00[encoding convertto utf-8 [lindex $args 1]]" 172 } else { 173 set comment "tEXt$keyword\x00$arg1" 174 } 175 176 if {![catch {package present crc32}]} { 177 append comment [binary format I [::crc::crc32 $comment]] 178 } else { 179 append comment [binary format I 0] 180 } 181 182 while {[set r [read $fh 8]] != ""} { 183 binary scan $r Ia4 len type 184 if {$type == "IDAT"} { 185 seek $fh -8 current 186 set pos [tell $fh] 187 set data [read $fh] 188 seek $fh $pos start 189 set 1 [tell $fh] 190 puts -nonewline $fh $comment 191 set clen [binary format I [expr {[tell $fh] - $1 - 8}]] 192 seek $fh $pos start 193 puts -nonewline $fh $clen$comment$data 194 close $fh 195 return 196 } 197 seek $fh [expr {$len + 4}] current 198 } 199 close $fh 200 return -code error "no data chunk found" 201} 202 203