Tcl Source Code

Check-in [a6272a9779]
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:Restore the core of the changes to init.tcl; TIP *specifies* that they're OK.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | tip-452
Files: files | file ages | folders
SHA3-256: a6272a97794ee1b9a58bc214b71e84af1b7867aea51bebc8df9b4da112ac8b1d
User & Date: dkf 2018-09-21 13:12:54
Context
2018-09-22
16:33
merge core-8-branch check-in: 938e58b7ab user: jan.nijtmans tags: tip-452
2018-09-21
13:12
Restore the core of the changes to init.tcl; TIP *specifies* that they're OK. check-in: a6272a9779 user: dkf tags: tip-452
2018-09-16
15:14
Undo TIP #452 change to library/init.tcl: It depends on tcltest, which shouldn't be there yet check-in: 8bbc67839c user: jan.nijtmans tags: tip-452
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to library/init.tcl.

794
795
796
797
798
799
800










801
802
803
804
805
806
807
    foreach s [lsort -unique $filelist] {
	if {[file tail $s] ni {. ..}} {
	    file copy -force -- $s [file join $dest [file tail $s]]
	}
    }
    return
}











set isafe [interp issafe]
###
# Package manifest for all Tcl packages included in the /library file system
###
set isafe [interp issafe]
set dir [file dirname [info script]]






>
>
>
>
>
>
>
>
>
>







794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
    foreach s [lsort -unique $filelist] {
	if {[file tail $s] ni {. ..}} {
	    file copy -force -- $s [file join $dest [file tail $s]]
	}
    }
    return
}

## TIP 452 hack --
##	Creates a stub for part of tcltest to let code use one specific
##	operation without needing to explicitly import the tcltest package.
##
namespace eval ::tcltest {
    namespace ensemble create -command seam -map {
	define {::apply {{seamName body} {tailcall if true $body}}}
    }
}

set isafe [interp issafe]
###
# Package manifest for all Tcl packages included in the /library file system
###
set isafe [interp issafe]
set dir [file dirname [info script]]

Changes to library/tcltest/tcltest.tcl.

2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
....
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
....
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
....
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
....
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
....
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
....
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
....
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
....
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
4147
4148
4149
4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160
4161
4162
4163
4164
4165
4166
4167
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199

4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225

4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247

4248
4249

4250
4251
4252
4253
4254
4255
4256
4257
4258
4259
4260
4261
4262
4263
4264
4265
4266
4267
4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282

4283
4284
4285
4286
4287
4288
4289
4290
4291
4292
4293
4294
4295
4296
4297
4298
4299
4300
4301
4302
4303
4304
4305
4306
4307
....
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
4323
4324
4325
4326
4327
4328
#####################################################################

# Test utility procs - not used in tcltest, but may be useful for
# testing.

# tcltest::loadTestedCommands --
#
#     Uses the specified script to load the commands to test. Allowed to
#     be empty, as the tested commands could have been compiled into the
#     interpreter.
#
# Arguments
#     none
#
# Results
#     none
#
# Side Effects:
#     none.

proc tcltest::loadTestedCommands {} {
    return [uplevel 1 [loadScript]]
}

# tcltest::saveState --
#
................................................................................
	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

   namespace export testSetup addStub saveVars addVars
   namespace export callCount testCleanup sortedArrayData callProc seam

}


###########################################################################
#
# 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)]} {
................................................................................
        }
        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

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

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

##
## Add in the TclOO support
##

