#!perl

#	kill_WWW*_suffix_map.pl
#	by Eric Dobbs <dobbs@dobbse.net>

#	a script to remove suffix maps from a
#	collection of WebSTAR 2.0 servers

#	If you only have one server to tweek,
#	then you should just use a web browser.
#	But if you need to make the same change
#	across more than 5 servers, doing it by
#	hand is tedious.  Whereas hacking perl
#	is fun.  8^)

use strict;
use LWP::UserAgent;
use HTTP::Request;
use HTTP::Request::Common;
use HTTP::Response;

#	need to do this for about 20 servers
#	each element in this array contains a reference to an anonymous array
#	each anonymous array contains the following info:
#		nickname	domain or ip	realm login		realm password
my @servers = (
	[qw(server1		one.somewhere.com		pi_admin	password)],
	[qw(server2		two.somewhere.com		pi_admin	password)],
	[qw(server3		three.somewhere.com		pi_admin	password)],
	[qw(server4		four.somewhere.com		pi_admin	password)]
);

#	these are the fields in WebSTARs suffix maps.
#	they're used in a regex match below.
my $webstar_action			= q(TANGO);
my $webstar_suffix			= q(\.QRY);
my $webstar_file_type		= q([^<\015\012]*);	# The fields are wrapped in 
my $webstar_file_creator	= q([^<\015\012]*); # <TD></TD> tags.  These match
my $webstar_MIME_type		= q([^<\015\012]*); # everything up to the next <

foreach (@servers) {
	my ($name,$ip,$user,$pw) = @$_;
	#	this is the WebSTAR 2.0 url for text-only modification of suffix maps
	my $url = qq(http://$ip/pi_admin_ssi.admin\$adm_suffixmappingstext.ssi);
	my $ua = LWP::UserAgent->new();
	my $req = HTTP::Request->new(GET => $url);
	
	#	This is important.  Need to give our UserAgent the
	#	login name and password for realm authentication.
	$req->authorization_basic($user,$pw);

	print qq($name\t) . $req->url() . qq(\n);
	
	my $response = $ua->request($req);
	if ($response->is_error()) {
		print $response->status_line . qq(\n);
	} else {
		#	successfully grabbed the page from the server,
		#	so now lets see if we can find and remove the suffix
		my $content = $response->content();

		#	here is where we are matching the fields defined above.
		#	this is grabbing the values needed in POST arguments
		#	below.
		$content =~ m|<TD>$webstar_action</TD>
<TD>$webstar_suffix</TD>
<TD align=CENTER>$webstar_file_type</TD>
<TD align=CENTER>$webstar_file_creator</TD>
<TD>$webstar_MIME_type</TD>
<TD align=CENTER><INPUT TYPE="radio" NAME="selection" VALUE="(\d+)"  ><
/TD>
<TD align=CENTER><INPUT TYPE="number" NAME="order(\d+)" VALUE="(\d+)" 
SIZE=4 MAXLENGTH=6></TD>|;
		my ($selection,$ordernum,$orderval) = ($1,$2,$3);

		#	if you look at the source for WebSTARs suffix maps,
		#	you'll find some hidden fields.  We'll send these in
		#	our POST arguments too.
		my ($last_locked,$list_count) = ($content =~ 
			m|<INPUT TYPE="hidden" NAME="last_locked" VALUE="(\d+)"><INPUT TYPE="hidden" NAME="list_count" VALUE="(\d+)">|);

		print qq(\tselection:$selection\t\tlist_count before:$list_count);

		#	little error checking -- do not want to delete the
		#	suffix map unless it is really the one
		if (defined($selection) and
			defined($ordernum) and
			defined($orderval)) {

			#	This is where all the magic happens.  LWP is cool.
			#	Here we POST the necessary arguments to the server.
			#	You could also modify this code to add a suffix map.
			#	One thing -- the $ua object must be remembering the
			#	authentication information from the last request,
			#	because none of that is specified here.
			$response = $ua->request(POST $url,[
				service => qq(suffix_mappings),
				last_locked => $last_locked,
				list_count => $list_count,
				selection => qq($selection),
				button => qq(Delete Selection)
			]);
			if ($response->is_error()) {
				print qq(\n) . $response->status_line . qq(\n);
			} else {
				$content = $response->content();
				($last_locked,$list_count) = ($content =~ 
					m|<INPUT TYPE="hidden" NAME="last_locked" VALUE="(\d+)"><INPUT TYPE="hidden" NAME="list_count" VALUE="(\d+)">|);
				print qq(\tafter:$list_count);
			}
		}
		print qq(\n\n);
	}
}


__END__

# -----begin Example output-----
# 
# server1	http://one.somewhere.com/
# pi_admin_ssi.admin$adm_suffixmappingstext.ssi
# 	selection:12		list_count before:35	after:34
# 
# server2	http://two.somewhere.com/
# pi_admin_ssi.admin$adm_suffixmappingstext.ssi
# 	selection:		list_count before:34
# 
# server3	http://three.somewhere.com/
# pi_admin_ssi.admin$adm_suffixmappingstext.ssi
# 500 # Can't resolv address for three.somewhere.com
# File 'Macintosh HD:Applications:MacPerl ƒ:lib:LWP:Protocol:http.pm'; 
# Line 64
# 
# server4 http://four.somewhere.com/
# pi_admin_ssi.admin$adm_suffixmappingstext.ssi
#     selection:12        list_count before:35    after:34
# 
# -----end Example output-----
# 
# 
# In this example, server 1 succeeded.  'selection' has a value,
# and the 'after' count is 1 less than the 'before' count.
# 
# On server 2, the connection and proccessing was successful, but
# the suffix in question could not be found.  'selection' does not
# have a value, and there is no 'after' count.
# 
# The program could not connect to server 3.
# 
# Server 4 is another successful one -- shown here mainly to indicate
# that the script will continue processing if it hits a server that
# it cannot connect to.