Tcl Library Source Code

Check-in [ee79783f52]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Merged png-get-physical-dimension, full tests passing.
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA3-256: ee79783f52b23077670a4be8a21e907a996464b72898588e19e672e660d05fb8
User & Date: aku 2019-02-21 21:30:36
References
2019-03-02
04:46 Closed ticket [48fe95c519]: Add function "getPixelDimension" to get physical pixel dimensions plus 7 other changes artifact: 09b35c6c5e user: aku
Context
2019-02-21
23:32
Tkt [fdf6afed94] done. Merged tkt-fdf6afed94, full tests passing. check-in: 5e257ddf79 user: aku tags: trunk
21:30
Merged png-get-physical-dimension, full tests passing. check-in: ee79783f52 user: aku tags: trunk
20:02
Forward port of Harald Oehlmann's work on the png package: - Add "getPhysicalDimension" to png package to get physical pixel size. Closed-Leaf check-in: b430832e75 user: aku tags: png-get-physical-dimension
2019-02-20
05:39
Test fixes in assorted modules - hook: Updated to match changes in 8.6+ core error stack results. - html: Undone bad removal of some trailing whitespace. - markdown: Fixed bad name of untabify2 function, and fixed result postprocessing in tests. - math::pca is Tcl 8.6+ - string::token::shell: Updated to match result variation starting with 8.6. check-in: e6742077ec user: aku tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to modules/png/ChangeLog.





1
2
3
4
5
6
7



2013-02-01  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.15 ========================
	* 

2012-07-09  Aaron Faupell <[email protected]>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
2018-12-12  Harald Oehlmann <[email protected]>

	* png.tcl: add function getPixelDimension to   get physical pixel size

2013-02-01  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.15 ========================
	* 

2012-07-09  Aaron Faupell <[email protected]>

Changes to modules/png/pkgIndex.tcl.

1
2
if {![package vsatisfies [package provide Tcl] 8.2]} {return}
package ifneeded png 0.2 [list source [file join $dir png.tcl]]
|
1
2
if {![package vsatisfies [package provide Tcl] 8.2]} {return}
package ifneeded png 0.3 [list source [file join $dir png.tcl]]

Changes to modules/png/png.man.


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
121
122
123
124
125
126
127













128
129
130
131
132
133
134
[manpage_begin png n 0.1.2]
[keywords comment]
[keywords image]
[keywords png]
[keywords timestamp]
[copyright {2004, Code: Aaron Faupell <[email protected]>}]
[copyright {2004, Doc:  Andreas Kupries <[email protected]>}]
[moddesc   {Image manipulation}]
[titledesc {PNG querying and manipulation of meta data}]
[category  {File formats}]
[require Tcl 8.2]
[require crc32]
[require png [opt 0.1.2]]
[description]
[para]

This package provides commands to query and modify PNG images. PNG
stands for [term {Portable Network Graphics}] and is specified at
[uri http://www.libpng.org/pub/png/spec/1.2].

................................................................................
Adds a unicode (international) comment to the PNG image in [arg file],
just before the first data chunk. Will throw an error if no data chunk
is found. [arg keyword] has to be less than 80 characters long to
conform to the PNG specification. [arg keyword2] is the translated
[arg keyword], in the language specified by the language identifier
[arg lang].














[call [cmd ::png::image] [arg file]]

Given a PNG file returns the image in the list of scanlines format used by Tk_GetColor.

[call [cmd ::png::write] [arg file] [arg data]]

Takes a list of scanlines in the Tk_GetColor format and writes the represented image
>
|











|







 







>
>
>
>
>
>
>
>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
[vset VERSION 0.3]
[manpage_begin png n [vset VERSION]]
[keywords comment]
[keywords image]
[keywords png]
[keywords timestamp]
[copyright {2004, Code: Aaron Faupell <[email protected]>}]
[copyright {2004, Doc:  Andreas Kupries <[email protected]>}]
[moddesc   {Image manipulation}]
[titledesc {PNG querying and manipulation of meta data}]
[category  {File formats}]
[require Tcl 8.2]
[require crc32]
[require png [opt [vset VERSION]]]
[description]
[para]

This package provides commands to query and modify PNG images. PNG
stands for [term {Portable Network Graphics}] and is specified at
[uri http://www.libpng.org/pub/png/spec/1.2].

................................................................................
Adds a unicode (international) comment to the PNG image in [arg file],
just before the first data chunk. Will throw an error if no data chunk
is found. [arg keyword] has to be less than 80 characters long to
conform to the PNG specification. [arg keyword2] is the translated
[arg keyword], in the language specified by the language identifier
[arg lang].

[call [cmd ::png::getPixelDimension] [arg file]]

Returns a dictionary with keys [const ppux], [const ppuy] and
[const unit] if the information is present.  Otherwise, it returns the empty
string.

[para] The values of [const ppux] and [const ppuy] return the pixel
per unit value in X or Y direction.

[para] The allowed values for key [const unit] are [const meter] and
[const unknown]. In the case of meter, the dpi value can be calculated
by multiplying with the conversion factor [const 0.0254].

[call [cmd ::png::image] [arg file]]

Given a PNG file returns the image in the list of scanlines format used by Tk_GetColor.

[call [cmd ::png::write] [arg file] [arg data]]

Takes a list of scanlines in the Tk_GetColor format and writes the represented image

Changes to modules/png/png.tcl.

5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
...
205
206
207
208
209
210
211






















212
213
214
215
216
217
218
# Copyright (c) 2004-2012 Aaron Faupell <[email protected]>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: png.tcl,v 1.11 2012/07/09 16:35:04 afaupell Exp $

package provide png 0.2

namespace eval ::png {}

proc ::png::_openPNG {file {mode r}} {
    set fh [open $file $mode]
    fconfigure $fh -encoding binary -translation binary -eofchar {}
    if {[read $fh 8] != "\x89PNG\r\n\x1a\n"} { close $fh; return -code error "not a png file" }
................................................................................
            return
        }
        seek $fh [expr {$len + 4}] current
    }
    close $fh
    return -code error "no data chunk found"
}























