#!/usr/local/bin/perl

# $Header: /usr/local/src/dhcpd/tools/RCS/dhcp-bindings-tool,v 1.7 2005/11/01 18:32:34 root Exp $

# dhcp-bindings-tool  
#
# This tool reads the bindings directory produced by CMU+PU dhcpd.
# Once they have been read into memory, you may optionally prune them.
# You may optionally write the results to a new bindings directory, a plain text report file,
# and/or a plain text statistics file. 
#
# This tool is distributed as part of Carngie Mellon University dhcpd with the
# Princeton University patches, available at http://www.net.princeton.edu/software/dhcpd/
#
# Irwin Tillman, irwin at princeton dot edu


use 5.8.0;

use warnings;
use strict;

use English qw( -no_match_vars );
use Getopt::Long;
use Cwd;						# for getcwd
use Readonly;					# from CPAN
use Statistics::Descriptive;	# from CPAN, used by --write-statistics option


 

######################################################################################
#
# Constants
#
######################################################################################

Readonly my $VERSION => '1.0.1';

Readonly my $REPORT_FILE_FORMAT_WRITE_VERSION => '1.0';			# version of the report file format we write
Readonly my $STATISTICS_FILE_FORMAT_WRITE_VERSION => '1.0';		# version of the statistics file format we write
Readonly my @REPORT_FILE_FORMAT_READ_VERSIONS => qw(1.0);		# versions of the report file format we read

Readonly my $REAL_PROG_NAME => 'dhcp-bindings-tool';			# for display by --version option

Readonly my $MAX_UINT32 => 2**32 - 1;

Readonly my $STATISTICS_FILENAME_FIELD_WIDTH => 5; # for filenames written by --write-statistics
Readonly my $STATISTICS_NUMERIC_FIELD_WIDTH => 10; # for descriptive statistics written by --write-statistics

# The values below must match those used by the DHCP server.
#
Readonly my $INFINITY => 0xFFFFFFFF;  # special value for 'expire' field within a binding
#
# Possible values of 'code' field within a binding
# We init this in such a way that we can support non-contiguous values if necessary.
my @CODENAME;
Readonly $CODENAME[0]	=> 'UNKNOWN';
Readonly $CODENAME[1]	=> 'RESERVED_FLAG';
Readonly $CODENAME[2]	=> 'DHCP_FLAG';
Readonly $CODENAME[3]	=> 'BOOTP_FLAG';
Readonly $CODENAME[4]	=> 'ROAMING_FLAG';
Readonly $CODENAME[5]	=> 'SYCH_FLAG';


######################################################################################
#
# Construct any data structures based on constants
#
######################################################################################


# Construct @codename based on @CODENAME

# We can't simply use @CODENAME to decode codes we read from bindings, because if the binding
# contains a code (number) that isn't defined in @CODENAME, it will cause a runtime error 
# under 'use strict'.
#
# So we construct @codename that *is* safe to use.
#
# We want the @codename array populated such that each elements that *could* be indexed using an 
# unsigned one-byte value has a defined value.

# Define all elements to be empty strings
my @codename = ( q{} ) x 256;

# Overwrite those elements with the defined elements from @CODENAME
foreach my $index ( 0 .. scalar(@CODENAME)) {
	$codename[$index] = $CODENAME[$index] if defined $CODENAME[$index];
}


######################################################################################
#
# Parse command line
#
######################################################################################


(my $prog = $0) =~ s/.*\///g;

my $debug = '';
my $prune_cliid = '';
my $prune_cliidhw = '';
my $prune_code = '';
my $prune_last_touch = '';
my $prune_last_ip = '';
my $prune_expire = '';
my $read_bindings_dir = '';
my $read_report = '';
my $write_bindings_dir = '';
my $write_report = '';
my $write_statistics = '';

GetOptions(	'debug'						=>	\$debug,
			'prune-cliid=s'				=>	\$prune_cliid,
			'prune-cliidhw=s'			=>	\$prune_cliidhw,
			'prune-code=i'				=>	\$prune_code,
			'prune-expire=s'			=>	\$prune_expire,
			'prune-last-ip=s'			=>	\$prune_last_ip,
			'prune-last-touch=s'		=>	\$prune_last_touch,
			'read-bindings-dir=s'		=>	\$read_bindings_dir,
			'read-report=s'				=>	\$read_report,
			'write-bindings-dir=s'		=>	\$write_bindings_dir,
			'write-report=s'			=>	\$write_report,
			'write-statistics=s'		=>	\$write_statistics,

			# standard meta-options
			'help'						=>	sub { help(); },
			'usage'						=>	sub { help(); },
			'version'					=>	sub { version(); },
		) or exit 1;




if (!$read_bindings_dir && !$read_report) {
	die "${prog}: either the 'read-bindings-dir' or 'read-report' option must be specified.\n";
}

if ($read_bindings_dir && $read_report) {
	die "${prog}: only one of the 'read-bindings-dir' and 'read-report' options may be specified.\n";
}

