Tcl Library Source Code

# -*- tcl -*-
# bee.test:  tests for the bee encoding.
#
# Copyright (c) 2004 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: bee.test,v 1.9 2006/10/09 21:41:39 andreas_kupries Exp $

# -------------------------------------------------------------------------

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

................................................................................
}


test bee-12.0 {decoder, torrent file} {
    set end 0

    # tcltest::viewFile does not do binary :(
    set f [open  [file join $::tcltest::testsDirectory example.torrent] r]
    fconfigure $f -translation binary
    set d [read $f]
    close $f

    set data [bee::decode $d end]

    # Cut the binary stuff out of the result, to much, display problems
................................................................................
	removeFile bee16.$n
	set res
    } [lrange $result 0 1] ; # {}
}

# ....... ............................................................
testsuiteCleanup

# -*- tcl -*-
# bee.test:  tests for the bee encoding.
#
# Copyright (c) 2004,2018 by Andreas Kupries <[email protected]>
# All rights reserved.



# -------------------------------------------------------------------------

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

................................................................................
}


test bee-12.0 {decoder, torrent file} {
    set end 0

    # tcltest::viewFile does not do binary :(
    set f [open  [asset example.torrent] r]
    fconfigure $f -translation binary
    set d [read $f]
    close $f

    set data [bee::decode $d end]

    # Cut the binary stuff out of the result, to much, display problems
................................................................................
	removeFile bee16.$n
	set res
    } [lrange $result 0 1] ; # {}
}

# ....... ............................................................
testsuiteCleanup
return

# -*- tcl -*-
# bibtex.test:  tests for the bibtex parser.
#
# Copyright (c) 2005 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: bibtex.test,v 1.7 2006/10/09 21:41:40 andreas_kupries Exp $

# -------------------------------------------------------------------------

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

................................................................................
	year      1990 \
	pages     471--478 \
	address   {Boston, MA} \
	]]]


test bibtex-2.0 {Parse string, direct result} {
    set str [viewFile [file join [file dirname [info script]] bytecode.bib]]
    bibtex::parse $str
} $bytecode

test bibtex-2.1 {Parse string, sax mode} {
    set track {}
    set str [viewFile [file join [file dirname [info script]] bytecode.bib]]
    set t [bibtex::parse \
	    -progresscommand {track progress} \
	    -commentcommand  {track comment_} \
	    -stringcommand   {track string__} \
	    -preamblecommand {track preamble} \
	    -recordcommand   {track record__} \
	    $str]
................................................................................
	[linsert [lindex $bytecode 0] 0 record__ bibtex2]
]]

test bibtex-2.2 {Parse channel, direct result} {
    # The contents of penn_sub.bib have been taken out of
    # ftp://ftp.cis.upenn.edu/pub/anoop/bib/pennbib.bib

    set chan    [open [file join [file dirname [info script]] penn_sub.bib] r]
    set records [bibtex::parse -channel $chan]
    close $chan
    set records
} $pennfull

test bibtex-2.3 {Parse channel, sax mode} {
    set track {}
    set chan [open [file join [file dirname [info script]] penn_sub.bib] r]

    set t [bibtex::parse \
	    -progresscommand {track progress} \
	    -commentcommand  {track comment_} \
	    -stringcommand   {track string__} \
	    -preamblecommand {track preamble} \
	    -recordcommand   {track record__} \
................................................................................
	{string__ bibtex4 {aaai90 {Proc. National Conference on Artificial Intelligence, Boston}}} \
	{progress bibtex4 100} \
	[linsert [lindex $penn 0] 0 record__ bibtex4] \
	]

test bibtex-2.4 {Parse channel, sax mode 2} {
    set track {}
    set chan [open [file join [file dirname [info script]] penn_sub.bib] r]

    set t [bibtex::parse \
	    -progresscommand {track progress} \
	    -commentcommand  {track comment_} \
	    -stringcommand   addstr \
	    -preamblecommand {track preamble} \
	    -recordcommand   {track record__} \
................................................................................
	[linsert [lindex $pennfull 0] 0 record__ bibtex5] \
	]

test bibtex-2.5 {Parse channel, async} {
    # The contents of penn_sub.bib have been taken out of
    # ftp://ftp.cis.upenn.edu/pub/anoop/bib/pennbib.bib

    set chan [open [file join [file dirname [info script]] penn_sub.bib] r]
    proc done {args} {global done ; set done $args ; return}

    set done ""
    set t [bibtex::parse -command done -channel $chan]
    vwait ::done
    bibtex::destroy $t
    close $chan
................................................................................
test bibtex-3.2 {Destroying a parser} {
    set code [catch {::bibtex::destroy foo} msg]
    list $code $msg
} {1 {Illegal bibtex parser "foo"}}

test bibtex-4.0 {Destroying a parser} {

    set chan [open [file join [file dirname [info script]] bytecode.bib] r]
    proc done {args} {global done ; set done $args ; return}

    set done ""
    set t [bibtex::parse -command done -channel $chan]
    bibtex::destroy $t
    close $chan
} {}

# ... Tests of addStrings ...
#     (Requires introspection of parser state)

testsuiteCleanup

# -*- tcl -*-
# bibtex.test:  tests for the bibtex parser.
#
# Copyright (c) 2005 by Andreas Kupries <[email protected]>
# All rights reserved.



# -------------------------------------------------------------------------

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

................................................................................
	year      1990 \
	pages     471--478 \
	address   {Boston, MA} \
	]]]


test bibtex-2.0 {Parse string, direct result} {
    set str [viewFile [asset bytecode.bib]]
    bibtex::parse $str
} $bytecode

test bibtex-2.1 {Parse string, sax mode} {
    set track {}
    set str [viewFile [asset bytecode.bib]]
    set t [bibtex::parse \
	    -progresscommand {track progress} \
	    -commentcommand  {track comment_} \
	    -stringcommand   {track string__} \
	    -preamblecommand {track preamble} \
	    -recordcommand   {track record__} \
	    $str]
................................................................................
	[linsert [lindex $bytecode 0] 0 record__ bibtex2]
]]

test bibtex-2.2 {Parse channel, direct result} {
    # The contents of penn_sub.bib have been taken out of
    # ftp://ftp.cis.upenn.edu/pub/anoop/bib/pennbib.bib

    set chan    [open [asset penn_sub.bib] r]
    set records [bibtex::parse -channel $chan]
    close $chan
    set records
} $pennfull

test bibtex-2.3 {Parse channel, sax mode} {
    set track {}
    set chan [open [asset penn_sub.bib] r]

    set t [bibtex::parse \
	    -progresscommand {track progress} \
	    -commentcommand  {track comment_} \
	    -stringcommand   {track string__} \
	    -preamblecommand {track preamble} \
	    -recordcommand   {track record__} \
................................................................................
	{string__ bibtex4 {aaai90 {Proc. National Conference on Artificial Intelligence, Boston}}} \
	{progress bibtex4 100} \
	[linsert [lindex $penn 0] 0 record__ bibtex4] \
	]

test bibtex-2.4 {Parse channel, sax mode 2} {
    set track {}
    set chan [open [asset penn_sub.bib] r]

    set t [bibtex::parse \
	    -progresscommand {track progress} \
	    -commentcommand  {track comment_} \
	    -stringcommand   addstr \
	    -preamblecommand {track preamble} \
	    -recordcommand   {track record__} \
................................................................................
	[linsert [lindex $pennfull 0] 0 record__ bibtex5] \
	]

test bibtex-2.5 {Parse channel, async} {
    # The contents of penn_sub.bib have been taken out of
    # ftp://ftp.cis.upenn.edu/pub/anoop/bib/pennbib.bib

    set chan [open [asset penn_sub.bib] r]
    proc done {args} {global done ; set done $args ; return}

    set done ""
    set t [bibtex::parse -command done -channel $chan]
    vwait ::done
    bibtex::destroy $t
    close $chan
................................................................................
test bibtex-3.2 {Destroying a parser} {
    set code [catch {::bibtex::destroy foo} msg]
    list $code $msg
} {1 {Illegal bibtex parser "foo"}}

test bibtex-4.0 {Destroying a parser} {

    set chan [open [asset bytecode.bib] r]
    proc done {args} {global done ; set done $args ; return}

    set done ""
    set t [bibtex::parse -command done -channel $chan]
    bibtex::destroy $t
    close $chan
} {}

# ... Tests of addStrings ...
#     (Requires introspection of parser state)

testsuiteCleanup

# Tests for the comm module.
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 2001 by ActiveState Tool Corp.
# All rights reserved.
#
# RCS: @(#) $Id: comm.test,v 1.14 2010/09/15 19:48:33 andreas_kupries Exp $

# -------------------------------------------------------------------------

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

................................................................................
}

# ------------------------------------------------------------------------
# First order of things is to spawn a separate tclsh into the background
# and have it execute comm too, with some general code to respond to our
# requests

useLocalFile comm.slaveboot

# ------------------------------------------------------------------------

test comm-1.0 {set remote variable} {
    ::comm::comm send [slave] {set foo b}
} {b}

# Tests for the comm module.
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 2001 by ActiveState Tool Corp.
# All rights reserved.



# -------------------------------------------------------------------------

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

................................................................................
}

# ------------------------------------------------------------------------
# First order of things is to spawn a separate tclsh into the background
# and have it execute comm too, with some general code to respond to our
# requests

source [asset comm.slaveboot]

# ------------------------------------------------------------------------

test comm-1.0 {set remote variable} {
    ::comm::comm send [slave] {set foo b}
} {b}

# -*- tcl -*-
# Script to boot a child running an open comm server

set spawncode [makeFile {
    catch {wm withdraw .}
    ##puts [set fh [open ~/foo w]] $argv ; close $fh

    source [lindex $argv 0]     ; # load 'snit'
    source [lindex $argv 1].tcl ; # load 'comm'
    # and wait for commands. But first send our
    # own server socket to the initiator
    ::comm::comm send [lindex $argv 2] [list slaveat [::comm::comm self]]
    vwait forever
} spawn]

proc slaveat {id} {
    #puts "Slave @ $id"
    proc slave {} [list return $id]
    set ::go .
}

#puts "self @ [::comm::comm self]"

exec \
    [info nameofexecutable] $spawncode \
    [tcllibPath snit/snit.tcl] \
    [file rootname [info script]] \
    [::comm::comm self] &

#puts "Waiting for spawned comm system to boot"
# Wait for the slave to initialize itself.
vwait ::go

#puts "Running tests"

# -*- tcl -*-
# Script to boot a child running an open comm server

set spawncode [asset slave.tcl]











proc slaveat {id} {
    #puts "Slave @ $id"
    proc slave {} [list return $id]
    set ::go .
}

#puts "self @ [::comm::comm self]"

exec \
    [info nameofexecutable] $spawncode \
    [tcllibPath snit/snit.tcl] \
    [localPath  comm.tcl] \
    [::comm::comm self] &

#puts "Waiting for spawned comm system to boot"
# Wait for the slave to initialize itself.
vwait ::go

#puts "Running tests"

# -*- tcl -*-
catch {wm withdraw .}
##puts [set fh [open ~/foo w]] $argv ; close $fh

source [lindex $argv 0] ; # load 'snit'
source [lindex $argv 1] ; # load 'comm'
# and wait for commands. But first send our
# own server socket to the initiator
::comm::comm send [lindex $argv 2] [list slaveat [::comm::comm self]]
vwait forever

# Tests for the find function.
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 2001-2011 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: csv.test,v 1.23 2011/11/23 02:22:10 andreas_kupries Exp $

# -------------------------------------------------------------------------

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

................................................................................
    ::struct::matrix m
    catch {::csv::read2matrix dummy m foo} result
    m destroy
    set result
} {illegal separator character "foo", is a string}

