Tcl Library Source Code

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

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

[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

# 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" }

            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]

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