my $prune_cliid_bin = '';			# if set, will be an opaque sequence of bytes
if ($prune_cliid) {
	my $errmsg = "${prog}: format for the --prune-cliid option is '--prune-cliid 0xhh...' where 'hh...' is an even number of hex digits'\n";
	die $errmsg unless ($prune_cliid =~ s/^0x//i);
	die $errmsg unless ($prune_cliid =~ /^[0-9A-Fa-f]+$/);
	die $errmsg unless (length($prune_cliid) % 2 == 0); # require an even number of nibbles
	$prune_cliid_bin = pack 'H*', $prune_cliid;
}

my $prune_cliidhw_bin = '';			# if set, will be an opaque sequence of bytes
if ($prune_cliidhw) {
	my $errmsg = "${prog}: format for the --prune-cliidhw option is '--prune-cliidhw 0xhh...' where 'hh...' is an even number of hex digits'\n";
	die $errmsg unless ($prune_cliidhw =~ s/^0x//i);
	die $errmsg unless ($prune_cliidhw =~ /^[0-9A-Fa-f]+$/);
	die $errmsg unless (length($prune_cliidhw) % 2 == 0); # require an even number of nibbles
	$prune_cliidhw_bin = pack 'H*', $prune_cliidhw;
}

if ($prune_code) {
	my $errmsg = "${prog}: format for the --prune-code option is '--prune-code num', where 'num' is in the range 0...255\n";
	die $errmsg unless $prune_code =~ /^\d+$/;
	die $errmsg unless ($prune_code >= 0 && $prune_code <= 255);
}

my $prune_last_touch_operator;		# if set, will be the string 'lt', 'gt', or 'eq'
my $prune_last_touch_time_t;		# if set, will be a decimal number
if ($prune_last_touch) {
	my $errmsg = qq[${prog}: format for the --prune-last-touch option is "--prune-last-touch 'gt|lt|eq time_t'", where time_t <= $MAX_UINT32\n];
	die $errmsg unless ($prune_last_touch_operator, $prune_last_touch_time_t) = ($prune_last_touch =~ /^(gt|lt|eq)\s+(\d+)$/);
	die $errmsg if $prune_last_touch_time_t > $MAX_UINT32;
}

my $prune_expire_operator;			# if set, will be the string 'lt', 'gt', or 'eq'
my $prune_expire_time_t;			# if set, will be a decimal number
if ($prune_expire) {
	my $errmsg = qq[${prog}: format for the --prune-expire option is "--prune-expire 'gt|lt|eq time_t'", where time_t <= $MAX_UINT32\n];
	die $errmsg unless ($prune_expire_operator, $prune_expire_time_t) = ($prune_expire =~ /^(gt|lt|eq)\s+(\d+)$/);
	die $errmsg if $prune_expire_time_t > $MAX_UINT32;
}

my $prune_last_ip_address = '';		# if set, will be a 4-byte unsigned long in network byte order
my $prune_last_ip_netmask = '';		# if set, will be a 4-byte unsigned long in network byte order
if ($prune_last_ip) {
	my $errmsg = "${prog}: format for the --prune-last-ip option is '--prune-last-ip IP[&netmask]', where IP and netmask are in dotted quad format, e.g. '192.168.1.0'\n";
	($prune_last_ip_address, $prune_last_ip_netmask) = split('&', $prune_last_ip, 2);
	{
		die $errmsg unless (my ($byte1, $byte2, $byte3, $byte4) = IP_address_in_dotted_quad_format_to_decimal_bytes($prune_last_ip_address));
		$prune_last_ip_address = pack 'C4', $byte1, $byte2, $byte3, $byte4;
	}
	$prune_last_ip_netmask = '255.255.255.255' unless $prune_last_ip_netmask;
	{
		die $errmsg unless (my ($byte1, $byte2, $byte3, $byte4) = IP_address_in_dotted_quad_format_to_decimal_bytes($prune_last_ip_netmask));
		$prune_last_ip_netmask = pack 'C4', $byte1, $byte2, $byte3, $byte4;
	}
}


######################################################################################
#
# Main Program
#
######################################################################################


# The bindings we parse from read_bindings_dir or read_report will be stored in a hash
# referenced by $parsed_bindings_ref.
#	The referenced hash contains one key for each bindings file; the (unqualified) filenames are the keys.
#	Each hash value is a listref.
#	The referenced list contains one hashref for each binding in that file.
#	The referenced hash is a single binding.
my $parsed_bindings_ref;

#
# Read bindings
#

if ($read_bindings_dir) {
	unless ($parsed_bindings_ref = read_bindings_dir($read_bindings_dir)) {
		die "${prog}: Giving up due to error reading bindings directory\n"; 
		exit 1;
	}
}
elsif ($read_report) {
	unless ($parsed_bindings_ref = read_report($read_report)) {
		die "${prog}: Giving up due to error reading report file\n"; 
		exit 2;
	}
}
# Parsing of cmdline already guaranteed that exactly one of these was specified.


#
# Prune the bindings in memory (if requested)
#

if ($prune_cliid || $prune_cliidhw || $prune_last_touch || $prune_last_ip || $prune_expire || $prune_code) {
	unless ($parsed_bindings_ref = prune_bindings($parsed_bindings_ref)) {
		die "${prog}: Giving up due to error pruning bindings\n";
		exit 3;
	}
}


#
# Write output files (if requested)
#

if ($write_report) {
	unless (write_report($write_report, $parsed_bindings_ref)) {
		die "${prog}: Giving up due to error writing report file\n"; 
		exit 3;
	}
}

if ($write_statistics) {
	unless (write_statistics($write_statistics, $parsed_bindings_ref)) {
		die "${prog}: Giving up due to error writing statistics file\n"; 
		exit 4;
	}
}

if ($write_bindings_dir) {
	unless (write_bindings_dir($write_bindings_dir, $parsed_bindings_ref)) {
		warn "${prog}: Giving up due to error writing new bindings directory\n";
		exit 5;
	}
}

exit 0;


######################################################################################
#
# Routines for reading a bindings directory
#
######################################################################################

sub read_bindings_dir {

	my ($read_bindings_dir) = @_;

	# On success, return a hashref.
	#	The referenced hash contains one key for each file in the bindings directory; the (unqualified) filenames are the keys.
	#	Each hash value is a listref.
	#	The referenced list contains one hashref for each binding in that file.
	#	The referenced hash is a single binding.
	# On any error, return false.


	my %parsed_bindings;	# Build the hash here.

	# Get filenames from dir $read_bindings_dir
	
	my $read_bindings_dir_dh;
	unless (opendir($read_bindings_dir_dh, $read_bindings_dir)) {
		warn "${prog}: can't open directory $read_bindings_dir for reading: $!\n";
		return;
	}
	
	my @read_bindings_dir_filenames = grep { $_ ne '..' && $_ ne '.' } readdir $read_bindings_dir_dh;
	
	if ($!) {
		warn "${prog}: error reading directory ${read_bindings_dir}: $!\n";
		return;
	}
	
	closedir($read_bindings_dir_dh);
	
	
	# Walk through each @read_bindings_dir_filenames
	
	# Save cwd so we can restore it later
	my $cwd_old = getcwd;

	unless (chdir $read_bindings_dir) {
		warn "${prog}: chdir(${read_bindings_dir}): $!\n";
		return;
	}
	
	foreach my $read_bindings_dir_filename (@read_bindings_dir_filenames) {
	
		# Insert the listref to the parsed bindings (for this file) into %parsed_bindings,
		# using the $filename as the key. 
		unless ($parsed_bindings{$read_bindings_dir_filename} = read_bindings_file($read_bindings_dir_filename)) {
			# failure
			return;
		}
	}

	unless (chdir $cwd_old) {
		warn "${prog}: couldn't restore cwd, chdir(${$cwd_old}): $!\n";
		return;
	}

	# success
	return \%parsed_bindings;
}


sub read_bindings_file {
	my ($filename) = @_;

	# On success, return a listref.
	#    The referenced list contains a hashref for each binding in the file.
	#    Each referenced hash is a single binding. 
	# On any error, return false.


	# We must take care because the file's contents is binary

	my $filename_fh;
	unless (open($filename_fh, '< :raw', $filename)) {

		warn "${prog}: can't open file $filename for reading: $!\n";
		return;
	}

	my $data;

	{
		# Read entire binary contents of file into $data

		my $buf;
		my $bytes_read;
		my @data;

		my $blksize = ( stat($filename_fh) )[11];

		while ($bytes_read = read($filename_fh, $buf, $blksize)) {
			push @data, $buf;
		}
		if (! defined $bytes_read) {
			warn "${prog}: error reading ${filename}: $!\n";
			close($filename_fh);
			return;
		}
		$data = join('', @data);
	}

	close $filename_fh;

	my $parsed_bindings_list_ref;
	unless ( $parsed_bindings_list_ref = parse_bindings_file_contents( {data => $data, filename =>$filename} )) {
		# failure
		return;
	}

	# success
	return $parsed_bindings_list_ref;
}


sub parse_bindings_file_contents {
	my ($arg_ref) = @_;

	my $data = $arg_ref->{data};			# binary content of an entire single bindings file
	my $filename = $arg_ref->{filename};	# name of the current bindings file, used ONLY for error reporting

	# On success, return a listref.
	#    This listref provides access to the parsed bindings .
	#    The referenced list contains a hashref for each parsed binding; the referenced hashes are the bindings. 
	# On any error, return false.

	use bytes; # we will use length(), substr(), etc with binary data

	my $subroutine_name = 'parse_bindings_file_contents()';
	my $debugmsg_prefix = "${prog}: ${subroutine_name}:";

	if ($debug) {
		print	"$debugmsg_prefix entered subroutine\n",
				"$debugmsg_prefix data=0x", unpack("H*", $data), "\n",
				"$debugmsg_prefix filename=$filename\n",
				;
	}

	my @parsed_bindings;	# We will build the list of parsed binding in here.
							# Each element will be a hashref.
							# Each referenced hash is a parsed binding.

	my $data_offset = 0; # index into $data
	my $recno = 0;  # count the records in this bindings file, only used for error reporting purposes

	my $data_len = length($data);
	print "$debugmsg_prefix data_len=$data_len\n" if $debug;


	while ($data_offset < $data_len) {

		my $errmsg_prefix = "${prog}: error reading bindings file ${filename}, recno ${recno}:";

		if ($debug) {
			print	"$debugmsg_prefix data_offset=$data_offset\n" ,
					"$debugmsg_prefix recno=$recno\n", 
			;
		}

		# The upcoming field should be a 4-byte value written in host byte order as an unsigned long.
		# It represents the length of the binding record to follow.

		unless (enough_bytes_remain( {offset => $data_offset, need => 4,  data_len => $data_len} )) {
			print "$debugmsg_prefix data_offset=${data_offset}, data_len=${data_len}\n" if $debug;
			warn "$errmsg_prefix can't read field 'binding_len' because there aren't 4 bytes left in 'data'\n";
			return;
		}
		my ($binding_len) = unpack "\@$data_offset L1", $data;
		# XXX What happens if the unpack fails?
		print "$debugmsg_prefix $binding_len=$binding_len\n" if $debug;

		$data_offset += 4;
		print "$debugmsg_prefix data_offset=$data_offset\n" if $debug;

		# sanity check
		if ($binding_len == 0) {
			warn "$errmsg_prefix binding_len=0, huh?\n";
			return;
		}

		# The upcoming field should be a $binding_len bytes long, and is treated (for now) as sequence of unsigned bytes.
		# It is a single binding (i.e. one complete record).
		unless (enough_bytes_remain( {offset => $data_offset, need => $binding_len,  data_len => $data_len} )) {
			print "$debugmsg_prefix data_offset=${data_offset}, binding_len=${binding_len}, data_len=${data_len}\n" if $debug;
			warn "$errmsg_prefix can't read field 'binding' because there aren't $binding_len bytes left in 'data'\n";
			return;
		}
		my $binding = substr($data, $data_offset, $binding_len); 
		print("$debugmsg_prefix binding=0x", unpack("H*", $binding), "\n") if $debug;

		# sanity check
		if (length($binding) != $binding_len) {
			warn "$errmsg_prefix binding_len=${binding_len}, but instead retrieved ", length($binding), " bytes , huh?\n";
			return;
		}

		my $parsed_binding_ref;
		unless ($parsed_binding_ref = parse_one_binding( {binding => $binding, filename => $filename, recno => $recno} )) {
			# failure
			return;
		}

		push @parsed_bindings, $parsed_binding_ref;

		# proceed to next binding
		$data_offset += $binding_len;
		$recno++;
	
	}

	# XXX $recno is 1 more than the number of bindings we have read

	# success
	return \@parsed_bindings;
	
}


sub parse_one_binding {
	my ($arg_ref) = @_;

	my $binding = $arg_ref->{binding};		# binary content of a single binding record
	my $filename = $arg_ref->{filename};	# name of the current bindings file, used ONLY for error reporting
	my $recno = $arg_ref->{recno};			# number of current record (binding) within current bindingsfile, used ONLY for error reporting

	# Parse one binding record.
	#
	# Return a hashref on success.
	# The referenced hash contains the parsed binding.
	# Return false on any error.

	use bytes; # we will use length(), substr(), etc with binary data

	my $subroutine_name = 'parse_one_binding()';
	my $debugmsg_prefix = "${prog}: ${subroutine_name}:";
	my $errmsg_prefix = "${prog}: error reading bindings file ${filename}, recno ${recno}:";

	my %binding;	# we will build the parsed binding in here

	my $binding_offset = 0;  # offset into $binding
	my $binding_len = length($binding);

	# The upcoming field should be 1 byte long, and was written as an unsigned value.
	# It represents the length of the cliid (Client Identifier) field to follow.

	unless (enough_bytes_remain( {offset => $binding_offset, need => 1,  data_len => $binding_len} )) {
		warn "$errmsg_prefix can't read field 'cliid_len' because there isn't 1 byte left in 'binding'\n";
		return;
	}
	my ($cliid_len) = unpack "\@$binding_offset C1", $binding;
	print("$debugmsg_prefix cliid_len=$cliid_len\n") if $debug;
	$binding{cliid_len} = $cliid_len;
	$binding_offset++;

	# The upcoming field should be $cliid_len bytes long, and is an opaque sequence of unsigned bytes.
	# It is the cliid (Client Identifier). 
	# The field is absent if $cliid_len == 0.

	my $cliid = '';
	if ($cliid_len > 0) {
		unless (enough_bytes_remain( {offset => $binding_offset, need => $cliid_len,  data_len => $binding_len} )) {
			warn "$errmsg_prefix can't read field 'cliid' because there aren't $cliid_len bytes left in 'binding'\n";
			return;
		}
		$cliid = substr($binding, $binding_offset, $cliid_len);
		$binding_offset += $cliid_len;
	}
	$binding{cliid} = $cliid;
	print("$debugmsg_prefix cliid=0x", unpack("H*", $cliid), "\n") if $debug;

	# The upcoming field should be 1 byte long, and was written as an unsigned value.
	# It represents the length of the cliidhw (Client Hardware Address) field to follow.

	unless (enough_bytes_remain( {offset => $binding_offset, need => 1,  data_len => $binding_len} )) {
		warn "$errmsg_prefix can't read field 'cliidhw_len' because there isn't 1 byte left in 'binding'\n";
		return;
	}
	my ($cliidhw_len) = unpack "\@$binding_offset C1", $binding;
	print("$debugmsg_prefix cliidhw_len=$cliidhw_len\n") if $debug;
	$binding{cliidhw_len} = $cliidhw_len;
	$binding_offset++;

	# The upcoming field should be $cliidhw_len bytes long, and is an opaque sequence of unsigned bytes.
	# It is the cliidhw (Client Hardware Address).
	# The field is absent if $cliidhw_len == 0.

	my $cliidhw = '';
	if ($cliidhw_len > 0) {
		unless (enough_bytes_remain( {offset => $binding_offset, need => $cliidhw_len,  data_len => $binding_len} )) {
			warn "$errmsg_prefix can't read field 'cliidhw' because there aren't $cliidhw_len bytes left in 'binding'\n";
			return;
		}
		$cliidhw = substr($binding, $binding_offset, $cliidhw_len);
		$binding_offset += $cliidhw_len;
	}
	$binding{cliidhw} = $cliidhw;
	print("$debugmsg_prefix cliidhw=0x", unpack("H*", $cliidhw), "\n") if $debug;


	# The upcoming field should be 4 bytes long.
	# Since it was copied directly from a struct in_addr, it's in network byte order.
	# It is the last_ip (Last IP address).
	# We store it in the same binary format.

	unless (enough_bytes_remain( {offset => $binding_offset, need => 4,  data_len => $binding_len} )) {
		warn "$errmsg_prefix can't read field 'last_ip' because there aren't 4 bytes left in 'binding'\n";
		return;
	}

	my $last_ip = substr($binding, $binding_offset, 4); # still in network byte order
	print("$debugmsg_prefix last_ip=0x", unpack("H*", $last_ip), "\n") if $debug;
	print("$debugmsg_prefix last_ip=", join('.', unpack("C4", $last_ip)), "\n") if $debug;
	$binding{last_ip} = $last_ip;
	$binding_offset += 4;

	# The upcoming field should be 4 bytes long.
	# It is an unsigned long.
	# It is replys (yes, that's how it is spelled in dhcpd)
	# We store it in decimal format.
	# What this really represents isn't quite clear.
	# The name suggests that it is the number of replies sent to the client, 
	# but the dhcp server actually increments this only in update_lastbind(), and it isn't clear
	# to me that this routine is called exactly exactly once for every every reply sent to a client.

	unless (enough_bytes_remain( {offset => $binding_offset, need => 4,  data_len => $binding_len} )) {
		warn "$errmsg_prefix can't read field 'replys' because there aren't 4 bytes left in 'binding'\n";
		return;
	}
	my ($replys) = unpack "\@$binding_offset L1", $binding;
	printf("$debugmsg_prefix replys=%lu\n", $replys) if $debug;
	$binding{replys} = $replys;
	$binding_offset += 4;

	# The upcoming field should be 4 bytes long.
	# It is a time_t, but the dhcp server also assumes that a time_t is an unsigned long.
	# It is last_touch (the last time that update_lastbind() was called for this binding).
	# We store it in decimal format.
	
	unless (enough_bytes_remain( {offset => $binding_offset, need => 4,  data_len => $binding_len} )) {
		warn "$errmsg_prefix can't read field 'last_touch' because there aren't 4 bytes left in 'binding'\n";
		return;
	}
	my ($last_touch) = unpack "\@$binding_offset L1", $binding;
	printf("%s last_touch=%lu (%s)\n", $debugmsg_prefix, $last_touch, scalar(localtime($last_touch))) if $debug;
	$binding{last_touch} = $last_touch;
	$binding_offset += 4;

	# The upcoming field should be 4 bytes long.
	# It is a time_t, but the dhcp server also assumes that a time_t is an unsigned long.
	# It is expire (the expiration time of the lease, or INFINITY).
	# We store it in decimal format.
	
	unless (enough_bytes_remain( {offset => $binding_offset, need => 4,  data_len => $binding_len} )) {
		warn "$errmsg_prefix can't read field 'expire' because there aren't 4 bytes left in 'binding'\n";
		return;
	}
	my ($expire) = unpack "\@$binding_offset L1", $binding;
	printf("%s expire=%lu (%s)\n", $debugmsg_prefix, $expire, ($expire == $INFINITY ? "never" : scalar(localtime($expire)))) if $debug;
	$binding{expire} = $expire;
	$binding_offset += 4;


	# The upcoming code should be 1 byte long.
	# It is an unsigned byte.
	# It is 'code'.
	# We store it in decimal format.
	unless (enough_bytes_remain( {offset => $binding_offset, need => 1,  data_len => $binding_len} )) {
		warn "$errmsg_prefix can't read field 'code' because there isn't 1 byte left in 'binding'\n";
		return;
	}
	my ($code) = unpack "\@$binding_offset C1", $binding;
	print("$debugmsg_prefix code=$code (", $codename[$code], ")\n") if $debug;
	$binding{code} = $code;
	$binding_offset++;


	# The upcoming field should be 1 byte long, and was written as an unsigned value.
	# It represents the length of the vend field.

	unless (enough_bytes_remain( {offset => $binding_offset, need => 1,  data_len => $binding_len} )) {
		warn "$errmsg_prefix can't read field 'vend_len' because there isn't 1 byte left in 'binding'\n";
		return;
	}
	my ($vend_len) = unpack "\@$binding_offset C1", $binding;
	print("$debugmsg_prefix vend_len=$vend_len\n") if $debug;
	$binding{vend_len} = $vend_len;
	$binding_offset++;

	# The upcoming field should be $vend_len bytes long, and is an opaque sequence of unsigned bytes.
	# It is the 'vend' field (vendor)
	# The field is absent if $vend_len == 0.

	my $vend = '';
	if ($vend_len > 0) {
		unless (enough_bytes_remain( {offset => $binding_offset, need => $vend_len,  data_len => $binding_len} )) {
			warn "$errmsg_prefix can't read field 'vend' because there aren't $vend_len bytes left in 'binding'\n";
			return;
		}
		$vend = substr($binding, $binding_offset, $vend_len);
		$binding_offset += $vend_len;
	}
	print("$debugmsg_prefix vend=0x", unpack("H*", $vend), "\n") if ($debug && ($vend_len > 0));
	$binding{vend} = $vend;

	# The upcoming field should be 1 byte long, and was written as an unsigned value.
	# It represents the length of the user field.

	unless (enough_bytes_remain( {offset => $binding_offset, need => 1,  data_len => $binding_len} )) {
		warn "$errmsg_prefix can't read field 'user_len' because there isn't 1 byte left in 'binding'\n";
		return;
	}
	my ($user_len) = unpack "\@$binding_offset C1", $binding;
	print("$debugmsg_prefix user_len=$user_len\n") if $debug;
	$binding{user_len} = $user_len;
	$binding_offset++;

	# The upcoming field should be $user_len bytes long, and is an opaque sequence of unsigned bytes.
	# It is the 'user' field 
	# The field is absent if $user_len == 0.

	my $user = '';
	if ($user_len > 0) {
		unless (enough_bytes_remain( {offset => $binding_offset, need => $user_len,  data_len => $binding_len} )) {
			warn "$errmsg_prefix can't read field 'user' because there aren't $user_len bytes left in 'binding'\n";
			return;
		}
		$user = substr($binding, $binding_offset, $user_len);
		$binding_offset += $user_len;
	}
	print("$debugmsg_prefix user=0x", unpack("H*", $user), "\n") if ($debug && ($user_len > 0));
	$binding{user} = $user;

	# We should be at the end of the binding data.

	if ($binding_offset != $binding_len) {
		warn "$errmsg_prefix unexpected data remaining at end of 'binding', binding_offset=${binding_offset}, binding_len=${binding_len}, unexpected data=0x", unpack("H*", substr($binding, $binding_offset)), "\n";
		return;
	}

	# We have parsed this entire binding record succesfully.
	# The result is in %binding.

	# success
	return \%binding;
}


######################################################################################
#
# Routines for writing a bindings directory
#
######################################################################################


sub write_bindings_dir {
	my ($write_bindings_dir, $parsed_bindings_ref) = @_;

	unless (mkdir($write_bindings_dir)) {
			warn "${prog}: can't mkdir new bindings directory ${write_bindings_dir}: $!\n";
			return;
	}
	
	foreach my $filename (keys %$parsed_bindings_ref) {

			my $filename_long = "${write_bindings_dir}/${filename}";

			unless (write_bindings_file( { filename_long => $filename_long, bindings_list_ref => $parsed_bindings_ref->{$filename} } )) {
				# error message was already produced by the subroutine (or one it calls)
				return;
			}
	}

	# success
	return 1;
}


sub write_bindings_file {

	my ($arg_ref) = @_;

	my $filename_long = $arg_ref->{filename_long};			# Complete filename to open for writing.
	my $bindings_list_ref = $arg_ref->{bindings_list_ref};	# A listref.
															# The referenced list contains one element per binding.
															# Each element is a hashref.
															# Each referenced hash is a binding.


	# Create the bindings file '$filename_long', write into it all the bindings
	# represented by '$bindings_list_ref'.
	# On success, return true.
	# On any error, return false.

	# If there are no bindings to write to this file, return successfully without creating any file.
	# That's so we don't simply create an empty bindings file (that would be an erroneous bindings file).
	return 1 unless @$bindings_list_ref;

	my $filename_long_fh;
	unless (open($filename_long_fh, '> :raw', $filename_long)) {
		warn "${prog}: can't open file $filename_long for writing: $!\n";
		return;
	}

	foreach my $binding_ref (@$bindings_list_ref) {
		# $binding is a hashref, the actual binding
		unless (write_one_binding( { fh => $filename_long_fh, binding_ref => $binding_ref, filename => $filename_long } )) {
			# error message was already produced by the subroutine we called (or a subroutine it called).
			return;
		}
	}

	unless (close($filename_long_fh)) {
		warn "${prog}: error closing  $filename_long for writing: $!\n";
		return;
	}

	# success
	return 1;
}


sub write_one_binding {

	my ($arg_ref) = @_;

	my $fh	= $arg_ref->{fh};							# fh to write to (is already open)
	my $binding_ref = $arg_ref->{binding_ref};				# A hashref to parsed binding structure
	my $filename_long = $arg_ref->{filename_long};	# Name of file we are writing, for error reporting purposes ONLY.


	# Given a bindings structure, append it to an open bindings file.
	# On success, return true;
	# On any error, return false.

	use bytes;

	my $serialized_binding;	# will contain the string (binary data) representing the binding
	unless ($serialized_binding = serialize_one_binding( { binding_ref => $binding_ref } )) {
		# error message was produced by the subroutine we called (or a subroutine it called).
		return;
	}

	my $serialized_binding_len = length($serialized_binding);

	# The record to write consists of the serialized binding preceeded by a 4-byte value representing its length.
	# The length field is an unsigned long.
	my $data = join('', pack("L1", $serialized_binding_len), $serialized_binding);

	unless (print({$fh} $data)) {
		warn "${prog}: error writing to ${filename_long}: $!\n";
		return;
	}

	# success
	return 1;
}


sub serialize_one_binding {
	
	my ($arg_ref) = @_;

	my $binding_ref = $arg_ref->{binding_ref};				# A parsed binding structure to serialize.

	# Given a bindings structure, construct a serialized (flattened) version 
	# in the format suitable for writing to a bindings file.
	# It does NOT include the binding_len field at the start.
	# On success, return the serialized binding (a string)
	# On failure, return false.

	use bytes;

	my $serialized_binding;	# Build result here.


	$serialized_binding = join('', 
								(pack "C1", $binding_ref->{cliid_len}),
								$binding_ref->{cliid},
								(pack "C1", $binding_ref->{cliidhw_len}),
								$binding_ref->{cliidhw},
								$binding_ref->{last_ip},
								(pack "L1", $binding_ref->{replys}),
								(pack "L1", $binding_ref->{last_touch}),
								(pack "L1", $binding_ref->{expire}),
								(pack "C1", $binding_ref->{code}),
								(pack "C1", $binding_ref->{vend_len}),
								$binding_ref->{vend},
								(pack "C1", $binding_ref->{user_len}),
								$binding_ref->{user}
							);

	return $serialized_binding;
	
}


######################################################################################
#
# Routines for reading a report
#
######################################################################################


sub read_report {

	my ($read_report) = @_;
	local($_);

	# On success, return a hashref.
	#	The referenced hash contains one key for each file mentiond in the report; the (unqualified) filenames are the keys.
	#	Each hash value is a listref.
	#	The referenced list contains one hashref for each binding in that file.
	#	The referenced hash is a single binding.
	# On any error, return false.

	my %parsed_bindings;	# Build the hash here.

	my $read_report_fh;
	unless (open($read_report_fh, '<', $read_report)) {
		warn "${prog}: can't open report file $read_report for reading: $!\n";
		return;
	}

	my $report_file_format_version;

	READ_REPORT_LINE:
	while (my $read_report_line = <$read_report_fh>) {

		chomp $read_report_line;

		# We expect to find a comment line that looks something like the following before any data:
		#      # Report file format version: 1.0
		if ($read_report_line =~ /^\s*#\s*Report\s+file\s+format\s+version:\s*(\S+)$/i) {
			$report_file_format_version = $1;
			unless (grep { $_ eq $report_file_format_version } @REPORT_FILE_FORMAT_READ_VERSIONS) {
				warn "${prog}: error reading report file ${read_report}: unsupported report file format version '${report_file_format_version}', supported versions are: ", join(', ', @REPORT_FILE_FORMAT_READ_VERSIONS), "\n";
				# failure
				return;
			}
			next READ_REPORT_LINE;
		}

		next READ_REPORT_LINE if $read_report_line =~ /^\s*#/ || $read_report_line =~ /^\s*$/;

		# It's not a comment or blank line.

		unless ($report_file_format_version) {
			# We've reached something other than a comment or a blank line,
			# but have not yet found the comment that contains the report file format version.
			warn "${prog}: error reading report file ${read_report}: didn't find report file format version number before start of data\n";
			# failure
			return;
		}
		
		my ($binding_filename, $parsed_binding_ref);
		unless (($binding_filename, $parsed_binding_ref) = parse_one_report_line( { report_line => $read_report_line, report_filename => $read_report, line_num => $INPUT_LINE_NUMBER } )) {
			# failure
			return;
		}

		# insert the parsed binding into %parsed_bindings
		push @{$parsed_bindings{$binding_filename}}, $parsed_binding_ref;

	}

	close($read_report_fh);

	# success
	return \%parsed_bindings;
}


sub parse_one_report_line {
	my ($arg_ref) = @_;

	my $report_line 	= $arg_ref->{report_line};		# text of a single report file line
	my $report_filename = $arg_ref->{report_filename};	# name of the report file, used ONLY for error reporting
	my $line_num 		= $arg_ref->{line_num};			# number of current line within the report file, used ONLY for error reporting

	#  Parse one report file line
	#
	# Return a list on success.
	#   The list is (binding_filename, binding_hashref).
	#   The binding_filename is the unqualified name of the binding file for this binding.
	#   The hash referenced by 'binding_hashref' contains the parsed binding.
	# Return false on any error.
	#
	# This code handles version 1.0 of the report file format.

	my $subroutine_name = 'parse_one_report_line()';
	my $debugmsg_prefix = "${prog}: ${subroutine_name}:";
	my $errmsg_prefix = "${prog}: error reading report file ${report_filename}, line ${line_num}:";

	my %binding;	# we will build the parsed binding in here


	# The fields in version 1.0 of the report file format are delimited by whitespace, except:
	#
	# An exception is the last_touch field, which contains the actual last_touch value, followed by whitespace,
	#	followed by a comment (i.e. the date corresponding to the actual last_touch value) in parentheses.
	#   The comment is defined by an open paren, any sequence of non-close parens, followed by a close paren,
	#   so the comment MAY include whitespace.
	#   And the comment is just that -- we ignore its value, and only pay attention to the actual last_touch (numeric) value.
	#
	# An exception is the expire field, which contains the actual expire value, followed by whitespace,
	#	followed by a comment (i.e. the date corresponding to the actual expire value) in parentheses.
	#   The comment is defined by an open paren, any sequence of non-close parens, followed by a close paren,
	#   so the comment MAY include whitespace.
	#   And the comment is just that -- we ignore its value, and only pay attention to the actual expire (numeric) value.
	#
	# An exception is the code field, which contains the actual code value, followed by whitespace,
	#	followed by a comment (i.e. the name of the flag corresponding to the actual code value) in parentheses.
	#   The comment is defined by an open paren, any sequence of non-close parens, followed by a close paren,
	#   so the comment MAY include whitespace.
	#   And the comment is just that -- we ignore its value, and only pay attention to the actual code (numeric) value.

	my ($binding_filename, $cliid_len, $cliid, $cliidhw_len, $cliidhw, $last_ip, $replys, $last_touch, $expire, $code, $vend_len, $vend, $user_len, $user);

	unless ( ($binding_filename, $cliid_len, $cliid, $cliidhw_len, $cliidhw, $last_ip, $replys, $last_touch, $expire, $code, $vend_len, $vend, $user_len, $user) 
				=
			($report_line =~ /^(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+\([^)]*\)\s+(\S+)\s+\([^)]*\)\s+(\S+)\s+\([^)]*\)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)$/ ) ) {
		warn "$errmsg_prefix can't match syntax: $report_line\n";
		return;
	}

	if ($debug) {
		print	"$debugmsg_prefix matched fields:\n",
				"   line_num=$line_num\n",
				"   binding_filename=$binding_filename\n",
				"   cliid_len=$cliid_len\n",
				"   cliid=$cliid\n",
				"   cliidhw_len=$cliidhw_len\n",
				"   last_ip=$last_ip\n",
				"   replys=$replys\n",
				"   last_touch=$last_touch\n",
				"   expire=$expire\n",
				"   code=$code\n",
				"   vend_len=$vend_len\n",
				"   vend=$vend\n",
				"   user_len=$user_len\n",
				"   user=$user\n",
				;
	}

	# $binding_filename is an unqualified filename
	# The DHCP server generates names consisting of uppercase hex digits
	#
	# Verify the chars are acceptable
	unless ($binding_filename =~ /^[0-9A-F]+$/) {
		warn "$errmsg_prefix 'filename' value '$binding_filename' contains characters outside the uppercase hexadecimal range\n";
		return;
	}


	# $cliid_len is an positive integer
	#
	# Verify the chars are acceptable digits
	unless ($cliid_len =~ /^[0-9]+$/) {
		warn "$errmsg_prefix 'cliid_len' value '$cliid_len' contains non-numeric characters\n";
		return;
	}
	# Verify the value is in the acceptable range 0...255
	# That's because the DHCP server implementation stores this value in the bindings file as a single unsigned char.
	unless ($cliid_len >=0 && $cliid_len <=255) {
		warn "$errmsg_prefix 'cliid_len' value '$cliid_len' is outside the range 0...255\n";
		return;
	}
	$binding{cliid_len} = $cliid_len;


	# $cliid is a string looking something like '0x010203040506070a0b0c0d0e0f'
	# It should be stored as an opaque series of bytes.
	my $cliid_tmp = $cliid;
	# Remove leading '0x'
	unless ($cliid_tmp =~ s/^0x//) {
		warn "$errmsg_prefix 'cliid' field '$cliid' doesn't begin with '0x'\n";
		return;
	}
	# Verify remaining chars are acceptable for hex digits
	unless ($cliid_tmp =~ /^[0-9a-fA-F]*$/) {
		warn "$errmsg_prefix 'cliid' value '$cliid' contains non-hexadecimal characters\n";
		return;
	}
	# Verify there are an even number of chars
	unless (length($cliid_tmp) % 2 == 0) {
		warn "$errmsg_prefix 'cliid' value '$cliid' contains an odd number of characters\n";
		return;
	}
	$binding{cliid} = pack 'H*', $cliid_tmp;
	undef $cliid_tmp;


	# Sanity check: verify the $cliid_len accurately describes the length of $binding{cliid}
	{
		use bytes;
		if ($cliid_len != length($binding{cliid})) {
			warn "$errmsg_prefix 'cliid' value '$cliid' represents a ",  length($binding{cliid}),
				" byte binary value, but 'cliid_len' field is $cliid_len\n";
			return;
		}
	}


	# $cliidhw_len is an positive integer
	#
	# Verify the chars are acceptable digits
	unless ($cliidhw_len =~ /^[0-9]+$/) {
		warn "$errmsg_prefix 'cliidhw_len' value '$cliidhw_len' contains non-numeric characters\n";
		return;
	}
	# Verify the value is in the acceptable range 0...255
	# That's because the DHCP server implementation stores this value in the bindings file as a single unsigned char.
	unless ($cliidhw_len >=0 && $cliidhw_len <=255) {
		warn "$errmsg_prefix 'cliidhw_len' value '$cliidhw_len' is outside the range 0...255\n";
		return;
	}
	$binding{cliidhw_len} = $cliidhw_len;


	# $cliidhw is a string looking something like '0x010203040506070a0b0c0d0e0f'
	# It should be stored as an opaque series of bytes.
	my $cliidhw_tmp = $cliidhw;
	# Remove leading '0x'
	unless ($cliidhw_tmp =~ s/^0x//) {
		warn "$errmsg_prefix 'cliidhw' field '$cliidhw' doesn't begin with '0x'\n";
		return;
	}
	# Verify remaining chars are acceptable for hex digits
	unless ($cliidhw_tmp =~ /^[0-9a-fA-F]*$/) {
		warn "$errmsg_prefix 'cliidhw' value '$cliidhw' contains non-hexadecimal characters\n";
		return;
	}
	# Verify there are an even number of chars
	unless (length($cliidhw_tmp) % 2 == 0) {
		warn "$errmsg_prefix 'cliidhw' value '$cliidhw' contains an odd number of characters\n";
		return;
	}
	$binding{cliidhw} =  pack 'H*', $cliidhw_tmp;
	undef $cliidhw_tmp;


	# Sanity check: verify the $cliidhw_len accurately describes the length of $binding{cliidhw}
	{
		use bytes;
		if ($cliidhw_len != length($binding{cliidhw})) {
			warn "$errmsg_prefix 'cliidhw' value '$cliidhw' represents a ",  length($binding{cliidhw}),
				" byte binary value, but 'cliidhw_len' field is $cliidhw_len\n";
			return;
		}
	}

	

	{
		# last_ip is a string looking something like '192.168.1.2'
		# It should be stored in a 4-byte unsigned long in network byte order.
		my ($byte1, $byte2, $byte3, $byte4); 
		unless (($byte1, $byte2, $byte3, $byte4) = IP_address_in_dotted_quad_format_to_decimal_bytes($last_ip)) {
			warn "$errmsg_prefix 'last_ip' value '$last_ip' does not appear to be in dotted quad format\n";
			return;
		}
		$binding{last_ip} = pack 'C4', $byte1, $byte2, $byte3, $byte4;
	}


	# replys is a string representing a decimal number 
	# It should be stored in decimal format.
	unless ($replys =~ /^[0-9]+$/) {
		warn "$errmsg_prefix 'replys' value '$replys' contains non-numeric characters\n";
		return;
	}
	unless ($replys >= 0 && $replys <= $MAX_UINT32 ) {
		warn "$errmsg_prefix 'replys' value '$replys' is outside the range 0...$MAX_UINT32\n";
		return;
	}
	$binding{replys} = $replys;


	# last_touch is a string representing a time_t
	# The DHCP server assumes a time_t is stored as a 4-byte unsigned long
	# It should be stored in decimal format.
	unless ($last_touch =~ /^[0-9]+$/) {
		warn "$errmsg_prefix 'last_touch' value '$last_touch' contains non-numeric characters\n";
		return;
	}
	unless ($last_touch >= 0 && $last_touch <= $MAX_UINT32) {
		warn "$errmsg_prefix 'last_touch' value '$last_touch' is outside the range 0...$MAX_UINT32\n";
		return;
	}
	$binding{last_touch} = $last_touch;


	# expire is a string representing a time_t
	# The DHCP server assumes a time_t is stored as a 4-byte unsigned long
	# It should be stored in decimal format.
	unless ($expire =~ /^[0-9]+$/) {
		warn "$errmsg_prefix 'expire' value '$expire' contains non-numeric characters\n";
		return;
	}
	unless ($expire >= 0 && $expire <= $MAX_UINT32) {
		warn "$errmsg_prefix 'expire' value '$expire' is outside the range 0...$MAX_UINT32\n";

		return;
	}
	$binding{expire} = $expire;



	# $code is an positive integer
	# It should be stored in a decimal format
	#
	# Verify the chars are acceptable digits
	unless ($code =~ /^[0-9]+$/) {
		warn "$errmsg_prefix 'code' value '$code' contains non-numeric characters\n";
		return;
	}
	# Verify the value is in the acceptable range 0...255
	# That's because the DHCP server implementation stores this value in the bindings file as a single unsigned char.
	unless ($code >=0 && $code <=255) {
		warn "$errmsg_prefix 'code' value '$code' is outside the range 0...255\n";
		return;
	}
	$binding{code} = $code;



	# $vend_len is an positive integer
	#
	# Verify the chars are acceptable digits
	unless ($vend_len =~ /^[0-9]+$/) {
		warn "$errmsg_prefix 'vend_len' value '$vend_len' contains non-numeric characters\n";
		return;
	}
	# Verify the value is in the acceptable range 0...255
	# That's because the DHCP server implementation stores this value in the bindings file as a single unsigned char.
	unless ($vend_len >=0 && $vend_len <=255) {
		warn "$errmsg_prefix 'vend_len' value '$vend_len' is outside the range 0...255\n";
		return;
	}
	$binding{vend_len} = $vend_len;


	# $vend is a string looking something like '0x010203040506070a0b0c0d0e0f'
	# It should be stored as an opaque series of bytes.
	my $vend_tmp = $vend;
	# Remove leading '0x'
	unless ($vend_tmp =~ s/^0x//) {
		warn "$errmsg_prefix 'vend' field '$vend' doesn't begin with '0x'\n";
		return;
	}
	# Verify remaining chars are acceptable for hex digits
	unless ($vend_tmp =~ /^[0-9a-fA-F]*$/) {
		warn "$errmsg_prefix 'vend' value '$vend' contains non-hexadecimal characters\n";
		return;
	}
	# Verify there are an even number of chars
	unless (length($vend_tmp) % 2 == 0) {
		warn "$errmsg_prefix 'vend' value '$vend' contains an odd number of characters\n";
		return;
	}
	$binding{vend} = pack 'H*', $vend_tmp;
	undef $vend_tmp;


	# Sanity check: verify the $vend_len accurately describes the length of $binding{vend}
	{
		use bytes;
		if ($vend_len != length($binding{vend})) {
			warn "$errmsg_prefix 'vend' value '$vend' represents a ",  length($binding{vend}),
				" byte binary value, but 'vend_len' field is $vend_len\n";
			return;
		}
	}



	# $user_len is an positive integer
	#
	# Verify the chars are acceptable digits
	unless ($user_len =~ /^[0-9]+$/) {
		warn "$errmsg_prefix 'user_len' value '$user_len' contains non-numeric characters\n";
		return;
	}
	# Verify the value is in the acceptable range 0...255
	# That's because the DHCP server implementation stores this value in the bindings file as a single unsigned char.
	unless ($user_len >=0 && $user_len <=255) {
		warn "$errmsg_prefix 'user_len' value '$user_len' is outside the range 0...255\n";
		return;
	}
	$binding{user_len} = $user_len;


	# $user is a string looking something like '0x010203040506070a0b0c0d0e0f'
	# It should be stored as an opaque series of bytes.
	my $user_tmp = $user;
	# Remove leading '0x'
	unless ($user_tmp =~ s/^0x//) {
		warn "$errmsg_prefix 'user' field '$user' doesn't begin with '0x'\n";
		return;
	}
	# Verify remaining chars are acceptable for hex digits
	unless ($user_tmp =~ /^[0-9a-fA-F]*$/) {
		warn "$errmsg_prefix 'user' value '$user' contains non-hexadecimal characters\n";
		return;
	}
	# Verify there are an even number of chars
	unless (length($user_tmp) % 2 == 0) {
		warn "$errmsg_prefix 'user' value '$user' contains an odd number of characters\n";
		return;
	}
	$binding{user} = pack 'H*', $user_tmp;
	undef $user_tmp;


	# Sanity check: verify the $user_len accurately describes the length of $binding{user}
	{
		use bytes;
		if ($user_len != length($binding{user})) {
			warn "$errmsg_prefix 'user' value '$user' represents a ",  length($binding{user}),
				" byte binary value, but 'user_len' field is $user_len\n";
			return;
		}
	}


	# We have parsed this line from the report file successfully.
	# The result is in %binding.

	return ($binding_filename, \%binding);

}


