The following is really rough code but it works on Unix and Windows (although Windows gives me a list warning, however it still works just the same.)
It is from a overseer project i worked on some years ago; before Windows even had a fork() (whch it does -- it is part of the activestate.com Perl release.) #!/usr/bin/perl -w use strict; use warnings; use diagnostics; use Socket; use POSIX; use IO::File; # Written by WC -Sx- Jones # http://insecurity.org/ my $maxTO = 5; # Set to prevent hung clients... unless (@ARGV && (@ARGV < 1)) { print <<_Usage; Usage: $0 [Enter] Where - Running Socket_Server... _Usage } # Disconnect timeout ignored at present... my $timeout = pop(@ARGV) || 2; unless ($timeout > 0 && $timeout < $maxTO) { print "Value $timeout: Not numeric or not between 1 thru $maxTO. Using 2"; } # Port number to run on... my $server_port = pop(@ARGV) || 1963; die "Privledged Port $server_port Requested: Access Denied.\n" unless (($server_port > 1023) || ($> > 0)); my $path = pop(@ARGV) || ''; unless (-d $path) { print "Directory $path specified does not exist. Using ", `pwd`; } else { my $log_file = $path . $0 . ".log"; # Open it Write Only (O_WRONLY), in Append Mode (O_APPEND), # if it already exists; otherwise Create the file (O_CREAT) # Set the file permission bits to 0600 ( -rw------- ) my $fh = new IO::File $log_file, O_WRONLY|O_APPEND|O_CREAT, 0600; if (defined $fh) { print $fh $0 . " started by " . $> . " for Port " . $server_port . " on Date: " . (localtime) . "\n"; undef $fh; } else { die "Oops! Betcha that hurt: $!"; } autoflush STDOUT 1; $path = $log_file; } my @services = qw{ # integrate your services... }; my @ip_allow = qw{ 192.168.2.22 127.0.0.1 }; socket(SERVER, PF_INET, SOCK_STREAM, getprotobyname('tcp')); setsockopt(SERVER, SOL_SOCKET, SO_REUSEADDR, 1); my $my_addr = sockaddr_in($server_port, INADDR_ANY); bind(SERVER, $my_addr) or die "Couldn't bind to addr $my_addr on port $server_port : $!\n"; listen(SERVER, SOMAXCONN) or die "Couldn't listen on port $server_port : $!\n"; while (accept(CLIENT, SERVER)) { $/ = ''; my $data_read = ''; my $sindex = ''; my $eindex = ''; my $maxlen = 1500; # MTA Limit, no fragment? my $flags = 0; my $data_to_send = ''; defined (recv(CLIENT, $data_read, $maxlen, $flags)) or die "Can't read: $! $@"; $sindex = chr(64 + (localtime)[3]); $eindex = chr(ord($sindex) + 9 + ($sindex gt 'Q' and 64 - 90)); for (1 .. ($ARGV[0] || 1)) { my @num = ($sindex..$eindex); for (my $i = $#num; $i > 0; $i--) { my $swapper = int rand(1+$i); if ($swapper < $i) { @num[$i,$swapper] = @num[$swapper,$i]; } } #print '', split(' ', "@num"), "\n"; $data_to_send = "@num\n"; } print "IN: $data_read OUT: $data_to_send\n"; send (CLIENT, $data_to_send, $flags); } close(SERVER); exit; __END__ Maybe someone would be willing to clean it up a bit more? -- WC -Sx- Jones http://youve-reached-the.endoftheinternet.org/ -- To unsubscribe, e-mail: [EMAIL PROTECTED] For additional commands, e-mail: [EMAIL PROTECTED] <http://learn.perl.org/> <http://learn.perl.org/first-response>
