Adding a perl script that can send HTCP queries

diff --git a/test-suite/htcp-client.pl b/test-suite/htcp-client.pl
new file mode 100644 (file)
index 0000000..4a9c7c7
--- /dev/null
+++ b/test-suite/htcp-client.pl
@@ -0,0 +1,125 @@
+#!/usr/bin/perl
+
+# htcp-client.pl
+# by Duane Wessels
+#
+# simple tool to send client HTCP queries
+#
+# only supports TST and CLR so far
+#
+
+use strict;
+use warnings;
+use IO::Socket::INET;
+
+my $op = shift;
+my $url = shift;
+my $server = shift;
+my %opcodes = (
+       NOP => 0,
+       TST => 1,
+       MON => 2,
+       SET => 3,
+       CLR => 4,
+);
+
+print "sending $op $url to $server\n";
+
+my $op_data = op_data($op, $url);
+
+
+my $data = data($op_data, $opcodes{$op}, 0, 1, 0, rand 1<<31);
+my $auth = auth();
+
+my $htcp = packet($data, $auth);
+
+my $sock = IO::Socket::INET->new(PeerAddr => $server,
+               PeerPort => 4827,
+               Proto => 'udp');
+
+die "$server: $!" unless $sock;
+
+$sock->send($htcp, 0) || die "send $server: $!";
+exit 0;
+
+sub packet {
+       my $data = shift;
+       my $auth = shift;
+       my $hdr = header(length($data) + length($auth));
+       printf STDERR "hdr is %d bytes\n", length($hdr);
+       printf STDERR "data is %d bytes\n", length($data);
+       printf STDERR "auth is %d bytes\n", length($auth);
+       $hdr . $data . $auth;
+}
+
+sub header {
+       my $length = 4 + shift;
+       my $major = 0;
+       my $minor = 0;
+       my $buf;
+       pack('nCC', $length, $major, $minor);
+}
+
+sub data {
+       my $op_data = shift;
+       my $opcode = shift;
+       my $response = shift;
+       my $reserved = 0;
+       my $f1 = shift;
+       my $rr = shift;
+       my $trans_id = shift;
+       printf STDERR "op_data is %d bytes\n", length($op_data);
+       printf STDERR "response is %d\n", $response;
+       printf STDERR "F1 is %d\n", $f1;
+       printf STDERR "RR is %d\n", $rr;
+       my $length = 8 + length($op_data);
+       my $x1 = ($opcode & 0xF) | (($response & 0xF) << 4);
+       #my $x2 = ($rr & 0x1) | (($f1 & 0x1) << 1) | (($reserved & 0x3F) << 2);
+       my $x2 = ($reserved & 0x3F) | (($f1 & 0x1) << 6) | (($rr & 0x1) << 7);
+       pack('nCCNa*', $length, $x1, $x2, $trans_id, $op_data);
+}
+
+sub auth {
+       pack('n', 2);
+}
+
+sub countstr {
+       my $str = shift;
+       pack('na*', length($str), $str);
+}
+
+sub specifier {
+       my $method = countstr(shift);
+       my $uri = countstr(shift);
+       my $version = countstr(shift);
+       my $req_hdrs = countstr(shift);
+       $method . $uri . $version . $req_hdrs;
+}
+
+sub clr {
+       my $reason = shift;
+       my $reserved = 0;
+       my $specifier = shift;
+       printf STDERR "CLR specifier is %d bytes\n", length($specifier);
+       my $x1 = ($reason & 0xF) | (($reserved & 0x7F) << 4);
+       pack('na*', $x1, $specifier);
+}
+
+sub tst {
+       my $specifier = shift;
+       printf STDERR "TST specifier is %d bytes\n", length($specifier);
+       pack('a*', $specifier);
+}
+
+sub op_data {
+       my $op = shift;
+       my $url = shift;
+       if ($op eq 'CLR') {
+               return clr(1, specifier('GET', $url, 'HTTP/1.1', "Accept: */*\r\n"));
+       } elsif ($op eq 'TST') {
+               return tst(specifier('GET', $url, 'HTTP/1.1', "Accept: */*\r\n"));
+       } else {
+               print STDERR "unsupported HTCP opcode $op\n";
+               exit 1;
+       }
+}