[squid-users] Test script for ICP parents

[Kevin <kkadow@xxxxxxxxx>]

A simple Perl script (uses the WebCache::ICP module from CPAN)
test-icp sends an ICP query to a cache peer and records the response time,
optionally print packet contents.

The primary reason I wrote this was to graph response time from
parent cache servers in Cricket, however the same script can
(if $debug is set) be useful for debugging general ICP problems.

It could also be useful as an example WebCache::ICP client.

Kevin Kadow

#!/usr/bin/perl 
# -*- perl -*-

#  Copyright (c) 2005 by Kevin Kadow
#
#	The code in this file is made freely available for any purpose
#	whatsoever. The author does not take any responsibility for the
#	correctness or suitability of the code.
#
# ICP Test Script 'test-icp.pl'
# Version 0.2
#
#	Simple script for testing Internet Cache Protocol Servers,
#	suitable for interactive use, or to be executed from a
#	response time graphing tool such as Cricket, Hobbit, etc.
#
# Usage:
#
#	test-icp.pl host[:port] [uri]
#
#	Sends an ICP query for uri to the specified host and port.
#	See below for default values for port and uri.
#

#
# Debugging
#
#	Remove the "#" in front of $debug=1 for verbose output.
#
#$debug=1;

#
# Required modules:
#	You will almost certainly need to download and install the
#	 Time::HiRes and WebCache::ICP modules from CPAN.
#
use Time::HiRes qw(gettimeofday);
use WebCache::ICP;
use Socket;


#
# Defaults:
#	Seldom any reason to change these.
#
$DEFAULT_PORT=3130;
$DEFAULT_QUERY="http://www.w3.org/";;
$TIMEOUT=10;


#
# Pick up the host and (optional) query from the command line.
#
$host=shift;
$query=shift;
$query=$DEFAULT_QUERY unless($query);

$icp = new WebCache::ICP;
$icp->opcode("OP_QUERY");
$icp->payload($query);
warn "Will query via ICP for \'$query\'\n" if($debug);


#  In case of failure, print 'U' results for Cricket to parse.
#
sub death {
	local($why)=@_;
        print "U\nU\n";
	die "\nDied on SIG$why";
        }

$SIG{'INT'}='death';
$SIG{'QUIT'}='death';
$SIG{'PIPE'}='death';
$SIG{'ALRM'}='death';

$port=$DEFAULT_PORT;
die("Missing URL on command line.\n") unless($host);

if($host=~m/^([^:]+):(\d+)$/) {
	$host=$1;
	$port=$2;
	}

$host=&name2address($host);
die "Invalid IP address $host\n" unless($host);


#
# Construct our socket for the ICP query.
#
warn "Sending packet to $host:$port" if($debug);

socket(SOCK, PF_INET, SOCK_DGRAM, getprotobyname('udp'))
	or die "socket: $!";

my $sin = sockaddr_in($port, inet_aton($host));
die "bad sin" unless($sin);


#
# Send the packet.
#
alarm($TIMEOUT);
$start = now();
$icp->send(fd => \*SOCK, sin => $sin);

#
# Get an answer (or timeout due to SIGALRM)
#
$response= $icp->recv(fd =>\*SOCK);
$stop = now();

alarm(0);

warn "Back from recv()\n" if($debug);
close(SOCK);


#
# Calculate the elapsed time since we sent the query. 
#
$delta = $stop - $start;
$SCALE=1000000;
$delta = (int(0.9+($delta * $SCALE)))/$SCALE;

#
# Cricket wants a number as the first field of the first line of output.
#
print $delta," Seconds\n";


#
# Process our answer, print as necessary.
#
$answer = new WebCache::ICP($response);
$c=$answer->opcode;

print $c,"\t",&code2name( $c ),"\n";

$answer->dump if($debug);

exit(0);

#########################################################
#
# Subroutines follow
#
#########################################################


sub now {
	my(@t) = gettimeofday();
	return $t[0] + ($t[1] / 1000000.0);
}


#
# Convert an ICP opcode to a human-readable form.
#
sub code2name {
my($code)=(@_);

%OPCODENAMES = (
     0 => "OP_INVALID",
     1, "OP_QUERY",
     2, "OP_HIT",
     3, "OP_MISS",
     4, "OP_ERR",
    10, "OP_SECHO",
    11, "OP_DECHO",
    21, "OP_MISS_NOFETCH",
    22, "OP_DENIED",
    23, "OP_HIT_OBJ",
);
return($OPCODENAMES{$code}) if($OPCODENAMES{$code});
return "UNDEF $code";
}

#
# Convert a hostname to a machine-readable form.  Die if DNS fails.
#
sub name2address {
my($name)=@_;
my $address;

eval {$address=&n2a($name) };

if($@ || !$address) {
        print "U bad dns\nU cannot resolve dns\n";
        die("DNS lookup failed, fatal error");
        }
return($address);
}


sub n2a {
my($hostname)=@_;
return($hostname) if($hostname=~m/^\d[\d.]+\d$/ );

my($name, $aliases, $addrtype, $length, @addrs,@result);
alarm(7);
@result = gethostbyname($hostname);
alarm(0);

unless(@result) {
        warn "name2address($hostname) Cannot resolve\n" if($debug);
        return undef;
        }

($name, $aliases, $addrtype, $length, @addrs) =@result;
($a, $b, $c, $d) = unpack('C4', $addrs[0]);

my($ip)="$a.$b.$c.$d";

warn "$hostname resolves to $ip\n" if($debug);

return($ip);
}

###EOF###