File: tcp_client.pl

package info (click to toggle)
skiboot 6.7.1%2Bdfsg-1
  • links: PTS, VCS
  • area: main
  • in suites: bullseye
  • size: 35,060 kB
  • sloc: ansic: 214,818; sh: 11,529; python: 3,418; cpp: 3,135; makefile: 1,773; perl: 1,479; asm: 1,445; tcl: 1,147; pascal: 107
file content (86 lines) | stat: -rwxr-xr-x 2,643 bytes parent folder | download | duplicates (6)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
#!/usr/bin/env perl

# A simple TCP client that sends some data and expects a response.
# Usage: tcp_client.pl HOSTNAME PORT DATA1 RESPONSE1
#   DATA: hex-encoded data to send to the server
#   RESPONSE: regexp that must match the server's response

use warnings;
use strict;
use IO::Socket::INET;

# Pack hex digits into a binary string, ignoring whitespace.
sub parse_hex {
    my ($hex) = @_;
    $hex =~ s/\s+//g;
    return pack('H*', $hex);
}

## Open a TCP connection to the specified host and port.
sub open_connection {
    my ($host, $port) = @_;
    my $socket = IO::Socket::INET->new(PeerAddr => $host,
                                       PeerPort => $port,
                                       Proto => 'tcp',
                                       Timeout => 1);
    die "Cannot connect to $host:$port: $!" unless $socket;
    return $socket;
}

## Close the TCP connection.
sub close_connection {
    my ($connection) = @_;
    $connection->shutdown(2);
    # Ignore shutdown failures (at least for now)
    return 1;
}

## Write the given data, expressed as hexadecimal
sub write_data {
    my ($connection, $hexdata) = @_;
    my $data = parse_hex($hexdata);
    my $total_sent = 0;
    while ($total_sent < length($data)) {
        my $sent = $connection->send($data, 0);
        if (!defined $sent) {
            die "Unable to send data: $!";
        }
        $total_sent += $sent;
    }
    return 1;
}

## Read a response and check it against an expected prefix
sub read_response {
    my ($connection, $expected_hex) = @_;
    my $expected_data = parse_hex($expected_hex);
    my $start_offset = 0;
    while ($start_offset < length($expected_data)) {
        my $actual_data;
        my $ok = $connection->recv($actual_data, length($expected_data));
        if (!defined $ok) {
            die "Unable to receive data: $!";
        }
        if (($actual_data ^ substr($expected_data, $start_offset)) =~ /[^\000]/) {
            printf STDERR ("Received \\x%02x instead of \\x%02x at offset %d\n",
                           ord(substr($actual_data, $-[0], 1)),
                           ord(substr($expected_data, $start_offset + $-[0], 1)),
                           $start_offset + $-[0]);
            return 0;
        }
        $start_offset += length($actual_data);
    }
    return 1;
}

if (@ARGV != 4) {
    print STDERR "Usage: $0 HOSTNAME PORT DATA1 RESPONSE1\n";
    exit(3);
}
my ($host, $port, $data1, $response1) = @ARGV;
my $connection = open_connection($host, $port);
write_data($connection, $data1);
if (!read_response($connection, $response1)) {
    exit(1);
}
close_connection($connection);