Tcl Source Code

Check-in [2e7887b673]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

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

Overview
Comment:Check in reference implementation of TIP 452.

TO DO: create test for two existing Tcl procedure to demostrate the use of the package.

Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | tip-452
Files: files | file ages | folders
SHA1: 2e7887b6739220c4e6e162f50a703118a899fd78
User & Date: gerald 2017-06-08 21:49:40
Context
2017-06-10
17:06
1) Added namespace exports to tcltest namespace for new features 2) Rolled minor revision number of ... check-in: 9c86f726c0 user: gerald tags: tip-452
2017-06-08
21:49
Check in reference implementation of TIP 452.

TO DO: create test for two existing Tcl procedure to ... check-in: 2e7887b673 user: gerald tags: tip-452

20:38
Create new branch named "tip-452" check-in: 0aad28628c user: gerald tags: tip-452
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to library/init.tcl.

826
827
828
829
830
831
832















    foreach s [lsort -unique $filelist] {
	if {[file tail $s] ni {. ..}} {
	    file copy -force -- $s [file join $dest [file tail $s]]
	}
    }
    return
}





















>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
    foreach s [lsort -unique $filelist] {
	if {[file tail $s] ni {. ..}} {
	    file copy -force -- $s [file join $dest [file tail $s]]
	}
    }
    return
}


##
## TIP 452 -- start of addition
##
namespace eval ::tcltest:: {}
proc ::tcltest::seam {action seamName body} {
    if {![string equal $action "define"]} {
        return -code error -errorcode [list tcltest seam UNKACT $action] "Uknown action: '$action' -- must be 'define'"
    }
    return [uplevel 1 $body]
}
##
## TIP 452 -- end of addition
##

Changes to library/tcltest/tcltest.tcl.

3329
3330
3331
3332
3333
3334
3335




































































































































































































































































































































































































































































































































































































































































































































































































































3336
3337
3338
3339
3340
3341
3342
	thread::errorproc ThreadError
	return [llength [thread::names]]
    } else {
	return 1
    }
    return 0
}





































































































































































































































































































































































































































































































































































































































































































































































































































# Initialize the constraints and set up command line arguments
namespace eval tcltest {
    # Define initializers for all the built-in contraint definitions
    DefineConstraintInitializers

    # Set up the constraints in the testConstraints array to be lazily






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







3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
4144
4145
4146
	thread::errorproc ThreadError
	return [llength [thread::names]]
    } else {
	return 1
    }
    return 0
}


##
## Begin TIP 452
##
##
## This is a set of Tcl Test Utilities for white box testing.
##

# Module Header - as this namespace/module is modified, please be sure that
#                 you update this header block. Thanks.
#
#>>BEGIN MODULE<<
#
# Public Functions :
#   testSetup       - Defines which procedures/commands are stubbed out
#                     and how they should behave for each invocation. This should
#                     only be called once per test.
#   addStub         - Adds a procedures/commands  to the list that are stubbed out.
#   saveVars        - Saves the values of variables to be restored later. This should
#                     only be called once per test.
#   addVars         - Add a variable to the list of variables to be restored later
#   callCount       - Returns a dictionary sorted list of the stubbed out
#                     procedures and how many times they were called.
#   testCleanup     - Restores saved variables and stubbed out procedures.
#   sortedArrayData - Return the values of an array as a list of key value
#                     pairs sorted by the keys.
#   callProc        - Call the real implementation of a stubbed out procedure.
#   seam            - Test seam definition and injection (aka enabling)
#
# Public Variables : none
#
# Other Files : none
#
#>>END MODULE<<
#
###########################################################################

namespace eval ::tcltest:: {
    array set ::tcltest::TestData {}
    array set ::tcltest::SavedVars {}
    array set ::tcltest::SeamData {}
    set ::tcltest::debugLevel 0
}