######################################################################################
#
# Routines for writing a report file
#
######################################################################################


sub write_report {

	# Write a report of the bindings in memory.
	# On success, returns true.
	# On any failure, returns false.

	my ($report_filename, $parsed_bindings_ref) = @_;

	my $report_fh;
	unless (open($report_fh, '>', $report_filename)) {
		warn "${prog}: error opening report file '${report_filename}' for writing: $!\n";
		return;
	}	


	my $rc;

	$rc = print {$report_fh}	"# DHCP bindings report produced by $prog at ", scalar(localtime), "\n",
								"# Report file format version: $REPORT_FILE_FORMAT_WRITE_VERSION\n",
								"#\n",
								"#filename cliid_len cliid             cliidhw_len cliid_hw             last_ip             replys    last_touch                            expire                               code                 vend_len vend user_len user\n",
								"#\n",
							;
	unless ($rc) {
		warn "${prog}: error writing to report file '${report_filename}'\n";
		close($report_fh); # no point checking for error, as there's nothing we can do
		return;
	}

	foreach my $bindings_filename (sort { hex($a) <=> hex($b) } keys %$parsed_bindings_ref) {
		foreach my $binding_ref (@{$parsed_bindings_ref->{$bindings_filename}}) {

			my $codename_in_parens = sprintf("(%s)", $codename[$binding_ref->{code}]);
			my $last_touch_time_in_parens = sprintf("(%s)", scalar(localtime($binding_ref->{last_touch})));
			my $expire_time_in_parens = sprintf("(%s)", ($binding_ref->{expire} eq $INFINITY ? 'never' : scalar(localtime($binding_ref->{expire}))) );

			$rc = printf({$report_fh}
					"%s        %3d       0x%s  %3d         0x%s     %-15s %10lu    %10lu %-26s %10lu %-26s %3d %-15s  %3d      0x%s   %3d      0x%s\n",
					$bindings_filename,
					$binding_ref->{cliid_len},
					unpack("H*", $binding_ref->{cliid}),
					$binding_ref->{cliidhw_len},
					unpack("H*", $binding_ref->{cliidhw}),
					join('.', unpack("C4", $binding_ref->{last_ip})),
					$binding_ref->{replys},
					$binding_ref->{last_touch}, $last_touch_time_in_parens,
					$binding_ref->{expire}, $expire_time_in_parens,
					$binding_ref->{code}, $codename_in_parens,
					$binding_ref->{vend_len},
					unpack("H*", $binding_ref->{vend}),
					$binding_ref->{user_len},
					unpack("H*", $binding_ref->{user}),
					);
			unless ($rc) {
				warn "${prog}: error writing to report file '${report_filename}'\n";
				close($report_fh); # no point reporting error, as there's nothing we can do
				return;
			}
		}
	}

	unless (close($report_fh)) {
		warn "${prog}: error closing report file '${report_filename}': $!\n";
		close($report_fh); # no point reporting error, as there's nothing we can do
		return;
	}


	# success
	return 1;
}


