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 -*-
# 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]
    bibtex::destroy $t
    list $t $track
} [list bibtex2 [list \
	{progress bibtex2 100} \
	[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 -*-
# 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}

# -*- 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 -*-
# 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
    set result
} {023,EVAL cmd eval in list obj var,26,45,57.78
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-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

# -*- tcl -*-
# exif.test:  tests for the exif structure.
#
# 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]

testsNeedTcl     8.3
testsNeedTcltest 1.0

testing {
    useLocal exif.tcl exif
}

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

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

# -*- tcl -*-
# 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) 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

# -*- 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.
#
# 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 {
    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

# -*- 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]
	    # Note: The .thumb files were created from the .JPG files
	    # using 'jhead -st', version 2.6.
	    set expected [fileutil::cat -translation binary ${f}.thumb]
	    set have     [::jpeg::getThumbnail $f]
	    list [string equal $expected $have] [strdiff $expected $have]
	} -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

# ldap.test - Copyright (C) 2006 Michael Schlenker <[email protected]>
#
# 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

# -*- tcl -*-
# 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

# -*- tcl -*-
# 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
	}

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

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

    }
    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 {