###########################################################################
#
# Module Header - as this namespace/module is modified, please be sure that
#                 you update this header block. Thanks.
#
#>>BEGIN MODULE<<
#
# Module : ::tcltest::Stubbedout::
#
# Description : Namespace to hold renamed stubbed out routines
#
# Public Functions :    none
#
# Public Variables :    none
#
# Other Files : none
#
#>>END MODULE<<
###########################################################################
namespace eval ::tcltest::Stubbedout:: {}


###########################################################################
#
# Public Procedure Header - as this procedure is modified, please be sure
#                           that you update this header block. Thanks.
#
#>>BEGIN PUBLIC<<
#
# Procedure Name :  ::tcltest::Seam
#
# Description : Handle definition, activation (aka enable or injection) and
#               deactivation of a test seam.
#
# Arguments :
#   action  - must be one of:
#               define      - Define a test seam
#               activiate   - Activate a test seam and sepcify the "injected" behavior
#               deactivate  - Deactivate a test seam
#   args    - depends on the action as follows:
#               define:
#                   seamName - the name of the seam being defined. Seam names
#                               are relative to the procedure where they are
#                               defined.
#                   body     - the body of code to execute when the seam
#                               is not active
#               activiate:
#                   procName - the fully qualified procedure name the seam is in.
#                   seamName - the name of the seam being activated.
#                   body     - the body of code to execute
#               deactivate  - Deactivate a test seam
#                   procName - the fully qualified procedure name the seam is in.
#                   seamName - the name of the seam being deactivated.
#
# Returns :         1 success
#
# Side-Effects :    None
#
# Exception Conditions :
#   tcltest Seam BADARGS   - Incorrect number of arguments for the action
#   tcltest Seam UNKACT    - Uknown action
#
# Pre-requisite Conditions :    None
#
# Original Author : Gerald Lester
#
#>>END PUBLIC<<
#
###########################################################################
proc ::tcltest::seam {action args} {
    set argCount [llength $args]
    switch -exact -- $action {
        define {
            if {$argCount != 2} {
                return -code error -errorcode [list tcltest seam BADARGS $argCount] "Usage: ::tcltest::Seam define seamName body"
            }
            ::tcltest::SeamDefine {*}$args
        }
        activate {
            if {$argCount != 3} {
                return -code error -errorcode [list tcltest seam BADARGS $argCount] "Usage: ::tcltest::Seam activate procName seamName body"
            }
            ::tcltest::SeamActivate {*}$args
        }
        deactivate {
            if {$argCount != 2} {
                return -code error -errorcode [list tcltest seam BADARGS $argCount] "Usage: ::tcltest::Seam deactivate procName seamName"
            }
            ::tcltest::SeamDeactivate {*}$args
        }
        default {
            return -code error -errorcode [list tcltest seam UNKACT $action] "Uknown action: '$action' -- must be 'define, activate or deactivate'"
        }
    }

    return
}

###########################################################################
#
# Public Procedure Header - as this procedure is modified, please be sure
#                           that you update this header block. Thanks.
#
#>>BEGIN PUBLIC<<
#
# Procedure Name :  ::tcltest::testSetup
#
# Description : Setup stubs for testing.
#
# Arguments :
#   dataList    - a structured list specifing commands/procedures to stub
#                   out.  The format of each entry of the list is as follows:
#                       procName procData
#                   Where procData is structed as follows:
#                       invocationNumber behaviorDict
#                   The invocationNumber is a positive number, defining the behaviour of a
#                     given invocation, or an asterisk ("*") defining the behavior for an invocation
#                     not specified otherwise.
#                   The behaviorDict may have any of the following key value pairs:
#                       use     - this specifies what routine is to handle this invocation.
#                                 Defaults to "standard".  It must be one of the following:
#                                   standard - the standard stub processing is to be done.
#                                                The other keys in the dictionary define the behvaior.
#                                   actual   - use the actual implementation.
#                                   prefix   - use the prefix specified as a value.
#                       returns - the value of which is returned from the stub, defaults to {}.
#                       code - the value given to the -code option on return, defaults to "ok".
#                       errorcode - the value given to the -errorcode option if the code is not "ok".
#                       set - a list of triplets specifing variables to be modified and their values.
#                               This is only done for a code of "ok".  The triplets are as follows:
#                                   varName varType value
#                               Where:
#                                   varName - the name of the variable
#                                   varType - an "S" for a scalar variable and an "A" for an array
#                                   value - For a scalar, the value.
#                                           For an array, a list suitable to be used by [array set]
#
# Returns :         Nothing
#
# Side-Effects :    Clears saved stub list.
#
# Exception Conditions :    None
#
# Pre-requisite Conditions :    This may only be called once per test.
#
# Original Author : Gerald Lester
#
#>>END PUBLIC<<
###########################################################################
proc ::tcltest::testSetup {dataList} {
    variable TestData

    array unset TestData
    set TestData(stubIdx) 0
    foreach {procName procData} $dataList {
        addStub $procName $procData
    }
    return;
}


