Permalink
Browse files

[t/spec/S32-io/IO-Socket-INET.t] shell script forks client and server

git-svn-id: http://svn.pugscode.org/pugs@26670 c213334d-75ef-0310-aa23-eaa082d1ae64
  • Loading branch information...
1 parent 4701aa5 commit ba86db9d9dca28eabffc3e9781514f3858733a8a mberends committed May 4, 2009
Showing with 221 additions and 0 deletions.
  1. +87 −0 S32-io/IO-Socket-INET.pl
  2. +24 −0 S32-io/IO-Socket-INET.sh
  3. +110 −0 S32-io/IO-Socket-INET.t
View
@@ -0,0 +1,87 @@
+# t/spec/S32-io/IO-Socket-INET.pl
+# run by IO-Socket-INET.sh, which is run by IO-Socket-INET.t
+
+# May 2009: script laden with commented out warnings that
+# can be removed after stability of tests has been confirmed
+# on multiple operating systems.
+
+use v6;
+
+constant PF_INET = 2; # these should move into a file,
+constant SOCK_STREAM = 1; # but what name and directory?
+constant TCP = 6;
+my ( $test, $port, $server_or_client ) = @*ARGS;
+my $host = '127.0.0.1';
+
+given $test {
+
+ when 2 { # test number 2 - echo protocol, RFC 862
+ if $server_or_client eq 'server' {
+ # warn "SERVER TEST=$test PORT=$port";
+ my $server = IO::Socket::INET.socket( PF_INET, SOCK_STREAM, TCP );
+ $server.bind( $host, int($port) );
+ $server.listen(); # should accept max queue size parameter
+ # warn "SERVER LISTENING";
+ while my $client = $server.accept() {
+ # warn "SERVER ACCEPTED";
+ my $received = $client.recv();
+ # warn "SERVER RECEIVED '$received'";
+ $client.send( $received );
+ # warn "SERVER REPLIED";
+ $client.close();
+ }
+ }
+ else { # $server_or_client eq 'client'
+ # warn "CLIENT TEST=$test PORT=$port";
+ # avoid a race condition, where the client tries to
+ # open() before the server gets to accept().
+ sleep 1; # crude, sorry
+ my $client = IO::Socket::INET.new;
+ $client.open( $host, int($port) );
+ # warn "CLIENT OPENED";
+ $client.send( [~] '0'..'9', 'a'..'z' );
+ # warn "CLIENT SENT";
+ my $received = $client.recv();
+ # warn "CLIENT RECEIVED '$received'";
+ # let IO-Socket-INET.t judge the pass/fail
+ say "echo '$received' received";
+ $client.close();
+ }
+ }
+
+ when 3 { # test number 3 - discard protocol, RFC 863
+ if $server_or_client eq 'server' {
+ # warn "SERVER TEST=$test PORT=$port";
+ my $server = IO::Socket::INET.socket( PF_INET, SOCK_STREAM, TCP );
+ $server.bind( $host, int($port) );
+ $server.listen(); # should accept max queue size parameter
+ # warn "SERVER LISTENING";
+ while my $client = $server.accept() {
+ # warn "SERVER ACCEPTED";
+ my $received = $client.recv();
+ # warn "SERVER RECEIVED '$received'";
+ $client.close(); # without sending anything back
+ }
+ }
+ else { # $server_or_client eq 'client'
+ # warn "CLIENT TEST=$test PORT=$port";
+ # avoid a race condition, where the client tries to
+ # open() before the server gets to accept().
+ sleep 1; # crude, sorry
+ my $client = IO::Socket::INET.new;
+ $client.open( $host, int($port) );
+ # warn "CLIENT OPENED";
+ $client.send( [~] '0'..'9', 'a'..'z' );
+ # warn "CLIENT SENT";
+ my $received = $client.recv();
+ # warn "CLIENT RECEIVED '$received'";
+ # let IO-Socket-INET.t judge the pass/fail
+ say "discard '$received' received";
+ $client.close();
+ }
+ }
+}
+
+=begin pod
+
+=end pod
View
@@ -0,0 +1,24 @@
+# shell script (unix style) to supply a fork() for Rakudo
+# request to Windows developers - make a similar script for cmd shell?
+TEST="$1"
+PORT="$2"
+# commented out echo lines are diagnostics used during development.
+# echo TEST=$TEST PORT=$PORT
+
+# use & to run the server as a background process
+./perl6 t/spec/S32-io/IO-Socket-INET.pl $TEST $PORT server & SERVER=$!
+
+# use & to run the client as a background process
+./perl6 t/spec/S32-io/IO-Socket-INET.pl $TEST $PORT client & CLIENT=$!
+
+# make a watchdog to kill a hanging client (occurs only if a test fails)
+( sleep 10; kill $CLIENT 2>/dev/null ) &
+
+# the client should exit after about 3 seconds. The watchdog would kill
+# it after 10 sec. Hang around here until the client ends, either way.
+# echo BEFORE CLIENT ENDS
+wait $CLIENT 2>/dev/null
+# echo AFTER CLIENT ENDED
+# now that the client is finished either way, stop the server
+kill $SERVER 2>/dev/null
+# echo SHELL COMPLETED
View
@@ -0,0 +1,110 @@
+use v6;
+use Test;
+
+plan 3;
+
+# Testing socket must solve 2 problems: find an unused port to bind to,
+# and fork a client process before the server is blocked in accept().
+
+my $host = '127.0.0.1'; # or 'localhost' may be friendlier
+
+# To find an free port, list the ports currently in use.
+my ( $host, @ports, $netstat_cmd, $netstat_pat, $received, $expected );
+given $*OS {
+ when 'linux' {
+ $netstat_cmd = "netstat --tcp --all --numeric";
+ $netstat_pat = regex { State .+? [ ^^ .+? ':' (\d+) .+? ]+ $ };
+ }
+ when 'darwin' {
+ $netstat_cmd = "netstat -f inet -p tcp -a -n";
+ $netstat_pat = regex { [ ^^ .+? <dot> (\d+) <.sp> .+? ]+ $ };
+ }
+ # TODO: when 'Win32' etc.
+}
+#$received = slurp( '/home/martin/osx-netstat' );
+$received = fake_qx( $netstat_cmd ); # refactor into 1 line after
+if $received ~~ $netstat_pat { @ports = $/[]; } # development complete
+warn @ports.elems ~ " PORTS=" ~ @ports;
+
+exit(1);
+
+# sequentially search for the first unused port
+my $port = 1024;
+while $port < 65535 && $port==any(@ports) { $port++; }
+if $port > 65535 { die "no free port"; }
+# warn "CHOSEN PORT $port";
+
+# test 1 creates a TCP socket but does not use it.
+constant PF_INET = 2; # these should move into a file,
+constant SOCK_STREAM = 1; # but what name and directory?
+constant TCP = 6;
+my $server = IO::Socket::INET.socket( PF_INET, SOCK_STREAM, TCP );
+isa_ok $server, IO::Socket::INET;
+# Do not bind to this socket in the parent process, that would prevent a
+# child process from using it.
+
+#
+if $*OS eq any <linux darwin> { # please add more valid OS names
+
+ # test 2 does echo protocol - Internet RFC 862
+ $received = fake_qx( "sh t/spec/S32-io/IO-Socket-INET.sh 2 $port" );
+ #warn "TEST 2 $received";
+ $expected = "echo '0123456789abcdefghijklmnopqrstuvwxyz' received\n";
+ is $received, $expected, "echo server and client";
+
+ # test 3 does discard protocol - Internet RFC 863
+ $received = fake_qx( "sh t/spec/S32-io/IO-Socket-INET.sh 3 $port" );
+ #warn "TEST 3 $received";
+ $expected = "discard '' received\n";
+ is $received, $expected, "discard server and client";
+}
+else {
+ # eg Win32 shell script needs writing
+ skip 1, "OS '$*OS' shell support not confirmed";
+}
+
+# inefficient workaround - remove when Rakudo gets a qx operator
+sub fake_qx( $command ) {
+ my $tempfile = "/tmp/rakudo_httpd_qx.tmp";
+ my $fullcommand = "$command >$tempfile";
+ run $fullcommand;
+ my $result = slurp( $tempfile );
+ unlink $tempfile;
+ return $result;
+}
+
+=begin pod
+
+=head1 Perl 6 Internet Sockets Testing
+The initial use of the BSD Sockets library by Parrot and Rakudo happened
+without a formal test suite, slowing development and causing occasional
+random errors. This set of tests aims to ensure the future stability of
+of the Sockets library integration, and to help enhance Rakudo's
+IO::Socket::INET class in the 'setting'.
+
+The BSD Sockets functions provide server and client functions that run
+synchronously, blocking and waiting indefinitely for communication from
+a remote process. Sockets testing therefore requires separate server and
+client processes or threads. Rakudo does not currently fork or thread,
+so these tests employ a unix shell script that uses the & symbol to fork
+background processes. When Rakudo starts forking or threading, this
+testing solution should be refactored down to just the main script.
+
+=head1 Scope of tests
+To date, only single TCP sessions have been tested, and only on Linux.
+The Internet standard protocols are used, except that a dynamic port
+number above the first 1024 is used so that superuser (root) privileges
+are not required. Execution time is 5 to 10 seconds.
+
+=head1 TODO
+UDP. Unix sockets. Concurrent connections (needs threads).
+
+=head1 SEE ALSO
+
+ echo L<http://www.ietf.org/rfc/rfc862.txt> port 7
+ discard L<http://www.ietf.org/rfc/rfc863.txt> port 9
+ chargen L<http://www.ietf.org/rfc/rfc864.txt> port 19
+ daytime L<http://www.ietf.org/rfc/rfc867.txt> port 13
+ time L<http://www.ietf.org/rfc/rfc868.txt> port 37
+
+=end pod

0 comments on commit ba86db9

Please sign in to comment.