Tcl Library Source Code

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

testsNeedTcl     8.4
testsNeedTcltest 1.0

testing {
    useLocal bibtex.tcl bibtex
}

}

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

	    regsub {^.*Snit_method} $method {} method
	    tcltest::tooManyArgs "$obj $method" $arglist
	}

    } else {
	proc snitWrongNumArgs {obj method arglist missingIndex} {
	    incr missingIndex 4
	    tcltest::wrongNumArgs $method [linsert $arglist 0 \
		    type selfns win self] $missingIndex
	}

	proc snitTooManyArgs {obj method arglist} {
	    tcltest::tooManyArgs $method [linsert $arglist 0 \
		    type selfns win self]
	}
    }
}

# ### ### ### ######### ######### #########
## Commands to load files from various locations within the local
## Tcllib, and the loading of local Tcllib packages. None of them goes
## through the auto-loader, nor the regular package management, to
## avoid contamination of the testsuite by packages and code outside
## of the Tcllib under test.


proc asset args {
    set localPath [file join [uplevel 1 [
		list [namespace which localPath]]]]
	foreach location {test-assets {.. test-assets}} {
		set candidate [eval file join [list $localPath] $location $args]
		if {[file exists $candidate]} {
			set {asset path} $candidate
			break
		}
	}
	if {![info exists {asset path}]} {
		error [list {can not find asset path}]
	}
	return ${asset path}
}

proc asset-get args {
	file-get [uplevel 1 [list [namespace which asset]] $args]
}

proc file-get path {
    set c [open $path r]
    set d [read $c]
    close $c
    return $d
}

proc localDirectory {} {
    set script [uplevel 1 [list ::info script]]
    file dirname [file dirname [file normalize [
	    file join $script[set script {}] ...]]]
}

# General access to module-local files
proc localPath args {
    set {script dir} [uplevel 1 [list [namespace which localDirectory]]]
    eval file join [list ${script dir}] $args
}

# General access to global (project-local) files
proc tcllibPath {fname} {
    return [file join $::tcllib::testutils::tcllib $fname]
}

	return -code return
    }
    return
}