###########################################################################
#
# Public Procedure Header - as this procedure is modified, please be sure
#                           that you update this header block. Thanks.
#
#>>BEGIN PUBLIC<<
#
# Procedure Name :  ::tcltest::testSetup
#
# Description : Setup stubs for testing.
#
# Arguments :
#   procName    -- See definition in ::tcltest::testSetup
#   procData    -- See definition in ::tcltest::testSetup
#
# Returns :         Nothing
#
# Side-Effects :    None.
#
# Exception Conditions :    None
#
# Pre-requisite Conditions :    ::tcltest::testSetup must have been called
#
# Original Author : Gerald Lester
#
#>>END PUBLIC<<
###########################################################################
proc ::tcltest::addStub {procName procData} {
    variable TestData

    if {![info exists TestData($procName,count)]} {
        set idx [incr TestData(stubIdx)]
        set TestData($procName,count) 0
        set TestData($procName,idx) $idx
        set TestData($procName,data) $procData
        catch {rename $procName  ::tcltest::Stubbedout::Rtn_$idx}
        if {$procName in {puts ::puts}} {
            interp alias {} ::tcltest::puts {} ::tcltest::Stubbedout::Rtn_$idx
        }
        interp alias {} $procName {} ::tcltest::StandardStub $procName
    } else {
        set TestData($procName,data) [concat $TestData($procName,data) $procData]
    }
    ::tcltest::CreateNamespace $procName

    return;
}

###########################################################################
#
# Public Procedure Header - as this procedure is modified, please be sure
#                           that you update this header block. Thanks.
#
#>>BEGIN PUBLIC<<
#
# Procedure Name :  ::tcltest::callCount
#
# Description : Returns a dictionary sorted list of stubbed routines and
#               the number of times they were invoked.
#
# Arguments :       none
#
# Returns : A list of stubbed routines and the number of times they were invoked
#
# Side-Effects :    None
#
# Exception Conditions :    None
#
# Pre-requisite Conditions :    None
#
# Original Author : Gerald Lester
#
#>>END PUBLIC<<
#
###########################################################################
proc ::tcltest::callCount {} {
    variable TestData

    array set tmpArr [array get TestData *,count]
    return [sortedArrayData tmpArr]
}

###########################################################################
#
# Public Procedure Header - as this procedure is modified, please be sure
#                           that you update this header block. Thanks.
#
#>>BEGIN PUBLIC<<
#
# Procedure Name :  ::tcltest::sortedArrayData
#
# Description : Return the values of an array as a list of key value pairs
#               sorted by the keys.
#
# Arguments :
#   varName - name of array to process
#
# Returns : sorted list of key value pairs
#
# Side-Effects :    None
#
# Exception Conditions :    None
#
# Pre-requisite Conditions :    None
#
# Original Author : Gerald Lester
#
#>>END PUBLIC<<
#
###########################################################################
proc ::tcltest::sortedArrayData {varName} {
    upvar 1 $varName dataArray
    set results {}
    foreach var [lsort -dictionary [array names dataArray *]] {
        lappend results $var $dataArray($var)
    }
    return $results
}