######################################################################################
#
# Routines for writing a statistics file
#
######################################################################################


sub write_statistics {

	# Write statistics for the bindings in memory.
	# On success, returns true.
	# On any failure, returns false.

	my ($statistics_filename, $parsed_bindings_ref) = @_;

	my $statistics_fh;
	unless (open($statistics_fh, '>', $statistics_filename)) {
		warn "${prog}: error opening statistics file '${statistics_filename}' for writing: $!\n";
		return;
	}

	my $rc;

	$rc = print {$statistics_fh}	"# DHCP bindings statistics produced by $prog at ", scalar(localtime), "\n",
									"# Statistics file format version: $STATISTICS_FILE_FORMAT_WRITE_VERSION\n",
									"#\n",
									"#\n",
							;

	unless ($rc) {
		warn "${prog}: error writing to statistics file '${statistics_filename}'\n";
		close($statistics_fh); # no point checking for error, as there's nothing we can do
		return;
	}

	my $stat = Statistics::Descriptive::Full->new();

	# print number of bindings in each bindings file
	foreach my $bindings_filename (sort { hex($a) <=> hex($b) } keys %$parsed_bindings_ref) {

		my $num_bindings_for_filename = scalar @{$parsed_bindings_ref->{$bindings_filename}};

		$rc = printf {$statistics_fh}
			"file %${STATISTICS_FILENAME_FIELD_WIDTH}s : %${STATISTICS_NUMERIC_FIELD_WIDTH}d bindings\n",
			$bindings_filename , $num_bindings_for_filename;
		unless ($rc) {
			warn "${prog}: error writing to statistics file '${statistics_filename}'\n";
			close($statistics_fh); # no point reporting error, as there's nothing we can do
			return;
		}

		$stat->add_data($num_bindings_for_filename);
	}

	# print summary statistics
	$rc = printf {$statistics_fh}
									"#\n"
									. "number of bindings files             : %${STATISTICS_NUMERIC_FIELD_WIDTH}d\n"
									. "total bindings                       : %${STATISTICS_NUMERIC_FIELD_WIDTH}d\n"
									. "minimum number of bindings in a file : %${STATISTICS_NUMERIC_FIELD_WIDTH}d\n"
									. "maximum number of bindings in a file : %${STATISTICS_NUMERIC_FIELD_WIDTH}d\n"
									. "mean number of bindings in a file    : %${STATISTICS_NUMERIC_FIELD_WIDTH}.1f\n"
									. "median number of bindings in a file  : %${STATISTICS_NUMERIC_FIELD_WIDTH}.1f\n"
									. "variance                             : %${STATISTICS_NUMERIC_FIELD_WIDTH}.1f\n"
									. "standard deviation                   : %${STATISTICS_NUMERIC_FIELD_WIDTH}.1f\n",
									defined($stat->count())					?	$stat->count()					: 0,
									defined($stat->sum())					?	$stat->sum()					: 0,
									defined($stat->min())					?	$stat->min()					: 0,
									defined($stat->max())					?	$stat->max()					: 0,
									defined($stat->mean())					?	$stat->mean()					: 0,
									defined($stat->median())				?	$stat->median()					: 0,
									defined($stat->variance())				?	$stat->variance()				: 0,
									defined($stat->standard_deviation())	?	$stat->standard_deviation() 	: 0
									;
	unless ($rc) {
		warn "${prog}: error writing to statistics file '${statistics_filename}'\n";
		close($statistics_fh); # no point reporting error, as there's nothing we can do
		return;
	}
									
	unless (close($statistics_fh)) {
		warn "${prog}: error closing statistics file '${statistics_filename}': $!\n";
		close($statistics_fh); # no point reporting error, as there's nothing we can do
		return;
	}

	# success
	return 1;
}

