#
# 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.1.1.1 1999/06/28 20:35:24 damon Exp $
#------------------------------------------------------------------------------
#

if [cequal [info procs Test] {}] {source 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} {
    dup
} 1 {wrong # args: dup channelId ?targetChannelId?}

Test dup-1.2 {dup argument checking} {
    dup a b c
} 1 {wrong # args: dup channelId ?targetChannelId?}

Test dup-1.3 {dup argument checking} {
    dup a
} 1 {can not find channel named "a"}

Test dup-1.4 {dup argument checking} {
    dup stdin a
} 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
} 0 [GenRec 0]

Test dup-2.2 {dup tests} {
    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
} 0 [GenRec 0] unixOnly

Test dup-2.3 {dup tests} {
    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
} 0 {1 {on MS Windows, only stdin, stdout or stderr maybe the dup target}} pcOnly

#
# 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
} 0 {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

        catch {
            execl $TCL_PROGRAM [list -qc {commandloop -prompt1 {} -prompt2 {}}]
        } msg
        puts stderr "execl failed: $msg"
        exit 1
    }

    Test dup-4.1 {dup tests} {
        wait $childPid
    } 0 "$childPid EXIT 0"

    set outFH [open OUTPUT.TMP r]
    foreach line $data {
        Test dup-4.2 {dup tests} {
            gets $outFH
        } 0 $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]
            set prog {}
            append prog "set toParent \[dup $toParent\]" \n
            append prog "set fromParent \[dup $fromParent\]" \n
            append prog {if ![fcntl $fromParent RDWR] } "{\n"
            append prog {    puts $toParent "DOING ACCESS CHECK"} \n
            append prog {    flush $toParent} \n
            append prog {    catch {puts $fromParent arf} msg} \n
            append prog {    puts $toParent "msg1: $msg"} \n
            append prog {    flush $toParent} \n
            append prog {    catch {gets $toParent} msg} \n
            append prog {    puts $toParent "msg2: $msg"} \n
            append prog {    flush $toParent} \n
            append prog "} else {\n"
            append prog {    puts $toParent "SKIPPING ACCESS CHECK"} \n
            append prog {    flush $toParent} \n
            append prog "}\n"
            append prog {while {[gets $fromParent msg] >= 0} {
                puts $toParent "got: $msg"; flush $toParent}}
            execl $TCL_PROGRAM [list -qc $prog]
        } 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
            }
        }
    } 0 OK


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

        Test dup-5.3 {dup tests} {
            puts $fromChild arf
        } 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
            }
        } 0 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
            }
        } 0 OK
    }

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

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

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

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

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