oo::class create ::tcltest::object {

  # An independant constructor that tcltest can control
  constructor args {
    my variable tcltest
    set tcltest(mixinmap) {}
    my tcltest_configure {*}$args
  }

  destructor {
    my variable tcltest
    if {[info exists tcltest(destructor)]} {
      eval $tcltest(destructor)
    } else {
      next
    }
  }

  method tcltest_destructor body {
    my variable tcltest
    set tcltest(destructor) $body
  }

  # A means of controlling the tcltest framework class
  # Note the method names are designed to minimize conflict
  # with existing classes
  method tcltest_configure args {
    foreach {key value} $args {
      switch [string trimleft $key -] {
        class {
          set tcltest(class) $value
          my tcltest_morph $value
        }
        eval {
          eval $value
        }
        destructor {
          my tcltest_destructor $value
        }
      }
    }
  }

  method tcltest_set args {
    my variable tcltest
    array set tcltest $args
  }

  method tcltest_morph classname {
    my variable tcltest
    if {[info commands ::tcltest::hybrid::$classname] eq {}} {
      oo::class create ::tcltest::hybrid::$classname [list superclass ::tcltest::object $classname]

    }
    set tcltest(class) $classname
    ::oo::objdefine [self] class ::tcltest::hybrid::$classname
    if {[info exists tcltest(mixinmap)]} {
      my Tcltest_mixin_apply $tcltest(mixinmap)
    }
  }

  # A method to allow tcltest to invoke code internally to
  # objects. Including access to private methods and variables
  method tcltest_eval script {
    eval $script
  }

  method Tcltest_mixin_apply {map} {
    set mixlist {}
    foreach {s c} $map {
      if {$c eq {}} continue
      lappend mixlist $c
    }
    ::oo::objdefine [self] mixin {*}$mixlist
  }

  # A formalized slot-based mechanism for managing mixins. Because we
  # break the space up into slots, individual aspects of behavior
  # can be added, removed, and combined with other mixins.

  # We use a dict internally for storage to allow the order in which mixins
  # were applied to be preserved. Not the difference between:
  # tcltest_mixin map FOO {}
  # and
  # tcltest_mixin unmap FOO
  #
  # A blank mapping will removed the effect, but preserve FOO's place in line
  # Unmap removes the concept completely.
  #
  method tcltest_mixin {command args} {
    my variable tcltest
    switch $command {
      dump {
        return $tcltest(mixinmap)
      }
      map {
        if {[llength $args]!=2} {
          error "Usage: [self method] map STUB CLASS"
        }
        lassign $args stub class
        # Placed here as a safety in case the before or after did not actually exist
        # And it's a handy place to make the call even if we didn't use before/after

        dict set tcltest(mixinmap) $stub $class
        # Build the list of classes to mixin, in the order proscribed by the dict

        my Tcltest_mixin_apply $tcltest(mixinmap)
      }
      replace {
        # Allows users to specify the order of mixins
        # Note we always include ::tcltest::object
        set tcltest(mixinmap) $args
        my Tcltest_mixin_apply $tcltest(mixinmap)
      }
      unmap {
        if {[llength $args]!=1} {
          error "Usage: mixinmap unmap STUB"
        }
        lassign $args stub
        if {[dict exists $tcltest(mixinmap) $stub]} {
          dict unset tcltest(mixinmap) $stub
        }
        my Tcltest_mixin_apply $tcltest(mixinmap)
      }
      default {
        error "Valid commands are: dump, map, replace, unmap"
      }
    }
  }
}

##
## Define the "Static" methods on the ::tcltest::object
##
oo::objdefine ::tcltest::object {
  method hijack object {
    set classname [info object class $object]
    if {[info commands ::tcltest::hybrid::$classname] eq {}} {
      oo::class create ::tcltest::hybrid::$classname [list superclass ::tcltest::object $classname]

    }
    ::oo::objdefine $object class ::tcltest::hybrid::$classname
    $object tcltest_set class $classname
  }
}

##
## Add in the "easy to use" command
##
namespace eval ::tcltest:: {
    array set ::tcltest::SavedObjectDefinitions {
        constructor {}
        destructor  {}
    }

