1#!/usr/bin/perl -I../p 2# Copyright (c) 1998 Sampo Kellomaki <sampo@iki.fi>, All Rights Reserved. 3# This software may not be used or distributed for free or under any other 4# terms than those detailed in file COPYING. There is ABSOLUTELY NO WARRANTY. 5 6package tcpcat; 7 8# tcpcat.pm - Send a message and receive a reply from server. 9# 10# Usage: $reply = &tcpcat ($address, $port, $message); 11# E.g: $reply = &tcpcat ('foo.bar.com', 900, "Hello World!"); 12 13use Socket; 14 15$trace = 0; 16 17### Start listening on given port 18 19sub open_tcp_server { 20 my ($port) = @_; # port=0 --> let system pick any free port 21 $port = getservbyname ($port, 'tcp') unless $port =~ /^\d+$/; 22 my $serv_params = pack ('S n a4 x8', &AF_INET, $port, "\0\0\0\0"); 23 24 if (socket (SERV_S, &PF_INET, &SOCK_STREAM, 0)) { 25 warn "next bind\n" if $trace > 2; 26 if (bind (SERV_S, $serv_params)) { 27 my $old_out = select (SERV_S); $| = 1; select ($old_out); 28 warn "next listen\n" if $trace > 2; 29 if (listen(SERV_S, 5)) { 30 $serv_params = getsockname(SERV_S); # getpeername(SERV_S); 31 my ($fam, $sport, $saddr) = unpack('S n a4 x8',$serv_params); 32 my ($a,$b,$c,$d) = unpack('C4',$saddr); 33 $saddr = "$a.$b.$c.$d"; 34 warn "bound to $saddr:$sport\n" if $trace > 2; 35 return ($saddr, $sport); # Success, now we're ready to accept 36 } 37 } 38 } 39 warn "$0 $$: open_tcp_server: failed 0.0.0.0, $port ($!)\n"; 40 close SERV_S; 41 return 0; # Fail 42} 43 44### Open stream to given host and port 45 46sub open_tcp_connection { 47 my ($dest_serv, $port) = @_; 48 $port = getservbyname ($port, 'tcp') unless $port =~ /^\d+$/; 49 my $dest_serv_ip = gethostbyname ($dest_serv); 50 unless (defined($dest_serv_ip)) { 51 warn "$0 $$: open_tcp_connection: destination host not found:" 52 . " `$dest_serv' (port $port) ($!)\n"; 53 return 0; 54 } 55 my $dest_serv_params = pack ('S n a4 x8', &AF_INET, $port, $dest_serv_ip); 56 57 if (socket (S, &PF_INET, &SOCK_STREAM, 0)) { 58 warn "next connect\n" if $trace > 2; 59 if (connect (S, $dest_serv_params)) { 60 my $old_out = select (S); $| = 1; select ($old_out); 61 warn "connected to $dest_serv, $port\n" if $trace > 2; 62 return 1; # Success 63 } 64 } 65 warn "$0 $$: open_tcp_connection: failed `$dest_serv', $port ($!)\n"; 66 close S; 67 return 0; # Fail 68} 69 70### Perform full roundtrip: open, write, read, close 71 72sub tcpcat { # address, port, message --> returns reply, undef on error 73 my ($dest_serv, $port, $out_message) = @_; 74 my $reply = ''; 75 76 return unless (open_tcp_connection($dest_serv, $port)); 77 78 warn "$0 $$: tcpcat: sending `$out_message'\n" if $trace>2; 79 print S $out_message; 80 shutdown S, 1; # Half close --> No more output, sends EOF to server 81 warn "$0 $$: tcpcat: receiving...\n" if $trace>2; 82 while (<S>) { $reply .= $_; } 83 warn "$0 $$: tcpcat: Done -- EOF. Got `$reply'.\n" if $trace>1; 84 85 close S; 86 return $reply; 87} 88 891; 90#__END__ 91