#
# dup.test
#
# Tests for the dup command.
#---------------------------------------------------------------------------
# Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans.
#
# Permission to use, copy, modify, and distribute this software and its
# documentation for any purpose and without fee is hereby granted, provided
# that the above copyright notice appear in all copies.  Karl Lehenbauer and
# Mark Diekhans make no representations about the suitability of this
# software for any purpose.  It is provided "as is" without express or
# implied warranty.
#------------------------------------------------------------------------------
# $Id: dup.test,v 1.2 2002/04/02 02:29:43 hobbs Exp $
#------------------------------------------------------------------------------
#

if {[cequal [info procs Test] {}]} {
    source [file join [file dirname [info script]] testlib.tcl]
}

# FIX: Need tests on sockets.

# Create a test file

TestRemove DUP.TMP DUP2.TMP

set testFH [open DUP.TMP w]
for {set cnt 0} {$cnt < 100} {incr cnt} {
     puts $testFH [GenRec $cnt]
}
close $testFH

test dup-1.1 {dup argument checking} {
    list [catch {dup} msg] $msg
} {1 {wrong # args: dup channelId ?targetChannelId?}}

test dup-1.2 {dup argument checking} {
    list [catch {dup a b c} msg] $msg
} {1 {wrong # args: dup channelId ?targetChannelId?}}

test dup-1.3 {dup argument checking} {
    list [catch {dup a} msg] $msg
} {1 {can not find channel named "a"}}

test dup-1.4 {dup argument checking} {
    list [catch {dup stdin a} msg] $msg
} {1 {invalid channel id: a}}

test dup-2.1 {dup tests} {
    set testFH [open DUP.TMP]
    set testFH2 [dup $testFH]
    gets $testFH2 testRec
    close $testFH
    close $testFH2
    set testRec
} [GenRec 0]

test dup-2.2 {dup tests} {unixOnly} {
    set testFH [open DUP.TMP]
    set testFH2 [open DUP2.TMP w]
    set testFH2 [dup $testFH $testFH2]
    gets $testFH2 testRec
    close $testFH
    close $testFH2
    set testRec
} [GenRec 0]

test dup-2.3 {dup tests} {pcOnly} {
    set testFH [open DUP.TMP]
    set testFH2 [open DUP2.TMP w]
    set result [list [catch {dup $testFH $testFH2} msg] $msg]
    close $testFH
    close $testFH2
    set result
} {1 {on MS Windows, only stdin, stdout or stderr maybe the dup target}}

#
# Test to channels to the same file, including duping of some channel options.
#
test dup-3.0 {dup tests} {
    set testFH1 [open DUP2.TMP w]
    fconfigure $testFH1 -buffering line
    set testFH2 [dup $testFH1]
    set result [fconfigure $testFH2 -buffering]
    puts $testFH1 "line 1"
    puts $testFH2 "line 2"
    puts $testFH1 "line 3"
    puts $testFH2 "line 4"
    puts $testFH1 "line 5"
    puts $testFH2 "line 6"
    close $testFH1
    close $testFH2
    set testFH1 [open DUP2.TMP]
    while {[gets $testFH1 line] >= 0} {
        lappend result $line
    }
    close $testFH1
    set result
} {line {line 1} {line 2} {line 3} {line 4} {line 5} {line 6}}

#
# Test passing a file via dup to a child process.
# FIX: Should really have a way of doing this on windows.
#
if [cequal $tcl_platform(platform) unix] {
    set data {{now is the time}    {for all good programmers} 
              {to come to the aid} {of their software}}
    set inFH [open INCMDS.TMP w]
    catch {file delete OUTPUT.TMP}
    foreach line $data {
        puts $inFH "puts stdout \"$line\""
    }
    puts $inFH {flush stdout}
    puts $inFH {exit 0}
    close $inFH

    flush stdout
    flush stderr

    if {[set childPid [fork]] == 0} {
        set inFH  [open INCMDS.TMP r]
        set outFH [open OUTPUT.TMP w]

        dup $inFH stdin
        close $inFH

        dup $outFH stdout
        close $outFH

	removeFile script
	makeFile {package require Tclx; commandloop -prompt1 {} -prompt2 {}} \
		script
        catch {execl $::tcltest::tcltest script} msg
        puts stderr "execl failed: $msg"
        exit 1
    }

    test dup-4.1 {dup tests} {
        wait $childPid
    } [list $childPid EXIT 0]

    set outFH [open OUTPUT.TMP r]
    foreach line $data {
        test dup-4.2 {dup tests} {
            gets $outFH
        } $line
    }
    close $outFH
}

# Test binding of open files to ids on Unix systems.  Solaris opens pipes RDWR,
# so skip some tests if this is the case.

if [cequal $tcl_platform(platform) unix] {
    pipe fromChild toParent
    pipe fromParent toChild

    flush stdout
    flush stderr

    if {[set childPid [fork]] == 0} {
        catch {
            close $fromChild
            close $toChild
            set toParent [crange $toParent 4 end]
            set fromParent [crange $fromParent 4 end]
	    removeFile script
	    makeFile [subst {
		package require Tclx
		set toParent \[dup $toParent\]
		set fromParent \[dup $fromParent\]
		if {!\[fcntl \$fromParent RDWR\]} {
		    puts \$toParent "DOING ACCESS CHECK"
		    flush \$toParent
		    catch {puts \$fromParent arf} msg
		    puts \$toParent "msg1: \$msg"
		    flush \$toParent
		    catch {gets \$toParent} msg
		    puts \$toParent "msg2: \$msg"
		    flush \$toParent
		} else {
		    puts \$toParent "SKIPPING ACCESS CHECK"
		    flush \$toParent
		}
		while {\[gets \$fromParent msg\] >= 0} {
		    puts \$toParent "got: \$msg"
		    flush \$toParent
		}
	    }] {script}
            execl $::tcltest::tcltest script
        } msg
        puts stderr "child failed: $msg"
        exit 1
    }
    close $toParent
    close $fromParent

    test dup-5.1 {dup tests} {
        set line [gets $fromChild]
        switch $line {
            {DOING ACCESS CHECK} {
                set doingAccess 1
                concat OK
            }
            {SKIPPING ACCESS CHECK} {
                set doingAccess 0
                concat OK
            }
            default {
                set doingAccess 0
                list $line
            }
        }
    } OK

    if ![fcntl $toChild RDWR] {
        test dup-5.2 {dup tests} {
            list [catch {gets $toChild} msg] $msg
        } [list 1 "channel \"$toChild\" wasn't opened for reading"]

        test dup-5.3 {dup tests} {
            list [catch {puts $fromChild arf} msg] $msg
        } [list 1 "channel \"$fromChild\" wasn't opened for writing"]
    }

    if $doingAccess {
        test dup-5.4 {dup tests} {
            gets $fromChild line
            if [string match {msg1: channel "*" wasn't opened for writing} $line] {
                list OK
            } else {
                list $line
            }
        } OK
        test dup-5.5 {dup tests} {
            gets $fromChild line
            if [string match {msg2: channel "*" wasn't opened for reading} $line] {
                list OK
            } else {
                list $line
            }
        } OK
    }

    test dup-5.6 {dup tests} {
        puts $toChild "test 5.2"
        flush $toChild
        gets $fromChild
    } {got: test 5.2}

    test dup-5.7 {dup tests} {
        puts $toChild "test 3.3"
        flush $toChild
        gets $fromChild
    } {got: test 3.3}

    test dup-5.8 {dup tests} {
        close $toChild
        close $fromChild
        wait $childPid
    } [list $childPid EXIT 0]

    test dup-5.9 {dup tests} {
       set stat [catch {dup 100}]
       list $stat [lrange $errorCode 0 1]
    } {1 {POSIX EBADF}}
}

TestRemove DUP.TMP DUP2.TMP INCMDS.TMP OUTPUT.TMP

# cleanup
::tcltest::cleanupTests
return