proc ::png::image {file} {
    set fh [_openPNG $file]
    set chunks [_chunks $fh]
    set cdata {}

    set h [lsearch -exact -index 0 -inline $chunks IHDR]






|







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
...
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
# Copyright (c) 2004-2012 Aaron Faupell <[email protected]>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: png.tcl,v 1.11 2012/07/09 16:35:04 afaupell Exp $

package provide png 0.3

namespace eval ::png {}

proc ::png::_openPNG {file {mode r}} {
    set fh [open $file $mode]
    fconfigure $fh -encoding binary -translation binary -eofchar {}
    if {[read $fh 8] != "\x89PNG\r\n\x1a\n"} { close $fh; return -code error "not a png file" }
................................................................................
            return
        }
        seek $fh [expr {$len + 4}] current
    }
    close $fh
    return -code error "no data chunk found"
}

proc ::png::getPixelDimension {file} {
    set fh [_openPNG $file]

    while {[set r [read $fh 8]] != ""} {
        binary scan $r Ia4 len type
        if {$type == "pHYs"} {
            set r [read $fh [expr {$len + 4}]]
            binary scan $r IIc ppux ppuy unit
            close $fh
            # mask out sign bit, from tcl 8.5, one may use u specifier
            set res [list ppux [expr {$ppux & 0xFFFFFFFF}]\
                     ppuy [expr {$ppuy & 0xFFFFFFFF}]\
                    unit]
            if {$unit == 1} {lappend res meter} else {lappend res unknown}
            return $res
        }
        seek $fh [expr {$len + 4}] current
    }
    close $fh
    return
}

proc ::png::image {file} {
    set fh [_openPNG $file]
    set chunks [_chunks $fh]
    set cdata {}

    set h [lsearch -exact -index 0 -inline $chunks IHDR]

Changes to modules/png/png.test.

297
298
299
300
301
302
303















304
305
306
	::png::removeComments $copy
	set res [list [::png::validate $copy] [::png::getComments $copy]]
	removeFile pngrc.$root
	set res
    } {OK {}}
}
















# -------------------------------------------------------------------------
testsuiteCleanup






>
>
>
>
>
>
>
>
>
>
>
>
>
>
>



297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
	::png::removeComments $copy
	set res [list [::png::validate $copy] [::png::getComments $copy]]
	removeFile pngrc.$root
	set res
    } {OK {}}
}

# -------------------------------------------------------------------------
# PhysicalDimensions

test png-physical-dimensions-missing {Test for empty list if no physical dimensions present} {
    ::png::getPixelDimension [file join\
	    [file dirname [file join [pwd] [info script]]]\
	    testimages/physicaldimensions/basi0g01.png]
} {}

test png-physical-dimensions-missing {Test for empty list if no physical dimensions present} {
    ::png::getPixelDimension [file join\
	    [file dirname [file join [pwd] [info script]]]\
	    testimages/physicaldimensions/basi0g01_300dpi.png]
} {ppux 11811 ppuy 11811 unit meter}

# -------------------------------------------------------------------------
testsuiteCleanup

Added modules/png/testimages/physicaldimensions/basi0g01.png.

cannot compute difference between binary files

Added modules/png/testimages/physicaldimensions/basi0g01_300dpi.png.

cannot compute difference between binary files