Princeton/pu/libexec/check_http_sim

#!/usr/bin/perl -w

use strict;
use warnings;
use lib qw(/usr/local/perl/lib/perl5);
use WWW::Mechanize;
$ENV{HTTPS_CA_DIR}='/etc/pki/tls/certs';
use Data::Dumper;

my %args;

sub sub_var {
	my $var = shift (@_);
#print "####$var#####\n";
	foreach (keys %args) {
		my $argv = $args{$_};
		$var =~ s#%%$_%%#$argv#g;
	}
#print "NEW####$var#####\n";

	return $var;
}

unless (@ARGV) {
	print STDERR "The first argument should be the web script configuration file\n";
	exit 3;
}

my $config_file = shift @ARGV;

unless (-f $config_file) {
	print STDERR "Unable to locate or access configuration file \"$config_file\"\n";
	exit 3;
}

my %exp;
my ($usage, $url);
my $stat = 0;
my $expect = 0;

open FL, "< $config_file" or do { print STDERR "Unable to open the configuration file \"$config_file\" for reading"; exit 3; };
my @fllines = <FL>;
close FL;

my @usg = grep (/^usage: /, @fllines);
$usage = $usg[0] =~ /^usage: (.*)/ && defined $1 ? $1 : "USAGE CHANGEME IN FILE";

my @arg = grep (/^arg: /, @fllines);

if (@arg) {
	$arg[0] =~ s/^arg: //; chomp $arg[0];
	my @argn = split (/\s*,\s*/, $arg[0]);
	unless (@argn == @ARGV) { print STDERR "Usage: $0 $usage\n"; exit 3; }
	foreach (@argn) {
		my $argv = shift @ARGV;
		$args{$_} = $argv;
	}
}

my $mech = WWW::Mechanize->new (agent => 'Mozilla/5.0 (X11; Linux x86_64; rv:24.0) Gecko/20100101 Firefox/24.0', stack_depth => '1', noproxy => '1', quiet => '1', onerror => undef, onwarn => undef, timeout => '20') or do {
	print STDERR "Unable to instantiate WWW::Mechanize!\n";
	exit 3;
};
#$mech -> add_handler("request_send",  sub { shift->dump; return });
#$mech -> add_handler("response_done", sub { shift->dump; return });

foreach (@fllines) {
	next if /^\s*(|#.*)$/;

	/^\s*;;\s*(|#.*)$/ and do {
		if ($mech -> success()) {
			$stat = 0;
		} else {
			$stat = exists $exp{'abort'} ? $exp{'abort'} : 3;
		}

		if (exists $exp{'title'}) {
			if (defined $mech -> title() && $mech -> title() =~ m#$exp{'title'}#) {
				$stat = 0;
			} else {
				$stat = $exp{'abort'} if exists $exp{'abort'};
			}
		}

		if (exists $exp{'content_type'}) {
			if (defined $mech -> ct() && $mech -> ct() =~ m#$exp{'content_type'}#) {
				$stat = 0;
			} else {
				$stat = $exp{'abort'} if exists $exp{'abort'};
			}
		}

		if (exists $exp{'exists'}) {
			if (defined $mech -> response() -> decoded_content && $mech -> response() -> decoded_content =~ m#$exp{'exists'}#) {
				$stat = 0;
			} else {
				$stat = $exp{'abort'} if exists $exp{'abort'};
			}
		}
#print Dumper (\%exp);
		if ($stat) {
			print "$exp{'error'}\n" if exists $exp{'error'};
		} else {
			print "$exp{'ok'}\n" if exists $exp{'ok'};
		}
			
		%exp = ();
		$expect = 0;
		next;
	};

	if ($expect) {
		/^\s*(\S+)\s*=>\s*(.+)/ and do {
			my ($fldk, $fldv) = ($1, $2);
			my $m_stat = defined $mech -> status ? $mech -> status : 'not defined';
			my $m_answer = defined $mech -> response() && defined $mech -> response() -> decoded_content ? $mech -> response() -> decoded_content : 'not defined';
			my $m_title = defined $mech -> title() ? $mech -> title : 'not defined';
			my $m_cururl = defined $mech -> uri -> as_string ? $mech -> uri -> as_string : 'not defined';
			$fldv =~ s/%%url%%/$url/g;
			$fldv =~ s/%%cururl%%/$m_cururl/g;
			$fldv =~ s/%%code%%/$m_stat/g;
			$fldv =~ s/%%answer%%/$m_answer/g;
			$fldv =~ s/%%title%%/$m_title/g;
			$exp{$fldk} = $fldv;
		};

		next;
	}

	/^GET:\s*(.*)/ and do {
		$expect = 1;

		$url = sub_var $1;

		if ($url =~ m#%%\w+%%#) {
			print "Unable to resolve all of the needed arguments in the URL";
			exit 3;
		}

		$mech -> get ($url);

		next;
	};

	/^POST:\s*(.*)$/ and do {
		$expect = 1;

		if ((not defined $1) || ($1 =~ /^\s*$/)) {
			$mech -> submit();
			next;
		}

		my @argpairs = split /\s*,\s*/;
		my (%field_args, %submit_args);

		foreach (@argpairs) {
			/(\S+) => (.*)/ and do {
				my ($fldk, $fldv) = ($1, $2);
				if ($fldk eq 'button') {
					$submit_args{'button'} = $fldv;
				} else {
					$fldk = sub_var $fldk;
					$fldv = sub_var $fldv;
					$field_args{$fldk} = $fldv;
				}
			};
		}
#foreach (keys %field_args) {
#	print $_, "###", $field_args{$_}, "\n";
#}

		$mech -> submit_form (
			with_fields => \%field_args,
			%submit_args,
		);

		next;
	};

}

exit $stat;