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