Tcl Source Code

Check-in [b21b173086]
Login

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

Overview
Comment:Fixed bugs 1521, 1578, 1608--tests were failing due to bad test construction and failure to use constraints.
Downloads: Tarball | ZIP archive
Timelines: family | ancestors | descendants | both | core-8-1-branch-old
Files: files | file ages | folders
SHA1: b21b17308673042af5530207c2b59eb561110e02
User & Date: hershey 1999-03-25 04:32:16.000
Context
1999-03-25
17:20
defs: lint io.test: fix for bug 1580--"after 100" calls in test scripts were not waiting long ... check-in: 5c981db38c user: hershey tags: core-8-1-branch-old
04:32
Fixed bugs 1521, 1578, 1608--tests were failing due to bad test construction and failure to use cons... check-in: b21b173086 user: hershey tags: core-8-1-branch-old
03:55
* tests/execute.test: * generic/tclExecute.c (TclExecuteByteCode): Fixed expression code that incorr... check-in: d1a8033603 user: stanton tags: core-8-1-branch-old
Changes
Unified Diff Ignore Whitespace Patch
Changes to tests/basic.test.
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: basic.test,v 1.1.2.5 1999/03/24 02:48:57 hershey Exp $
#

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {namespace delete test_ns_basic}







|







11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: basic.test,v 1.1.2.6 1999/03/25 04:32:16 hershey Exp $
#

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {namespace delete test_ns_basic}
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
            }
        }
    }
    list [interp eval test_interp {test_ns_basic::p}] \
         [interp delete test_interp]
} {::test_ns_basic {}}

test basic-2.1 {TclHideUnsafeCommands} {
} {}

test basic-3.1 {Tcl_CallWhenDeleted: see dcall.test} {
} {}

test basic-4.1 {Tcl_DontCallWhenDeleted: see dcall.test} {
} {}

test basic-5.1 {Tcl_SetAssocData: see assoc.test} {
} {}

test basic-6.1 {Tcl_DeleteAssocData: see assoc.test} {
} {}

test basic-7.1 {Tcl_GetAssocData: see assoc.test} {
} {}

test basic-8.1 {Tcl_InterpDeleted} {
} {}

test basic-9.1 {Tcl_DeleteInterp: see interp.test} {
} {}

test basic-10.1 {DeleteInterpProc, destroys interp's global namespace} {
    catch {interp delete test_interp}
    interp create test_interp
    interp eval test_interp {
        namespace eval test_ns_basic {







|


|


|


|


|


|


|


|







39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
            }
        }
    }
    list [interp eval test_interp {test_ns_basic::p}] \
         [interp delete test_interp]
} {::test_ns_basic {}}

test basic-2.1 {TclHideUnsafeCommands} {emptyTest} {
} {}

test basic-3.1 {Tcl_CallWhenDeleted: see dcall.test} {emptyTest} {
} {}

test basic-4.1 {Tcl_DontCallWhenDeleted: see dcall.test} {emptyTest} {
} {}

test basic-5.1 {Tcl_SetAssocData: see assoc.test} {emptyTest} {
} {}

test basic-6.1 {Tcl_DeleteAssocData: see assoc.test} {emptyTest} {
} {}

test basic-7.1 {Tcl_GetAssocData: see assoc.test} {emptyTest} {
} {}

test basic-8.1 {Tcl_InterpDeleted} {emptyTest} {
} {}

test basic-9.1 {Tcl_DeleteInterp: see interp.test} {emptyTest} {
} {}