    proc  testObject {name description class args} {
        if {([llength $args] % 2) != 0 } {
            return -code error {Unpaired options and values.}
        }
        array set optionArr {
            -objectVar cut
            -arguments {}
            -stubs {}
        }
        array set optionArr $args
................................................................................

        set consList [info class constructor $class]
        if {![info exists optionArr(-constructor)]} {
            set optionArr(-constructor) [lindex $consList 1]
        }
        set consScript {}
        if {[llength [lindex $consList 0]]} {
            append consScript \
                [format {lassign {%s} %s} $optionArr(-arguments) [lindex $consList 0]] \
                "\n"
        }
        append consScript $optionArr(-constructor)

        if {![info exists optionArr(-destructor)]} {
            set optionArr(-destructor) [info class destructor $class]
        }
    }






|
|
|

|
|

|
|


|







 







|
<












|
|
|

|
>
|
|
|
>








|

|













|
<
<








|

|

|

|

|



<

>








|

|


|
|
|
|
|
|
|
|
|
<
|
<
<
>
|
|
|
|
|
|

|

|

|
|
>
>
|

|

|




|
|
<
<
<
<
<
|
<
<
<
<
<
|
<
<
<
<
<
|
|
<
<
<
<
<
<









|

|

|
|
|
|
|
|
>
|
|
|
>
|
>
|
|
>
>
|
>
>
|

|
>
>
|
>
|
>
|
<
>
>
>
|
>
|
>

|
|
>
|
|
>

|

|

|

|

|











|

<








|

|

|



|

|

|

|

|







 







|









|

|
|

|
>

>
|

|
>

|
>

|
>

|







 







|

|
|

|


>
|

|
>

|
>

|
>

|







 







|

|
|


|

|
>

>
|

|
>

>
|

|








<

<


<








|

|
|


|

|
>

|
>

|
>

>
|

|







 







|

<








|

|
|
|

|
>

|
>

>
|

|
>

|
>

|







 







|









|

|
|
|


|
|

>
|

>
|
|
<

>
|

|
>

|







|




<
|


<
>
|
|
|
>
|
|
>
|

|
<
|
<
<

>
|






<




<
<

>






<
>
|
|
<







 







<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








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









|

|


|
|

>
|

>
|

|
>

>
|
<

|







 







|

|


|

|
>

|
>

|
>

|
>

|







 







<







|

|

|
>

|
>

|
>

|
>

|
<
<
>

|











|
|

>






|

<








|

|

|
>

|
>

|
>

|
>

|
>

|






<

<


<








|

|

|
>

|
>

|
>

|
>

|
>

|






<









<
|
|
|
|
|
|

|
|
|
|
|
|
|
|

|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|

|
|
|
|
>
|
|
|
|
|
|
|

|
|
|
|
|

|
|
|
|
|
|
|
|

|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|






|
|
|
|
>
|
|
|
|











|

|







 







|
|
<







2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
....
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
....
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
....
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
....
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
....
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
....
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
....
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
....
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
4147
4148
4149
4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160
4161
4162
4163
4164
4165
4166
4167
4168
4169

4170
4171
4172
4173
4174
4175
4176
4177
4178

4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
4249
4250
4251
4252
4253
4254
4255
4256
4257
4258
4259
4260
4261
4262
4263
4264
4265
4266
4267
4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282
4283
4284
4285
4286
4287
4288
4289
4290
4291
4292
4293
4294
4295
4296
4297
4298
4299
4300
4301
4302
4303
4304
4305
4306
4307
4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
4323
4324
4325
4326
4327
4328
4329
4330
4331
4332
4333
4334
4335
4336
4337
4338
4339
4340
4341
....
4346
4347
4348
4349
4350
4351
4352
4353
4354

4355
4356
4357
4358
4359
4360
4361
#####################################################################

# Test utility procs - not used in tcltest, but may be useful for
# testing.

# tcltest::loadTestedCommands --
#
#	Uses the specified script to load the commands to test. Allowed to
#	be empty, as the tested commands could have been compiled into the
#	interpreter.
#
# Arguments:
#	none
#
# Results:
#	none
#
# Side Effects:
#	none

proc tcltest::loadTestedCommands {} {
    return [uplevel 1 [loadScript]]
}

# tcltest::saveState --
#
................................................................................
	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