proc testing {script} {
    InitializeTclTest
    set ::tcllib::testutils::tag *
    if {[catch {
	uplevel 1 $script
    } msg]} {
	set prefix "SETUP Error (Testing): "
	puts $prefix[join [split $::errorInfo \n] "\n$prefix"]

	return -code return

    ${namespace}::SwitchTo {}
    return
}

# ### ### ### ######### ######### #########
##

proc TestFiles pattern {
    set {local directory} [uplevel 1 [list [namespace which localDirectory]]]
    if {[package vsatisfies [package provide Tcl] 8.3]} {
	# 8.3+ -directory ok
	set flist [glob -nocomplain -directory ${local directory} $pattern]
    } else {
	# 8.2 or less, no -directory
	set flist [glob -nocomplain [file join ${local directory} $pattern]]
    }
    foreach f [lsort -dict $flist] {
	uplevel 1 [list source $f]
    }
    return
}

proc TestFilesGlob pattern {
    set {local directory} [uplevel 1 [list [namespace which localDirectory]]]
    if {[package vsatisfies [package provide Tcl] 8.3]} {
	# 8.3+ -directory ok
	set flist [glob -nocomplain -directory ${local directory} $pattern]
    } else {
	# 8.2 or less, no -directory
	set flist [glob -nocomplain [file join ${local directory} $pattern]]
    }
    return [lsort -dict $flist]
}

# ### ### ### ######### ######### #########
##

::tcllib::testutils::SaveEnvironment

# ### ### ### ######### ######### #########
package provide tcllib::testutils 1.2
puts "- tcllib::testutils [package present tcllib::testutils]"
return

# -*- tcl -*-
# docparsetcl.testsuite:  tests for the tcl parser.
#
# Copyright (c) 2009 Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: tcl_parse,v 1.1 2009/04/01 04:27:47 andreas_kupries Exp $

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

source [localPath common]
set mytestdir tcl_data

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

TestFilesProcess $mytestdir ok in out -> n label input data expected {
    test doctools-tcl-parse-${stkimpl}-${setimpl}-${impl}-10.$n "doctools::tcl::parse, $label, ok" -setup {
	struct::tree myresult
    } -body {

# -*- tcl -*-
# idx.test:  Tests for the doctools::idx package. Index management.
#
# Copyright (c) 2009-2019 by Andreas Kupries <[email protected]>
# All rights reserved.

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

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

testsNeedTcl     8.4
testsNeedTcltest 2

support {
    use struct/list.tcl          struct::list
    use snit/snit.tcl            snit

# -*- tcl -*-
# idx.test:  tests for the doctools::idx package.
#
# Copyright (c) 2009-2019 by Andreas Kupries <[email protected]>
# All rights reserved.

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

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

testsNeedTcl     8.4
testsNeedTcltest 2

support {
    use fileutil/fileutil.tcl    fileutil      ;# tests/common

# -*- tcl -*-
# docidx.testsuite:  tests for the docidx management.
#
# Copyright (c) 2009 Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: container,v 1.2 2009/04/17 05:42:07 andreas_kupries Exp $

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

set mytestdir data

# -------------------------------------------------------------------------
# -------------------------------------------------------------------------
# I. Handling regular serialization of indices, import and export.
#    Import serialization, then re-export.

TestFilesProcess $mytestdir ok serial serial-print -> n label input data expected {

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

# Tests are run for all formats we have an export plugin for.

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

set mytestdir      data
set mytestconfig   {fox dog lazy jump}
set mytestincludes [TestFilesGlob $mytestdir]

# -------------------------------------------------------------------------
# -------------------------------------------------------------------------
# docidx markup

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

# Tests are run for all formats we have an import plugin for.

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

set mytestdir      data
set mytestconfig   {fox dog lazy jump}
set mytestincludes [TestFilesGlob $mytestdir]

# -------------------------------------------------------------------------
# -------------------------------------------------------------------------
# docidx markup

# -*- tcl -*-
# idx_import_docidx.testsuite:  tests for the docidx import plugin.
#
# Copyright (c) 2009 Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: import_docidx,v 1.1 2009/04/01 04:28:37 andreas_kupries Exp $

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

source [tcllibPath doctools2base/tests/common]
set mytestdir      data
set mytestconfig   {fox dog lazy jump}
set mytestincludes [TestFilesGlob $mytestdir]

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

# We are checking that the various forms of docidx markup, as can be
# generated by doctools::idx(::export(::docidx)) are valid input to

# -*- tcl -*-
# docidx_parse.testsuite:  tests for the docidx parser.
#
# Copyright (c) 2009 Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: parse,v 1.2 2009/04/08 04:08:58 andreas_kupries Exp $

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

source [tcllibPath doctools2base/tests/common]
set mytestdir data

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

# We are checking that the various forms of docidx markup, as can be
# generated by doctools::idx::export::docidx are valid input to the
# docidx parser.
#

# -*- tcl -*-
# -- toc_import.test:
# -- Tests for package "doctools::toc::import": Management of import plugins.
#
# Copyright (c) 2009-2019 by Andreas Kupries <[email protected]>
# All rights reserved.

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

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

testsNeedTcl     8.4
testsNeedTcltest 2

support {
    use struct/list.tcl         struct::list
    use snit/snit.tcl           snit

# -*- tcl -*-
# doctoc.testsuite:  tests for the doctoc management.
#
# Copyright (c) 2009 Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: container,v 1.2 2009/11/15 05:50:03 andreas_kupries Exp $

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

set mytestdir data

# -------------------------------------------------------------------------
# -------------------------------------------------------------------------
# I. Handling regular serialization of indices, import and export.
#    Import serialization, then re-export.

TestFilesProcess $mytestdir ok serial serial-print -> n label input data expected {

# TODO :: check toc merging (+=).

# toc tests, numbering starts at 40
# -------------------------------------------------------------------------

source [localPath container]
return

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

# Tests are run for all formats we have an export plugin for.

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

set mytestdir      data
set mytestconfig   {fox dog lazy jump}
set mytestincludes [TestFilesGlob $mytestdir]

# -------------------------------------------------------------------------
# -------------------------------------------------------------------------
# doctoc markup

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

# Tests are run for all formats we have an import plugin for.

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

set mytestdir      data
set mytestconfig   {fox dog lazy jump}
set mytestincludes [TestFilesGlob $mytestdir]

# -------------------------------------------------------------------------
# -------------------------------------------------------------------------
# doctoc markup

# -*- tcl -*-
# toc_import_doctoc.testsuite:  tests for the doctoc import plugin.
#
# Copyright (c) 2009 Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: import_doctoc,v 1.1 2009/04/18 21:14:21 andreas_kupries Exp $

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

source [tcllibPath doctools2base/tests/common]
set mytestdir      data
set mytestconfig   {fox dog lazy jump}
set mytestincludes [TestFilesGlob $mytestdir]

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

# We are checking that the various forms of doctoc markup, as can be
# generated by doctools::toc(::export(::doctoc)) are valid input to

# -*- tcl -*-
# doctoc_parse.testsuite:  tests for the doctoc parser.
#
# Copyright (c) 2009 Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: parse,v 1.1 2009/04/18 21:14:21 andreas_kupries Exp $

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

source [tcllibPath doctools2base/tests/common]
set mytestdir data

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

# We are checking that the various forms of doctoc markup, as can be
# generated by doctools::toc::export::doctoc are valid input to the
# doctoc parser.
#

# json.test - Copyright (C) 2006 ActiveState Software Inc.
#
# Tests for the Tcllib json 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     [expr {[catch {package require dict}] ? "8.5" : "8.4"}]

            default {
		error "Invalid type"
	    }
        }
    }
}

foreach f [TestFilesGlob *.json] {
    set name [file rootname [file tail $f]]
    set JSON($name) [tcltest::viewFile $f]
}

foreach f [TestFilesGlob *.result] {
    set name [file rootname [file tail $f]]
    set TCL($name) [tcltest::viewFile $f]
}

foreach f [TestFilesGlob *.sort] {
    set name [file rootname [file tail $f]]
    set DICTSORT($name) [tcltest::viewFile $f]
}

# Postprocessing result of one test case, insert proper expected unicodepoint
set  TCL(menu) [string map [list @@@ \u6021]  $TCL(menu)]

# oometa.test - Copyright (c) 2016 Sean Woods

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

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

testsNeedTcl     8.6 ;# tailcall in oo::meta
testsNeedTcltest 2
testsNeed        TclOO

testing {
  useLocal oometa.tcl   oo::meta

# -*- tcl -*-
# char.test:  tests for the char package.
#
# Copyright (c) 2014 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: char.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $

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

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

testsNeedTcl     8.5
testsNeedTcltest 2.0

support {
}
testing {
    useLocal char.tcl char
}

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

set mytestdir data

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

source [localPath tests/char.tests]

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

# -*- tcl -*-
# pt_astree.test:  tests for the pt::ast package.
#
# Copyright (c) 2009 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: pt_astree.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $

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

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

testsNeedTcl     8.5
testsNeedTcltest 2.0

support {
    use fileutil/fileutil.tcl  fileutil ; # For tests/common
    use snit/snit.tcl          snit

    source [localPath tests/common]
}
testing {
    useLocal pt_astree.tcl pt::ast
}

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

set mytestdir data

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

source [localPath tests/pt_astree.tests]

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

unset mytestdir
testsuiteCleanup
return

# -*- tcl -*-
# pt_cparam_config_critcl.test: tests for the pt::peg::to::cparam
# converter package configured for critcl.
#
# Copyright (c) 2009 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: pt_cparam_config_critcl.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $

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


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

testsNeedTcl     8.5
testsNeedTcltest 2

support {
    useAccel [useTcllibC] struct/sets.tcl struct::set ; # used by pt::pe::op,
    TestAccelInit                         struct::set ; # however not by the

    source [localPath tests/common]
}
testing {
    useLocal pt_cparam_config_critcl.tcl pt::cparam::configuration::critcl
}

set mytestdir data

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

source [localPath tests/pt_cparam_config_critcl.tests]

# -------------------------------------------------------------------------
TestAccelExit struct::set
testsuiteCleanup
return

# -*- tcl -*-
# pt_cparam_config_critcl.test: tests for the pt::peg::to::cparam
# converter package configured for critcl.
#
# Copyright (c) 2009 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: pt_cparam_config_critcl.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $

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

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

testsNeedTcl     8.5
testsNeedTcltest 2

support {
    useAccel [useTcllibC] struct/sets.tcl struct::set ; # used by pt::pe::op,
    TestAccelInit                         struct::set ; # however not by the

    source [localPath tests/common]
}
testing {
    useLocal pt_cparam_config_tea.tcl pt::cparam::configuration::tea
}

set mytestdir data

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

source [localPath tests/pt_cparam_config_tea.tests]

# -------------------------------------------------------------------------
TestAccelExit struct::set
testsuiteCleanup
return

# -*- tcl -*-
# pt_parse_peg.test:  tests for the pt::parse::peg peg parsing package.
#
# Copyright (c) 2010 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: pt_parse_peg.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $

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

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

testsNeedTcl     8.5
testsNeedTcltest 2

support {
    useAccel [useTcllibC] struct/stack.tcl struct::stack ; # User: pt::rde
    TestAccelInit                          struct::stack ; # (tcl)

    source [localPath tests/common]
}
testing {
    useAccel [useTcllibC] pt/pt_parse_peg.tcl pt::parse::peg ; # User: pt::peg::from::peg
    TestAccelInit                             pt::parse::peg
}

set mytestdir data

# -------------------------------------------------------------------------
# Note: When using pt::rde's C implementation struct::stack is not
#       used, and its implementation of no relevance.
#
#       Similarly, when pt::parse::peg's C implementation is used
#       neither pt::rde's, nor struct::stack's implementations are of

# -*- tcl -*-
# peg_container.test:  Tests for the pt::peg package.
#
# Copyright (c) 2009 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: pt_peg_container.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $

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

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

testsNeedTcl     8.5
testsNeedTcltest 2

support {
    useAccel [useTcllibC] struct/sets.tcl  struct::set
    TestAccelInit                          struct::set

# -*- tcl -*-
# peg_export.test:  tests for the pt::peg::export package.
#
# Copyright (c) 2009-2019 by Andreas Kupries <[email protected]>
# All rights reserved.

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

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

testsNeedTcl     8.5
testsNeedTcltest 2

support {
    useAccel [useTcllibC] struct/sets.tcl  struct::set
    TestAccelInit                          struct::set

# -*- tcl -*-
# peg_export_container.test:  tests for the pt::peg::export::container
# package/plugin.
#
# Copyright (c) 2009 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: pt_peg_export_container.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $

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

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

testsNeedTcl     8.5
testsNeedTcltest 2

support {
    useAccel [useTcllibC] struct/sets.tcl  struct::set
    TestAccelInit                          struct::set

testing {
    package provide pt::peg::export::plugin 1
    # The above fakes the export plugin environment.

    useLocal pt_peg_export_container.tcl pt::peg::export::container
}

set mytestdir data

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

TestAccelDo struct::set setimpl {
    source [localPath tests/pt_peg_export_container.tests]
}

# -------------------------------------------------------------------------
TestAccelExit struct::set
testsuiteCleanup
return

# -*- tcl -*-
# peg_export_json.test:  tests for the pt::peg::export::json package/plugin.
#
# Copyright (c) 2009 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: pt_peg_export_json.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $

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

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

testsNeedTcl     8.5
testsNeedTcltest 2

support {
    useAccel [useTcllibC] struct/sets.tcl  struct::set
    TestAccelInit                          struct::set

testing {
    package provide pt::peg::export::plugin 1
    # The above fakes the export plugin environment.

    useLocal pt_peg_export_json.tcl pt::peg::export::json
}

set mytestdir data

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

TestAccelDo struct::set setimpl {
    source [localPath tests/pt_peg_export_json.tests]
}

# -------------------------------------------------------------------------
TestAccelExit struct::set
testsuiteCleanup
return

# -*- tcl -*-
# peg_export_peg.test:  tests for the pt::peg::export::peg package/plugin.
#
# Copyright (c) 2009 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: pt_peg_export_peg.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $

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

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

testsNeedTcl     8.5
testsNeedTcltest 2

support {
    useAccel [useTcllibC] struct/sets.tcl  struct::set
    TestAccelInit                          struct::set

testing {
    package provide pt::peg::export::plugin 1
    # The above fakes the export plugin environment.

    useLocal pt_peg_export_peg.tcl pt::peg::export::peg
}

set mytestdir data

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

TestAccelDo struct::set setimpl {
    source [localPath tests/pt_peg_export_peg.tests]
}

# -------------------------------------------------------------------------
TestAccelExit struct::set
testsuiteCleanup
return

# -*- tcl -*-
# pt_peg_from_json.test:  tests for the pt::peg::from::json converter package.
#
# Copyright (c) 2009 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: pt_peg_from_json.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $

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

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

testsNeedTcl     8.5
testsNeedTcltest 2

support {
    use      fileutil/fileutil.tcl  fileutil      ;# tests/common
    use      json/json.tcl          json

    useLocal pt_pexpression.tcl     pt::pe
    useLocal pt_pegrammar.tcl       pt::peg

    source [localPath tests/common]
}
testing {
    useLocal pt_peg_from_json.tcl pt::peg::from::json
}

set mytestdir data

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

source [localPath tests/pt_peg_from_json.tests]

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

testsuiteCleanup
return

# -*- tcl -*-
# pt_peg_from_peg.test:  tests for the pt::peg::from::peg converter package.
#
# Copyright (c) 2009 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: pt_peg_from_peg.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $

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

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

testsNeedTcl     8.5
testsNeedTcltest 2

support {
    useAccel [useTcllibC] struct/stack.tcl struct::stack ; # User: pt::rde
    TestAccelInit                          struct::stack ; # (tcl)

    source [localPath tests/common]
}
testing {
    useLocal pt_peg_from_peg.tcl pt::peg::from::peg
}

set mytestdir data

# -------------------------------------------------------------------------
# Note: When using pt::rde's C implementation struct::stack is not
#       used, and its implementation of no relevance.
#
#       Similarly, when pt::parse::peg's C implementation is used
#       neither pt::rde's, nor struct::stack's implementations are of

# -*- tcl -*-
# peg_import.test:  tests for the pt::peg::import package.
#
# Copyright (c) 2009-2019 by Andreas Kupries <[email protected]>
# All rights reserved.

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

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

testsNeedTcl     8.5
testsNeedTcltest 2

support {
    use fileutil/fileutil.tcl      fileutil      ;# tests/common
    use snit/snit.tcl              snit

# -*- tcl -*-
# toc_import_json.test:  tests for the doctools::toc::import::json package/plugin.
#
# Copyright (c) 2009 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: pt_peg_import_json.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $

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

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

testsNeedTcl     8.5
testsNeedTcltest 2.0

support {
    use      fileutil/fileutil.tcl  fileutil      ;# tests/common
    use      json/json.tcl          json

    package provide pt::peg::import::plugin 1
    # The above fakes plugin environment. Well, not completely. We are
    # leaving out a definition for the 'include' alias

    useLocal pt_peg_import_json.tcl pt::peg::import::json
}

set mytestdir data

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

source [localPath tests/pt_peg_import_json.tests]

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

testsuiteCleanup
return

# -*- tcl -*-
# peg_import_peg.test:  tests for the pt::peg::import::peg package/plugin.
#
# Copyright (c) 2009 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: pt_peg_import_peg.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $

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

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

testsNeedTcl     8.5
testsNeedTcltest 2

support {
    useAccel [useTcllibC] struct/stack.tcl struct::stack ; # User: pt::rde
    TestAccelInit                          struct::stack ; #

testing {
    package provide pt::peg::import::plugin 1
    # The above fakes the import plugin environment.

    useLocal pt_peg_import_peg.tcl pt::peg::import::peg
}

set mytestdir data

# -------------------------------------------------------------------------
# Note: When using pt::rde's C implementation struct::stack is not
#       used, and its implementation of no relevance.
#
#       Similarly, when pt::parse::peg's C implementation is used
#       neither pt::rde's, nor struct::stack's implementations are of

# -*- tcl -*-
# pt_peg_interp.test:  tests for the pt::peg::interp peg interpreter package.
#
# Copyright (c) 2010 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: pt_peg_interp.test,v 1.1 2010/07/27 22:53:53 andreas_kupries Exp $

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

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

testsNeedTcl     8.5
testsNeedTcltest 2

support {
    useAccel [useTcllibC] struct/stack.tcl struct::stack ; # User: pt::rde
    TestAccelInit                          struct::stack ; # (tcl)

    source [localPath tests/common]
}
testing {
    use pt/pt_peg_interp.tcl pt::peg::interp
}

set mytestdir data

# -------------------------------------------------------------------------
# Note: When using pt::rde's C implementation struct::stack is not
#       used, and its implementation of no relevance.

TestAccelDo pt::rde rdeimpl {
    if {$rdeimpl eq "critcl"} {

# -*- tcl -*-
# pe_peg_op.test:  tests for the pt::peg::op package.
#
# Copyright (c) 2018 by Stefan Sobernig <[email protected]>
# All rights reserved.
#

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

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

testsNeedTcl     8.5
testsNeedTcltest 2.0

support {
    useAccel [useTcllibC] struct/sets.tcl struct::set
    TestAccelInit                         struct::set

}
testing {
    useLocal pt_peg_op.tcl pt::peg::op
}

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

set mytestdir data

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

TestAccelDo struct::set setimpl {
    source [localPath tests/pt_peg_op.tests]
}

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

unset mytestdir
TestAccelExit struct::set
testsuiteCleanup
return

# -*- tcl -*-
# pt_peg_export_container.test:  tests for the pt::peg::export::container
# package/plugin.
#
# Copyright (c) 2009 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: pt_peg_to_container.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $

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

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

testsNeedTcl     8.5
testsNeedTcltest 2

support {
    useAccel [useTcllibC] struct/sets.tcl  struct::set
    TestAccelInit                          struct::set

    source [localPath tests/common]
}
testing {
    useLocal pt_peg_to_container.tcl pt::peg::to::container
}

set mytestdir data

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

TestAccelDo struct::set setimpl {
    source [localPath tests/pt_peg_to_container.tests]
}

# -------------------------------------------------------------------------
TestAccelExit struct::set
testsuiteCleanup
return

# -*- tcl -*-
# pt_peg_to_cparam.test:  tests for the pt::peg::to::cparam converter package.
#
# Copyright (c) 2009 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: pt_peg_to_cparam.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $

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

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

testsNeedTcl     8.5
testsNeedTcltest 2

support {
    useAccel [useTcllibC] struct/sets.tcl struct::set ; # used by pt::pe::op,
    TestAccelInit                         struct::set ; # however not by the

    source [localPath tests/common]
}
testing {
    useLocal pt_peg_to_cparam.tcl pt::peg::to::cparam
}

set mytestdir data

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

source [localPath tests/pt_peg_to_cparam.tests]

# -------------------------------------------------------------------------
TestAccelExit struct::set
testsuiteCleanup
return

# -*- tcl -*-
# pt_peg_to_json.test:  tests for the pt::peg::to::json converter package.
#
# Copyright (c) 2009 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: pt_peg_to_json.test,v 1.2 2011/01/14 03:49:54 andreas_kupries Exp $

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

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

testsNeedTcl     8.5
testsNeedTcltest 2

support {
    use      fileutil/fileutil.tcl  fileutil      ;# tests/common
    use      textutil/adjust.tcl    textutil::adjust
    use      json/json_write.tcl    json::write

    useLocal pt_pexpression.tcl     pt::pe
    useLocal pt_pegrammar.tcl       pt::peg

    source [localPath tests/common]
}
testing {
    useLocal pt_peg_to_json.tcl pt::peg::to::json
}

set mytestdir data

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

source [localPath tests/pt_peg_to_json.tests]

# -------------------------------------------------------------------------
testsuiteCleanup
return

# -*- tcl -*-
# pt_peg_to_param.test:  tests for the pt::peg::to::param converter package.
#
# Copyright (c) 2009 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: pt_peg_to_param.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $

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

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

testsNeedTcl     8.5
testsNeedTcltest 2

support {
    use      fileutil/fileutil.tcl  fileutil      ;# tests/common
    use      textutil/adjust.tcl    textutil::adjust

    useLocal pt_pexpression.tcl     pt::pe
    useLocal pt_pegrammar.tcl       pt::peg
    useLocal text_write.tcl         text::write
    useLocal char.tcl               char

    source [localPath tests/common]
}
testing {
    useLocal pt_peg_to_param.tcl pt::peg::to::param
}

set mytestdir data

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

source [localPath tests/pt_peg_to_param.tests]

# -------------------------------------------------------------------------
testsuiteCleanup
return

# -*- tcl -*-
# pt_peg_to_peg.test:  tests for the pt::peg::to::peg converter package.
#
# Copyright (c) 2009 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: pt_peg_to_peg.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $

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

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

testsNeedTcl     8.5
testsNeedTcltest 2

support {
    useAccel [useTcllibC] struct/sets.tcl  struct::set
    TestAccelInit                          struct::set

    source [localPath tests/common]
}
testing {
    useLocal pt_peg_to_peg.tcl pt::peg::to::peg
}

set mytestdir data

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

TestAccelDo struct::set setimpl {
    source [localPath tests/pt_peg_to_peg.tests]
}

# -------------------------------------------------------------------------
TestAccelExit struct::set
testsuiteCleanup
return

# -*- tcl -*-
# pt_peg_to_tclparam.test:  tests for the pt::peg::to::tclparam converter package.
#
# Copyright (c) 2009 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: pt_peg_to_tclparam.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $

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

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

testsNeedTcl     8.5
testsNeedTcltest 2

support {
    useAccel [useTcllibC] struct/sets.tcl struct::set ; # used by pt::pe::op,
    TestAccelInit                         struct::set ; # however not by the

    source [localPath tests/common]
}
testing {
    useLocal pt_peg_to_tclparam.tcl pt::peg::to::tclparam
}

set mytestdir data

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

source [localPath tests/pt_peg_to_tclparam.tests]

# -------------------------------------------------------------------------
TestAccelExit struct::set
testsuiteCleanup
return

# -*- tcl -*-
# peg_structure.test:  tests for the pt::peg package.
#
# Copyright (c) 2009 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: pt_pegrammar.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $

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

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

testsNeedTcl     8.5
testsNeedTcltest 2.0

support {
    use fileutil/fileutil.tcl   fileutil ; # For tests/common
    use snit/snit.tcl           snit

    useLocal pt_pexpression.tcl pt::pe

    source [localPath tests/common]
}
testing {
    useLocal pt_pegrammar.tcl   pt::peg
}

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

set mytestdir data

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

source [localPath tests/pt_pegrammar.tests]

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

unset mytestdir
testsuiteCleanup
return

# -*- tcl -*-
# pe_op.test:  tests for the pt::pe::op package.
#
# Copyright (c) 2009 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: pt_pexpr_op.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $

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

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

testsNeedTcl     8.5
testsNeedTcltest 2.0

support {
    useAccel [useTcllibC] struct/sets.tcl struct::set
    TestAccelInit                         struct::set

    use fileutil/fileutil.tcl  fileutil ; # For tests/common
    use snit/snit.tcl          snit

    source [localPath tests/common]
}
testing {
    useLocal pt_pexpr_op.tcl pt::pe::op
}

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

set mytestdir data

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

TestAccelDo struct::set setimpl {
    source [localPath tests/pt_pexpr_op.tests]
}

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

unset mytestdir
TestAccelExit struct::set
testsuiteCleanup
return

# -*- tcl -*-
# pe_structure.test:  tests for the pt::pe package.
#
# Copyright (c) 2009 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: pt_pexpression.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $

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

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

testsNeedTcl     8.5
testsNeedTcltest 2.0

support {
    use fileutil/fileutil.tcl  fileutil ; # For tests/common
    use snit/snit.tcl          snit

    source [localPath tests/common]
}
testing {
    useLocal pt_pexpression.tcl pt::pe
}

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

set mytestdir data

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

source [localPath tests/pt_pexpression.tests]

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

unset mytestdir
testsuiteCleanup
return

# -*- tcl -*-
# pt_pgen.test:  Testing the parser generator, and the generated parsers.
#                Mainly for testing generated parsers for good and bad inputs.
#
# Copyright (c) 2014 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: pt_parse_peg.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $

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

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

testsNeedTcl     8.5
testsNeedTcltest 2

# Check if we have critcl available.
tcltest::testConstraint critcl [expr {![catch {package require critcl}]}]

    source [localPath tests/common]
}
testing {
    useLocal pt_pgen.tcl pt::pgen ;# Generator
}

set mytestdir data

# Table of test cases ...
#             Id PEG     InText Error detail    Readable char
set     chars  {}
lappend chars  0 \{      \{     [list t \{]     \{
lappend chars  1 \[      \[     [list t \[]     \[
lappend chars  2 \"      \"     [list t \"]     \"

# -*- tcl -*-
# pt_rdeengine.test:  tests for the pt::rde package.
#
# Copyright (c) 2009 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: pt_rdengine.test,v 1.2 2010/07/27 22:53:53 andreas_kupries Exp $

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

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

testsNeedTcl     8.5
testsNeedTcltest 2.0

support {
    useAccel [useTcllibC] struct/stack.tcl struct::stack
    TestAccelInit                          struct::stack

# -*- tcl -*-
# pt_runtime.test: tests for the pt::rde package and parsers on top
# (generated, interpreted) for various grammars and inputs.
#
# Copyright (c) 2010 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: pt_runtime.test,v 1.1 2010/07/27 22:53:53 andreas_kupries Exp $

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

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

testsNeedTcl     8.5
testsNeedTcltest 2.0

support {
    useAccel [useTcllibC] struct/stack.tcl struct::stack
    TestAccelInit                          struct::stack

# -*- tcl -*-
# pt_tclparam_config_nx.test: tests for the pt::peg::to::tclparam
# converter package configured for NX.
#
# Copyright (c) 2009 by Andreas Kupries <[email protected]>
# Copyright (c) 2016 by Stefan Sobernig <[email protected]>
# All rights reserved.
#
# -------------------------------------------------------------------------

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

testsNeedTcl     8.5
testsNeedTcltest 2

support {
    useAccel [useTcllibC] struct/sets.tcl struct::set ; # used by pt::pe::op,
    TestAccelInit                         struct::set ; # however not by the

    source [localPath tests/common]
}
testing {
    useLocal pt_tclparam_config_nx.tcl pt::tclparam::configuration::nx
}

set mytestdir data

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

source [localPath tests/pt_tclparam_config_nx.tests]

# -------------------------------------------------------------------------
TestAccelExit struct::set
testsuiteCleanup
return

# -*- tcl -*-
# pt_tclparam_config_snit.test: tests for the pt::peg::to::tclparam
# converter package configured for snit.
#
# Copyright (c) 2009 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: pt_tclparam_config_snit.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $

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

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

testsNeedTcl     8.5
testsNeedTcltest 2

support {
    useAccel [useTcllibC] struct/sets.tcl struct::set ; # used by pt::pe::op,
    TestAccelInit                         struct::set ; # however not by the

    source [localPath tests/common]
}
testing {
    useLocal pt_tclparam_config_snit.tcl pt::tclparam::configuration::snit
}

set mytestdir data

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

source [localPath tests/pt_tclparam_config_snit.tests]

# -------------------------------------------------------------------------
TestAccelExit struct::set
testsuiteCleanup
return

# -*- tcl -*-
# pt_tclparam_config_tcloo.test: tests for the pt::peg::to::tclparam
# converter package configured for tcloo.
#
# Copyright (c) 2009 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: pt_tclparam_config_tcloo.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $

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

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

testsNeedTcl     8.5
testsNeedTcltest 2

support {
    useAccel [useTcllibC] struct/sets.tcl struct::set ; # used by pt::pe::op,
    TestAccelInit                         struct::set ; # however not by the

    source [localPath tests/common]
}
testing {
    useLocal pt_tclparam_config_tcloo.tcl pt::tclparam::configuration::tcloo
}

set mytestdir data

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

source [localPath tests/pt_tclparam_config_tcloo.tests]

# -------------------------------------------------------------------------
TestAccelExit struct::set
testsuiteCleanup
return

    E destroy
} -result {A B N V}

# Tests for the various export plugins, i.e. for their use from the
# export manager. Numbering starts at 20.
# -------------------------------------------------------------------------

source [localPath pt_peg_export_plugins.tests]

# -------------------------------------------------------------------------
return

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

# Tests are run for all formats we have an export plugin for.

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

set mytestdir      data
set mytestconfig   {fox dog lazy jump}
set mytestincludes [TestFilesGlob $mytestdir]

# -------------------------------------------------------------------------
# -------------------------------------------------------------------------
# PEG markup (standard text representation).
# TODO :: templating

    I destroy
} -result {}

# Tests for the various import plugins, i.e. for their use from the
# import manager. Numbering starts at 20.
# -------------------------------------------------------------------------

source [localPath pt_peg_import_plugins.tests]

# -------------------------------------------------------------------------
return

    }

    return
}

# # ## ### ##### ######## ############# #####################

proc ::textutil::patch::Report args {
    upvar 1 reportcmd reportcmd
    uplevel #0 [list {*}$reportcmd {*}$args]
    ##
    # apply        $fname
    # fail-already $fname $hunkno
    # fail         $fname $hunkno $expected $seen
    ##

# -*- tcl -*-
# patch.test:  tests for application of `diff -ruN` patches.

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

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

testsNeedTcl     8.5
testsNeedTcltest 2

testing {
    useLocal patch.tcl textutil::patch
}

test textutil-patch-1.4 {wrong args, too many} -body {
    textutil::patch apply D S P R X
} -returnCodes error -result $m

unset m

variable scratchdir [file join [file dirname [asset pkgIndex.tcl]] scratch]

# -------------------------------------------------------------------------
## Patch application. All ok.

proc setup-scratch {} {
    variable scratchdir
    # Create a temp directory hierarchy where we can perform patch application.
    # scratch
    # \- pkgIndex.tcl

    file mkdir $scratchdir
    file copy  [asset pkgIndex.tcl] [file join $scratchdir pkgIndex.tcl]
    set ::trace {}
    return    
}

proc cleanup-scratch {} {
    variable scratchdir
    # Drop scratch area again.
    unset ::trace
    file delete -force $scratchdir
    return
}

proc record args { lappend ::trace $args }

proc recorded {} {
    variable scratchdir
    lappend ::trace === [tcltest::viewFile [file join $scratchdir pkgIndex.tcl]]
    join $::trace \n
}

foreach {tool striplevel} {
    diff-ruN    1
    git-diff    2
    fossil-diff 2
} {
    incr k
    test textutil-patch-2.$k "apply $tool" -setup {
	setup-scratch
    } -cleanup {
	cleanup-scratch
    } -body {
	# Apply patch `pkgIndex.tcl.<tool>` to `scratch/pkgIndex.tcl`.
	# The result should match `pkgIndex.tcl.patched`.
	textutil::patch apply \
	    $scratchdir $striplevel \
	    [asset-get pkgIndex.tcl.$tool] \
	    record
	recorded
    } -result [join \
		   [list \
			[list apply [file join $scratchdir pkgIndex.tcl]] \
			=== \
			[tcltest::viewFile [asset pkgIndex.tcl.patched]]] \
		   \n]
}
unset k

catch { unset trace }