1#
2# dup.test
3#
4# Tests for the dup command.
5#---------------------------------------------------------------------------
6# Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans.
7#
8# Permission to use, copy, modify, and distribute this software and its
9# documentation for any purpose and without fee is hereby granted, provided
10# that the above copyright notice appear in all copies.  Karl Lehenbauer and
11# Mark Diekhans make no representations about the suitability of this
12# software for any purpose.  It is provided "as is" without express or
13# implied warranty.
14#------------------------------------------------------------------------------
15# $Id: dup.test,v 1.3 2002/04/03 02:44:21 hobbs Exp $
16#------------------------------------------------------------------------------
17#
18
19if {[cequal [info procs Test] {}]} {
20    source [file join [file dirname [info script]] testlib.tcl]
21}
22
23# FIX: Need tests on sockets.
24
25# Create a test file
26
27TestRemove DUP.TMP DUP2.TMP
28
29set testFH [open DUP.TMP w]
30for {set cnt 0} {$cnt < 100} {incr cnt} {
31     puts $testFH [GenRec $cnt]
32}
33close $testFH
34
35test dup-1.1 {dup argument checking} {
36    list [catch {dup} msg] $msg
37} {1 {wrong # args: dup channelId ?targetChannelId?}}
38
39test dup-1.2 {dup argument checking} {
40    list [catch {dup a b c} msg] $msg
41} {1 {wrong # args: dup channelId ?targetChannelId?}}
42
43test dup-1.3 {dup argument checking} {
44    list [catch {dup a} msg] $msg
45} {1 {can not find channel named "a"}}
46
47test dup-1.4 {dup argument checking} {
48    list [catch {dup stdin a} msg] $msg
49} {1 {invalid channel id: a}}
50
51test dup-2.1 {dup tests} {
52    set testFH [open DUP.TMP]
53    set testFH2 [dup $testFH]
54    gets $testFH2 testRec
55    close $testFH
56    close $testFH2
57    set testRec
58} [GenRec 0]
59
60test dup-2.2 {dup tests} {unixOnly} {
61    set testFH [open DUP.TMP]
62    set testFH2 [open DUP2.TMP w]
63    set testFH2 [dup $testFH $testFH2]
64    gets $testFH2 testRec
65    close $testFH
66    close $testFH2
67    set testRec
68} [GenRec 0]
69
70test dup-2.3 {dup tests} {pcOnly} {
71    set testFH [open DUP.TMP]
72    set testFH2 [open DUP2.TMP w]
73    set result [list [catch {dup $testFH $testFH2} msg] $msg]
74    close $testFH
75    close $testFH2
76    set result
77} {1 {on MS Windows, only stdin, stdout or stderr maybe the dup target}}
78
79#
80# Test to channels to the same file, including duping of some channel options.
81#
82test dup-3.0 {dup tests} {
83    set testFH1 [open DUP2.TMP w]
84    fconfigure $testFH1 -buffering line
85    set testFH2 [dup $testFH1]
86    set result [fconfigure $testFH2 -buffering]
87    puts $testFH1 "line 1"
88    puts $testFH2 "line 2"
89    puts $testFH1 "line 3"
90    puts $testFH2 "line 4"
91    puts $testFH1 "line 5"
92    puts $testFH2 "line 6"
93    close $testFH1
94    close $testFH2
95    set testFH1 [open DUP2.TMP]
96    while {[gets $testFH1 line] >= 0} {
97        lappend result $line
98    }
99    close $testFH1
100    set result
101} {line {line 1} {line 2} {line 3} {line 4} {line 5} {line 6}}
102
103#
104# Test passing a file via dup to a child process.
105# FIX: Should really have a way of doing this on windows.
106#
107if [cequal $tcl_platform(platform) unix] {
108    set data {{now is the time}    {for all good programmers} 
109              {to come to the aid} {of their software}}
110    set inFH [open INCMDS.TMP w]
111    catch {file delete OUTPUT.TMP}
112    foreach line $data {
113        puts $inFH "puts stdout \"$line\""
114    }
115    puts $inFH {flush stdout}
116    puts $inFH {exit 0}
117    close $inFH
118
119    flush stdout
120    flush stderr
121
122    if {[set childPid [fork]] == 0} {
123        set inFH  [open INCMDS.TMP r]
124        set outFH [open OUTPUT.TMP w]
125
126        dup $inFH stdin
127        close $inFH
128
129        dup $outFH stdout
130        close $outFH
131
132	removeFile script
133	makeFile {package require Tclx; commandloop -prompt1 {} -prompt2 {}} \
134		script
135        catch {execl $::tcltest::tcltest script} msg
136        puts stderr "execl failed: $msg"
137        exit 1
138    }
139
140    test dup-4.1 {dup tests} {
141        wait $childPid
142    } [list $childPid EXIT 0]
143
144    set outFH [open OUTPUT.TMP r]
145    foreach line $data {
146        test dup-4.2 {dup tests} {
147            gets $outFH
148        } $line
149    }
150    close $outFH
151}
152
153# Test binding of open files to ids on Unix systems.  Solaris opens pipes RDWR,
154# so skip some tests if this is the case.
155
156if [cequal $tcl_platform(platform) unix] {
157    pipe fromChild toParent
158    pipe fromParent toChild
159
160    flush stdout
161    flush stderr
162
163    if {[set childPid [fork]] == 0} {
164        catch {
165            close $fromChild
166            close $toChild
167            set toParent [crange $toParent 4 end]
168            set fromParent [crange $fromParent 4 end]
169	    removeFile script
170	    makeFile [subst {
171		package require Tclx
172		set toParent \[dup $toParent\]
173		set fromParent \[dup $fromParent\]
174		if {!\[fcntl \$fromParent RDWR\]} {
175		    puts \$toParent "DOING ACCESS CHECK"
176		    flush \$toParent
177		    catch {puts \$fromParent arf} msg
178		    puts \$toParent "msg1: \$msg"
179		    flush \$toParent
180		    catch {gets \$toParent} msg
181		    puts \$toParent "msg2: \$msg"
182		    flush \$toParent
183		} else {
184		    puts \$toParent "SKIPPING ACCESS CHECK"
185		    flush \$toParent
186		}
187		while {\[gets \$fromParent msg\] >= 0} {
188		    puts \$toParent "got: \$msg"
189		    flush \$toParent
190		}
191	    }] {script}
192            execl $::tcltest::tcltest script
193        } msg
194        puts stderr "child failed: $msg"
195        exit 1
196    }
197    close $toParent
198    close $fromParent
199
200    test dup-5.1 {dup tests} {
201        set line [gets $fromChild]
202        switch $line {
203            {DOING ACCESS CHECK} {
204                set doingAccess 1
205                concat OK
206            }
207            {SKIPPING ACCESS CHECK} {
208                set doingAccess 0
209                concat OK
210            }
211            default {
212                set doingAccess 0
213                list $line
214            }
215        }
216    } OK
217
218    if ![fcntl $toChild RDWR] {
219        test dup-5.2 {dup tests} {
220            list [catch {gets $toChild} msg] $msg
221        } [list 1 "channel \"$toChild\" wasn't opened for reading"]
222
223        test dup-5.3 {dup tests} {
224            list [catch {puts $fromChild arf} msg] $msg
225        } [list 1 "channel \"$fromChild\" wasn't opened for writing"]
226    }
227
228    if $doingAccess {
229        test dup-5.4 {dup tests} {
230            gets $fromChild line
231            if [string match {msg1: channel "*" wasn't opened for writing} $line] {
232                list OK
233            } else {
234                list $line
235            }
236        } OK
237        test dup-5.5 {dup tests} {
238            gets $fromChild line
239            if [string match {msg2: channel "*" wasn't opened for reading} $line] {
240                list OK
241            } else {
242                list $line
243            }
244        } OK
245    }
246
247    test dup-5.6 {dup tests} {
248        puts $toChild "test 5.2"
249        flush $toChild
250        gets $fromChild
251    } {got: test 5.2}
252
253    test dup-5.7 {dup tests} {
254        puts $toChild "test 3.3"
255        flush $toChild
256        gets $fromChild
257    } {got: test 3.3}
258
259    test dup-5.8 {dup tests} {
260        close $toChild
261        close $fromChild
262        wait $childPid
263    } [list $childPid EXIT 0]
264
265    test dup-5.9 {dup tests} {
266       set stat [catch {dup 100}]
267       list $stat [lrange $errorCode 0 1]
268    } {1 {POSIX EBADF}}
269}
270
271TestRemove DUP.TMP DUP2.TMP INCMDS.TMP OUTPUT.TMP
272
273# cleanup
274::tcltest::cleanupTests
275return
276