test csv-5.1 {reading csv files} {
    set f [open [file join $::tcltest::testsDirectory mem_debug_bench.csv] r]
    ::struct::queue q
    ::csv::read2queue $f q
    close $f
    set result [list [q size] [q get 2]]
    q destroy
    set result
} {251 {{000 VERSIONS: 2:8.4a3 1:8.4a3 1:8.4a3%} {001 {CATCH return ok} 7 13 53.85}}}

test csv-5.2 {reading csv files} {
    set f [open [file join $::tcltest::testsDirectory mem_debug_bench_a.csv] r]
    ::struct::queue q
    ::csv::read2queue $f q
    close $f
    set result [list [q size] [q get 2]]
    q destroy
    set result
} {251 {{000 VERSIONS: 2:8.4a3 1:8.4a3 1:8.4a3%} {001 {CATCH return ok} 7 13 53.85}}}

test csv-5.3 {reading csv files} {
    set f [open [file join $::tcltest::testsDirectory mem_debug_bench.csv] r]
    ::struct::matrix m
    m add columns 5
    ::csv::read2matrix $f m
    close $f
    set result [m get rect 0 227 end 231]
    m destroy
    set result
} {{227 {STR append (1MB + 1MB * 3)} 125505 327765 38.29} {228 {STR append (1MB + 1MB * 5)} 158507 855295 18.53} {229 {STR append (1MB + (1b + 1K + 1b) * 100)} 33101 174031 19.02} {230 {STR info locals match} 946 1521 62.20} {231 {TRACE no trace set} 34 121 28.10}}

test csv-5.4 {reading csv files} {
    set f [open [file join $::tcltest::testsDirectory mem_debug_bench_a.csv] r]
    ::struct::matrix m
    m add columns 5
    ::csv::read2matrix $f m
    close $f
    set result [m get rect 0 227 end 231]
    m destroy
    set result
} {{227 {STR append (1MB + 1MB * 3)} 125505 327765 38.29} {228 {STR append (1MB + 1MB * 5)} 158507 855295 18.53} {229 {STR append (1MB + (1b + 1K + 1b) * 100)} 33101 174031 19.02} {230 {STR info locals match} 946 1521 62.20} {231 {TRACE no trace set} 34 121 28.10}}

test csv-5.5 {reading csv files} {
    set f [open [file join $::tcltest::testsDirectory mem_debug_bench.csv] r]
    ::struct::matrix m
    m add columns 5
    ::csv::read2matrix $f m
    close $f

    set result [list]
    foreach c {0 1 2 3 4} {
................................................................................
	lappend result [m columnwidth $c]
    }
    m destroy
    set result
} {3 39 7 7 8}

test csv-5.6 {reading csv files, linking} {
    set f [open [file join $::tcltest::testsDirectory mem_debug_bench.csv] r]
    ::struct::matrix m
    m add columns 5
    ::csv::read2matrix $f m
    close $f
    m link a
    set result [array size a]
    m destroy
    set result
} {1255}


test csv-5.7 {reading csv files, empty expansion mode} {
    set f [open [file join $::tcltest::testsDirectory mem_debug_bench.csv] r]
    ::struct::matrix m
    ::csv::read2matrix $f m , empty
    close $f
    set result [m get rect 0 227 end 231]
    m destroy
    set result
} {{227 {STR append (1MB + 1MB * 3)} 125505 327765 38.29} {228 {STR append (1MB + 1MB * 5)} 158507 855295 18.53} {229 {STR append (1MB + (1b + 1K + 1b) * 100)} 33101 174031 19.02} {230 {STR info locals match} 946 1521 62.20} {231 {TRACE no trace set} 34 121 28.10}}

test csv-5.8 {reading csv files, auto expansion mode} {
    set f [open [file join $::tcltest::testsDirectory mem_debug_bench.csv] r]
    ::struct::matrix m
    m add columns 1
    ::csv::read2matrix $f m , auto
    close $f
    set result [m get rect 0 227 end 231]
    m destroy
    set result
................................................................................
} {{227 {STR append (1MB + 1MB * 3)} 125505 327765 38.29} {228 {STR append (1MB + 1MB * 5)} 158507 855295 18.53} {229 {STR append (1MB + (1b + 1K + 1b) * 100)} 33101 174031 19.02} {230 {STR info locals match} 946 1521 62.20} {231 {TRACE no trace set} 34 121 28.10}}

# =========================================================================
# Bug 2926387

test csv-5.9.0 {reading csv files, inner field newline processing, bug 2926387} {
    set m [struct::matrix]
    set f [open [file join $::tcltest::testsDirectory 2926387.csv] r]
    csv::read2matrix $f $m , auto
    close $f
    set result [$m serialize]
    $m destroy
    set result
} {2 3 {{a b c} {d {e,
e} f}}}

test csv-5.9.1 {reading csv files, inner field newline processing, bug 2926387} {
    set q [struct::queue]
    set f [open [file join $::tcltest::testsDirectory 2926387.csv] r]
    csv::read2queue $f $q
    close $f
    set result [$q get [$q size]]
    $q destroy
    set result
} {{a b c} {d {e,
e} f}}

# =========================================================================

test csv-6.1 {writing csv files} {
    set f [open [localPath eval.csv] r]
    ::struct::matrix m
    m add columns 5
    ::csv::read2matrix $f m
    close $f

    set f [open [makeFile {} eval-out1.csv] w]
    ::csv::writematrix m $f
................................................................................
024,EVAL cmd eval as list,23,42,54.76
025,EVAL cmd eval as string,53,92,57.61
026,EVAL cmd and mixed lists,3805,11276,33.74
027,EVAL list cmd and mixed lists,3812,11325,33.66
028,EVAL list cmd and pure lists,592,1598,37.05}

test csv-6.2 {writing csv files} {
    set f [open [localPath eval.csv] r]
    ::struct::queue q
    ::csv::read2queue $f q
    close $f

    set f [open [makeFile {} eval-out2.csv] w]
    ::csv::writequeue q $f
    close $f
................................................................................
025,EVAL cmd eval as string,53,92,57.61
026,EVAL cmd and mixed lists,3805,11276,33.74
027,EVAL list cmd and mixed lists,3812,11325,33.66
028,EVAL list cmd and pure lists,592,1598,37.05}


test csv-7.1 {reporting} {
    set f [open [localPath eval.csv] r]
    ::struct::matrix m
    m add columns 5
    ::csv::read2matrix $f m
    close $f

    set result [m format 2string csv::report]
    m destroy
................................................................................
025,EVAL cmd eval as string,53,92,57.61
026,EVAL cmd and mixed lists,3805,11276,33.74
027,EVAL list cmd and mixed lists,3812,11325,33.66
028,EVAL list cmd and pure lists,592,1598,37.05
}

test csv-7.2 {reporting} {
    set f [open [localPath eval.csv] r]
    ::struct::matrix m
    m add columns 5
    ::csv::read2matrix $f m
    close $f

    set f [open [makeFile {} eval-out3.csv] w]
    m format 2chan csv::report $f

# Tests for the find function.
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 2001-2011 by Andreas Kupries <[email protected]>
# All rights reserved.



# -------------------------------------------------------------------------

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

................................................................................
    ::struct::matrix m
    catch {::csv::read2matrix dummy m foo} result
    m destroy
    set result
} {illegal separator character "foo", is a string}

test csv-5.1 {reading csv files} {
    set f [open [asset mem_debug_bench.csv] r]
    ::struct::queue q
    ::csv::read2queue $f q
    close $f
    set result [list [q size] [q get 2]]
    q destroy
    set result
} {251 {{000 VERSIONS: 2:8.4a3 1:8.4a3 1:8.4a3%} {001 {CATCH return ok} 7 13 53.85}}}

test csv-5.2 {reading csv files} {
    set f [open [asset mem_debug_bench_a.csv] r]
    ::struct::queue q
    ::csv::read2queue $f q
    close $f
    set result [list [q size] [q get 2]]
    q destroy
    set result
} {251 {{000 VERSIONS: 2:8.4a3 1:8.4a3 1:8.4a3%} {001 {CATCH return ok} 7 13 53.85}}}

test csv-5.3 {reading csv files} {
    set f [open [asset mem_debug_bench.csv] r]
    ::struct::matrix m
    m add columns 5
    ::csv::read2matrix $f m
    close $f
    set result [m get rect 0 227 end 231]
    m destroy
    set result
} {{227 {STR append (1MB + 1MB * 3)} 125505 327765 38.29} {228 {STR append (1MB + 1MB * 5)} 158507 855295 18.53} {229 {STR append (1MB + (1b + 1K + 1b) * 100)} 33101 174031 19.02} {230 {STR info locals match} 946 1521 62.20} {231 {TRACE no trace set} 34 121 28.10}}