test basic-10.1 {DeleteInterpProc, destroys interp's global namespace} {
    catch {interp delete test_interp}
    interp create test_interp
    interp eval test_interp {
        namespace eval test_ns_basic {
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
    proc test_ns_basic::cmd {} {  ;# proc requires that ns already exist
        return [namespace current]
    }
    list [test_ns_basic::cmd] \
         [namespace delete test_ns_basic]
} {::test_ns_basic {}}

test basic-16.1 {TclInvokeStringCommand} {
} {}

test basic-17.1 {TclInvokeObjCommand} {
} {}

test basic-18.1 {TclRenameCommand, name of existing cmd can have namespace qualifiers} {
    catch {eval namespace delete [namespace children :: test_ns_*]}
    catch {rename cmd ""}
    namespace eval test_ns_basic {
        proc p {} {







|


|







222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
    proc test_ns_basic::cmd {} {  ;# proc requires that ns already exist
        return [namespace current]
    }
    list [test_ns_basic::cmd] \
         [namespace delete test_ns_basic]
} {::test_ns_basic {}}

test basic-16.1 {TclInvokeStringCommand} {emptyTest} {
} {}

test basic-17.1 {TclInvokeObjCommand} {emptyTest} {
} {}

test basic-18.1 {TclRenameCommand, name of existing cmd can have namespace qualifiers} {
    catch {eval namespace delete [namespace children :: test_ns_*]}
    catch {rename cmd ""}
    namespace eval test_ns_basic {
        proc p {} {
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
        }
    }
    list [test_ns_basic::callP] \
         [rename q test_ns_basic::p] \
         [test_ns_basic::callP]
} {{p in ::} {} {q in ::test_ns_basic}}

test basic-19.1 {Tcl_SetCommandInfo} {
} {}

if {[info commands testcmdtoken] == {}} {
    puts "This application hasn't been compiled with the \"testcmdtoken\""
    puts "command, so I can't test Tcl_GetCommandInfo."
} else {
test basic-20.1 {Tcl_GetCommandInfo, names for commands created inside namespaces} {







|







292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
        }
    }
    list [test_ns_basic::callP] \
         [rename q test_ns_basic::p] \
         [test_ns_basic::callP]
} {{p in ::} {} {q in ::test_ns_basic}}

test basic-19.1 {Tcl_SetCommandInfo} {emptyTest} {
} {}

if {[info commands testcmdtoken] == {}} {
    puts "This application hasn't been compiled with the \"testcmdtoken\""
    puts "command, so I can't test Tcl_GetCommandInfo."
} else {
test basic-20.1 {Tcl_GetCommandInfo, names for commands created inside namespaces} {
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
    set x [testcmdtoken create test_ns_basic::test_ns_basic2::p]
    list [testcmdtoken name $x] \
         [rename test_ns_basic::test_ns_basic2::p q] \
         [testcmdtoken name $x]
} {{p ::test_ns_basic::test_ns_basic2::p} {} {q ::q}}
}

test basic-21.1 {Tcl_GetCommandName} {
} {}

test basic-22.1 {Tcl_GetCommandFullName} {
    catch {eval namespace delete [namespace children :: test_ns_*]}
    namespace eval test_ns_basic1 {
        namespace export cmd*
        proc cmd1 {} {}







|







321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
    set x [testcmdtoken create test_ns_basic::test_ns_basic2::p]
    list [testcmdtoken name $x] \
         [rename test_ns_basic::test_ns_basic2::p q] \
         [testcmdtoken name $x]
} {{p ::test_ns_basic::test_ns_basic2::p} {} {q ::q}}
}

test basic-21.1 {Tcl_GetCommandName} {emptyTest} {
} {}

test basic-22.1 {Tcl_GetCommandFullName} {
    catch {eval namespace delete [namespace children :: test_ns_*]}
    namespace eval test_ns_basic1 {
        namespace export cmd*
        proc cmd1 {} {}
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
             [namespace which -command q] \
             [namespace which -command p] \
             [namespace which -command cmd1] \
             [namespace which -command ::test_ns_basic2::cmd2]
    }
} {::foreach ::test_ns_basic3::q ::test_ns_basic3::p ::test_ns_basic3::cmd1 ::test_ns_basic2::cmd2}

test basic-23.1 {Tcl_DeleteCommand} {
} {}

test basic-24.1 {Tcl_DeleteCommandFromToken, invalidate all compiled code if cmd has compile proc} {
    catch {interp delete test_interp}
    catch {unset x}
    interp create test_interp
    interp eval test_interp {







|







347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
             [namespace which -command q] \
             [namespace which -command p] \
             [namespace which -command cmd1] \
             [namespace which -command ::test_ns_basic2::cmd2]
    }
} {::foreach ::test_ns_basic3::q ::test_ns_basic3::p ::test_ns_basic3::cmd1 ::test_ns_basic2::cmd2}

test basic-23.1 {Tcl_DeleteCommand} {emptyTest} {
} {}

test basic-24.1 {Tcl_DeleteCommandFromToken, invalidate all compiled code if cmd has compile proc} {
    catch {interp delete test_interp}
    catch {unset x}
    interp create test_interp
    interp eval test_interp {
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
    list [test_ns_basic2::callP] \
         [info commands test_ns_basic2::*] \
         [rename test_ns_basic::p ""] \
         [catch {test_ns_basic2::callP} msg] $msg \
         [info commands test_ns_basic2::*]
} {42 {::test_ns_basic2::callP ::test_ns_basic2::p} {} 1 {invalid command name "p"} ::test_ns_basic2::callP}

test basic-25.1 {TclCleanupCommand} {
} {}

test basic-26.1 {Tcl_EvalObj: preserve object while evaling it} {
    # If object isn't preserved, errorInfo would be set to
    # "foo\n    while executing\n\"garbage bytes\"" because the object's
    # string would have been freed, leaving garbage bytes for the error
    # message.

    proc bgerror {args} {set ::x $::errorInfo}
    set f [open test1 w]
    fileevent $f writable "fileevent $f writable {}; error foo"
    set x {}
    vwait x
    close $f
    file delete test1
    rename bgerror {}
    set x
} "foo\n    while executing\n\"error foo\""

test basic-27.1 {Tcl_ExprLong} {
} {}

test basic-28.1 {Tcl_ExprDouble} {
} {}

test basic-29.1 {Tcl_ExprBoolean} {
} {}

test basic-30.1 {Tcl_ExprLongObj} {
} {}

test basic-31.1 {Tcl_ExprDoubleObj} {
} {}

test basic-32.1 {Tcl_ExprBooleanObj} {
} {}

test basic-33.1 {TclInvoke} {
} {}

test basic-34.1 {TclGlobalInvoke} {
} {}

test basic-35.1 {TclObjInvokeGlobal} {
} {}

test basic-36.1 {TclObjInvoke, lookup of "unknown" command} {
    catch {eval namespace delete [namespace children :: test_ns_*]}
    catch {interp delete test_interp}
    interp create test_interp
    interp eval test_interp {







|



















|


|


|


|


|


|


|


|


|







408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
    list [test_ns_basic2::callP] \
         [info commands test_ns_basic2::*] \
         [rename test_ns_basic::p ""] \
         [catch {test_ns_basic2::callP} msg] $msg \
         [info commands test_ns_basic2::*]
} {42 {::test_ns_basic2::callP ::test_ns_basic2::p} {} 1 {invalid command name "p"} ::test_ns_basic2::callP}

test basic-25.1 {TclCleanupCommand} {emptyTest} {
} {}

test basic-26.1 {Tcl_EvalObj: preserve object while evaling it} {
    # If object isn't preserved, errorInfo would be set to
    # "foo\n    while executing\n\"garbage bytes\"" because the object's
    # string would have been freed, leaving garbage bytes for the error
    # message.

    proc bgerror {args} {set ::x $::errorInfo}
    set f [open test1 w]
    fileevent $f writable "fileevent $f writable {}; error foo"
    set x {}
    vwait x
    close $f
    file delete test1
    rename bgerror {}
    set x
} "foo\n    while executing\n\"error foo\""

test basic-27.1 {Tcl_ExprLong} {emptyTest} {
} {}

test basic-28.1 {Tcl_ExprDouble} {emptyTest} {
} {}

test basic-29.1 {Tcl_ExprBoolean} {emptyTest} {
} {}

test basic-30.1 {Tcl_ExprLongObj} {emptyTest} {
} {}

test basic-31.1 {Tcl_ExprDoubleObj} {emptyTest} {
} {}

test basic-32.1 {Tcl_ExprBooleanObj} {emptyTest} {
} {}

test basic-33.1 {TclInvoke} {emptyTest} {
} {}

test basic-34.1 {TclGlobalInvoke} {emptyTest} {
} {}

test basic-35.1 {TclObjInvokeGlobal} {emptyTest} {
} {}

test basic-36.1 {TclObjInvoke, lookup of "unknown" command} {
    catch {eval namespace delete [namespace children :: test_ns_*]}
    catch {interp delete test_interp}
    interp create test_interp
    interp eval test_interp {
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
        }
    }
    list [interp alias test_interp newAlias test_interp doesntExist] \
         [catch {interp eval test_interp {newAlias}} msg] $msg \
         [interp delete test_interp]
} {newAlias 0 {global unknown} {}}

test basic-37.1 {Tcl_ExprString: see expr.test} {
} {}

test basic-38.1 {Tcl_ExprObj} {
} {}

if {[info commands testcmdtrace] == {}} {
    puts "This application hasn't been compiled with the \"testcmdtrace\""
    puts "command, so I can't test Tcl_CreateTrace."
} else {
test basic-39.1 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {
    testcmdtrace tracetest {set stuff [expr 14 + 16]}
} {{expr 14 + 16} {expr 14 + 16} {set stuff [expr 14 + 16]} {set stuff 30}}
test basic-39.2 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {
    testcmdtrace tracetest {set stuff [info tclversion]}
} {{info tclversion} {info tclversion} {set stuff [info tclversion]} {set stuff 8.1}}
test basic-39.3 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {
    testcmdtrace deletetest {set stuff [info tclversion]}
} 8.1
}

test basic-40.1 {Tcl_DeleteTrace} {
} {}

test basic-41.1 {Tcl_AddErrorInfo} {
} {}

test basic-42.1 {Tcl_AddObjErrorInfo} {
} {}

test basic-43.1 {Tcl_VarEval} {
} {}

test basic-44.1 {Tcl_GlobalEval} {
} {}

test basic-45.1 {Tcl_SetRecursionLimit: see interp.test} {
} {}

test basic-46.1 {Tcl_AllowExceptions} {
} {}

# cleanup
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {namespace delete george}
catch {interp delete test_interp}
catch {rename p ""}







|


|

















|


|


|


|


|


|


|







474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
        }
    }
    list [interp alias test_interp newAlias test_interp doesntExist] \
         [catch {interp eval test_interp {newAlias}} msg] $msg \
         [interp delete test_interp]
} {newAlias 0 {global unknown} {}}

test basic-37.1 {Tcl_ExprString: see expr.test} {emptyTest} {
} {}

test basic-38.1 {Tcl_ExprObj} {emptyTest} {
} {}

if {[info commands testcmdtrace] == {}} {
    puts "This application hasn't been compiled with the \"testcmdtrace\""
    puts "command, so I can't test Tcl_CreateTrace."
} else {
test basic-39.1 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {
    testcmdtrace tracetest {set stuff [expr 14 + 16]}
} {{expr 14 + 16} {expr 14 + 16} {set stuff [expr 14 + 16]} {set stuff 30}}
test basic-39.2 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {
    testcmdtrace tracetest {set stuff [info tclversion]}
} {{info tclversion} {info tclversion} {set stuff [info tclversion]} {set stuff 8.1}}
test basic-39.3 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {
    testcmdtrace deletetest {set stuff [info tclversion]}
} 8.1
}

test basic-40.1 {Tcl_DeleteTrace} {emptyTest} {
} {}

test basic-41.1 {Tcl_AddErrorInfo} {emptyTest} {
} {}

test basic-42.1 {Tcl_AddObjErrorInfo} {emptyTest} {
} {}

test basic-43.1 {Tcl_VarEval} {emptyTest} {
} {}

test basic-44.1 {Tcl_GlobalEval} {emptyTest} {
} {}

test basic-45.1 {Tcl_SetRecursionLimit: see interp.test} {emptyTest} {
} {}

test basic-46.1 {Tcl_AllowExceptions} {emptyTest} {
} {}

# cleanup
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {namespace delete george}
catch {interp delete test_interp}
catch {rename p ""}
Changes to tests/io.test.
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: io.test,v 1.1.2.10 1999/03/24 02:49:18 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {"[info commands testchannel]" != "testchannel"} {
    puts "Skipping io tests. This application does not seem to have the"







|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: io.test,v 1.1.2.11 1999/03/25 04:32:17 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {"[info commands testchannel]" != "testchannel"} {
    puts "Skipping io tests. This application does not seem to have the"
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81

82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105

106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130

131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
    vwait forever
} cat

set thisScript [file join $::tcltest::testsDir [info script]]

# These tests are disabled until we decide what to do with "unsupported0".
#
#test io-1.1 {unsupported0 command} {
#    removeFile test1
#    set f1 [open iocmd.test]
#    set f2 [open test1 w]
#    unsupported0 $f1 $f2
#    close $f1
#    catch {close $f2}
#    set s1 [file size $thisScript]
#    set s2 [file size test1]
#    set x ok
#    if {"$s1" != "$s2"} {
#        set x broken
#    }

#    set x
#} ok
#test io-1.2 {unsupported0 command} {
#    removeFile test1
#    set f1 [open $thisScript]
#    set f2 [open test1 w]
#    unsupported0 $f1 $f2 40
#    close $f1
#    close $f2
#    file size test1
#} 40
#test io-1.3 {unsupported0 command} {
#    removeFile test1
#    set f1 [open $thisScript]
#    set f2 [open test1 w]
#    unsupported0 $f1 $f2 -1
#    close $f1
#    close $f2
#    set x ok
#    set s1 [file size $thisScript]
#    set s2 [file size test1]
#    if {$s1 != $s2} {
#        set x broken
#    }

#    set x
#} ok
#test io-1.4 {unsupported0 command} {unixOrPc} {
#    removeFile pipe
#    removeFile test1
#    set f1 [open pipe w]
#    puts $f1 {puts ready}
#    puts $f1 {gets stdin}
#    puts $f1 {set f1 [open $thisScript r]}
#    puts $f1 {puts [read $f1 100]}
#    puts $f1 {close $f1}
#    close $f1
#    set f1 [open "|[list $tcltest pipe]" r+]
#    gets $f1
#    puts $f1 ready
#    flush $f1
#    set f2 [open test1 w]
#    set c [unsupported0 $f1 $f2 40]
#    catch {close $f1}
#    close $f2
#    set s1 [file size test1]
#    set x ok
#    if {$s1 != "40"} {
#        set x broken
#    }

#    list $c $x
#} {40 ok}

proc contents {file} {
    set f [open $file]
    fconfigure $f -translation binary
    set a [read $f]
    close $f
    return $a
}

test io-1.5 {Tcl_WriteChars: CheckChannelErrors} {
    # no test, need to cause an async error.
} {}
test io-1.6 {Tcl_WriteChars: WriteBytes} {
    set f [open test1 w]
    fconfigure $f -encoding binary
    puts -nonewline $f "a\u4e4d\0"
    close $f







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









|







62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80

81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104

105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129

130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
    vwait forever
} cat

set thisScript [file join $::tcltest::testsDir [info script]]

# These tests are disabled until we decide what to do with "unsupported0".
#
test io-1.1 {unsupported0 command} {knownBug} {
    removeFile test1
    set f1 [open iocmd.test]
    set f2 [open test1 w]
    unsupported0 $f1 $f2
    close $f1
    catch {close $f2}
    set s1 [file size $thisScript]
    set s2 [file size test1]
    set x ok
    if {"$s1" != "$s2"} {
        set x broken

    }
    set x
} ok
test io-1.2 {unsupported0 command} {knownBug} {
    removeFile test1
    set f1 [open $thisScript]
    set f2 [open test1 w]
    unsupported0 $f1 $f2 40
    close $f1
    close $f2
    file size test1
} 40
test io-1.3 {unsupported0 command} {knownBug} {
    removeFile test1
    set f1 [open $thisScript]
    set f2 [open test1 w]
    unsupported0 $f1 $f2 -1
    close $f1
    close $f2
    set x ok
    set s1 [file size $thisScript]
    set s2 [file size test1]
    if {$s1 != $s2} {
        set x broken

    }
    set x
} ok
test io-1.4 {unsupported0 command} {knownBug unixOrPc} {
    removeFile pipe
    removeFile test1
    set f1 [open pipe w]
    puts $f1 {puts ready}
    puts $f1 {gets stdin}
    puts $f1 {set f1 [open $thisScript r]}
    puts $f1 {puts [read $f1 100]}
    puts $f1 {close $f1}
    close $f1
    set f1 [open "|[list $tcltest pipe]" r+]
    gets $f1
    puts $f1 ready
    flush $f1
    set f2 [open test1 w]
    set c [unsupported0 $f1 $f2 40]
    catch {close $f1}
    close $f2
    set s1 [file size test1]
    set x ok
    if {$s1 != "40"} {
        set x broken

    }
    list $c $x
} {40 ok}

proc contents {file} {
    set f [open $file]
    fconfigure $f -translation binary
    set a [read $f]
    close $f
    return $a
}

test io-1.5 {Tcl_WriteChars: CheckChannelErrors} {emptyTest} {
    # no test, need to cause an async error.
} {}
test io-1.6 {Tcl_WriteChars: WriteBytes} {
    set f [open test1 w]
    fconfigure $f -encoding binary
    puts -nonewline $f "a\u4e4d\0"
    close $f
6404
6405
6406
6407
6408
6409
6410
6411
6412
6413
6414
6415
6416
6417
6418
6419
6420
6421
6422
6423
6424
6425
    set result
} {0 0 ok}
test io-52.8 {TclCopyChannel} {stdio} {
    removeFile test1
    removeFile pipe
    set f1 [open pipe w]
    fconfigure $f1 -translation lf
    puts $f1 {
	puts ready
	gets stdin
	set f1 [open $thisScript r]
	fconfigure $f1 -translation lf
	puts [read $f1 100]
	close $f1
    }
    close $f1
    set f1 [open "|[list $tcltest pipe]" r+]
    fconfigure $f1 -translation lf
    gets $f1
    puts $f1 ready
    flush $f1
    set f2 [open test1 w]







|


|
|
|
|
|







6404
6405
6406
6407
6408
6409
6410
6411
6412
6413
6414
6415
6416
6417
6418
6419
6420
6421
6422
6423
6424
6425
    set result
} {0 0 ok}
test io-52.8 {TclCopyChannel} {stdio} {
    removeFile test1
    removeFile pipe
    set f1 [open pipe w]
    fconfigure $f1 -translation lf
    puts $f1 [subst {
	puts ready
	gets stdin
	set f1 \[open $thisScript r\]
	fconfigure \$f1 -translation lf
	puts \[read \$f1 100\]
	close \$f1
    }]
    close $f1
    set f1 [open "|[list $tcltest pipe]" r+]
    fconfigure $f1 -translation lf
    gets $f1
    puts $f1 ready
    flush $f1
    set f2 [open test1 w]
Changes to tests/pkgMkIndex.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
# This file contains tests for the pkg_mkIndex command.
# Note that the tests are limited to Tcl scripts only, there are no shared
# libraries against which to test.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors.  No output means no errors were found.
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
# RCS: @(#) $Id: pkgMkIndex.test,v 1.4.2.6 1999/03/24 02:49:33 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# temporarily copy the pkg and pkg1 dirs from testsDir to tmpDir
if {"$::tcltest::testsDir" != "$::tcltest::workingDir"} {










|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
# This file contains tests for the pkg_mkIndex command.
# Note that the tests are limited to Tcl scripts only, there are no shared
# libraries against which to test.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors.  No output means no errors were found.
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
# RCS: @(#) $Id: pkgMkIndex.test,v 1.4.2.7 1999/03/25 04:32:18 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# temporarily copy the pkg and pkg1 dirs from testsDir to tmpDir
if {"$::tcltest::testsDir" != "$::tcltest::workingDir"} {
325
326
327
328
329
330
331
332
333


334
335
336

337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
} "0 {{pkg2:1.0 {source [file join pkg pkg2_a.tcl]
source [file join pkg pkg2_b.tcl]}} {pkg5:1.0 {source [file join pkg pkg5.tcl]}}}"

test pkgMkIndex-9.1 {circular packages} {
    pkgtest::runIndex pkg circ1.tcl circ2.tcl circ3.tcl
} {0 {{circ1:1.0 {tclPkgSetup {circ1.tcl source {::circ1::c1-1 ::circ1::c1-2 ::circ1::c1-3 ::circ1::c1-4}}}} {circ2:1.0 {tclPkgSetup {circ2.tcl source {::circ2::c2-1 ::circ2::c2-2}}}} {circ3:1.0 {tclPkgSetup {circ3.tcl source ::circ3::c3-1}}}}}

# Try to find one of the DLLs in the dltest directory
set x [file join $::tcltest::testsDir ../unix/dltest/pkga[info sharedlibextension]]


if {[file exists $x]} {
    file copy -force $x pkg
    test pkgMkIndex-10.1 {package in DLL and script} {

	pkgtest::runIndex pkg pkga[info sharedlibextension] pkga.tcl
    } "0 {{Pkga:1.0 {tclPkgSetup {pkga[info sharedlibextension] load {pkga_eq pkga_quote}} {pkga.tcl source pkga_neq}}}}"
    test pkgMkIndex-10.2 {package in DLL hidden by -load} {
	pkgtest::runIndex -load Pkg* -- pkg pkga[info sharedlibextension]
    } {0 {}}
} else {
    puts "Skipping pkgMkIndex-10.1 (index of DLL and script)"
}

# cleanup
namespace delete pkgtest
cd $::tcltest::workingDir
if {[info exists removePkgDir]} {
    # strange error deleting the pkg dir only once--needs be done twice!
    catch {file delete -force $newPkgDir}







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







325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344



345
346
347
348
349
350
351
} "0 {{pkg2:1.0 {source [file join pkg pkg2_a.tcl]
source [file join pkg pkg2_b.tcl]}} {pkg5:1.0 {source [file join pkg pkg5.tcl]}}}"