######################################################################################
#
# Pruning routines
#
######################################################################################

sub prune_bindings {
	my ($parsed_bindings_ref) = @_;

	# Takes a ref to a parsed bindings structure.
	# Constructs a new parsed bindings structure based on it,
	# pruning out any bindings that match the --prune* options.
	# On success, returns a ref to the new parsed bindings structure.
	# On any failure, return false.

	my %new_parsed_bindings;

	foreach my $bindings_filename (keys %$parsed_bindings_ref) {
		my @binding_refs = @{$parsed_bindings_ref->{$bindings_filename}};

		@binding_refs = grep { ! binding_matches_all_prune_specs($_) } @binding_refs;

		# Insert the listref of matching bindings into new parsed bindings structure
		$new_parsed_bindings{$bindings_filename} = \@binding_refs;
	}

	# success
	return \%new_parsed_bindings;
}


sub binding_matches_all_prune_specs {
	my ($binding_ref) = @_;

	# Given a $binding_ref, return true if it matches all the prune specs.
	# Else return false.
	#
	# XXX It would be cleaner for the caller to explicitly pass us the $prune* vars we need to look at,
	# rather than have us look at vars in the enclosing lexical scope.
	# But if an enclosing scope packaged all those up for us and caused them to get passed to us,
	# it would mean significantly more vars for this routine  to unpack every time it is called.
	# Given that this routine (as is) can really slow things down, do we want to make it worse?

	my %binding = %$binding_ref;
		
	if ($prune_code) {
		return unless $binding{code} == $prune_code;
	}
	if ($prune_cliid) {
		use bytes;
		return unless $binding{cliid} eq $prune_cliid_bin;
	}
	if ($prune_cliidhw) {
		use bytes;
		return unless $binding{cliidhw} eq $prune_cliidhw_bin;
	}
	if ($prune_last_touch) {
		return unless last_touch_field_matches_prune_spec($binding_ref, $prune_last_touch_operator, $prune_last_touch_time_t);
	}
	if ($prune_expire) {
		return unless expire_field_matches_prune_spec($binding_ref, $prune_expire_operator, $prune_expire_time_t);
	}
	if ($prune_last_ip) {
		return unless last_ip_field_matches_prune_spec($binding_ref, $prune_last_ip_address, $prune_last_ip_netmask);
	}

	# The binding matches all the prune specs
	return 1;
}