test csv-5.4 {reading csv files} {
    set f [open [asset mem_debug_bench_a.csv] r]
    ::struct::matrix m
    m add columns 5
    ::csv::read2matrix $f m
    close $f
    set result [m get rect 0 227 end 231]
    m destroy
    set result
} {{227 {STR append (1MB + 1MB * 3)} 125505 327765 38.29} {228 {STR append (1MB + 1MB * 5)} 158507 855295 18.53} {229 {STR append (1MB + (1b + 1K + 1b) * 100)} 33101 174031 19.02} {230 {STR info locals match} 946 1521 62.20} {231 {TRACE no trace set} 34 121 28.10}}

test csv-5.5 {reading csv files} {
    set f [open [asset mem_debug_bench.csv] r]
    ::struct::matrix m
    m add columns 5
    ::csv::read2matrix $f m
    close $f

    set result [list]
    foreach c {0 1 2 3 4} {
................................................................................
	lappend result [m columnwidth $c]
    }
    m destroy
    set result
} {3 39 7 7 8}

test csv-5.6 {reading csv files, linking} {
    set f [open [asset mem_debug_bench.csv] r]
    ::struct::matrix m
    m add columns 5
    ::csv::read2matrix $f m
    close $f
    m link a
    set result [array size a]
    m destroy
    set result
} {1255}


test csv-5.7 {reading csv files, empty expansion mode} {
    set f [open [asset mem_debug_bench.csv] r]
    ::struct::matrix m
    ::csv::read2matrix $f m , empty
    close $f
    set result [m get rect 0 227 end 231]
    m destroy
    set result
} {{227 {STR append (1MB + 1MB * 3)} 125505 327765 38.29} {228 {STR append (1MB + 1MB * 5)} 158507 855295 18.53} {229 {STR append (1MB + (1b + 1K + 1b) * 100)} 33101 174031 19.02} {230 {STR info locals match} 946 1521 62.20} {231 {TRACE no trace set} 34 121 28.10}}

test csv-5.8 {reading csv files, auto expansion mode} {
    set f [open [asset mem_debug_bench.csv] r]
    ::struct::matrix m
    m add columns 1
    ::csv::read2matrix $f m , auto
    close $f
    set result [m get rect 0 227 end 231]
    m destroy
    set result
................................................................................
} {{227 {STR append (1MB + 1MB * 3)} 125505 327765 38.29} {228 {STR append (1MB + 1MB * 5)} 158507 855295 18.53} {229 {STR append (1MB + (1b + 1K + 1b) * 100)} 33101 174031 19.02} {230 {STR info locals match} 946 1521 62.20} {231 {TRACE no trace set} 34 121 28.10}}

# =========================================================================
# Bug 2926387

test csv-5.9.0 {reading csv files, inner field newline processing, bug 2926387} {
    set m [struct::matrix]
    set f [open [asset 2926387.csv] r]
    csv::read2matrix $f $m , auto
    close $f
    set result [$m serialize]
    $m destroy
    set result
} {2 3 {{a b c} {d {e,
e} f}}}

test csv-5.9.1 {reading csv files, inner field newline processing, bug 2926387} {
    set q [struct::queue]
    set f [open [asset 2926387.csv] r]
    csv::read2queue $f $q
    close $f
    set result [$q get [$q size]]
    $q destroy
    set result
} {{a b c} {d {e,
e} f}}

# =========================================================================

test csv-6.1 {writing csv files} {
    set f [open [asset eval.csv] r]
    ::struct::matrix m
    m add columns 5
    ::csv::read2matrix $f m
    close $f

    set f [open [makeFile {} eval-out1.csv] w]
    ::csv::writematrix m $f
................................................................................
024,EVAL cmd eval as list,23,42,54.76
025,EVAL cmd eval as string,53,92,57.61
026,EVAL cmd and mixed lists,3805,11276,33.74
027,EVAL list cmd and mixed lists,3812,11325,33.66
028,EVAL list cmd and pure lists,592,1598,37.05}

test csv-6.2 {writing csv files} {
    set f [open [asset eval.csv] r]
    ::struct::queue q
    ::csv::read2queue $f q
    close $f

    set f [open [makeFile {} eval-out2.csv] w]
    ::csv::writequeue q $f
    close $f
................................................................................
025,EVAL cmd eval as string,53,92,57.61
026,EVAL cmd and mixed lists,3805,11276,33.74
027,EVAL list cmd and mixed lists,3812,11325,33.66
028,EVAL list cmd and pure lists,592,1598,37.05}


test csv-7.1 {reporting} {
    set f [open [asset eval.csv] r]
    ::struct::matrix m
    m add columns 5
    ::csv::read2matrix $f m
    close $f

    set result [m format 2string csv::report]
    m destroy
................................................................................
025,EVAL cmd eval as string,53,92,57.61
026,EVAL cmd and mixed lists,3805,11276,33.74
027,EVAL list cmd and mixed lists,3812,11325,33.66
028,EVAL list cmd and pure lists,592,1598,37.05
}

test csv-7.2 {reporting} {
    set f [open [asset eval.csv] r]
    ::struct::matrix m
    m add columns 5
    ::csv::read2matrix $f m
    close $f

    set f [open [makeFile {} eval-out3.csv] w]
    m format 2chan csv::report $f

#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 2001-2006 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: exif.test,v 1.6 2006/10/09 21:41:40 andreas_kupries Exp $

# -------------------------------------------------------------------------

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

................................................................................
}

# -------------------------------------------------------------------------

test exif-makernote-19.0 {makernote field 19 (afpoint) is optional} {
    # AFPoint == AutoFocus Point

    set f [open [file join $::tcltest::testsDirectory noafpoint.jpg] r]
    fconfigure $f -translation binary
    array set resa [exif::analyze $f]
    close $f
    set resa(FocalPlaneXResolution) [format %13.8f $resa(FocalPlaneXResolution)]
    set resa(FocalPlaneYResolution) [format %13.8f $resa(FocalPlaneYResolution)]
    set res [dictsort [array get resa]]
    unset resa
    set res
} {AFPointsUsed {3 right} AperatureValue 7.1 AutoFocusMode {AI servo} CameraMake Canon CameraModel {Canon PowerShot S100} ColorSpace 1 ComponentsConfigured 0x00030201 Contrast Normal DateTime {2004:09:06 05:22:56} DateTimeDigitized {2004:09:06 05:22:56} DateTimeOriginal {2004:09:06 05:22:56} ExifImageHeight 1200 ExifImageWidth 1600 ExifInteroperabilityOffset 1088 ExifVersion 0210 ExposureBiasValue 0 ExposureTime {1/250.0 seconds} FNumber 7.1 FileSource {3 - Digital camera} FirmwareVersion {Firmware Version 1.0} Flash no FlashMode auto FlashPixVersion 0100 FocalLength {5.40625 mm} FocalPlaneResolutionUnit inch FocalPlaneXResolution 7766.99029126 FocalPlaneYResolution 7741.93548387 ISO unknown ImageFormat {IMG:JPEG file} ImageNumber 140-4060 ImageQuality Fine ImageSize large MacroMode normal MeteringMode unknown Orientation 1 Owner Irochka ResolutionUnit inch Saturation Normal SensingMethod 2 Sharpness Normal ShootingMode {Single frame} ShutterSpeedValue {250 Hz} SubjectDistance {3.358 m} UnknownTag-0x10 100925440 UserComment {554 - } WhiteBalance Auto XResolution 180.0 YCbCrPositioning {Center of pixel array} YResolution 180.0}

testsuiteCleanup

#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 2001-2006 by Andreas Kupries <[email protected]>
# All rights reserved.



# -------------------------------------------------------------------------

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

................................................................................
}

# -------------------------------------------------------------------------

test exif-makernote-19.0 {makernote field 19 (afpoint) is optional} {
    # AFPoint == AutoFocus Point

    set f [open [asset noafpoint.jpg] r]
    fconfigure $f -translation binary
    array set resa [exif::analyze $f]
    close $f
    set resa(FocalPlaneXResolution) [format %13.8f $resa(FocalPlaneXResolution)]
    set resa(FocalPlaneYResolution) [format %13.8f $resa(FocalPlaneYResolution)]
    set res [dictsort [array get resa]]
    unset resa
    set res
} {AFPointsUsed {3 right} AperatureValue 7.1 AutoFocusMode {AI servo} CameraMake Canon CameraModel {Canon PowerShot S100} ColorSpace 1 ComponentsConfigured 0x00030201 Contrast Normal DateTime {2004:09:06 05:22:56} DateTimeDigitized {2004:09:06 05:22:56} DateTimeOriginal {2004:09:06 05:22:56} ExifImageHeight 1200 ExifImageWidth 1600 ExifInteroperabilityOffset 1088 ExifVersion 0210 ExposureBiasValue 0 ExposureTime {1/250.0 seconds} FNumber 7.1 FileSource {3 - Digital camera} FirmwareVersion {Firmware Version 1.0} Flash no FlashMode auto FlashPixVersion 0100 FocalLength {5.40625 mm} FocalPlaneResolutionUnit inch FocalPlaneXResolution 7766.99029126 FocalPlaneYResolution 7741.93548387 ISO unknown ImageFormat {IMG:JPEG file} ImageNumber 140-4060 ImageQuality Fine ImageSize large MacroMode normal MeteringMode unknown Orientation 1 Owner Irochka ResolutionUnit inch Saturation Normal SensingMethod 2 Sharpness Normal ShootingMode {Single frame} ShutterSpeedValue {250 Hz} SubjectDistance {3.358 m} UnknownTag-0x10 100925440 UserComment {554 - } WhiteBalance Auto XResolution 180.0 YCbCrPositioning {Center of pixel array} YResolution 180.0}

testsuiteCleanup

# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 1998-2000 by Ajuba Solutions.
# Copyright (c) 2001 by ActiveState Tool Corp.
# Copyright (c) 2005-2007,2017 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: filetype.test,v 1.1 2007/08/03 23:07:25 andreas_kupries Exp $

# -------------------------------------------------------------------------

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

................................................................................
    set f [makeGzipFile]
    set res [catch {fileutil::fileType $f} msg]
    removeGzipFile
    list $res $msg
} [list 0 [list binary compressed gzip]]

test fileType-1.22 {text pdf} {
    set f [localPath test-data/pdf4tcl_01.pdf]
    set res [catch {fileutil::fileType $f} msg]
    list $res $msg
} [list 0 [list text pdf]]

# -------------------------------------------------------------------------

