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