sub last_touch_field_matches_prune_spec {
	my ($binding_ref, $operator, $time_t) = @_;

	# Given a reference to a binding,
	# an $operator ('lt', 'gt', or 'eq'),
	# and a $time_t,
	# return true if "the binding's last_touch field is $operator time_t".
	# Else return false.
	#
	# Note that the operators are textual, but we perform the corresponding numeric comparison.
	# The use of textual operators is just to make them easier to specify via the cmdline without
	# them looking like shell metachars.

	return 1 if (($operator eq 'lt') && $binding_ref->{last_touch} < $time_t);
	return 1 if (($operator eq 'gt') && $binding_ref->{last_touch} > $time_t);
	return 1 if (($operator eq 'eq') && $binding_ref->{last_touch} == $time_t);

	return;
}


sub expire_field_matches_prune_spec {
	my ($binding_ref, $operator, $time_t) = @_;

	# Given a reference to a binding,
	# an $operator ('lt', 'gt', or 'eq'),
	# and a $time_t,
	# return true if "the binding's expire field is $operator time_t".
	# Else return false.
	#
	# Note that the operators are textual, but we perform the corresponding numeric comparison.
	# The use of textual operators is just to make them easier to specify via the cmdline without
	# them looking like shell metachars.

	return 1 if (($operator eq 'lt') && $binding_ref->{expire} < $time_t);
	return 1 if (($operator eq 'gt') && $binding_ref->{expire} > $time_t);
	return 1 if (($operator eq 'eq') && $binding_ref->{expire} == $time_t);

	return;
}