###########################################################################
#
# Public Procedure Header - as this procedure is modified, please be sure
#                           that you update this header block. Thanks.
#
#>>BEGIN PUBLIC<<
#
# Procedure Name :  ::tcltest::saveVars
#
# Description : Save the values of variables to be restored at the end
#               of the current test.
#
# Arguments :
#   args    - a list of variable names to save the values of.
#
# Returns :        Nothing
#
# Side-Effects :    Clears list of saved variables
#
# Exception Conditions :    None
#
# Pre-requisite Conditions :    Should only be called once per test.
#
# Original Author : Gerald Lester
#
#>>END PUBLIC<<
#
###########################################################################
proc ::tcltest::saveVars {args} {
    variable SavedVars

    array unset SavedVars

    addVars {*}$args

    return
}


###########################################################################
#
# Public Procedure Header - as this procedure is modified, please be sure
#                           that you update this header block. Thanks.
#
#>>BEGIN PUBLIC<<
#
# Procedure Name :  ::tcltest::addVars
#
# Description : Save the values of variables to be restored at the end
#               of the current test.
#
# Arguments :
#   args    - a list of variable names to save the values of.
#
# Returns :        Nothing
#
# Side-Effects :    None
#
# Exception Conditions :    None
#
# Pre-requisite Conditions :    ::tcltest::saveVars must be called first.
#
# Original Author : Gerald Lester
#
#>>END PUBLIC<<
#
###########################################################################
proc ::tcltest::addVars {args} {
    foreach var $args {
        if {[info exists $var]} {
            if {[array exists $var]} {
                set SavedVars($var) [array get $var]
            } else {
                set SavedVars($var) [set $var]
            }
        }
        ::tcltest::CreateNamespace $var
    }
    return;
}


###########################################################################
#
# Public Procedure Header - as this procedure is modified, please be sure
#                           that you update this header block. Thanks.
#
#>>BEGIN PUBLIC<<
#
# Procedure Name :  ::tcltest::testCleanup
#
# Description : Resets saved variables, undoes alias definitions and
#               renames the saved definitions of stubbed out commands to
#               their originals.
#
# Arguments :       none
#
# Returns :         nothing
#
# Side-Effects :    Unsets the TestData and SavedVars arrays
#
# Exception Conditions :    None
#
# Pre-requisite Conditions :    None
#
# Original Author : Gerald Lester
#
#>>END PUBLIC<<
#
###########################################################################
proc ::tcltest::testCleanup {} {
    variable TestData
    variable SavedVars

    set wasErrorInfo $::errorInfo
    set wasErrorCode $::errorCode
    foreach {procRow idx} [array get TestData *,idx] {
        set procName [lindex [split $procRow {,}] 0]
        interp alias {} $procName {}
        if {$procName in {puts ::puts}} {
            interp alias {} ::tcltest::puts {}
        }
        if {![string match {::*} $procName]} {
            set procName [format {::%s} $procName]
        }
        catch {rename ::tcltest::Stubbedout::Rtn_$idx $procName}
    }
    array unset TestData

    foreach {var value} [array get SavedVars] {
        if {[info exists $var]} {
            if {[array exists $var]} {
                array set $var $value
            } else {
                set $var $value
            }
        }
    }
    array unset SavedVars

    set ::errorInfo $wasErrorInfo
    set ::errorCode $wasErrorCode
    return -errorinfo $wasErrorInfo -errorcode $wasErrorCode;
}