test fileType-1.23 {sqlite3, fossil repo} {
    set f [localPath test-data/p.fossil]
    set res [catch {fileutil::fileType $f} msg]
    list $res $msg
} [list 0 [list binary sqlite3 fossil-repository]]

test fileType-1.24 {sqlite3, fossil checkout} {
    set f [localPath test-data/p.ckout]
    set res [catch {fileutil::fileType $f} msg]
    list $res $msg
} [list 0 [list binary sqlite3 fossil-checkout]]

test fileType-1.25 {sqlite3, fossil global config} {
    set f [localPath test-data/p.global]
    set res [catch {fileutil::fileType $f} msg]
    list $res $msg
} [list 0 [list binary sqlite3 fossil-global-config]]

test fileType-1.26 {sqlite3, no app} {
    set f [localPath test-data/p.sqlite]
    set res [catch {fileutil::fileType $f} msg]
    list $res $msg
} [list 0 [list binary sqlite3 A00000000]]

# -------------------------------------------------------------------------

unset path
testsuiteCleanup
return

# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 1998-2000 by Ajuba Solutions.
# Copyright (c) 2001 by ActiveState Tool Corp.
# Copyright (c) 2005-2007,2017 by Andreas Kupries <[email protected]>
# All rights reserved.



# -------------------------------------------------------------------------

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

................................................................................
    set f [makeGzipFile]
    set res [catch {fileutil::fileType $f} msg]
    removeGzipFile
    list $res $msg
} [list 0 [list binary compressed gzip]]

test fileType-1.22 {text pdf} {
    set f [asset pdf4tcl_01.pdf]
    set res [catch {fileutil::fileType $f} msg]
    list $res $msg
} [list 0 [list text pdf]]

# -------------------------------------------------------------------------

test fileType-1.23 {sqlite3, fossil repo} {
    set f [asset p.fossil]
    set res [catch {fileutil::fileType $f} msg]
    list $res $msg
} [list 0 [list binary sqlite3 fossil-repository]]

test fileType-1.24 {sqlite3, fossil checkout} {
    set f [asset p.ckout]
    set res [catch {fileutil::fileType $f} msg]
    list $res $msg
} [list 0 [list binary sqlite3 fossil-checkout]]

test fileType-1.25 {sqlite3, fossil global config} {
    set f [asset p.global]
    set res [catch {fileutil::fileType $f} msg]
    list $res $msg
} [list 0 [list binary sqlite3 fossil-global-config]]

test fileType-1.26 {sqlite3, no app} {
    set f [asset p.sqlite]
    set res [catch {fileutil::fileType $f} msg]
    list $res $msg
} [list 0 [list binary sqlite3 A00000000]]

# -------------------------------------------------------------------------

unset path
testsuiteCleanup
return

# Testing "fumagic" (FileUtil Magic). Filetype recognizer.
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 2005-2006 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: filetypes.test,v 1.9 2006/10/09 21:41:40 andreas_kupries Exp $

# -------------------------------------------------------------------------

package require tcltest
source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

# Testing "fumagic" (FileUtil Magic). Filetype recognizer.
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 2005-2006 by Andreas Kupries <[email protected]>
# All rights reserved.



# -------------------------------------------------------------------------

package require tcltest
source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

testing {
    useLocal ini.tcl inifile
}

#---------------------------------------------------------------------

set inifile [localPath ini.tcl]
set testini [localPath test.ini]
set sampini [localPath sample.ini]

#---------------------------------------------------------------------