sub last_ip_field_matches_prune_spec {
	my ($binding_ref, $prune_last_ip_address, $prune_last_ip_netmask) = @_;

	# Given a reference to a binding,
	# and a network range specified by $prune_last_ip_address and $prune_last_ip_netmask,
	# return true if "the binding's last_ip field is within the network range $prune_last_ip_address & $prune_last_ip_netmask".
	# Else return false.

	my $binding_last_ip = $binding_ref->{last_ip};

	# Each IP address is stored as a 4-byte unsigned int (in network byte order).

	use bytes;
	return 1 if ($binding_last_ip & $prune_last_ip_netmask) eq ($prune_last_ip_address & $prune_last_ip_netmask);

	return;
}


######################################################################################
#
# Miscellaneous utility routines
#
######################################################################################


sub enough_bytes_remain {
	my ($arg_ref) = @_;

	my $offset = $arg_ref->{offset};			# current offset (in bytes) into data
	my $need   = $arg_ref->{need};				# number of bytes we need from data, starting at current offset
	my $data_len = $arg_ref->{data_len};		# size (in bytes) for data

	# Return true if enough bytes remain read '$need' bytes starting at '$offset' within '$data_len'
	# Else return false.

	return 1 unless $offset + $need > $data_len; # failure

	# failure
	return;
}