   namespace export testSetup addStub saveVars addVars
   namespace export callCount testCleanup sortedArrayData callProc seam
}



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


#	activate:
#	    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:
#   TCL WRONGARGS          - Incorrect number of arguments for the action
#   TCL LOOKUP SUBCOMMAND  - Unknown action
#
#   NB: Subcommand implementations may raise other exceptions.
#
# Pre-requisite Conditions:    None
#
# Original Author: Gerald Lester
#
#>>END PUBLIC<<
#
###########################################################################
namespace eval ::tcltest {
    namespace ensemble create -command seam -map {





	define     ::tcltest::SeamDefine





	activate   ::tcltest::SeamActivate





	deactivate ::tcltest::SeamDeactivate
    }






}

###########################################################################
#
# 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
#                                              behavior.
#                                   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 specifying 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)]} {
................................................................................
        }
        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

................................................................................
###########################################################################
#
# 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 {}
................................................................................
###########################################################################
#
# 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]} {
................................................................................
                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
................................................................................
            }
        }
    }
    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., the variable
#	::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 true -strict $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"

    }
    set count [incr TestData($procName,count)]

    if {[dict exists $TestData($procName,data) $count]} {
        set dataDict [dict get $TestData($procName,data) $count]
    } elseif {[dict exists $TestData($procName,data) {*}]} {
        set dataDict [dict get $TestData($procName,data) {*}]
    } else {
        return -code error \
            -errorcode [list tcltest StandardStub UNKCASE [list $procName $count]] \
            [format "Undefined test invocation number %s for procedure: %s" \

		 $count $procName]


    }

    if {[info exists debugLevel] && [string is true -strict $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


                }
		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

                }
		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] ni {0 ok}} {
















        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
    }
    if {[dict exists $dataDict set]} {
	foreach {varName type value} [dict get $dataDict set] {
	    upvar 1 $varName dataVar
	    switch $type {
		A {
		    array set dataVar $value
		}
		S {
		    set dataVar $value
		}
		default {
		    return -code error \
			-errorcode [list tcltest StandardStub UNKTYPE \
					[list $procName $count $varName $type]] \
			[format "Undefined type '%s' for side effect variable '%s' in test invocation number %s for procedure: %s" \
			     $type $varName $count $procName]
		}
	    }
	}
    }
    return $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 invocation name.