test pkgMkIndex-9.1 {circular packages} {
    pkgtest::runIndex pkg circ1.tcl circ2.tcl circ3.tcl
} {0 {{circ1:1.0 {tclPkgSetup {circ1.tcl source {::circ1::c1-1 ::circ1::c1-2 ::circ1::c1-3 ::circ1::c1-4}}}} {circ2:1.0 {tclPkgSetup {circ2.tcl source {::circ2::c2-1 ::circ2::c2-2}}}} {circ3:1.0 {tclPkgSetup {circ3.tcl source ::circ3::c3-1}}}}}

# Some tests require the existence of one of the DLLs in the dltest directory
set x [file join $::tcltest::testsDir \
	../unix/dltest/pkga[info sharedlibextension]]
set dll "[file tail $x]Required"
set ::tcltest::testConfig($dll) [file exists $x]

test pkgMkIndex-10.1 {package in DLL and script} $dll {
    file copy -force $x pkg
    pkgtest::runIndex pkg pkga[info sharedlibextension] pkga.tcl
} "0 {{Pkga:1.0 {tclPkgSetup {pkga[info sharedlibextension] load {pkga_eq pkga_quote}} {pkga.tcl source pkga_neq}}}}"
test pkgMkIndex-10.2 {package in DLL hidden by -load} $dll {
    pkgtest::runIndex -load Pkg* -- pkg pkga[info sharedlibextension]
} {0 {}}