sub IP_address_in_dotted_quad_format_to_decimal_bytes {
	my ($ip_str) = @_;

	# If $ip_str appears to be an IP address in dotted quad format (e.g. '192.168.1.2'),
	# return a list of the four decimal bytes. 
	# Else return false.

	my ($byte1, $byte2, $byte3, $byte4); 
	unless (($byte1, $byte2, $byte3, $byte4) = ($ip_str =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/)) {
		return;
	}
	unless (($byte1 >= 0 && $byte1 <= 255) && ($byte2 >= 0 && $byte2 <= 255) && ($byte3 >= 0 && $byte3 <= 255) && ($byte4 >= 0 && $byte4 <= 255)) {
		return;
	}
	return ($byte1, $byte2, $byte3, $byte4);
}

######################################################################################
#
# Routines for documentation
#
######################################################################################


sub version {
	print "$REAL_PROG_NAME version $VERSION\n";
	exit 0;
}


sub help {
my $help =<<"END_HELP";
dhcp_bindings_tool  --read-bindings-dir directory  | --read-report filename
                    [--prune-cliid 0xhh...] [--prune-cliidhw 0xhh...] [--prune-code number]
                    [--prune-expire 'gt|lt|eq time_t'] [--prune-last-touch 'gt|lt|eq time_t'] [--prune-last-ip IP&netmask]
                    [--write-bindings-dir directory] [--write-report filename] [--write-statistics filename]
                    [--help] [--debug] [--usage] [--version]

Options:
  --debug                               Enable debugging
  --help                                Display usage information and exits
  --prune-cliid 0xhh...                 Prune any bindings where cliid matches 0xhh...
  --prune-cliidhw 0xhh...               Prune any bindings where cliidhw matches 0xhh...
  --prune-code number                   Prune any bindings where code matches number
  --prune-expire 'gt|lt|eq time_t'      Prune any bindings where expire is greater than, less then, or equal to time_t
  --prune-last-touch 'gt|lt|eq time_t'  Prune any bindings where last_touch is greater than, less then, or equal to time_t
  --prune-last-ip IP[&netmask]          Prune any bindings where last_ip is within the range IP & netmask
  --read-bindings-dir directory         Read bindings from specified directory
  --read-report filename                Read bindings from specified text file
  --write-bindings-dir directory        Create new directory and write resulting bindings to it
  --write-report filename               Write resulting bindings to text file
  --write-statistics filename           Write statistics describing resulting bindings to text file
  --usage                               Same as --help
  --version                             Display version information and exit

Either the --read-bindings-dir or --read-report option must be specified,
but not both.  They specify where this program should obtain the bindings data.
If any error is encountered reading the data, this program halts without
producing any output files.

If --read-bindings-dir is specified, the directory should
be one that was created by the DHCP server or by this program's
--write-bindings-dir option.  If --read-report is specified, the file
should be one that was created by this program's --write-report option.

After reading the bindings data, the program performs pruning of
the data (in memory) as specified by any --prune* options.  
No output files are created until after any pruning is done.
The resulting bindings (in memory) are used as the basis
for any output files.

The argument to --prune-last-touch or --prune-last-ip is a string
which consists of the word 'gt', 'lt',or 'eq', followed by whitespace,
followed by a series of digits which are treated as a time_t.
You will have to quote the argument so it is treated as a single
argument.

The argument to --prune-last-ip is an IP address optionally followed
by an '&' and a netmask.  If only an IP address is specified, the netmask
defaults to 255.255.255.255.  If your shell treats '&' as a metacharacter,
you will need to quote it.

The argument to --prune-code is a decimal number in the range 0...255.

If more than one of the --prune* options is specified, they are all 
AND'd together.  For example specifying 
   --prune-last-ip 192.168.1.0&255.255.255.0 --prune-expire 'lt 1006655461'
would mean to prune those where where the last_ip is within the
range 192.168.1.0 & 255.255.255.0 AND the expire time less than 1006655461.

If --write-report is specified, the program writes a plain text
file report of the bindings.  The file is in a format suitable
for reading by the --read-report option.

If --write-statistics is specified, the program writes a plain
text file containing statistics about the bindings.

If --write-bindings-dir is specified, the program creates a new
directory and writes the bindings to that directory.  The specified 
directory must not already exist.  The directory is in a format
suitable for reading by the --read-bindings-dir option, or 
for use by the DHCP server.

Any or all of the --write-report, --write-statistics, and --write-bindings-dir
options may be specified.  If more than one is specified, care should
be taken to ensure that the specified output files/directory do not
conflict with each other, to avoid overwriting output.
If any error is encountered writing output, this program halts; any output
produced up to that point may be truncated or corrupt.
END_HELP
;

	print $help;
	exit 0;
}

