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