#
# Original Author: Gerald Lester
#
#>>END PUBLIC<<
#
###########################################################################
proc ::tcltest::callProc {procName args} {
    variable TestData

................................................................................
###########################################################################
#
# 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]
................................................................................
            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:


#	None
#
# 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 1 {namespace current}] ":"] "::"
    append procName [lindex [split [lindex [info level -1] 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 1 $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: Implementation of [::tcltest::seam activate]
#
# 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: Implementation of [::tcltest::seam deactivate]
#
# 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
}

##
## Add in the TclOO support
##

oo::class create ::tcltest::object {

    # An independant constructor that tcltest can control
    constructor args {
	my variable tcltest
	set tcltest(mixinmap) {}
	my tcltest_configure {*}$args
    }

    destructor {
	my variable tcltest
	if {[info exists tcltest(destructor)]} {
	    eval $tcltest(destructor)
	} else {
	    next
	}
    }

    method tcltest_destructor body {
	my variable tcltest
	set tcltest(destructor) $body
    }

    # A means of controlling the tcltest framework class
    # Note the method names are designed to minimize conflict
    # with existing classes
    method tcltest_configure args {
	foreach {key value} $args {
	    switch [string trimleft $key -] {
		class {
		    set tcltest(class) $value
		    my tcltest_morph $value
		}
		eval {
		    eval $value
		}
		destructor {
		    my tcltest_destructor $value
		}
	    }
	}
    }

    method tcltest_set args {
	my variable tcltest
	array set tcltest $args
    }

    method tcltest_morph classname {
	my variable tcltest
	if {[info commands ::tcltest::hybrid::$classname] eq {}} {
	    oo::class create ::tcltest::hybrid::$classname [list \
		superclass ::tcltest::object $classname]
	}
	set tcltest(class) $classname
	::oo::objdefine [self] class ::tcltest::hybrid::$classname
	if {[info exists tcltest(mixinmap)]} {
	    my Tcltest_mixin_apply $tcltest(mixinmap)
	}
    }

    # A method to allow tcltest to invoke code internally to objects.
    # Including access to private methods and variables
    method tcltest_eval script {
	eval $script
    }

    method Tcltest_mixin_apply {map} {
	set mixlist {}
	foreach {s c} $map {
	    if {$c eq {}} continue
	    lappend mixlist $c
	}
	::oo::objdefine [self] mixin {*}$mixlist
    }

    # A formalized slot-based mechanism for managing mixins. Because we break
    # the space up into slots, individual aspects of behavior can be added,
    # removed, and combined with other mixins.
    #
    # We use a dict internally for storage to allow the order in which mixins
    # were applied to be preserved. Note the difference between:
    #	tcltest_mixin map FOO {}
    # and
    #	tcltest_mixin unmap FOO
    #
    # A blank mapping will removed the effect, but preserve FOO's place in line
    # Unmap removes the concept completely.
    #
    method tcltest_mixin {command args} {
	my variable tcltest
	switch $command {
	    dump {
		return $tcltest(mixinmap)
	    }
	    map {
		if {[llength $args]!=2} {
		    error "Usage: [self method] map STUB CLASS"
		}
		lassign $args stub class
		# Placed here as a safety in case the before or after did not
		# actually exist, and it's a handy place to make the call even
		# if we didn't use before/after
		dict set tcltest(mixinmap) $stub $class
		# Build the list of classes to mixin, in the order proscribed
		# by the dict
		my Tcltest_mixin_apply $tcltest(mixinmap)
	    }
	    replace {
		# Allows users to specify the order of mixins
		# Note we always include ::tcltest::object
		set tcltest(mixinmap) $args
		my Tcltest_mixin_apply $tcltest(mixinmap)
	    }
	    unmap {
		if {[llength $args]!=1} {
		    error "Usage: mixinmap unmap STUB"
		}
		lassign $args stub
		if {[dict exists $tcltest(mixinmap) $stub]} {
		    dict unset tcltest(mixinmap) $stub
		}
		my Tcltest_mixin_apply $tcltest(mixinmap)
	    }
	    default {
		error "Valid commands are: dump, map, replace, unmap"
	    }
	}
    }
}

##
## Define the "Static" methods on the ::tcltest::object
##
oo::objdefine ::tcltest::object {
    method hijack object {
	set classname [info object class $object]
	if {[info commands ::tcltest::hybrid::$classname] eq {}} {
	    oo::class create ::tcltest::hybrid::$classname [list \
		superclass ::tcltest::object $classname]
	}
	::oo::objdefine $object class ::tcltest::hybrid::$classname
	$object tcltest_set class $classname
    }
}

##
## Add in the "easy to use" command
##
namespace eval ::tcltest:: {
    array set ::tcltest::SavedObjectDefinitions {
        constructor {}
        destructor  {}
    }

    proc testObject {name description class args} {
        if {([llength $args] % 2) != 0 } {
            return -code error "Unpaired options and values"
        }
        array set optionArr {
            -objectVar cut
            -arguments {}
            -stubs {}
        }
        array set optionArr $args
................................................................................

        set consList [info class constructor $class]
        if {![info exists optionArr(-constructor)]} {
            set optionArr(-constructor) [lindex $consList 1]
        }
        set consScript {}
        if {[llength [lindex $consList 0]]} {
            append consScript [format "lassign %s %s\n" \
		    [list $optionArr(-arguments)] [lindex $consList 0]]

        }
        append consScript $optionArr(-constructor)

        if {![info exists optionArr(-destructor)]} {
            set optionArr(-destructor) [info class destructor $class]
        }
    }