#
# server.test
#
# Test for deprecated TclX server commands.  Some tests will be skipped if we
# are not on a known development machine, due to difficutly in certain
# environments.  Set the environment variable TCLX_FULL_TESTS to override.
#------------------------------------------------------------------------------
# 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: server.test,v 8.7 1999/03/31 06:37:52 markd Exp $
#------------------------------------------------------------------------------
#

if [cequal [info procs Test] {}] {source testlib.tcl}
eval $SAVED_UNKNOWN


if [cequal $tcl_platform(platform) windows] {
    echo "    * The server tests have not been ported to Win32" 
    return
}

#
# Determine if we are at a development site we know is good.  If we are, we
# do more checking.  
#
switch -glob -- [id host] {
    {*.neosoft.com} {set safeHost 1}
    {*.grizzly.com} {set safeHost 1}
    default         {set safeHost 0}
}
if [info exists env(TCLX_FULL_TESTS)] {
    set safeHost 1
}

#
# Test simple interaction with the echo server.  This proc is used to
# do the actual interaction.  The server is connected to using various
# different options and the same interaction done.
#

proc TalkToEcho {testId readFH writeFH buffered} {
    # Try gets/puts first.
    fconfigure $readFH -translation binary
    fconfigure $writeFH -translation binary

    Test $testId.1 {simple client interaction} {
        puts $writeFH "Test #1"
        if $buffered {
            flush $writeFH
        }
        list [gets $readFH result] $result
    } 0 {7 {Test #1}}

    # Queue serveral messages on buffered access

    if $buffered {
        Test $testId.2 {simple client interaction} {
            puts $writeFH "Test #2"
            puts $writeFH "Test #3"
            puts $writeFH "Test #4"
            puts $writeFH "Test #5"
            puts $writeFH "Test #6"
            puts $writeFH "Test #7"
            flush $writeFH
            list [gets $readFH] [gets $readFH] [gets $readFH] \
                    [gets $readFH] [gets $readFH] [gets $readFH]
        } 0 [list {Test #2} {Test #3} {Test #4} \
                {Test #5} {Test #6} {Test #7}]
    }

    Test $testId.3 {simple client interaction} {
        puts $writeFH "Test #8"
        flush $writeFH
        list [gets $readFH result] $result
    } 0 {7 {Test #8}}

    Test $testId.4 {simple client interaction} {
        puts $writeFH "Test #9"
        flush $writeFH
        read $readFH 8
    } 0 "Test #9\n"

    Test $testId.5 {simple client interaction} {
        puts -nonewline $writeFH "Test #10"
        flush $writeFH 
        read $readFH 8
    } 0 {Test #10}

    # Make sure we can dup a socket.

    Test $testId.6 {dup of a server connection} {
        set write2FH [dup $writeFH]
        if {"$readFH" != "$writeFH"} {
            set read2FH [dup $readFH]
        } else {
            set read2FH $write2FH
        }

        puts $write2FH "Test #11"
        flush $write2FH
        set stat [gets $read2FH result]

        close $write2FH
        if ![cequal $readFH $writeFH] {
            close $read2FH
        }
        list $stat $result
    } 0 {8 {Test #11}}

    # Try dup to stdin/stdout.  Skip under Tk, as fork with out exec will
    # not work.

    if [lempty [info commands button]] {
        flush stdout
        flush stderr
        if {[set pid [fork]] == 0} {
            catch {
                Test $testId.8 {dup of a server connection} {
                    dup $readFH stdin
                    dup $writeFH stdout
                    close $writeFH
                    if ![cequal $readFH $writeFH] {
                        close $readFH
                    }
                    puts stdout "Test #12"
                    flush stdout
                    list [gets stdin result] $result
                } 0 {8 {Test #12}}
            }
            exit 0
        }
        wait $pid
    }

    # Test some of the fcntl options against a socket.

    Test $testId.9 {fcntl on a server connection} {
        fcntl $readFH NOBUF
    } 0 [expr !$buffered]

    Test $testId.10 {fcntl on a server connection} {
        fcntl $writeFH NOBUF
    } 0 [expr !$buffered]

    if $buffered {
        Test $testId.11 {fcntl on a server connection} {
            # This will hang and get alarm if buffered
            alarm 120
            fcntl $writeFH NOBUF 1
            puts $writeFH "Test #13"
            set stat [gets $readFH result]
            alarm 0
            list $stat $result
        } 0 {8 {Test #13}}
    }

    Test $testId.12 {fcntl on a server connection} {
        fcntl $writeFH READ
    } 0 1

    Test $testId.13 {fcntl on a server connection} {
        fcntl $writeFH WRITE
    } 0 1
        
    # Test server_cntl on the socket.

    Test $testId.20 {server_cntl on a server connection} {
        server_cntl $writeFH KEEPALIVE 1
        server_cntl $writeFH KEEPALIVE
    } 0 1
        
    Test $testId.21 {server_cntl on a server connection} {
        server_cntl $writeFH KEEPALIVE 0
        server_cntl $writeFH KEEPALIVE
    } 0 0

    Test $testId.22 {server_send compatibility procs} {
        set all {}
        server_send $writeFH "Test 22.1"
        lappend all [gets $readFH result] $result

        server_send -nonewline $writeFH "Test 22.2\n"
        lappend all [gets $readFH result] $result

        set all
    } 0 {9 {Test 22.1} 9 {Test 22.2}}

    close $readFH
    if ![cequal $readFH $writeFH] {
        close $writeFH
    }
    return
}

# We might have trouble converting a hostname to IP address.  If we can't,
# just use the hostname to access.

if $safeHost {
    set maybeIP [lindex [host_info addresses [id host]] 0]
} else {
    set maybeIP [id host]
    catch {
        set maybeIP [lindex [host_info addresses [id host]] 0]
    }
}

# If we can't connect to the echo server, then skip these tests.

if [catch {
    close [server_connect [id host] echo]
} msg] {
    puts "*************************************************************"
    puts "Unable to connect to the \"echo\" server:"
    puts "$msg."
    puts "Some tests skipped."
    puts "*************************************************************"
} else {

    Test server-8.1 {simple client interaction} {
        set fh [server_connect [id host] echo]
        TalkToEcho server-8.1 $fh $fh 1
    } 0 {}

    Test server-8.2 {simple client interaction} {
        set ip [lindex [host_info addresses [id host]] 0]
        set fh [server_connect -nobuf $maybeIP echo]
        TalkToEcho server-8.2 $fh $fh 0
    } 0 {}

    Test server-8.3 {simple client interaction} {
        set fh [server_connect -buf $maybeIP echo]
        TalkToEcho server-8.3 $fh $fh 1
    } 0 {}

    Test server-8.4 {simple client interaction with compatibility interface} {
        set fhs [server_open -buf $maybeIP echo]
        TalkToEcho server-8.4 [lindex $fhs 0] [lindex $fhs 1] 1
    } 0 {}
}

#
# Fork a server to echo slightly modified versions of the messages.
#

proc TestServer {toClient} {
    signal ignore SIGPIPE
    set reqFH [server_create]
    fconfigure $toClient -buffering line
    puts $toClient [lindex [fstat $reqFH localhost] 2]
    set readIds $reqFH

    while 1 {
        set ready [lindex [select $readIds] 0]
        foreach id $ready {
            if [cequal $id $reqFH] {
                lappend readIds [server_accept -nobuf $reqFH]
                continue
            }
            if {[gets $id data] < 0} {
                set idx [lsearch -exact $readIds $id]
                set readIds [lreplace $readIds $idx $idx]
                continue
            }
            if [cequal $data EXIT] {
                exit
            }
            puts $id "Got \"$data\""
        }
    }
}

pipe fromServer toClient
flush stdout
flush stderr

if {[set serverPID [fork]] == 0} {
    catch {
        close $fromServer
        TestServer $toClient
        exit 0
    }
    global errorInfo
    puts stderr "Error in test server: $errorInfo"
    exit 1
}
close $toClient
if {[gets $fromServer serverPort] < 0} {
    error "Unexpected EOF from test server"
}
close $fromServer

Test server-9.1 {Tcl server} {
    set fh [server_connect -nobuf localhost $serverPort]
    puts $fh "Hello"
    set data [gets $fh]
    close $fh
    set data
} 0 {Got "Hello"}

Test server-9.2 {Tcl server} {
    set fh [server_connect -nobuf localhost $serverPort]
    puts $fh "Are you still there?"
    set data [list [gets $fh]]
    puts $fh "Are you really still there?"
    lappend data [gets $fh]
    close $fh
    set data
} 0 {{Got "Are you still there?"} {Got "Are you really still there?"}}

Test server-9.3 {Tcl server} {
    set fh [server_connect -nobuf localhost $serverPort]
    puts $fh "EXIT"
    lrange [wait $serverPID] 1 2
} 0 {EXIT 0}

rename unknown {}