# cleanup
namespace delete pkgtest
cd $::tcltest::workingDir
if {[info exists removePkgDir]} {
    # strange error deleting the pkg dir only once--needs be done twice!
    catch {file delete -force $newPkgDir}
Changes to tests/unixFCmd.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
# This file tests the tclUnixFCmd.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: unixFCmd.test,v 1.1.2.6 1999/03/24 02:49:46 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# Several tests require need to match results against the unix username
set user {}











|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
# This file tests the tclUnixFCmd.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: unixFCmd.test,v 1.1.2.7 1999/03/25 04:32:18 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# Several tests require need to match results against the unix username
set user {}
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90

91
92
93
94
95
96
97
98
99
100
101
102
    list [catch {file rename td2 td1} msg] $msg
} {1 {error renaming "td2" to "td1/td2": file already exists}}
test unixFCmd-1.3 {TclpRenameFile: EINVAL} {unixOnly notRoot} {
    cleanup
    file mkdir td1
    list [catch {file rename td1 td1} msg] $msg
} {1 {error renaming "td1" to "td1/td1": trying to rename a volume or move a directory into itself}}
test unixFCmd-1.4 {TclpRenameFile: EISDIR} {unixOnly notRoot} {
    # can't make it happen
} {}
test unixFCmd-1.5 {TclpRenameFile: ENOENT} {unixOnly notRoot} {
    cleanup
    file mkdir td1
    list [catch {file rename td2 td1} msg] $msg
} {1 {error renaming "td2": no such file or directory}}
test unixFCmd-1.6 {TclpRenameFile: ENOTDIR} {emptyTest unixOnly notRoot} {
    # can't make it happen
} {}
test unixFCmd-1.7 {TclpRenameFile: EXDEV} {unixOnly notRoot} {
    cleanup
    file mkdir foo/bar
    file attr foo -perm 040555
    set msg [list [catch {file rename foo/bar /tmp} msg] $msg]

    catch {file delete /tmp/bar}
    catch {file attr foo -perm 040777}
    catch {file delete -force foo}
    set msg
} {1 {can't unlink "foo/bar": permission denied}}
test unixFCmd-1.8 {Checking EINTR Bug} {unixOnly notRoot nonPortable} {
    testalarm 
    after 2000
    list [testgotsig] [testgotsig]
} {1 0}
test unixFCmd-1.9 {Checking EINTR Bug} {unixOnly notRoot nonPortable} {
    cleanup







|














|
>



|
|







68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
    list [catch {file rename td2 td1} msg] $msg
} {1 {error renaming "td2" to "td1/td2": file already exists}}
test unixFCmd-1.3 {TclpRenameFile: EINVAL} {unixOnly notRoot} {
    cleanup
    file mkdir td1
    list [catch {file rename td1 td1} msg] $msg
} {1 {error renaming "td1" to "td1/td1": trying to rename a volume or move a directory into itself}}
test unixFCmd-1.4 {TclpRenameFile: EISDIR} {emptyTest unixOnly notRoot} {
    # can't make it happen
} {}
test unixFCmd-1.5 {TclpRenameFile: ENOENT} {unixOnly notRoot} {
    cleanup
    file mkdir td1
    list [catch {file rename td2 td1} msg] $msg
} {1 {error renaming "td2": no such file or directory}}
test unixFCmd-1.6 {TclpRenameFile: ENOTDIR} {emptyTest unixOnly notRoot} {
    # can't make it happen
} {}
test unixFCmd-1.7 {TclpRenameFile: EXDEV} {unixOnly notRoot} {
    cleanup
    file mkdir foo/bar
    file attr foo -perm 040555
    set catchResult [catch {file rename foo/bar /tmp} msg]
    set msg [lindex [split $msg :] end]
    catch {file delete /tmp/bar}
    catch {file attr foo -perm 040777}
    catch {file delete -force foo}
    list $catchResult $msg
} {1 { permission denied}}
test unixFCmd-1.8 {Checking EINTR Bug} {unixOnly notRoot nonPortable} {
    testalarm 
    after 2000
    list [testgotsig] [testgotsig]
} {1 0}
test unixFCmd-1.9 {Checking EINTR Bug} {unixOnly notRoot nonPortable} {
    cleanup
Changes to tests/unixInit.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26












27
28
29
30
31
32
33
34
# The file tests the functions in the tclUnixInit.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: unixInit.test,v 1.1.2.6 1999/03/24 02:49:47 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {[catch {csh -c "setenv LANG japanese"}] == 0} {
    set ::tcltest::testConfig(japanese) 1
}

catch {set oldlibrary $env(TCL_LIBRARY); unset env(TCL_LIBRARY)}
catch {set oldlang $env(LANG)}
set env(LANG) C













test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {unixOnly} {
    set x {}

    set f [open "|[list $tcltest]" w+]
    exec kill -PIPE [pid $f]
    lappend x [catch {close $f}]

    set f [open "|[list $tcltest]" w+]












|













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







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
# The file tests the functions in the tclUnixInit.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: unixInit.test,v 1.1.2.7 1999/03/25 04:32:19 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {[catch {csh -c "setenv LANG japanese"}] == 0} {
    set ::tcltest::testConfig(japanese) 1
}

catch {set oldlibrary $env(TCL_LIBRARY); unset env(TCL_LIBRARY)}
catch {set oldlang $env(LANG)}
set env(LANG) C

# Some tests will fail if they are run on a machine that doesn't have
# this Tcl version installed (as opposed to built) on it.
if {[catch {
    set f [open "|[list $tcltest]" w+]
    exec kill -PIPE [pid $f]
    close $f
}]} {
    set ::tcltest::testConfig(installedTcl) 0
} else {
    set ::tcltest::testConfig(installedTcl) 1
}

test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {unixOnly installedTcl} {
    set x {}

    set f [open "|[list $tcltest]" w+]
    exec kill -PIPE [pid $f]
    lappend x [catch {close $f}]

    set f [open "|[list $tcltest]" w+]
43
44
45
46
47
48
49





50

51
52
53
54
55
56
57

58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82

83
84
85
86
87
88
89
90
91

92
93
94
95
96
97
98
99
100
101
102
103
104
105

106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134

135
136
137
138
139
140
141
    fconfigure $f -buffering none
    puts $f {puts $tcl_libPath; exit}
    set path [gets $f]
    close $f
    return $path
}






test unixInit-2.0 {TclpInitLibraryPath: setting tclDefaultEncodingDir} {unixOnly} {

    set origDir [testgetdefenc]
    testsetdefenc slappy
    set path [testgetdefenc]
    testsetdefenc $origDir
    set path
} {slappy}
test unixInit-2.1 {TclpInitLibraryPath: value of installLib, developLib} {unixOnly} {

    set path [getlibpath]

    set installLib lib/tcl[info tclversion]
    if {[string match {*[ab]*} [info patchlevel]]} {
	set developLib tcl[info patchlevel]/library
    } else {
        set developLib tcl[info tclversion]/library
    }
    set prefix [file dirname [file dirname $tcltest]]

    set x {}
    lappend x [string compare [lindex $path 0] $prefix/$installLib]
    lappend x [string compare [lindex $path 1] [file dirname $prefix]/$developLib]
    set x
} {0 0}
test unixInit-2.2 {TclpInitLibraryPath: TCL_LIBRARY} {unixOnly} {
    # ((str != NULL) && (str[0] != '\0')) 

    set env(TCL_LIBRARY) sparkly
    set path [getlibpath]
    unset env(TCL_LIBRARY)

    lindex $path 0
} "sparkly"
test unixInit-2.3 {TclpInitLibraryPath: TCL_LIBRARY wrong version} {unixOnly} {

    # ((pathc > 0) && (strcasecmp(installLib + 4, pathv[pathc - 1]) != 0))

    set env(TCL_LIBRARY) /a/b/tcl1.7
    set path [getlibpath]
    unset env(TCL_LIBRARY)

    lrange $path 0 1
} [list /a/b/tcl1.7 /a/b/tcl[info tclversion]]
test unixInit-2.4 {TclpInitLibraryPath: TCL_LIBRARY: INTL} {unixOnly} {

    # Child process translates env variable from native encoding.

    set env(TCL_LIBRARY) "\xa7"
    set x [lindex [getlibpath] 0]
    unset env(TCL_LIBRARY)
    unset env(LANG)

    set x
} "\xa7"
test unixInit-2.5 {TclpInitLibraryPath: compiled-in library path} \
	{emptyTest unixOnly} {
    # cannot test
} {}
test unixInit-2.6 {TclpInitLibraryPath: executable relative} {unixOnly} {

    file delete -force /tmp/sparkly
    file mkdir /tmp/sparkly/bin
    file copy $tcltest /tmp/sparkly/bin/tcltest

    file mkdir /tmp/sparkly/lib/tcl[info tclversion]
    close [open /tmp/sparkly/lib/tcl[info tclversion]/init.tcl w]

    set x [lrange [getlibpath /tmp/sparkly/bin/tcltest] 0 2]
    file delete -force /tmp/sparkly
    set x
} [list /tmp/sparkly/lib/tcl[info tclversion] /tmp/tcl[info patchlevel]/library]
test unixInit-2.7 {TclpInitLibraryPath: compiled-in library path} \
	{emptyTest unixOnly} {
    # would need test command to get defaultLibDir and compare it to
    # [lindex $auto_path end]
} {}
test unixInit-3.1 {TclpSetInitialEncodings} {unixOnly} {
    set env(LANG) C

    set f [open "|[list $tcltest]" w+]
    fconfigure $f -buffering none
    puts $f {puts [encoding system]; exit}
    set enc [gets $f]
    close $f
    unset env(LANG)

    set enc
} {iso8859-1}
test unixInit-3.1 {TclpSetInitialEncodings} {unixOnly japanese nonPortable} {

    set env(LANG) japanese

    set f [open "|[list $tcltest]" w+]
    fconfigure $f -buffering none
    puts $f {puts [encoding system]; exit}
    set enc [gets $f]
    close $f







>
>
>
>
>
|
>






|
>















|








|
>








|
>













|
>







|








|











|
>







55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
    fconfigure $f -buffering none
    puts $f {puts $tcl_libPath; exit}
    set path [gets $f]
    close $f
    return $path
}

# Some tests require the testgetdefenc command

set ::tcltest::testConfig(testgetdefenc) \
	[expr {[info commands testgetdefenc] != {}}]

test unixInit-2.0 {TclpInitLibraryPath: setting tclDefaultEncodingDir} \
	{unixOnly testgetdefenc} {
    set origDir [testgetdefenc]
    testsetdefenc slappy
    set path [testgetdefenc]
    testsetdefenc $origDir
    set path
} {slappy}
test unixInit-2.1 {TclpInitLibraryPath: value of installLib, developLib} \
	{unixOnly installedTcl} {
    set path [getlibpath]

    set installLib lib/tcl[info tclversion]
    if {[string match {*[ab]*} [info patchlevel]]} {
	set developLib tcl[info patchlevel]/library
    } else {
        set developLib tcl[info tclversion]/library
    }
    set prefix [file dirname [file dirname $tcltest]]

    set x {}
    lappend x [string compare [lindex $path 0] $prefix/$installLib]
    lappend x [string compare [lindex $path 1] [file dirname $prefix]/$developLib]
    set x
} {0 0}
test unixInit-2.2 {TclpInitLibraryPath: TCL_LIBRARY} {unixOnly installedTcl} {
    # ((str != NULL) && (str[0] != '\0')) 

    set env(TCL_LIBRARY) sparkly
    set path [getlibpath]
    unset env(TCL_LIBRARY)

    lindex $path 0
} "sparkly"
test unixInit-2.3 {TclpInitLibraryPath: TCL_LIBRARY wrong version} \
	{unixOnly installedTcl} {
    # ((pathc > 0) && (strcasecmp(installLib + 4, pathv[pathc - 1]) != 0))

    set env(TCL_LIBRARY) /a/b/tcl1.7
    set path [getlibpath]
    unset env(TCL_LIBRARY)

    lrange $path 0 1
} [list /a/b/tcl1.7 /a/b/tcl[info tclversion]]
test unixInit-2.4 {TclpInitLibraryPath: TCL_LIBRARY: INTL} \
	{unixOnly installedTcl} {
    # Child process translates env variable from native encoding.

    set env(TCL_LIBRARY) "\xa7"
    set x [lindex [getlibpath] 0]
    unset env(TCL_LIBRARY)
    unset env(LANG)

    set x
} "\xa7"
test unixInit-2.5 {TclpInitLibraryPath: compiled-in library path} \
	{emptyTest unixOnly} {
    # cannot test
} {}
test unixInit-2.6 {TclpInitLibraryPath: executable relative} \
	{unixOnly installedTcl} {
    file delete -force /tmp/sparkly
    file mkdir /tmp/sparkly/bin
    file copy $tcltest /tmp/sparkly/bin/tcltest

    file mkdir /tmp/sparkly/lib/tcl[info tclversion]
    close [open /tmp/sparkly/lib/tcl[info tclversion]/init.tcl w]

    set x [lrange [getlibpath /tmp/sparkly/bin/tcltest] 0 1]
    file delete -force /tmp/sparkly
    set x
} [list /tmp/sparkly/lib/tcl[info tclversion] /tmp/tcl[info patchlevel]/library]
test unixInit-2.7 {TclpInitLibraryPath: compiled-in library path} \
	{emptyTest unixOnly} {
    # would need test command to get defaultLibDir and compare it to
    # [lindex $auto_path end]
} {}
test unixInit-3.1 {TclpSetInitialEncodings} {unixOnly installedTcl} {
    set env(LANG) C

    set f [open "|[list $tcltest]" w+]
    fconfigure $f -buffering none
    puts $f {puts [encoding system]; exit}
    set enc [gets $f]
    close $f
    unset env(LANG)

    set enc
} {iso8859-1}
test unixInit-3.1 {TclpSetInitialEncodings} \
	{unixOnly japanese installedTcl nonPortable} {
    set env(LANG) japanese

    set f [open "|[list $tcltest]" w+]
    fconfigure $f -buffering none
    puts $f {puts [encoding system]; exit}
    set enc [gets $f]
    close $f