test inifile-1.1 {ini::open} {
    set res [ini::open $testini r]
    ini::close $res
    set res

testing {
    useLocal ini.tcl inifile
}

#---------------------------------------------------------------------

set inifile [localPath ini.tcl]
set testini [asset test.ini]
set sampini [asset sample.ini]

#---------------------------------------------------------------------

test inifile-1.1 {ini::open} {
    set res [ini::open $testini r]
    ini::close $res
    set res

# -*- tcl -*-
# jpeg.test:  Tests for the JPEG utilities.
#
# Copyright (c) 2008-2013 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# JPEG: @(#) $Id: jpeg.test,v 1.2 2011/05/06 13:39:27 patthoyts Exp $

# -------------------------------------------------------------------------

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

................................................................................
test jpeg-1.1 {isJPEG error, wrong#args, too many} -body {
    ::jpeg::isJPEG foo bar
} -returnCodes error -result [tcltest::tooManyArgs {::jpeg::isJPEG} {file}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob testimages/*JPG*] {
    test jpeg-2.$n "isJPEG, ok, [file tail $f]" -body {
	::jpeg::isJPEG $f
    } -result 1
    incr n
}

test jpeg-2.$n "isJPEG, fail, [file tail [info script]]" -body {
................................................................................
test jpeg-2.1 {imageInfo error, wrong#args, too many} -body {
    ::jpeg::imageInfo foo bar
} -returnCodes error -result [tcltest::tooManyArgs {::jpeg::imageInfo} {file}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob testimages/*.JPG] {
    test jpeg-3.$n "imageInfo regular, [file tail $f]" -body {
	::jpeg::imageInfo $f
    } -result [string trim [fileutil::cat [file rootname $f].info.txt]]
    incr n
}

set n 0
foreach f [TestFilesGlob testimages/*.thumb] {
    test jpeg-4.$n "imageInfo thumbnails, [file tail $f]" -body {
	::jpeg::imageInfo $f
    } -result {}
    incr n
}

test jpeg-5.0 "imageInfo, fail, [file tail [info script]]" -body {
................................................................................
test jpeg-6.1 {dimensions error, wrong#args, too many} -body {
    ::jpeg::dimensions foo bar
} -returnCodes error -result [tcltest::tooManyArgs {::jpeg::dimensions} {file}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob testimages/*.JPG] {
    test jpeg-7.$n "dimensions regular, [file tail $f]" -body {
	::jpeg::dimensions $f
    } -result [string trim [fileutil::cat [file rootname $f].WxH.txt]]
    incr n
}

set n 0
foreach f [TestFilesGlob testimages/*.thumb] {
    test jpeg-8.$n "dimensions thumbnails, [file tail $f]" -body {
	::jpeg::dimensions $f
    } -result {160 120}
    incr n
}

test jpeg-9.0 "dimensions, fail, [file tail [info script]]" -body {
................................................................................
test jpeg-10.1 {getThumbnail error, wrong#args, too many} -body {
    ::jpeg::getThumbnail foo bar
} -returnCodes error -result [tcltest::tooManyArgs {::jpeg::getThumbnail} {file}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob testimages/*.JPG] {
    if {![file exists $f.thumb]} {
	test jpeg-11.$n "getThumbnail - no thumbnail, [file tail $f]" -body {
	    ::jpeg::getThumbnail $f
	} -result {}
    } else {
	test jpeg-11.$n "getThumbnail regular, [file tail $f]" -body {
	    #fileutil::writeFile -translation binary ${f}.x.jpg [::jpeg::getThumbnail $f]
................................................................................
	} -result {1 -}
    }

    incr n
}

set n 0
foreach f [TestFilesGlob testimages/*.thumb] {
    test jpeg-12.$n "getThumbnail thumbnails, [file tail $f]" -body {
	::jpeg::getThumbnail $f
    } -result {}
    incr n
}

test jpeg-13.0 "getThumbnail, fail, [file tail [info script]]" -body {
................................................................................
test jpeg-16.1 {getComments error, wrong#args, too many} -body {
    ::jpeg::getComments foo bar
} -returnCodes error -result [tcltest::tooManyArgs {::jpeg::getComments} {file}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob testimages/*.JPG] {
    test jpeg-17.$n "getComments regular, [file tail $f]" -body {
	::jpeg::getComments $f
    } -result {}
    incr n
}

set n 0
foreach f [TestFilesGlob testimages/*.thumb] {
    test jpeg-18.$n "getComments thumbnails, [file tail $f]" -body {
	::jpeg::getComments $f
    } -result {}
    incr n
}

test jpeg-19.0 "getComments, fail, [file tail [info script]]" -body {
................................................................................
test jpeg-20.1 {addComment error, wrong#args, not enough} -body {
    ::jpeg::addComment foo
} -returnCodes error -result [tcltest::wrongNumArgs {::jpeg::addComment} {file comment args} 1]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob testimages/*JPG*] {
    test jpeg-21.$n "addComment regular, [file tail $f]" -setup {
	file copy -force $f [set fx [makeFile {} jtmp]]
	::jpeg::addComment $fx {a b} {c d}
    } -body {
	::jpeg::getComments $fx
    } -cleanup {
	removeFile $fx
................................................................................
test jpeg-23.1 {removeComments error, wrong#args, too many} -body {
    ::jpeg::removeComments foo bar
} -returnCodes error -result [tcltest::tooManyArgs {::jpeg::removeComments} {file}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob testimages/*JPG*] {
    test jpeg-24.$n "removeComments regular, [file tail $f]" -setup {
	file copy -force $f [set fx [makeFile {} jtmp]]
	::jpeg::addComment     $fx {a b} {c d}
    } -body {
	::jpeg::removeComments $fx
	::jpeg::getComments $fx
    } -cleanup {
................................................................................
test jpeg-26.2 {replaceComment error, wrong#args, too many} -body {
    ::jpeg::replaceComment foo bar barf
} -returnCodes error -result [tcltest::tooManyArgs {::jpeg::replaceComment} {file comment}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob testimages/*JPG*] {
    test jpeg-27.$n "replaceComment regular, [file tail $f]" -setup {
	file copy -force $f [set fx [makeFile {} jtmp]]
	::jpeg::addComment      $fx {a b} {c d}
    } -body {
	::jpeg::replaceComment $fx new
	::jpeg::getComments $fx
    } -cleanup {
................................................................................
} -returnCodes error -result [tcltest::wrongNumArgs {::jpeg::getExif} {file ?type?} 0]

test jpeg-29.1 {getExif error, wrong#args, too many} -body {
    ::jpeg::getExif foo bar barf
} -returnCodes error -result [tcltest::tooManyArgs {::jpeg::getExif} {file ?type?}]

test jpeg-29.2 {getExif error, bad section type} -body {
    ::jpeg::getExif [localPath testimages/IMG_7950.JPG] fufara
} -returnCodes error -result {Bad type "fufara", expected one of "main", or "thumbnail"}

test jpeg-29.3 {getExifFromChannel error, wrong#args, not enough} -body {
    ::jpeg::getExifFromChannel
} -returnCodes error -result [tcltest::wrongNumArgs {::jpeg::getExifFromChannel} {chan ?type?} 0]

test jpeg-29.4 {getExifFromChannel error, wrong#args, too many} -body {
    ::jpeg::getExifFromChannel foo bar barf
} -returnCodes error -result [tcltest::tooManyArgs {::jpeg::getExifFromChannel} {chan ?type?}]

test jpeg-29.5 {getExifFromChannel error, bad section type} -setup {
    set fd [::jpeg::openJFIF [localPath testimages/IMG_7950.JPG] r]
} -body {
    ::jpeg::getExifFromChannel $fd fufara
} -cleanup {
    close $fd
    unset fd
} -returnCodes error -result {Bad type "fufara", expected one of "main", or "thumbnail"}

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob testimages/*.JPG] {
    test jpeg-30.$n "getExif, main section, $f" -body {
	dictsort [fixupdata [::jpeg::formatExif [::jpeg::getExif $f]]]
    } -result [string trimright [fileutil::cat [file rootname $f].exif.txt]]
    incr n
}

set n 0
foreach f [TestFilesGlob testimages/*.thumb] {
    test jpeg-31.$n "getExif, main section, $f" -body {
	dictsort [fixupdata [::jpeg::formatExif [::jpeg::getExif $f]]]
    } -result {}
    incr n
}

set n 0
foreach f [TestFilesGlob testimages/*.JPG] {
    test jpeg-32.$n "getExif, thumbnail section, $f" -body {
	dictsort [fixupdata [::jpeg::formatExif [::jpeg::getExif $f thumbnail]]]
    } -result [string trimright [fileutil::cat [file rootname $f].thumbexif.txt]]
    incr n
}

set n 0
foreach f [TestFilesGlob testimages/*.thumb] {
    test jpeg-33.$n "getExif, thumbnail section, $f" -body {
	dictsort [fixupdata [::jpeg::formatExif [::jpeg::getExif $f thumbnail]]]
    } -result {}
    incr n
}

test jpeg-34.0 "getExif, fail, [file tail [info script]]" -body {
................................................................................
test jpeg-34.1 {removeExif error, wrong#args, too many} -body {
    ::jpeg::removeExif foo bar
} -returnCodes error -result [tcltest::tooManyArgs {::jpeg::removeExif} {file}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob testimages/*JPG*] {
    test jpeg-35.$n "removeExif ok, [file tail $f]" -setup {
	file copy -force $f [set fx [makeFile {} jtmp]]
	::jpeg::addComment $fx {a b} {c d}
    } -body {
	::jpeg::removeExif $fx
	set res [list [::jpeg::getComments $fx] [::jpeg::getExif $fx] [::jpeg::getExif $fx thumbnail]]
    } -cleanup {
................................................................................
test jpeg-37.1 {stripJPEG error, wrong#args, too many} -body {
    ::jpeg::stripJPEG foo bar
} -returnCodes error -result [tcltest::tooManyArgs {::jpeg::stripJPEG} {file}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob testimages/*JPG*] {
    test jpeg-38.$n "stripJPEG ok, [file tail $f]" -setup {
	file copy -force $f [set fx [makeFile {} jtmp]]
	::jpeg::addComment $fx {a b} {c d}
    } -body {
	::jpeg::stripJPEG $fx
	set res [list [::jpeg::getComments $fx] [::jpeg::getExif $fx] [::jpeg::getExif $fx thumbnail]]
    } -cleanup {
................................................................................
} -returnCodes error -result [tcltest::tooManyArgs {::jpeg::debug} {file}]

# -------------------------------------------------------------------------
# We do not try to actually run 'debug', because it prints its results
# to stdout. This may change when we can capture stdout as test result

set n 0
foreach f [TestFilesGlob testimages/*JPG*] {
    test jpeg-41.$n "debug ok, [file tail $f]" -constraints donotrun -body {
	::jpeg::debug $f
    } -result {}
    incr n
}

test jpeg-42.0 "debug, fail, [file tail [info script]]" -body {
    ::jpeg::debug [info script]
} -returnCodes error -result {not a jpg file}

# -------------------------------------------------------------------------
rename strdiff {}
testsuiteCleanup

# -*- tcl -*-
# jpeg.test:  Tests for the JPEG utilities.
#
# Copyright (c) 2008-2013 by Andreas Kupries <[email protected]>
# All rights reserved.



# -------------------------------------------------------------------------

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

................................................................................
test jpeg-1.1 {isJPEG error, wrong#args, too many} -body {
    ::jpeg::isJPEG foo bar
} -returnCodes error -result [tcltest::tooManyArgs {::jpeg::isJPEG} {file}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob test-assets/*JPG*] {
    test jpeg-2.$n "isJPEG, ok, [file tail $f]" -body {
	::jpeg::isJPEG $f
    } -result 1
    incr n
}

test jpeg-2.$n "isJPEG, fail, [file tail [info script]]" -body {
................................................................................
test jpeg-2.1 {imageInfo error, wrong#args, too many} -body {
    ::jpeg::imageInfo foo bar
} -returnCodes error -result [tcltest::tooManyArgs {::jpeg::imageInfo} {file}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob test-assets/*.JPG] {
    test jpeg-3.$n "imageInfo regular, [file tail $f]" -body {
	::jpeg::imageInfo $f
    } -result [string trim [fileutil::cat [file rootname $f].info.txt]]
    incr n
}

set n 0
foreach f [TestFilesGlob test-assets/*.thumb] {
    test jpeg-4.$n "imageInfo thumbnails, [file tail $f]" -body {
	::jpeg::imageInfo $f
    } -result {}
    incr n
}

test jpeg-5.0 "imageInfo, fail, [file tail [info script]]" -body {
................................................................................
test jpeg-6.1 {dimensions error, wrong#args, too many} -body {
    ::jpeg::dimensions foo bar
} -returnCodes error -result [tcltest::tooManyArgs {::jpeg::dimensions} {file}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob test-assets/*.JPG] {
    test jpeg-7.$n "dimensions regular, [file tail $f]" -body {
	::jpeg::dimensions $f
    } -result [string trim [fileutil::cat [file rootname $f].WxH.txt]]
    incr n
}

set n 0
foreach f [TestFilesGlob test-assets/*.thumb] {
    test jpeg-8.$n "dimensions thumbnails, [file tail $f]" -body {
	::jpeg::dimensions $f
    } -result {160 120}
    incr n
}

test jpeg-9.0 "dimensions, fail, [file tail [info script]]" -body {
................................................................................
test jpeg-10.1 {getThumbnail error, wrong#args, too many} -body {
    ::jpeg::getThumbnail foo bar
} -returnCodes error -result [tcltest::tooManyArgs {::jpeg::getThumbnail} {file}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob test-assets/*.JPG] {
    if {![file exists $f.thumb]} {
	test jpeg-11.$n "getThumbnail - no thumbnail, [file tail $f]" -body {
	    ::jpeg::getThumbnail $f
	} -result {}
    } else {
	test jpeg-11.$n "getThumbnail regular, [file tail $f]" -body {
	    #fileutil::writeFile -translation binary ${f}.x.jpg [::jpeg::getThumbnail $f]
................................................................................
	} -result {1 -}
    }

    incr n
}

set n 0
foreach f [TestFilesGlob test-assets/*.thumb] {
    test jpeg-12.$n "getThumbnail thumbnails, [file tail $f]" -body {
	::jpeg::getThumbnail $f
    } -result {}
    incr n
}

test jpeg-13.0 "getThumbnail, fail, [file tail [info script]]" -body {
................................................................................
test jpeg-16.1 {getComments error, wrong#args, too many} -body {
    ::jpeg::getComments foo bar
} -returnCodes error -result [tcltest::tooManyArgs {::jpeg::getComments} {file}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob test-assets/*.JPG] {
    test jpeg-17.$n "getComments regular, [file tail $f]" -body {
	::jpeg::getComments $f
    } -result {}
    incr n
}

set n 0
foreach f [TestFilesGlob test-assets/*.thumb] {
    test jpeg-18.$n "getComments thumbnails, [file tail $f]" -body {
	::jpeg::getComments $f
    } -result {}
    incr n
}

test jpeg-19.0 "getComments, fail, [file tail [info script]]" -body {
................................................................................
test jpeg-20.1 {addComment error, wrong#args, not enough} -body {
    ::jpeg::addComment foo
} -returnCodes error -result [tcltest::wrongNumArgs {::jpeg::addComment} {file comment args} 1]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob test-assets/*JPG*] {
    test jpeg-21.$n "addComment regular, [file tail $f]" -setup {
	file copy -force $f [set fx [makeFile {} jtmp]]
	::jpeg::addComment $fx {a b} {c d}
    } -body {
	::jpeg::getComments $fx
    } -cleanup {
	removeFile $fx
................................................................................
test jpeg-23.1 {removeComments error, wrong#args, too many} -body {
    ::jpeg::removeComments foo bar
} -returnCodes error -result [tcltest::tooManyArgs {::jpeg::removeComments} {file}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob test-assets/*JPG*] {
    test jpeg-24.$n "removeComments regular, [file tail $f]" -setup {
	file copy -force $f [set fx [makeFile {} jtmp]]
	::jpeg::addComment     $fx {a b} {c d}
    } -body {
	::jpeg::removeComments $fx
	::jpeg::getComments $fx
    } -cleanup {
................................................................................
test jpeg-26.2 {replaceComment error, wrong#args, too many} -body {
    ::jpeg::replaceComment foo bar barf
} -returnCodes error -result [tcltest::tooManyArgs {::jpeg::replaceComment} {file comment}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob test-assets/*JPG*] {
    test jpeg-27.$n "replaceComment regular, [file tail $f]" -setup {
	file copy -force $f [set fx [makeFile {} jtmp]]
	::jpeg::addComment      $fx {a b} {c d}
    } -body {
	::jpeg::replaceComment $fx new
	::jpeg::getComments $fx
    } -cleanup {
................................................................................
} -returnCodes error -result [tcltest::wrongNumArgs {::jpeg::getExif} {file ?type?} 0]

test jpeg-29.1 {getExif error, wrong#args, too many} -body {
    ::jpeg::getExif foo bar barf
} -returnCodes error -result [tcltest::tooManyArgs {::jpeg::getExif} {file ?type?}]

test jpeg-29.2 {getExif error, bad section type} -body {
    ::jpeg::getExif [asset IMG_7950.JPG] fufara
} -returnCodes error -result {Bad type "fufara", expected one of "main", or "thumbnail"}

test jpeg-29.3 {getExifFromChannel error, wrong#args, not enough} -body {
    ::jpeg::getExifFromChannel
} -returnCodes error -result [tcltest::wrongNumArgs {::jpeg::getExifFromChannel} {chan ?type?} 0]

test jpeg-29.4 {getExifFromChannel error, wrong#args, too many} -body {
    ::jpeg::getExifFromChannel foo bar barf
} -returnCodes error -result [tcltest::tooManyArgs {::jpeg::getExifFromChannel} {chan ?type?}]

test jpeg-29.5 {getExifFromChannel error, bad section type} -setup {
    set fd [::jpeg::openJFIF [asset IMG_7950.JPG] r]
} -body {
    ::jpeg::getExifFromChannel $fd fufara
} -cleanup {
    close $fd
    unset fd
} -returnCodes error -result {Bad type "fufara", expected one of "main", or "thumbnail"}

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob test-assets/*.JPG] {
    test jpeg-30.$n "getExif, main section, $f" -body {
	dictsort [fixupdata [::jpeg::formatExif [::jpeg::getExif $f]]]
    } -result [string trimright [fileutil::cat [file rootname $f].exif.txt]]
    incr n
}

set n 0
foreach f [TestFilesGlob test-assets/*.thumb] {
    test jpeg-31.$n "getExif, main section, $f" -body {
	dictsort [fixupdata [::jpeg::formatExif [::jpeg::getExif $f]]]
    } -result {}
    incr n
}

set n 0
foreach f [TestFilesGlob test-assets/*.JPG] {
    test jpeg-32.$n "getExif, thumbnail section, $f" -body {
	dictsort [fixupdata [::jpeg::formatExif [::jpeg::getExif $f thumbnail]]]
    } -result [string trimright [fileutil::cat [file rootname $f].thumbexif.txt]]
    incr n
}

set n 0
foreach f [TestFilesGlob test-assets/*.thumb] {
    test jpeg-33.$n "getExif, thumbnail section, $f" -body {
	dictsort [fixupdata [::jpeg::formatExif [::jpeg::getExif $f thumbnail]]]
    } -result {}
    incr n
}

test jpeg-34.0 "getExif, fail, [file tail [info script]]" -body {
................................................................................
test jpeg-34.1 {removeExif error, wrong#args, too many} -body {
    ::jpeg::removeExif foo bar
} -returnCodes error -result [tcltest::tooManyArgs {::jpeg::removeExif} {file}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob test-assets/*JPG*] {
    test jpeg-35.$n "removeExif ok, [file tail $f]" -setup {
	file copy -force $f [set fx [makeFile {} jtmp]]
	::jpeg::addComment $fx {a b} {c d}
    } -body {
	::jpeg::removeExif $fx
	set res [list [::jpeg::getComments $fx] [::jpeg::getExif $fx] [::jpeg::getExif $fx thumbnail]]
    } -cleanup {
................................................................................
test jpeg-37.1 {stripJPEG error, wrong#args, too many} -body {
    ::jpeg::stripJPEG foo bar
} -returnCodes error -result [tcltest::tooManyArgs {::jpeg::stripJPEG} {file}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob test-assets/*JPG*] {
    test jpeg-38.$n "stripJPEG ok, [file tail $f]" -setup {
	file copy -force $f [set fx [makeFile {} jtmp]]
	::jpeg::addComment $fx {a b} {c d}
    } -body {
	::jpeg::stripJPEG $fx
	set res [list [::jpeg::getComments $fx] [::jpeg::getExif $fx] [::jpeg::getExif $fx thumbnail]]
    } -cleanup {
................................................................................
} -returnCodes error -result [tcltest::tooManyArgs {::jpeg::debug} {file}]

# -------------------------------------------------------------------------
# We do not try to actually run 'debug', because it prints its results
# to stdout. This may change when we can capture stdout as test result

set n 0
foreach f [TestFilesGlob test-assets/*JPG*] {
    test jpeg-41.$n "debug ok, [file tail $f]" -constraints donotrun -body {
	::jpeg::debug $f
    } -result {}
    incr n
}

test jpeg-42.0 "debug, fail, [file tail [info script]]" -body {
    ::jpeg::debug [info script]
} -returnCodes error -result {not a jpg file}

# -------------------------------------------------------------------------
rename strdiff {}
testsuiteCleanup

#
# Tests for the Tcllib ldap package
#
# -------------------------------------------------------------------------
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# -------------------------------------------------------------------------
# RCS: @(#) $Id: ldap.test,v 1.5 2008/07/20 19:50:55 mic42 Exp $

# -------------------------------------------------------------------------

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

testsNeedTcl     8.4
testsNeedTcltest 2.0

testing {
    useLocal ldap.tcl ldap
    useLocal ../asn/asn.tcl asn
}


namespace import ::asn::*

# -------------------------------------------------------------------------
# Tests

#
# Tests for the Tcllib ldap package
#
# -------------------------------------------------------------------------
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# -------------------------------------------------------------------------


# -------------------------------------------------------------------------

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

testsNeedTcl     8.4
testsNeedTcltest 2.0

testing {
    useLocal ldap.tcl ldap
    use      asn/asn.tcl asn
}


namespace import ::asn::*

# -------------------------------------------------------------------------
# Tests

# ldapx.test:  tests for the ldapx module.
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 2006 by Pierre David <[email protected]>
# All rights reserved.
#
# $Id: ldapx.test,v 1.6 2007/08/19 20:20:43 pdav Exp $

# -------------------------------------------------------------------------

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

................................................................................
} {}


# -------------------------------------------------------------------------

test ldax-d6c9cfba {ldapx continuation line handling} {
    ::ldapx::ldif create ldin
    ldin channel [open $::tcltest::testsDirectory/data/d6c9cfba.ldif r]
    ::ldapx::entry create entr

    ldin read entr
    set r [entr get1 files]

    entr destroy
    ldin destroy

# ldapx.test:  tests for the ldapx module.
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 2006 by Pierre David <[email protected]>
# All rights reserved.



# -------------------------------------------------------------------------

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

................................................................................
} {}


# -------------------------------------------------------------------------

test ldax-d6c9cfba {ldapx continuation line handling} {
    ::ldapx::ldif create ldin
    ldin channel [open [asset d6c9cfba.ldif] r]
    ::ldapx::entry create entr

    ldin read entr
    set r [entr get1 files]

    entr destroy
    ldin destroy

# Tests for the cgi module.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1998-2000 by Ajuba Solutions
#
# RCS: @(#) $Id: ncgi.test,v 1.28 2012/05/03 17:56:07 andreas_kupries Exp $

# -------------------------------------------------------------------------

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

................................................................................

test ncgi-14.2 {ncgi::multipart} {
    catch {ncgi::multipart "multipart/form-data" {}} err
    set err
} {No boundary given for multipart document}

test ncgi-14.3 {ncgi::multipart} {
    set in [open [file join [file dirname [info script]] formdata.txt]]
    set X [read $in]
    close $in

    foreach line [split $X \n] {
	if {[string length $line] == 0} {
	    break
	}
................................................................................
                                         User Guide
</h1></center>


}}}

test ncgi-14.4 {ncgi::multipart} {
    set in [open [file join [file dirname [info script]] formdata.txt]]
    set X [read $in]
    close $in

    foreach line [split $X \n] {
	if {[string length $line] == 0} {
	    break
	}
................................................................................
</h1></center>


}}


test ncgi-14.6 {ncgi::multipart setValue} {
    set in [open [file join [file dirname [info script]] formdata.txt]]
    set X [read $in]
    close $in

    foreach line [split $X \n] {
	if {[string length $line] == 0} {
	    break
	}

# Tests for the cgi module.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1998-2000 by Ajuba Solutions



# -------------------------------------------------------------------------

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

................................................................................

test ncgi-14.2 {ncgi::multipart} {
    catch {ncgi::multipart "multipart/form-data" {}} err
    set err
} {No boundary given for multipart document}

test ncgi-14.3 {ncgi::multipart} {
    set in [open [asset formdata.txt]]
    set X [read $in]
    close $in

    foreach line [split $X \n] {
	if {[string length $line] == 0} {
	    break
	}
................................................................................
                                         User Guide
</h1></center>


}}}

test ncgi-14.4 {ncgi::multipart} {
    set in [open [asset formdata.txt]]
    set X [read $in]
    close $in

    foreach line [split $X \n] {
	if {[string length $line] == 0} {
	    break
	}
................................................................................
</h1></center>


}}


test ncgi-14.6 {ncgi::multipart setValue} {
    set in [open [asset formdata.txt]]
    set X [read $in]
    close $in

    foreach line [split $X \n] {
	if {[string length $line] == 0} {
	    break
	}

# -*- tcl -*-
# png.test:  tests for png decoding and manipulation.
#
# Copyright (c) 2004 by Andreas Kupries <[email protected]>
#
# RCS: @(#) $Id: png.test,v 1.10 2007/04/30 22:47:14 andreas_kupries Exp $

# -------------------------------------------------------------------------

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

................................................................................
testing {
    useLocal png.tcl png
}

# -------------------------------------------------------------------------
# Validation

foreach f [TestFilesGlob testimages/*.png] {
    set root [file rootname [file tail $f]]

    # All files have a valid signature, except for two.

    test png-ispng-$root {is png} {
	::png::isPNG $f
    } [expr {
................................................................................
    test png-validate-$root {full validation} {
	::png::validate $f
    } OK ;# {}
}

# Validation II, the bad files ...

foreach f [TestFilesGlob testimages/x*.png] {
    set root [file rootname [file tail $f]]

    test png-validate-$root {full validation} {
	::png::validate $f
    } [expr {[string match x00n0g01 $root] ? "NODATA" : "SIG"}] ;# {}
}

................................................................................
    tp1n3p08 {color 3 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
    z00n2c08 {color 2 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
    z03n2c08 {color 2 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
    z06n2c08 {color 2 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
    z09n2c08 {color 2 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
}

foreach f [TestFilesGlob testimages/*.png] {
    set root [file rootname [file tail $f]]

    # Files beginning with x are invalid, and thus not usable in these
    # tests.

    if {[string match x* $root]} continue

................................................................................

array set exptime {
    cm0n0g04 946730096
    cm7n0g04 0
    cm9n0g04 946684799
}

foreach f [TestFilesGlob testimages/cm*.png] {
    set root [file rootname [file tail $f]]

    #puts [clock format $exptime($root) -gmt 1]

    test png-gettimestamp-$root {retrieve timestamp} {
	::png::getTimestamp $f
    } $exptime($root) ; # {}
................................................................................
to the spec are present.}} {Software {Created on a NeXTstation color using "pnmtopng".}} {Disclaimer Freeware.}}   
    ctzn0g04 {{Title PngSuite} {Author {Willem A.J. van Schaik
([email protected])}}}
}

# - Retrieval

foreach f [TestFilesGlob testimages/*.png] {
    set root [file rootname [file tail $f]]

    # All files have a valid signature, except for two. These we ignore.
    if {[string equal $root xcrn0g04]} continue
    if {[string equal $root xlfn0g04]} continue
    # All files are fully valid, except for all beginning with an
    # 'x'. We ignore them as well.
................................................................................
# - Removal

# Note: For a bad removeComments tests fail only on platforms where
# the system encoding is not ASCII like, or the EOL is not a plain
# LF. Windows for example, or asian systems.

foreach root [array names comex] {
    set f [localPath testimages/${root}.png]

    test png-removecomment-$root {remove comments} {
	set copy [makeFile {} pngrc.$root]
	file copy -force $f $copy

	::png::removeComments $copy
	set res [list [::png::validate $copy] [::png::getComments $copy]]
................................................................................
    } {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-present {Test to extract physical dimensions} {
    ::png::getPixelDimension [file join\
	    [file dirname [file join [pwd] [info script]]]\
	    testimages/physicaldimensions/basi0g01_300dpi.png]
} {ppux 11811 ppuy 11811 unit meter}

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

# -*- tcl -*-
# png.test:  tests for png decoding and manipulation.
#
# Copyright (c) 2004 by Andreas Kupries <[email protected]>



# -------------------------------------------------------------------------

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

................................................................................
testing {
    useLocal png.tcl png
}

# -------------------------------------------------------------------------
# Validation

foreach f [TestFilesGlob test-assets/*.png] {
    set root [file rootname [file tail $f]]

    # All files have a valid signature, except for two.

    test png-ispng-$root {is png} {
	::png::isPNG $f
    } [expr {
................................................................................
    test png-validate-$root {full validation} {
	::png::validate $f
    } OK ;# {}
}

# Validation II, the bad files ...

foreach f [TestFilesGlob test-assets/x*.png] {
    set root [file rootname [file tail $f]]

    test png-validate-$root {full validation} {
	::png::validate $f
    } [expr {[string match x00n0g01 $root] ? "NODATA" : "SIG"}] ;# {}
}

................................................................................
    tp1n3p08 {color 3 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
    z00n2c08 {color 2 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
    z03n2c08 {color 2 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
    z06n2c08 {color 2 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
    z09n2c08 {color 2 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
}

foreach f [TestFilesGlob test-assets/*.png] {
    set root [file rootname [file tail $f]]

    # Files beginning with x are invalid, and thus not usable in these
    # tests.

    if {[string match x* $root]} continue

................................................................................

array set exptime {
    cm0n0g04 946730096
    cm7n0g04 0
    cm9n0g04 946684799
}

foreach f [TestFilesGlob test-assets/cm*.png] {
    set root [file rootname [file tail $f]]

    #puts [clock format $exptime($root) -gmt 1]

    test png-gettimestamp-$root {retrieve timestamp} {
	::png::getTimestamp $f
    } $exptime($root) ; # {}
................................................................................
to the spec are present.}} {Software {Created on a NeXTstation color using "pnmtopng".}} {Disclaimer Freeware.}}   
    ctzn0g04 {{Title PngSuite} {Author {Willem A.J. van Schaik
([email protected])}}}
}

# - Retrieval

foreach f [TestFilesGlob test-assets/*.png] {
    set root [file rootname [file tail $f]]

    # All files have a valid signature, except for two. These we ignore.
    if {[string equal $root xcrn0g04]} continue
    if {[string equal $root xlfn0g04]} continue
    # All files are fully valid, except for all beginning with an
    # 'x'. We ignore them as well.
................................................................................
# - Removal

# Note: For a bad removeComments tests fail only on platforms where
# the system encoding is not ASCII like, or the EOL is not a plain
# LF. Windows for example, or asian systems.

foreach root [array names comex] {
    set f [asset ${root}.png]

    test png-removecomment-$root {remove comments} {
	set copy [makeFile {} pngrc.$root]
	file copy -force $f $copy

	::png::removeComments $copy
	set res [list [::png::validate $copy] [::png::getComments $copy]]
................................................................................
    } {OK {}}
}

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

test png-physical-dimensions-missing {Test for empty list if no physical dimensions present} {


    ::png::getPixelDimension [asset physicaldimensions/basi0g01.png]
} {}

test png-physical-dimensions-present {Test to extract physical dimensions} {


    ::png::getPixelDimension [asset physicaldimensions/basi0g01_300dpi.png]
} {ppux 11811 ppuy 11811 unit meter}

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

# -*- tcl -*-
# tiff.test:  Tests for the TIFF utilities.
#
# Copyright (c) 2008 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# TIFF: @(#) $Id: tiff.test,v 1.1 2008/03/24 03:48:59 andreas_kupries Exp $

# -------------------------------------------------------------------------

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

................................................................................
    catch {::tiff::isTIFF foo bar} msg
    set msg
} [tcltest::tooManyArgs {::tiff::isTIFF} {file}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob testimages/*.tiff] {
    test tiff-2.$n "isTIFF, ok, [file tail $f]" {
	::tiff::isTIFF $f
    } 1
    incr n
}

test tiff-2.$n "isTIFF, fail, [file tail [info script]]" {
................................................................................
    catch {::tiff::byteOrder foo bar} msg
    set msg
} [tcltest::tooManyArgs {::tiff::byteOrder} {file}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob testimages/*.tiff] {
    test tiff-4.$n "byteOrder regular, [file tail $f]" {
	::tiff::byteOrder $f
    } little
    incr n
}

test tiff-5.0 "byteOrder, fail, [file tail [info script]]" {
................................................................................
    catch {::tiff::numImages foo bar} msg
    set msg
} [tcltest::tooManyArgs {::tiff::numImages} {file}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob testimages/*.tiff] {
    test tiff-7.$n "numImages regular, [file tail $f]" {
	::tiff::numImages $f
    } 1
    incr n
}

test tiff-8.0 "numImages, fail, [file tail [info script]]" {
................................................................................
    catch {::tiff::dimensions foo bar glop} msg
    set msg
} [tcltest::tooManyArgs {::tiff::dimensions} {file ?image?}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob testimages/*.tiff] {
    test tiff-10.$n "dimensions regular, [file tail $f]" {
	::tiff::dimensions $f
    } {320 240}
    incr n
}

test tiff-11.0 "dimensions, fail, [file tail [info script]]" {
................................................................................
    catch {::tiff::imageInfo foo bar glop} msg
    set msg
} [tcltest::tooManyArgs {::tiff::imageInfo} {file ?image?}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob testimages/*.tiff] {
    test tiff-13.$n "imageInfo regular, [file tail $f]" {
	dictsort [::tiff::imageInfo $f]
    } {Artist {} BitsPerSample {8 8 8} Compression 7 DateTime {} HostComputer {} ImageDescription {} ImageLength 240 ImageWidth 320 Orientation 1 PhotometricInterpretation 2 ResolutionUnit 2 XResolution 180 YResolution 180}
    incr n
}

test tiff-14.0 "imageInfo, fail, [file tail [info script]]" {
................................................................................
    catch {::tiff::entries foo bar glop} msg
    set msg
} [tcltest::tooManyArgs {::tiff::entries} {file ?image?}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob testimages/*.tiff] {
    test tiff-16.$n "entries regular, [file tail $f]" {
	lsort [::tiff::entries $f]
    } {BitsPerSample Compression DocumentName FillOrder ImageLength ImageWidth JPEGTables Orientation PhotometricInterpretation PlanarConfiguration ResolutionUnit RowsPerStrip SamplesPerPixel Software StripByteCounts StripOffsets XResolution YCbCrSubSampling YResolution}
    incr n
}

test tiff-17.0 "entries, fail, [file tail [info script]]" {
................................................................................
    catch {::tiff::getEntry foo bar glop snarf} msg
    set msg
} [tcltest::tooManyArgs {::tiff::getEntry} {file entry ?image?}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob testimages/*.tiff] {
    test tiff-19.$n "getEntry regular, [file tail $f]" {
	::tiff::getEntry $f {Artist Compression}
    } {Artist {} Compression 7}
    incr n
}

test tiff-20.0 "getEntry, fail, [file tail [info script]]" {
................................................................................
    catch {::tiff::addEntry foo bar glop snarf} msg
    set msg
} [tcltest::tooManyArgs {::tiff::addEntry} {file entry ?image?}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob testimages/*.tiff] {
    test tiff-22.$n "addEntry, new tag, [file tail $f]" {
	file copy -force $f [set fx [makeFile {} ttmp]]
	set res {}
	lappend res [tiff::getEntry $fx Artist]
	::tiff::addEntry $fx {{Artist 2 Andreas}}
	lappend res [tiff::getEntry $fx Artist]
	removeFile ttmp
	set res
    } {{Artist {}} {Artist Andreas}}
    incr n
}

set n 0
foreach f [TestFilesGlob testimages/*.tiff] {
    test tiff-23.$n "addEntry, overwrite tag, [file tail $f]" knownBug {
	file copy -force $f [set fx [makeFile {} ttmp]]
	set res {}
	::tiff::addEntry $fx {{Artist 2 Andreas}}
	lappend res [tiff::getEntry $fx Artist]
	::tiff::addEntry $fx {{Artist 2 AK}}
	lappend res [tiff::getEntry $fx Artist]
................................................................................
    catch {::tiff::deleteEntry foo bar glop snarf} msg
    set msg
} [tcltest::tooManyArgs {::tiff::deleteEntry} {file entry ?image?}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob testimages/*.tiff] {
    test tiff-26.$n "deleteEntry, [file tail $f]" {
	file copy -force $f [set fx [makeFile {} ttmp]]
	set res {}
	lappend res [tiff::getEntry $fx Artist]
	::tiff::addEntry $fx {{Artist 2 Andreas}}
	lappend res [tiff::getEntry $fx Artist]
	::tiff::deleteEntry $fx Artist
................................................................................
    catch {::tiff::getImage foo bar glop snarf} msg
    set msg
} [tcltest::tooManyArgs {::tiff::getImage} {file ?image?}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob testimages/*.tiff] {
    test tiff-29.$n "getImage, [file tail $f]" {tk unkownFormat} {
	set image [tiff::getImage $f]
	lappend res [image width  $image]
	lappend res [image height $image]
	image delete $image
	set res
    } {320 240}
................................................................................
    catch {::tiff::writeImage foo bar glop snarf} msg
    set msg
} [tcltest::tooManyArgs {::tiff::writeImage} {image file ?entry?}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob testimages/*.tiff] {
    test tiff-32.$n "writeImage, [file tail $f]" {tk unkownFormat} {
	set image [tiff::getImage $f]
	set fx [makeFile {} ttmp]
	tiff::writeImage $image $fx
	image delete $image
	foreach k [lsort [::tiff::entries $fx]] {
	    lappend res [tiff::getEntry $fx $k]
................................................................................
} [tcltest::tooManyArgs {::tiff::debug} {file}]

# -------------------------------------------------------------------------
# We do not try to actually run 'debug', because it prints its results
# to stdout. This may change when we can capture stdout as test result

set n 0
foreach f [TestFilesGlob testimages/*.tiff] {
    test tiff-41.$n "debug ok, [file tail $f]" donotrun {
	::tiff::debug $f
    } {}
    incr n
}

test tiff-42.0 "debug, fail, [file tail [info script]]" {
    list [catch {::tiff::debug [info script]} msg] $msg
} {1 {not a tiff file}}

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

# -*- tcl -*-
# tiff.test:  Tests for the TIFF utilities.
#
# Copyright (c) 2008 by Andreas Kupries <[email protected]>
# All rights reserved.



# -------------------------------------------------------------------------

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

................................................................................
    catch {::tiff::isTIFF foo bar} msg
    set msg
} [tcltest::tooManyArgs {::tiff::isTIFF} {file}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob test-assets/*.tiff] {
    test tiff-2.$n "isTIFF, ok, [file tail $f]" {
	::tiff::isTIFF $f
    } 1
    incr n
}

test tiff-2.$n "isTIFF, fail, [file tail [info script]]" {
................................................................................
    catch {::tiff::byteOrder foo bar} msg
    set msg
} [tcltest::tooManyArgs {::tiff::byteOrder} {file}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob test-assets/*.tiff] {
    test tiff-4.$n "byteOrder regular, [file tail $f]" {
	::tiff::byteOrder $f
    } little
    incr n
}

test tiff-5.0 "byteOrder, fail, [file tail [info script]]" {
................................................................................
    catch {::tiff::numImages foo bar} msg
    set msg
} [tcltest::tooManyArgs {::tiff::numImages} {file}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob test-assets/*.tiff] {
    test tiff-7.$n "numImages regular, [file tail $f]" {
	::tiff::numImages $f
    } 1
    incr n
}

test tiff-8.0 "numImages, fail, [file tail [info script]]" {
................................................................................
    catch {::tiff::dimensions foo bar glop} msg
    set msg
} [tcltest::tooManyArgs {::tiff::dimensions} {file ?image?}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob test-assets/*.tiff] {
    test tiff-10.$n "dimensions regular, [file tail $f]" {
	::tiff::dimensions $f
    } {320 240}
    incr n
}

test tiff-11.0 "dimensions, fail, [file tail [info script]]" {
................................................................................
    catch {::tiff::imageInfo foo bar glop} msg
    set msg
} [tcltest::tooManyArgs {::tiff::imageInfo} {file ?image?}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob test-assets/*.tiff] {
    test tiff-13.$n "imageInfo regular, [file tail $f]" {
	dictsort [::tiff::imageInfo $f]
    } {Artist {} BitsPerSample {8 8 8} Compression 7 DateTime {} HostComputer {} ImageDescription {} ImageLength 240 ImageWidth 320 Orientation 1 PhotometricInterpretation 2 ResolutionUnit 2 XResolution 180 YResolution 180}
    incr n
}

test tiff-14.0 "imageInfo, fail, [file tail [info script]]" {
................................................................................
    catch {::tiff::entries foo bar glop} msg
    set msg
} [tcltest::tooManyArgs {::tiff::entries} {file ?image?}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob test-assets/*.tiff] {
    test tiff-16.$n "entries regular, [file tail $f]" {
	lsort [::tiff::entries $f]
    } {BitsPerSample Compression DocumentName FillOrder ImageLength ImageWidth JPEGTables Orientation PhotometricInterpretation PlanarConfiguration ResolutionUnit RowsPerStrip SamplesPerPixel Software StripByteCounts StripOffsets XResolution YCbCrSubSampling YResolution}
    incr n
}

test tiff-17.0 "entries, fail, [file tail [info script]]" {
................................................................................
    catch {::tiff::getEntry foo bar glop snarf} msg
    set msg
} [tcltest::tooManyArgs {::tiff::getEntry} {file entry ?image?}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob test-assets/*.tiff] {
    test tiff-19.$n "getEntry regular, [file tail $f]" {
	::tiff::getEntry $f {Artist Compression}
    } {Artist {} Compression 7}
    incr n
}

test tiff-20.0 "getEntry, fail, [file tail [info script]]" {
................................................................................
    catch {::tiff::addEntry foo bar glop snarf} msg
    set msg
} [tcltest::tooManyArgs {::tiff::addEntry} {file entry ?image?}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob test-assets/*.tiff] {
    test tiff-22.$n "addEntry, new tag, [file tail $f]" {
	file copy -force $f [set fx [makeFile {} ttmp]]
	set res {}
	lappend res [tiff::getEntry $fx Artist]
	::tiff::addEntry $fx {{Artist 2 Andreas}}
	lappend res [tiff::getEntry $fx Artist]
	removeFile ttmp
	set res
    } {{Artist {}} {Artist Andreas}}
    incr n
}

set n 0
foreach f [TestFilesGlob test-assets/*.tiff] {
    test tiff-23.$n "addEntry, overwrite tag, [file tail $f]" knownBug {
	file copy -force $f [set fx [makeFile {} ttmp]]
	set res {}
	::tiff::addEntry $fx {{Artist 2 Andreas}}
	lappend res [tiff::getEntry $fx Artist]
	::tiff::addEntry $fx {{Artist 2 AK}}
	lappend res [tiff::getEntry $fx Artist]
................................................................................
    catch {::tiff::deleteEntry foo bar glop snarf} msg
    set msg
} [tcltest::tooManyArgs {::tiff::deleteEntry} {file entry ?image?}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob test-assets/*.tiff] {
    test tiff-26.$n "deleteEntry, [file tail $f]" {
	file copy -force $f [set fx [makeFile {} ttmp]]
	set res {}
	lappend res [tiff::getEntry $fx Artist]
	::tiff::addEntry $fx {{Artist 2 Andreas}}
	lappend res [tiff::getEntry $fx Artist]
	::tiff::deleteEntry $fx Artist
................................................................................
    catch {::tiff::getImage foo bar glop snarf} msg
    set msg
} [tcltest::tooManyArgs {::tiff::getImage} {file ?image?}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob test-assets/*.tiff] {
    test tiff-29.$n "getImage, [file tail $f]" {tk unkownFormat} {
	set image [tiff::getImage $f]
	lappend res [image width  $image]
	lappend res [image height $image]
	image delete $image
	set res
    } {320 240}
................................................................................
    catch {::tiff::writeImage foo bar glop snarf} msg
    set msg
} [tcltest::tooManyArgs {::tiff::writeImage} {image file ?entry?}]

# -------------------------------------------------------------------------

set n 0
foreach f [TestFilesGlob test-assets/*.tiff] {
    test tiff-32.$n "writeImage, [file tail $f]" {tk unkownFormat} {
	set image [tiff::getImage $f]
	set fx [makeFile {} ttmp]
	tiff::writeImage $image $fx
	image delete $image
	foreach k [lsort [::tiff::entries $fx]] {
	    lappend res [tiff::getEntry $fx $k]
................................................................................
} [tcltest::tooManyArgs {::tiff::debug} {file}]

# -------------------------------------------------------------------------
# We do not try to actually run 'debug', because it prints its results
# to stdout. This may change when we can capture stdout as test result

set n 0
foreach f [TestFilesGlob test-assets/*.tiff] {
    test tiff-41.$n "debug ok, [file tail $f]" donotrun {
	::tiff::debug $f
    } {}
    incr n
}

test tiff-42.0 "debug, fail, [file tail [info script]]" {
    list [catch {::tiff::debug [info script]} msg] $msg
} {1 {not a tiff file}}

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

#                }
#                set val [eval huddle list $subs]
#            }
#            lappend result $key $val
#        }
#        return [eval huddle create $result]
#    }
#    set fd [open [file join [file dirname [info script]] layers.txt] r]
#    set json1 [read $fd]
#    close $fd
#
#    set data [json::json2dict $json1]
##    set data [huddle_build $data]
##
##    set json2 [huddle jsondump $data]

#                }
#                set val [eval huddle list $subs]
#            }
#            lappend result $key $val
#        }
#        return [eval huddle create $result]
#    }
#    set fd [open [asset layers.txt] r]
#    set json1 [read $fd]
#    close $fd
#
#    set data [json::json2dict $json1]
##    set data [huddle_build $data]
##
##    set json2 [huddle jsondump $data]

    }
    error
}

# ------------

test yaml-21.0.06eef112da {ticket 06eef112da} -body {
    yaml::yaml2dict -file [localPath 06eef112da.data]
} -result {{} {} {alpha 43 beta {houston {{}} newyork {{{} aaa}}}}}

# ------------
# error  .....

test yaml-1.1 "error" -body {
    set error1 {

    }
    error
}

# ------------

test yaml-21.0.06eef112da {ticket 06eef112da} -body {
    yaml::yaml2dict -file [asset 06eef112da.data]
} -result {{} {} {alpha 43 beta {houston {{}} newyork {{{} aaa}}}}}

# ------------
# error  .....

test yaml-1.1 "error" -body {
    set error1 {