###########################################################################
#
# Private Procedure Header - as this procedure is modified, please be sure
#                           that you update this header block. Thanks.
#
#>>BEGIN PRIVATE<<
#
# Procedure Name :  ::tcltest::StandardStub
#
# Description : The standard stub used to replace stubbed out routines.
#               See the description of ::tcltest::testSetup for this
#               routine's behavior.
#
# Arguments :
#   procName    - the name of the stubbed out procedure
#   args        - the arguments passsed in this invocation
#
# Returns :     As defined by ::tcltest::TestData
#
# Side-Effects :    Increments the invocation count
#                       (i.e. ::tcltest::TestData($procName,count))
#                       for the stubbed out procedure
#
# Exception Conditions :    As defined by ::tcltest::TestData
#
# Pre-requisite Conditions :    None
#
# Original Author : Gerald Lester
#
#>>END PRIVATE<<
###########################################################################
proc ::tcltest::StandardStub {procName args} {
    variable TestData
    variable debugLevel

    if {[info exists debugLevel] && [string is boolean -strict $debugLevel] && $debugLevel} {
        puts stderr "Entering [info level 0]"
    }

    if {![info exists TestData($procName,count)]} {
        return \
            -code error \
            -errorcode [list tcltest StandardStub UNKPROC $procName] \
            "Undefined test: $procName"
    } else {
        set count [incr TestData($procName,count)]
    }
    if {![dict exists $TestData($procName,data) $count] &&
        ![dict exists $TestData($procName,data) {*}]} {
        return \
            -code error \
            -errorcode [list tcltest StandardStub UNKCASE [list $procName $count]] \
            "Undefined test invocation number $count for procedure: $procName"
    } elseif {[dict exists $TestData($procName,data) $count]} {
        set dataDict [dict get $TestData($procName,data) $count]
    } else {
        set dataDict [dict get $TestData($procName,data) {*}]
    }
    if {[info exists debugLevel] && [string is boolean -strict $debugLevel] && $debugLevel} {
        puts stderr "\t invocation $count.  Using $dataDict"
    }
    if {[dict exists $dataDict use]} {
        switch -exact -- [lindex [dict get $dataDict use] 0] {
            actual {
                set idx $TestData($procName,idx)

                set cmd [concat ::tcltest::Stubbedout::Rtn_$idx $args]
                set status [catch {uplevel 1 $cmd} result options]
                if {$status} {
                    return -options $options $result
                } else {
                    return $result
                }
            }
            prefix {
                set cmd [concat [dict get $dataDict use prefix] $args]
                set status [catch [list uplevel 1 $cmd] result options]
                if {$status} {
                    return -options $options $result
                } else {
                    lappend ::traceList [list Proc $procName returning $result]
                    return $result
                }
            }
            standard -
            default {
                ##
                ## Continue processing
                ##
            }
        }
    }
    if {[dict exists $dataDict returns]} {
        set result [dict get $dataDict returns]
    } else {
        set result {}
    }
    if {![dict exists $dataDict code] || ([dict get $dataDict code] eq "ok")} {
        if {[dict exists $dataDict set]} {
            foreach {varName type value} [dict get $dataDict set] {
                upvar 1 $varName dataVar
                if {$type eq "A"} {
                    array set dataVar $value
                } elseif {$type eq "S"} {
                    set dataVar $value
                } else {
                     return \
                        -code error \
                        -errorcode [list tcltest StandardStub UNKTYPE [list $procName $count $varName $type]] \
                        "Undefined type '$type' for side effect variable '$varName' in test invocation number $count for procedure: $procName"
                }
            }
        }
        return $result
    } else {
        set code [dict get $dataDict code]
        if {[dict exists $dataDict errorcode]} {
            set errorcode [dict get $dataDict errorcode]
        } else {
            set errorcode {}
        }
        return -code $code -errorcode $errorcode $result
    }
}

###########################################################################
#
# Public Procedure Header - as this procedure is modified, please be sure
#                           that you update this header block. Thanks.
#
#>>BEGIN PUBLIC<<
#
# Procedure Name :  ::tcltest::callProc
#
# Description : Call the real implementation of a stubbed out procedure.
#
# Arguments :
#   procName - The orignal name of the procedure to call
#   args     - The arguements to call it with
#
# Returns :  As returned by procedure
#
# Side-Effects : Side effects of procedure.
#
# Exception Conditions :  As raised by procedure
#
# Pre-requisite Conditions : The procedure must not query for its namespace
#                            of invcation name.
#
# Original Author : Gerald Lester
#
#>>END PUBLIC<<
#
###########################################################################
proc ::tcltest::callProc {procName args} {
    variable TestData

    set idx $TestData($procName,idx)

    set cmd [concat ::tcltest::Stubbedout::Rtn_$idx $args]
    set status [catch {uplevel 1 $cmd} result options]
    if {$status} {
        return -options $options $result
    } else {
        return $result
    }
}

