Tcl Library Source Code

Check-in [cc43ba987d]
Login

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

Overview
Comment:Add "getPhysicalDimension" to png package to get physical pixel size. Ticket [48fe95c519]
Downloads: Tarball | ZIP archive
Timelines: family | ancestors | descendants | both | png-get-physical-dimension
Files: files | file ages | folders
SHA3-256: cc43ba987d7cf8cb9e05e6060375c8bb1140266cd1743d1476fd3654a491d26c
User & Date: oehhar 2018-12-12 19:19:25.544
Context
2018-12-13
10:52
png: added tests for physical dimension retrieval Closed-Leaf check-in: 2313b69a8f user: oehhar tags: png-get-physical-dimension
2018-12-12
19:19
Add "getPhysicalDimension" to png package to get physical pixel size. Ticket [48fe95c519] check-in: cc43ba987d user: oehhar tags: png-get-physical-dimension
2018-11-26
05:02
Integrated disjoint-set work by Kevin. Somehow I completely forgot to do this integration after doing my changes. :facepalm: Fixed. And looking at the timeline from this merge it becomes clear that I actually had the merge done locally already and then forgot to commit and sync. check-in: 74b6db9a0d user: aku tags: pooryorick
Changes
Unified Diff 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
[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].

|











|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
[manpage_begin png n 0.3]
[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.3]]
[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].

121
122
123
124
125
126
127







128
129
130
131
132
133
134
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







>
>
>
>
>
>
>







121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
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.
The values of [const ppux] and [const ppuy] return the pixel per unit value iiiin X or Y direction.
The value of [const unit] may be meter or unknown. In case of meter, a dpi value may be found by the multiplication of 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.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
# png.tcl --
#
#       Querying and modifying PNG image files.
#
# 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" }











|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
# png.tcl --
#
#       Querying and modifying PNG image files.
#
# 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" }
205
206
207
208
209
210
211






















212
213
214
215
216
217
218
            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]







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







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
            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]