###########################################################################
#
# Private Procedure Header - as this procedure is modified, please be sure
#                           that you update this header block. Thanks.
#
#>>BEGIN PRIVATE<<
#
# Procedure Name :  ::tcltest::CreateNamespace
#
# Description : Description.
#
# Arguments :
#   item    - procedure/variable whose namespace is to be created
#
# Returns :         Nothing
#
# Side-Effects :    None
#
# Exception Conditions :    None
#
# Pre-requisite Conditions :    None
#
# Original Author : Gerald Lester
#
#>>END PRIVATE<<
#
###########################################################################
proc ::tcltest::CreateNamespace {item} {
    set tmpString [string map {{::} {:}} $item]
    set nsList [lrange [split $tmpString {:}] 0 end-1]
    if {[lindex $nsList 0] eq {}} {
        set nsList [lrange $nsList 1 end]
    }
    if {[llength $nsList]} {
        set ns ::
        foreach part $nsList {
            append ns $part ::
            namespace eval $ns {}
        }
    }

    return
}


###########################################################################
#
# Private Procedure Header - as this procedure is modified, please be sure
#                           that you update this header block. Thanks.
#
#>>BEGIN PRIVATE<<
#
# Procedure Name :  ::tcltest::SeamDefine
#
# Description : Description.
#
# Arguments :       none
#
# Returns :         1 success
#
# Side-Effects :    None
#
# Exception Conditions :    None
#
# Pre-requisite Conditions :
#   This must be called from ::tcltest::Seam and not directly since the code
#   assumes it is two call levels deep.
#
# Original Author : Gerald Lester
#
#>>END PRIVATE<<
#
###########################################################################
proc ::tcltest::SeamDefine {seamName body} {
    variable SeamData

    ##
    ## Get fully qualified procedure name
    ##
    set procName "::"
    append procName [string trim [uplevel 2 {namespace current}]  {:}] "::"
    append procName [lindex [split [lindex [info level -2] 0] {:}] end]
    set SeamData($procName,$seamName,definition) $body
    if {[info exists SeamData($procName,$seamName,useBody)]} {
        set useBody $SeamData($procName,$seamName,useBody)
    } else {
        set useBody $body
    }

    return [uplevel 2 $useBody]
}


###########################################################################
#
# Private Procedure Header - as this procedure is modified, please be sure
#                           that you update this header block. Thanks.
#
#>>BEGIN PRIVATE<<
#
# Procedure Name :  ::tcltest::SeamActivate
#
# Description : Description.
#
# Arguments :       none
#
# Returns :         1 success
#
# Side-Effects :    None
#
# Exception Conditions :    None
#
# Pre-requisite Conditions :    None
#
# Original Author : Gerald Lester
#
#>>END PRIVATE<<
#
###########################################################################
proc ::tcltest::SeamActivate {procName seamName body} {
    variable SeamData

    set SeamData($procName,$seamName,useBody) $body

    return 1
}


###########################################################################
#
# Private Procedure Header - as this procedure is modified, please be sure
#                           that you update this header block. Thanks.
#
#>>BEGIN PRIVATE<<
#
# Procedure Name :  ::tcltest::SeamDeactivate
#
# Description : Description.
#
# Arguments :       none
#
# Returns :         1 success
#
# Side-Effects :    None
#
# Exception Conditions :    None
#
# Pre-requisite Conditions :    None
#
# Original Author : Gerald Lester
#
#>>END PRIVATE<<
#
###########################################################################
proc ::tcltest::SeamDeactivate {procName seamName} {
    variable SeamData

    unset -nocomplain SeamData($procName,$seamName,useBody)
    return 1
}

##
## End TIP 452
##


# Initialize the constraints and set up command line arguments
namespace eval tcltest {
    # Define initializers for all the built-in contraint definitions
    DefineConstraintInitializers

    # Set up the constraints in the testConstraints array to be lazily