use strict;
binmode(STDOUT);

$criteria{'any'} = sub {
	return ('', 1);
	};

$criteria{'trailer'} = sub {
	my ($is_valid) = (0);
	my $err = '';
	Err: {
		last Err unless ($const{'ErrorCode'} == 404);

		# only do non-CGI
		last Err if ($const{'ErrorURL'} =~ m!\?!);

		# only those with trailing non-alphanum, non-slash
		last Err unless ($const{'ErrorURL'} =~ m!\W$!s);

		my $try_file = $const{'ErrorURL'};
		my $qmbu = quotemeta($system{'base_url'});
		$try_file =~ s!^$qmbu!$system{'base_folder'}!ois;

		# well, would it exist without that extra gunk?
		$try_file =~ s!\W+$!!os;
		last Err unless (-e $try_file);

		# okay, we have a clean URL
		my $new = $const{'ErrorURL'};
		if ($new =~ s!\W+$!!os) {
			$const{'new_url'} = $new;
			$is_valid = 1;
			}

		last Err;
		}
	return ($err, $is_valid);
	};

$criteria{'case-match'} = sub {
	my ($is_valid) = (0);
	my $err = '';
	Err: {
		last Err unless ($const{'ErrorCode'} == 404);

		# only do non-CGI
		last Err if ($const{'ErrorURL'} =~ m!\?!);

		# only those with upper-case
		last Err unless ($const{'ErrorURL'} =~ m![A-Z]!s);

		my $try_file = $const{'ErrorURL'};
		my $qmbu = quotemeta($system{'base_url'});
		$try_file =~ s!^$qmbu!$system{'base_folder'}!ois;

		# verify that the try-file doesn't exist
		last Err if (-e $try_file);

		# well, would it exist as lowercase?
		$try_file = lc($try_file);
		last Err unless (-e $try_file);

		# okay, we have a clean URL
		$const{'new_url'} = lc($const{'ErrorURL'});

		$is_valid = 1;

		last Err;
		}
	return ($err, $is_valid);
	};



$actions{'ignore'} = sub {
	my ($action_type, $action_string, $reaction_type, $reaction_string, $p_backref) = @_;
	my ($is_done, $str_handled) = (0, '');
	my $err = '';
	Err: {
		if ($reaction_string > $const{'ignore_request'}) {
			$const{'ignore_request'} = $reaction_string;
			$str_handled = "Increasing 'ignore_request' value to $reaction_string ($action_type:$action_string).\n";
			}
		last Err;
		}
	return ($err, $is_done, $str_handled);
	};


$actions{'replace'} = sub {
	my ($action_type, $action_string, $reaction_type, $reaction_string, $p_backref) = @_;
	return ('', 0, '') if ($const{'mode'} == 3);
	my ($is_done, $str_handled) = (1, '');
	my $err = '';
	Err: {
		my $file = $reaction_string;
		unless (-e $file) {
			$err = &pstr(49, &he($file));
			next Err;
			}
		# what is the file extension?
		my $lc_ext = '';
		if ($file =~ m!\.(.*?)$!) {
			$lc_ext = lc($1);
			}
		my $mime_type = 'text/html';
		if (defined($MimeType{$lc_ext})) {
			$mime_type = $MimeType{$lc_ext};
			}
		unless (open(FILE, "<$file")) {
			$err = "unable to open file '$file' - $!";
			next Err;
			}
		unless (binmode(FILE)) {
			$err = "unable to set binmode on file - $!";
			next Err;
			}
		print "HTTP/1.0 200 OK\015\012" if ($const{'PRINT_HTTP_STATUS_HEADER'});
		print "Last-Modified: Wed, 26 Jul 2000 13:33:42 GMT\015\012";
		print "Expires: Tue, 3 Nov 2015 13:33:42 GMT\015\012";
		print "Cache-control: public\015\012";
		print "Connection: close\015\012";
		print "Set-Cookie: Error$const{'ErrorCode'}=$const{'ErrorCount'}\015\012";
		print "Content-Length: " . (-s $file) . "\015\012";
		print "Status: 200 OK\015\012" if $const{'b_use_status_header_2'};
		print "Content-Type: $mime_type\015\012"; $const{'has_http_header'}++;
		print "\015\012";
		while (defined($_ = <FILE>)) {
			print;
			}
		close(FILE);
		$str_handled = "Replaced with file '$reaction_string'.\n";
		last Err;
		}
	continue {
		$str_handled = "Tried to replace with file '$reaction_string'. Error: $err.\n";
		}
	return ($err, $is_done, $str_handled);
	};


$actions{'dos'} = sub {
	my ($action_type, $action_string, $reaction_type, $reaction_string, $p_backref) = @_;
	return ('', 0, '') if ($const{'mode'} == 3);
	my ($is_done, $str_handled) = (1, '');
	my $err = '';
	Err: {
		if ($ENV{'HTTP_VIA'}) {
			$str_handled = "Averting DOS response because client is routing through a proxy server ($action_type:$action_string).\n";
			last Err;
			# skip because they are arriving from a proxy server
			# there are perhaps many many innocent civilians behind the same shared REMOTE_ADDR IP address
			}


		my $size = $reaction_string;

		$| = 1;
		print "HTTP/1.0 200 OK\015\012" if ($const{'PRINT_HTTP_STATUS_HEADER'});
		print "Status: 200 OK\015\012" if $const{'b_use_status_header_2'};
		print "Content-Type: text/html\015\012"; $const{'has_http_header'}++;
		print "Connection: keep-alive\015\012";
		print "Set-Cookie: Error$const{'ErrorCode'}=$const{'ErrorCount'}\015\012";
		print "Content-Length: " . int($size + 100 + 1024 * rand()) . "\015\012";
		print "\015\012";
		for (1..$size) {
			print chr(rand(128));
			sleep(1);
			}
		$| = 0;
		print 'xyz'; # trailing unbuffered write
		$str_handled = "Return DOS response with time interval $size ($action_type:$action_string).\n";
		last Err;
		}
	return ($err, $is_done, $str_handled);
	};

sub max_htaccess_size {
	return 32768;
	}

$actions{'blacklist'} = sub {
	my ($action_type, $action_string, $reaction_type, $reaction_string, $p_backref) = @_;
	return ('', 0, '') if ($const{'mode'} == 3);
	my ($is_done, $str_handled) = (0, '');
	my $err = '';
	Err: {
		if ($ENV{'HTTP_VIA'}) {
			$str_handled = "Averting blacklist action because client is routing through a proxy server ($action_type:$action_string).\n";
			last Err;
			# skip because they are arriving from a proxy server
			# there are perhaps many many innocent civilians behind the same shared REMOTE_ADDR IP address
			}

		my $htaccess_file = $reaction_string;

		my $remote_user = &query_env('REMOTE_ADDR');
		if ($remote_user eq '127.0.0.1') { # protect from f2s.com, similar, where all users have localhost as REMOTE_ADDR
			$str_handled = "Skipping blacklist action because REMOTE_ADDR is localhost 127.0.0.1.\n";
			last Err;
			}

		my $text = ''; # already blacklisted?
		($err, $text) = &ReadFile( $htaccess_file );
		next Err if ($err);

		my $qm_remote_user = quotemeta($remote_user);
		if ($text =~ m!deny from $qm_remote_user !s) {
			# we've done all we can here...
			}
		elsif ($remote_user =~ m!^\d+\.\d+\.\d+\.\d+$!) { # we only play with valid IP
			my $fsize = (-s $htaccess_file) || 0;
			my $max = &max_htaccess_size();
			if ($fsize > $max) {
				$str_handled = "Skipping blacklist action because file $htaccess_file is size $fsize bytes.  This software will not append to files larger than $max bytes.\n";
				last Err;
				}
			unless (open(FILE, ">>$htaccess_file")) {
				$err = "unable to open file '$htaccess_file' for appending - $!";
				next Err;
				}
			binmode(FILE);
			print FILE "\n# Added by Guardian " . scalar localtime() . " ($action_type:$action_string)\ndeny from $remote_user \n\n";
			close(FILE);
			&setchmod( $htaccess_file );
			$str_handled = "Blacklisted IP address $remote_user ($action_type:$action_string).\n";
			}
		last Err;
		}
	return ($err, $is_done, $str_handled);
	};



$actions{'http-redirect'} = sub {
	my ($action_type, $action_string, $reaction_type, $reaction_string, $p_backref) = @_;
	return ('', 0, '') if ($const{'mode'} == 3);
	my ($is_done, $str_handled) = (1, '');
	my $err = '';
	Err: {
		my $nexturl = $reaction_string;
		$nexturl =~ s!\%new_url\%!$const{'new_url'}!isg;
		if ($ENV{'REDIRECT_QUERY_STRING'}) {
			$nexturl .= '?' . $ENV{'REDIRECT_QUERY_STRING'};
			}
		print "HTTP/1.0 301 Moved Permanently\015\012" if ($const{'PRINT_HTTP_STATUS_HEADER'});
		print "Status: 301 Moved Permanently\015\012" if $const{'b_use_status_header_2'};
		print "Set-Cookie: Error$const{'ErrorCode'}=$const{'ErrorCount'}\015\012";
		print "Location: $nexturl\015\012";
		print "Content-Type: text/html\015\012\015\012"; $const{'has_http_header'}++;
		print "<a href=\"$nexturl\">Document moved: $nexturl</a>";
		$str_handled = "Responded with HTTP 301 permanent redirect to URL '$nexturl'.\n";
		last Err;
		}
	return ($err, $is_done, $str_handled);
	};

$actions{'http-redirect-temp'} = sub {
	my ($action_type, $action_string, $reaction_type, $reaction_string, $p_backref) = @_;
	return ('', 0, '') if ($const{'mode'} == 3);
	my ($is_done, $str_handled) = (1, '');
	my $err = '';
	Err: {
		my $nexturl = $reaction_string;
		$nexturl =~ s!\%new_url\%!$const{'new_url'}!isg;
		if ($ENV{'REDIRECT_QUERY_STRING'}) {
			$nexturl .= '?' . $ENV{'REDIRECT_QUERY_STRING'};
			}
		print "HTTP/1.0 302 Found\015\012" if ($const{'PRINT_HTTP_STATUS_HEADER'});
		print "Status: 302 Found\015\012" if $const{'b_use_status_header_2'};
		print "Set-Cookie: Error$const{'ErrorCode'}=$const{'ErrorCount'}\015\012";
		print "Location: $nexturl\015\012";
		print "Content-Type: text/html\015\012\015\012"; $const{'has_http_header'}++;
		print "<a href=\"$nexturl\">Document moved: $nexturl</a>";
		$str_handled = "Responded with HTTP 302 temporary redirect to URL '$nexturl'.\n";
		last Err;
		}
	return ($err, $is_done, $str_handled);
	};


$actions{'redirect'} = sub {
	my ($action_type, $action_string, $reaction_type, $reaction_string, $p_backref) = @_;
	return ('', 0, '') if ($const{'mode'} == 3);
	my ($is_done, $str_handled) = (1, '');
	my $err = '';
	Err: {
		my %replace_values = %const;

		$replace_values{'url'} = $reaction_string;
		$replace_values{'url'} =~ s!\%new_url\%!$const{'new_url'}!isg;

		if ($ENV{'REDIRECT_QUERY_STRING'}) {
			$replace_values{'url'} .= '?' . $ENV{'REDIRECT_QUERY_STRING'};
			}

		# HTML-encode everything except the copyright string:
		local $_;
		foreach (keys %replace_values) {
			next if (m!^(copyright)$!i);
			$replace_values{ $_ } = &he( $replace_values{ $_ } );
			}


		print "HTTP/1.0 200 OK\015\012" if ($const{'PRINT_HTTP_STATUS_HEADER'});
		print "Status: 200 OK\015\012" if $const{'b_use_status_header_2'};
		print "Set-Cookie: Error$const{'ErrorCode'}=$const{'ErrorCount'}\015\012";
		print "Content-Type: text/html\015\012"; $const{'has_http_header'}++;
		print "\015\012";
		print &ParseTemplate( 'moved.txt', "$system{'language'}", \%replace_values );
		$str_handled = "Redirected user to URL '$replace_values{'url'}'.\n";
		last Err;
		}
	return ($err, $is_done, $str_handled);
	};


$actions{'error-template'} = sub {
	my ($action_type, $action_string, $reaction_type, $reaction_string, $p_backref) = @_;
	my ($is_done, $str_handled) = (1, '');
	my $err = '';
	Err: {

		my %replace_values = %const;


		# HTML-encode everything except the copyright string:
		local $_;
		foreach (keys %replace_values) {
			next if (m!^(copyright)$!i);
			$replace_values{ $_ } = &he( $replace_values{ $_ } );
			}


		$replace_values{'specific_message'} = &ParseTemplate( $reaction_string, $system{'language'}, \%replace_values );

		# Customize the HTML for each error below:

		if (($const{'ErrorCode'} =~ m!^\d\d\d$!) and (not $ENV{'guardian_test'})) {
			print "HTTP/1.0 $const{'ErrorCode'} OK\015\012" if ($const{'PRINT_HTTP_STATUS_HEADER'});
			print "Status: $const{'ErrorCode'} Condition Intercepted\015\012" if $const{'b_use_status_header_2'};
			}
		else {
			print "HTTP/1.0 200 OK\015\012" if ($const{'PRINT_HTTP_STATUS_HEADER'});
			}
		print "Set-Cookie: Error$const{'ErrorCode'}=$const{'ErrorCount'}\015\012";
		print "Content-Type: text/html\015\012"; $const{'has_http_header'}++;
		print "\015\012";
		print &ParseTemplate( 'template.txt', "$system{'language'}", \%replace_values );

		$str_handled = "Responded with error template '$reaction_string'.\n";
		last Err;
		}
	return ($err, $is_done, $str_handled);
	};





sub shared_version {
	return '2.0.0.0010';
	}


=item check_regex

Usage:
	$err = &check_regex($pattern);

Checks against ?{} code-executing expressions.

Uses an eval wrapper to confirm that the expression is valid.

=cut

sub check_regex {
	my ($pattern) = @_;
	my $err = '';
	Err: {
		if ($pattern =~ m!\?\{!) {
			$err = 'query pattern "' . &he($pattern) . '" contains illegal ?{} code-executing regular expression';
			next Err;
			}
		eval '"foo" =~ m!$pattern!;';
		if ($@) {
			$err = 'unable to evaluate pattern "' . &he($pattern) . '" - ' . &he($@);
			undef($@);
			next Err;
			}
		}
	return $err;
	}


sub handle_error {
	my $err = '';
	Err: {
		&GetErrorInfo();
		my $text = '';
		($err, $text) = &ReadFile('filters.txt');
		next Err if ($err);

		my $user_agent = &query_env('HTTP_USER_AGENT');

		my $b_zeus = (&query_env('SERVER_SOFTWARE') =~ m!zeus!i) ? 1 : 0;

		my $is_done = 0;
		my ($str_handled, $stub) = ('', '');

		my ($action_type, $action_string, $reaction_type, $reaction_string, $response) = ();

		my $rule;

		Rule: foreach $rule (split(m!==!s, $text)) {
			local $_ = $rule = &Trim($rule);
			next Rule if ($_ eq ''); # skip spurious
			next Rule if (m!^\#!); # skip comments
			unless (m!^(.*?)\:\s*(.*?)\r?\n(.+?)\:\s*(.*)$!s) {
				&syslog("Filter Rule string '$_' is not valid; must pattern match 'action:str reaction:str'");
				next Rule;
				}
			($action_type, $action_string, $response) = ($1, $2, "$3: $4");

			if ($b_zeus) {
				next Rule if ($action_type =~ m!^(dos|replace)$!);
				$action_type = 'redirect' if ($action_type =~ m!^http-redirect!);
				}

			# does this Filter Rule apply to this request?

			my @backref = ();

			if (defined($criteria{$action_type})) {
				my $is_valid = 0;
				($err, $is_valid) = &{ $criteria{$action_type} };
				next Err if ($err);
				next Rule unless ($is_valid);
				}
			elsif ($action_type eq 'error-code') {
				next Rule unless ($const{'ErrorCode'} == $action_string);
				}
			elsif ($action_type eq 'url-pattern') {
				$err = &check_regex($action_string);
				next Err if ($err);
				next Rule unless (@backref = ($const{'ErrorURL'} =~ m!$action_string!i));
				}
			elsif ($action_type eq 'url-substring') {
				my $pattern = quotemeta($action_string);
				next Rule unless ($const{'ErrorURL'} =~ m!$pattern!i);
				}
			elsif ($action_type eq 'url-string') {
				next Rule unless ($const{'ErrorURL'} eq $action_string);
				}
			elsif ($action_type eq 'refer-pattern') {
				$err = &check_regex($action_string);
				next Err if ($err);
				next Rule unless (@backref = ($const{'HTTP_REFERER'} =~ m!$action_string!i));
				}
			elsif ($action_type eq 'refer-substring') {
				my $pattern = quotemeta($action_string);
				next Rule unless ($const{'HTTP_REFERER'} =~ m!$pattern!i);
				}
			elsif ($action_type eq 'refer-string') {
				next Rule unless ($const{'HTTP_REFERER'} eq $action_string);
				}
			elsif ($action_type eq 'ua-pattern') {
				$err = &check_regex($action_string);
				next Err if ($err);
				next Rule unless (@backref = ($const{'HTTP_USER_AGENT'} =~ m!$action_string!i));
				}
			elsif ($action_type eq 'ua-substring') {
				my $pattern = quotemeta($action_string);
				next Rule unless ($const{'HTTP_USER_AGENT'} =~ m!$pattern!i);
				}
			elsif ($action_type eq 'ua-string') {
				next Rule unless ($const{'HTTP_USER_AGENT'} eq $action_string);
				}
			else {
				$err = "action type $action_type does not have a handler defined";
				next Err;
				}

			foreach (split(m!\015\012!s, $response)) {
				next unless (m!^(.+?):\s+(.+?)$!s);
				($reaction_type, $reaction_string) = (lc($1), $2);
				if (defined($actions{$reaction_type})) {

					my $x = 1;
					my $match;
					foreach $match (@backref) {
						$reaction_string =~ s!\$$x!$match!sg;
						$x++;
						}


					($err, $is_done, $stub) = &{ $actions{$reaction_type} }($action_type, $action_string, $reaction_type, $reaction_string, \@backref);
					$str_handled .= $stub;
					next Err if ($err);
					if ($is_done) {
						$const{'rule'} = $rule;
						last Rule;
						}
					}
				else {
					$err = &pstr(48, &he($reaction_type) );
					next Err;
					}
				}
			}

		unless ($is_done) {
			print "Content-Type: text/html\015\012\015\012"; $const{'has_http_header'}++;
			print "<p><b>Error:</b> no filters applied to this request.</p>\n";
			}


		if (($const{'mode'} == 1) or ($const{'mode'} == 2)) {
			if (($system{'email_address'}) and (($system{'sendmail_program'}) or ($system{'smtp_server'}))) {
				$err = &send_mail($str_handled);
				# don't throw exception here -- at least try to log_err
				}
			}

		my $err2 = &log_error();
		next Err if ($err2);
		next Err if ($err); # from above
		last Err;
		}
	return $err;
	}




sub ag_init {
	my ($VERSION) = @_;
	my $err = '';
	Err: {

		if ($VERSION ne &shared_version()) {
			$err = "version mismatch - script is version $VERSION but shared library is version " . &shared_version();
			next Err;
			}

		@sendmail = (
			'/usr/sbin/sendmail -t',
			'/usr/bin/sendmail -t',
			'/usr/lib/sendmail -t',
			'/usr/sendmail -t',
			'/bin/sendmail -t',
			);
		%const = (
			'has_http_header' => 0,
			'PRINT_HTTP_STATUS_HEADER' => $const{'PRINT_HTTP_STATUS_HEADER'}, #changed 0006
			'b_use_status_header_2' => 1,


			'ignore_request' => 0,
			'help_file' => 'http://www.xav.com/scripts/guardian/help/',
			'ErrorCount' => 0,
			'ErrorURL' => 'Unknown URL',
			'ErrorDescription' => 'Unknown Error Type',
			'ErrorCode' => 0,

			'HTTP_REFERER' => &query_env('HTTP_REFERER'),
			'HTTP_USER_AGENT' => &query_env('HTTP_USER_AGENT'),

			'admin_url' => &query_env('SCRIPT_NAME'),

			'copyright' => '<table border="0" cellspacing="0" cellpadding="0" width="100%"><tr><td align="right"><small><a href="http://www.xav.com/scripts/guardian/" target="_blank">Guardian</a> v' . $VERSION . ' is &copy; 2003 by Fluid Dynamics Software</small></td></tr></table>',

			'version' => $VERSION,

			'mode' => 1,
			'trace' => '',
			'rule' => '',
			);

		if ((&query_env('SERVER_SOFTWARE') =~ m!^Microsoft-IIS/(\d+)!) and ($1 > 5)) {
			$const{'b_use_status_header_2'} = 0;
			}

		

		%MimeType = (
			'ico' => 'image/x-icon',
			'gif' => 'image/gif',
			'jpg' => 'image/jpeg',
			);


	@DataFields = (
			'TIME',
			'LOCALTIME',
			'REMOTE_HOST',
			'REMOTE_ADDR',
			'HTTP_REFERER',
			'AG_ERROR_URL',
			'AG_ERROR_CODE',
			'AG_ERROR_COUNT',
			'HTTP_USER_AGENT',
			'HTTP_VIA',
			);

		unless (chdir('data')) {
			$err = "unable to change directory to folder 'data' - $!";
			next Err;
			}

		$err = &load_system_settings();
		next Err if ($err);
		&validate_system_settings(0);
		if (-e 'is_demo') {
			$const{'mode'} = 0;
			}
		else {
			$const{'mode'} = $system{'mode'} || 1;
			}
		my $file = "$system{'language'}/strings.txt";
		unless (open(FILE, "<$file")) {
			$err = "unable to open file '$file' for reading - $!";
			next Err;
			}
		binmode(FILE);
		@str = ('');
		while (defined($_ = <FILE>)) {
			s!\r|\n!!g;
			push(@str, $_);
			}
		close(FILE);
		&WebFormL(\%FORM);

		last Err;
		}
	return $err;
	}

sub send_mail {
	my ($str_handled) = @_;
	my $err = '';
	Err: {
		last Err if (1 & $const{'ignore_request'});
		SendMail: {
			my $Message = &BuildMessage($str_handled);
			my $trace = '';
			($err, $trace) = &SendMailEx(
				'to' => $system{'email_address'},
				'from' => $system{'email_address'},
				'raw' => $Message,
				'host' => $system{'smtp_server'},
				'pipeto' => $system{'sendmail_program'},
				);
			next Err if ($err);
			}
		last Err;
		}
	return $err;
	};



=item syslog

Usage:
	&syslog($err);

Attempts to append the error message to the file 'data/syslog'.  Format of file is "unixtime,url-encoded-error\n"

The syslog contains Guardian's own personal errors, while the more general errors.log file contains HTTP server errors.

The syslog file is hardcoded to not exceed 100kb

No error handling.

=cut

sub syslog {
	my $err = $_[0] || '';
	my $size = (-s 'syslog') || 0;
	if (($system{'MaxLogBytes'}) and ($size > $system{'MaxLogBytes'})) {
		# do nothing
		}
	else {
		if (open(FILE, ">>syslog")) {
			binmode(FILE);
			print FILE time() . "," . &url_encode($err) . "\015\012";
			close(FILE);
			&setchmod( 'syslog' );
			}
		}
	}



sub log_error {
	my $err = '';
	Err: {
		if (2 & $const{'ignore_request'}) {
			#print "<!-- ignore logging request // $const{'ignore_request'} -->\n";
			last Err;
			}
		my $LogBytes = (-s 'errors.log') || 0;
		if (($system{'MaxLogBytes'}) and ($LogBytes > $system{'MaxLogBytes'})) {
			last Err; # changed 0008 - no explicit error msg (at this level) for full log
			}

		$ENV{'TIME'} = time;
		$ENV{'LOCALTIME'} = &FormatDateTime( time(), 12 );

		my $record = '';

		local $_;
		foreach (@DataFields) {
			$record .= $ENV{$_} || '';
			$record .= "\t";
			}

		unless (open(FILE, ">>errors.log")) {
			$err = "unable to append to file 'errors.log' - $! - $^E";
			next Err;
			}
		unless (binmode(FILE)) {
			$err = "unable to set binmode on file 'errors.log' - $! - $^E";
			close(FILE);
			next Err;
			}
		unless (print FILE $record . "\015\012") {
			$err = "unable to write data to file 'errors.log' - $! - $^E";
			close(FILE);
			next Err;
			}
		unless (close(FILE)) {
			$err = "unable to close file 'errors.log' - $! - $^E";
			next Err;
			}
		&setchmod( 'errors.log' );
		last Err;
		}
	return $err;
	};





sub BuildMessage {
	my ($str_handled) = (@_);
	my %replace_values = %const;
	$replace_values{'error_handling_description'} = "\n$str_handled";
	$replace_values{'date_smtp'} = &FormatDateTime( time(), 'smtp' );
	return &ParseTemplate( 'email_message.txt', $system{'language'}, \%replace_values );
	}


# This code autodetects the HTTP error code and URL for both Apache and IIS
# systems:

sub GetErrorInfo {
	if (($ENV{'REDIRECT_STATUS'}) and ($ENV{'REDIRECT_STATUS'} =~ m!^(\d\d\d)$!)) {
		$const{'ErrorCode'} = $1;
		}
	elsif (($ENV{'QUERY_STRING'}) and ($ENV{'QUERY_STRING'} =~ m!^(\d\d\d)!)) {
		$const{'ErrorCode'} = $1;
		}
	else {
		$const{'ErrorCode'} = 0;
		}
	if (($ENV{'QUERY_STRING'}) and ($ENV{'QUERY_STRING'} =~ m!\d+\;http://(.*)$!)) {
		$const{'ErrorURL'} = 'http://'.$1;
		}

# experimental support for:
# Apache/1.3.20 Sun Cobalt (Unix) mod_ssl/2.8.4 OpenSSL/0.9.6b PHP/4.0.3pl1 mod_auth_pam_external/0.1 FrontPage/4.0.4.3 mod_perl/1.25

	elsif ($ENV{'REDIRECT_SCRIPT_URL'}) {
		$const{'ErrorURL'} = 'http://';
		$const{'ErrorURL'} .= ($ENV{'HTTP_HOST'} ? $ENV{'HTTP_HOST'} : $ENV{'SERVER_NAME'});
		$const{'ErrorURL'} .= $ENV{'REDIRECT_SCRIPT_URL'};

		if (defined($ENV{'REDIRECT_QUERY_STRING'})) {
			$const{'ErrorURL'} .= '?' . $ENV{'REDIRECT_QUERY_STRING'};
			}

		}

# REQUEST_URI has to be used
# also needs to be used with the case of /a/foo%3Fbar; REDIRECT_URL will return this as /a/foo?bar

	elsif (($ENV{'SERVER_SOFTWARE'}) and ($ENV{'SERVER_SOFTWARE'} =~ m!Apache!) and ($ENV{'REQUEST_URI'})) {
		$const{'ErrorURL'} = 'http://';
		$const{'ErrorURL'} .= ($ENV{'HTTP_HOST'} ? $ENV{'HTTP_HOST'} : $ENV{'SERVER_NAME'});
		$const{'ErrorURL'} .= $ENV{'REQUEST_URI'};
			# request_uri includes the query string
		}

	elsif ($ENV{'REDIRECT_URL'}) {
		$const{'ErrorURL'} = 'http://';
		$const{'ErrorURL'} .= ($ENV{'HTTP_HOST'} ? $ENV{'HTTP_HOST'} : $ENV{'SERVER_NAME'});
		$const{'ErrorURL'} .= $ENV{'REDIRECT_URL'};

		if (defined($ENV{'REDIRECT_QUERY_STRING'})) {
			$const{'ErrorURL'} .= '?' . $ENV{'REDIRECT_QUERY_STRING'};
			}

		}

	# zeus3 server support: // http://support.zeus.com/faq/entries/errorcgi.html
	elsif (($ENV{'QUERY_STRING'}) and ($ENV{'QUERY_STRING'} =~ m!^\d\d\d$!) and (&query_env('SERVER_SOFTWARE') =~ m!zeus!i)) {
		$const{'ErrorURL'} = 'http://';
		$const{'ErrorURL'} .= ($ENV{'HTTP_HOST'} ? $ENV{'HTTP_HOST'} : $ENV{'SERVER_NAME'});
		$const{'ErrorURL'} .= $ENV{'DOCUMENT_URI'};

		if (defined($ENV{'REDIRECT_QUERY_STRING'})) {
			$const{'ErrorURL'} .= '?' . $ENV{'REDIRECT_QUERY_STRING'};
			}

		}
	else {
		$const{'ErrorURL'} = 'Unknown URL';
		}
	$const{'ErrorDescription'} = $str[6];
	if ($const{'ErrorCode'} == 401) {
		$const{'ErrorDescription'} = $str[7];
		}
	elsif ($const{'ErrorCode'} == 403) {
		$const{'ErrorDescription'} = $str[8];
		}
	elsif ($const{'ErrorCode'} == 404) {
		$const{'ErrorDescription'} = $str[9];
		}
	elsif ($const{'ErrorCode'} == 500) {
		$const{'ErrorDescription'} = $str[10];
		}
	if (($const{'ErrorCode'}) and ($ENV{'HTTP_COOKIE'}) and ($ENV{'HTTP_COOKIE'} =~ m!Error$const{'ErrorCode'}=(\d+)!i)) {
		$const{'ErrorCount'} = $1;
		}
	$const{'ErrorCount'}++;


	$const{'ErrorPathStr'} = '';
	if ($const{'ErrorURL'} =~ m!^http://.*?/(.*)$!) {
		my $path = lc($1);
		$path =~ s!\W+! !g;
		$const{'ErrorPathStr'} = &he($path);
		}



	$ENV{'AG_ERROR_URL'} = $const{'ErrorURL'};
	$ENV{'AG_ERROR_COUNT'} = $const{'ErrorCount'};
	$ENV{'AG_ERROR_CODE'} = $const{'ErrorCode'};



	# initialize other %const values
	# they will be used in ParseTemplate calls later:

	$const{'full_admin_url'} = &get_absolute_url();
	$const{'full_admin_url'} =~ s!/ag\.!/ag-admin.!oi;

	$const{'ENV_VARS'} = '';
	local $_;
	foreach (sort keys %ENV) {
		$const{'ENV_VARS'} .= &he($_) . ': ' . &he($ENV{$_}) . "\015\012";
		}


	my $RemoteHost = $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'} || '';
	if (($system{'dns_lookup'}) and ($RemoteHost =~ m!^(\d+)\.(\d+)\.(\d+)\.(\d+)$!)) {
		$RemoteHost = (((gethostbyaddr(pack('C4',$1,$2,$3,$4),2))[0]) || ($RemoteHost));
		}
	$RemoteHost =~ tr[A-Z][a-z];
	$ENV{'REMOTE_HOST'} = $RemoteHost;
	$const{'RemoteHost'} = $RemoteHost;

	$const{'HTTP_REFERER'} = &query_env('HTTP_REFERER');
	$const{'Server_Name'} = &query_env('SERVER_NAME');
	$const{'Script_Path'} = $0;
	$const{'email_address'} = $system{'email_address'};

	$const{'login_error_username'} = &query_env('REMOTE_USER');

	$const{'TimeStamp'} = &FormatDateTime( time(), 12 );

	#placeholders:
	$const{'error_handling_description'} = '';
	$const{'rule'} = '';
	$const{'specific_message'} = '';
	$const{'url'} = '';

	}




sub validate_system_settings {
	my ($b_verbose) = @_;
	my $err = '';
	Err: {
		local $_;

		if (($system{'email_address'}) and ($system{'email_address'} !~ m!^.+\@.+\..+!)) {
			if ($b_verbose) {
				$err = &pstr( 39, &he($system{'email_address'}) );
				next Err;
				}
			$system{'email_address'} = '';
			}


		unless ($system{'sec_data_file'} =~ m!^\d\d\d$!) {
			$err = "custom file permission must be a three-digit string, such as '666'";
			next Err;
			}

		my $min_value = 10;

		# nums
		foreach ('RecordsPerBatch','MaxLogBytes','mode', 'MaxChar_hostname', 'MaxChar_browser', 'MaxChar_url') {
			if ($system{$_} =~ m!\D!) {
				if ($b_verbose) {
					$err = &pstr( 38, $_, &he($system{$_}) );
					next Err;
					}
				$system{$_} = 0;
				}
			if ($_ eq 'mode') {
				if (($system{'mode'} > 3) or ($system{'mode'} < 0)) {
					if ($b_verbose) {
						$err = $str[36];
						next Err;
						}
					$system{'mode'} = 1;
					}
				}
			elsif ($_ eq 'MaxLogBytes') {
				# any int ok
				}
			elsif ($system{$_} < $min_value) {
				if ($b_verbose) {
					$err = &pstr(37, $_, $min_value );
					next Err;
					}
				$system{$_} = $min_value;
				}
			}



		if ($system{'sendmail_program'}) {
			my $b_match = 0;
			foreach (@sendmail) {
				if ($_ eq $system{'sendmail_program'}) {
					$b_match = 1;
					last;
					}
				}
			unless ($b_match) {
				if ($b_verbose) {
					$err = &pstr( 35, &he($system{'sendmail_program'}) );
					next Err;
					}
				$system{'sendmail_program'} = '';
				}
			}


		if ($system{'language'}) {
			if ($system{'language'} =~ m!\W!) {
				if ($b_verbose) {
					$err = &pstr(34, &he($system{'language'}) );
					next Err;
					}
				$system{'language'} = '';
				}
			elsif (not (-e "$system{'language'}/strings.txt")) {
				if ($b_verbose) {
					$err = &pstr(33, &he($system{'language'})  . "/strings.txt" );
					next Err;
					}
				$system{'language'} = '';
				}
			}

		if ($system{'RegKey'}) {
			my $is_valid = &regkey_validate($system{'RegKey'});
			if (not $is_valid) {
				if ($b_verbose) {
					$err = &pstr( 25, "$const{'help_file'}1088.html" );
					next Err;
					}
				$system{'RegKey'} = '';
				}
			}
		if (($system{'mode'} == 2) and (not $system{'RegKey'})) {
			if ($b_verbose) {
				$err = "cannot set mode to 'Registered' without a valid registration key";
				next Err;
				}
			$system{'mode'} = 1;
			}
		last Err;
		}
	return $err;
	}


sub setchmod($);
sub setchmod($) {
	my ($file) = @_;
	if ($system{'sec_mode_eff'} > 1) {
		chmod( $system{'sec_data_file_eff'}, $file );
		}
	};


sub detect_sec_mode();
sub detect_sec_mode() {
	if ($^O =~ m!mswin!i) {
		# don't bother
		return 1;
		}
	elsif ((-e $0) and (-w $0)) {
		# tight; suexec
		return 2;
		}
	else {
		# permissive
		return 3;
		}
	}

sub initiate_chmod($$);
sub initiate_chmod($$) {
	my ($sec_mode, $sec_data_file) = @_;
	if ($sec_mode == 0) {
		$sec_mode = detect_sec_mode();
		}

	if ($sec_mode == 1) {
		$sec_data_file = '666';
		}
	if ($sec_mode == 2) {
		# suexec
		$sec_data_file = '600';
		}
	elsif ($sec_mode == 3) {
		# full-on
		$sec_data_file = '666';
		}
	elsif ($sec_mode == 4) {
		# whatever user had set...
		}
	return ($sec_mode, oct("0$sec_data_file") );
	}


sub load_system_settings {
	my $err = '';
	Err: {
		%system = (

			'b_is_first_time' => 1,
			'ft_status' => '',

			'MaxLogBytes' => 1000000,
			'language' => 'en',
			'mode' => 1,
			'MaxChar_url' => 72,
			'MaxChar_browser' => 48,
			'MaxChar_hostname' => 24,
			'RecordsPerBatch' => 100,
			'ucf' => 1,
			'tcf' => 1,
			'sec_mode' => 0,
			'sec_data_file' => '666',

			'dns_lookup' => 0,
			);

		last unless (-e 'system.txt');

		my $text = '';
		($err, $text) = &ReadFile('system.txt');
		next Err if ($err);

		local $_;
		foreach (split(m!\n!s, $text)) {
			next if (m!\s*\#!);
			next unless (m!(.+)=(.+)!);
			$system{ &url_decode(&Trim($1)) } = &url_decode(&Trim($2));
			}

		( $system{'sec_mode_eff'}, $system{'sec_data_file_eff'} ) = initiate_chmod( $system{'sec_mode'}, $system{'sec_data_file'} );

		last Err;
		}
	return $err;
	}


=item get_absolute_url

Returns the absolute URL to this script, as guessed from environment variables.

Dependencies:

	Called by: BuildMessage

	Global: %const - 1

	Dependency: query_env - 3

	Required library: ../2.0.0.0002/files/guardian/ag-shared.txt

=cut

sub get_absolute_url {
	my $URL = '';
	my $script_name = $const{'admin_url'};
	$script_name =~ s!\?.*$!!;
	if ($ENV{'SERVER_NAME'}) {
		$URL = 'http://' . &query_env('SERVER_NAME') . $script_name;
		}
	elsif ($ENV{'HTTP_HOST'}) {
		$URL = 'http://' . &query_env('HTTP_HOST') . $script_name;
		}
	else {
		$URL = 'unknown';
		}
	return $URL;
	}

=item query_env

Usage:
	my $remote_host = &query_env('REMOTE_HOST');

Abstraction layer for the %ENV hash.  Why abstract?  Here's why:
 1. adds safety for -T taint checks
 2. always returns '' if undef; prevent -w warnings

Dependencies:

	Called by: BuildMessage
	Called by: WebFormL
	Called by: admin_main
	Called by: ag_init
	Called by: get_absolute_url
	Called by: handle_error
	Called by: regkey_verify

	Global: none

	Dependency: none

=cut

sub query_env {
	my ($name,$default) = @_;
	if (($ENV{$name}) and ($ENV{$name} =~ m!^(.*)$!s)) {
		return $1;
		}
	elsif (defined($default)) {
		return $default;
		}
	else {
		return '';
		}
	}






sub Assert {
	return if ($_[0]);
	my ($package, $file, $line) = caller();
	unless ($const{'has_http_header'}) {
		print "Content-Type: text/html\015\012\015\012";
		$const{'has_http_header'}++;
		}
	print "<hr><h1><pre>Assertion Error:<br />	Package: $package<br />	File: $file<br />	Line: $line</pre></h1><hr>";
	}


=item fs_path

($)

Usage:
	my $path = &fs_path($path);

Reduces a file pathname to its most simple, consistent form.  For example:

	"a/b.txt" = &fs_path("a/c/../b.txt");

Will trim leading and trailing whitespace; will strip anything after a "#" sign; will collapse // to / except at the very start of the path, to support UNC paths.

Dependencies:

	Called by: ParseTemplate

	Global: none

	Dependency: Trim - 1

	Required library: ../2.0.0.0002/files/guardian/ag-shared.txt

=cut

sub fs_path {
	local $_ = defined($_[0]) ? $_[0] : '';

	# trim whitespace:
	$_ = &Trim($_);

	s!\\!/!g;

	# strip pound signs and all that follows (links internal to a page)
	s!\#.*$!!;

	# map trailing "/." to "/"
	s!/+\.$!/!g;


	# collapase // to /
	if (m!^//!) {
		# is unc path:
		s!/+!/!g;
		$_ = "/$_";
		}
	else {
		s!/+!/!g;
		}

	# map "something/.." to ""

	unless ((m!^/!) or (m!^\w\:!)) {
		$_ = "./$_";
		}

	my $new = '';
	while (m!^(.*?)([^/]+)/\.\./(.*?)$!) {
		$_ = $3;
		if (($2 eq '..') or ($2 eq '.')) {
			$new .= "$1/$2/../";
			}
		else {
			$new .= "$1";
			}
		}
	$new .= $_;
	$_ = $new;

	# map "../something" to ""

	$new = '';
	while (m!^(.*?)/\.\./([^/]+)/(.*?)$!) {
		$_ = $3;
		if (($2 eq '..') or ($2 eq '.')) {
			$new .= "$1/../$2/";
			}
		else {
			$new .= "$1";
			}
		}
	$new .= $_;
	$_ = $new;


	# map trailing /.. to /

	s!^/+\.\.$!/!;

	s!([^/]+)/+\.\.$!!o;

	# map "/./" to "/"
	s!/+\./+!/!g;

	return $_;
	}


=item ParseTemplate

Usage:
	my $text = &ParseTemplate( 'tips.html', 'templates/german', \%replace, \%cache, \%visited );

Similar to PrintTemplate, but now *always* returns the parsed text as a return value.  To immediately print the return value, simply call as:

	print &ParseTemplate(...);

TODO: confirm that \\server\share format works (don't let fs_path to strip //)

See "admin_help.html" for extensive documentation on this function, its limitations, its failure scenarios, etc.

Dependencies:

	Called by: BuildMessage
	Called by: ParseTemplate

	Global: none

	Dependency: ParseTemplate - 1
	Dependency: ReadFile - 1
	Dependency: fs_path - 1

	Required library: ../2.0.0.0002/files/guardian/ag-shared.txt

=cut

sub ParseTemplate {
	my ( $file, $start_folder, $p_replace, $p_cache, $p_visited) = @_;

	$start_folder = '.' unless ($start_folder);

	my $return_text = '';

	my $err = '';
	Err: {

		# Initialize:
		unless ($p_replace) {
			$p_replace = {};
			}
		unless ($p_visited) {
			$p_visited = {};
			}


		# Query the cache for the text of the document, or search the filesystem for the file:

		my $text = '';
		my $basename = '';
		if (($p_cache) and ('HASH' eq ref($p_cache)) and ($$p_cache{$file})) {
			$text = $$p_cache{$file};
			}
		else {

			my $fullfile = '';
			my $max_parents = 12;
			for (0..$max_parents) {
				$fullfile = $start_folder . '/' . ('../' x $_) . $file;
				$fullfile = &fs_path($fullfile);
				last if (-e $fullfile);
				}
			unless (-e $fullfile) {
				$err = "unable to find file '$file'";
				next Err;
				}
			if ($fullfile =~ m!([^\\|/]+)$!) {
				$basename = $1;
				$$p_visited{$basename} = 1;
				}
			($err, $text) = &ReadFile( $fullfile );
			next Err if ($err);
			if (($p_cache) and ('HASH' eq ref($p_cache))) {
				$$p_cache{$file} = $text;
				}
			}


		# Handling replacement value substitutions:

		#conditionals
		foreach (reverse sort keys %$p_replace) {
			next unless (defined($_));
			$$p_replace{$_} = '' if (not defined($$p_replace{$_}));
			if ($$p_replace{$_}) {
				# true
				$text =~ s!<%\s*if\s+$_\s*%>(.*?)<%\s*end\s*if\s*%>!$1!eisg;
				$text =~ s!<%\s*(if\s+not|unless)\s+$_\s*%>.*?<%\s*end\s*if\s*%>!!eisg;
				}
			else {
				# false
				$text =~ s!<%\s*if\s+$_\s*%>.*?<%\s*end\s*if\s*%>!!isg;
				$text =~ s!<%\s*(if\s+not|unless)\s+$_\s*%>(.*?)<%\s*end\s*if\s*%>!$2!eisg;
				}
			}

		#interpolation
		foreach (reverse sort keys %$p_replace) {
			$text =~ s!\$$_!$$p_replace{$_}!isg;
			$text =~ s!\_\_$_\_\_!$$p_replace{$_}!isg;
			$text =~ s!\%$_\%!$$p_replace{$_}!isg;
			}


		# Now that replacement values are done, parse SSI tags and include files:

		my $pattern = '<!--#(include\s+file|include\s+virtual|echo\s+var)\s*=\s*\"(.*?)\"\s+-->';
		while ($text =~ m!^(.*?)$pattern(.*)$!is) {
			my ($start, $c1, $incfile, $end) = ($1, lc($2), $3, $4);

			$return_text .= $start;

			if ($c1 =~ m!echo\s+var!i) {
				my $var = uc($incfile);
				if ($var eq 'DATE_GMT') {
					$return_text .= scalar gmtime();
					}
				elsif ($var eq 'DATE_LOCAL') {
					$return_text .= scalar localtime();
					}
				elsif ($var eq 'DOCUMENT_NAME') {
					$return_text .= $1 if ($0 =~ m!([^\\|/]+)$!);
					}
				elsif ($var eq 'DOCUMENT_URI') {
					$return_text .= $ENV{'SCRIPT_NAME'};
					}
				elsif ($var eq 'LAST_MODIFIED') {
					$return_text .= scalar localtime( (stat($0))[9] );
					}
				elsif (defined($ENV{$var})) {
					$return_text .= $ENV{$var};
					}
				else {
					$return_text .= "<!--#echo var=\"$incfile\" -->"; # passthru
					}
				}
			else {

				my $basefile = $incfile;
				if ($incfile =~ m!.*(\\|/)(.*?)$!) {
					$basefile = $2;
					}

				# allow only approved file extensions:

				my $ok_list = 'txt|htm|html|shtml|stm|inc|css';
				if ($basefile !~ m!\.($ok_list)$!i) {
					$return_text .= "<!-- xParseTemplate: not including file '$incfile' because extension not in set '$ok_list' -->";
					}
				elsif ($$p_visited{$basefile}) {
					$return_text .= "<!-- xParseTemplate: loop avoidance: already parsed file '$basefile' somewhere in my ancestor tree -->";
					}
				else {
					$return_text .= &ParseTemplate($incfile, $start_folder, $p_replace, $p_cache, $p_visited );
					}
				}
			$text = $end;
			}
		$return_text .= $text;
		delete $$p_visited{$basename} if ($basename);
		last Err;
		}
	continue {
		$return_text .= "<p><b>Error:</b> $err.</p>\n";
		}
	return $return_text;
	}


=item Trim

Usage:

	my $word = &Trim("  word  \t\n");

Strips whitespace and line breaks from the beginning and end of the argument.

Dependencies:

	Called by: fs_path
	Called by: handle_error
	Called by: load_system_settings

	Global: none

	Dependency: none

=cut

sub Trim {
	local $_ = defined($_[0]) ? $_[0] : '';
	s!^[\r\n\s]+!!o;
	s![\r\n\s]+$!!o;
	return $_;
	}


=item url_encode

Usage:
	my $str_url = &url_encode($str);

Formats strings consistent with RFC 1945 by rewriting metacharacters in their
%HH format.

Dependencies:

	Called by: save_system_settings

	Global: none

	Dependency: none

=cut

sub url_encode {
	local $_ = defined($_[0]) ? $_[0] : '';
	s!([^a-zA-Z0-9_.-])!uc(sprintf("%%%02x", ord($1)))!eg;
	return $_;
	}


sub url_decode {
	local $_ = defined($_[0]) ? $_[0] : '';
	tr!+! !;
	s!\%([a-fA-F0-9][a-fA-F0-9])!pack('C', hex($1))!eg;
	return $_;
	}

sub he {
	my @out = @_;
	local $_;
	foreach (@out) {
		$_ = '' if (not defined($_));
		s!\&!\&amp;!g;
		s!\>!\&gt;!g;
		s!\<!\&lt;!g;
		s!\"!\&quot;!g;
		}
	if ((wantarray) or ($#out > 0)) {
		return @out;
		}
	else {
		return $out[0];
		}
	}


=item WebFormL

Usage:
	&WebFormL( \%FORM );

Returns a by-reference hash of all name-value pairs submitted to the CGI script.

updated: 8/21/2001

Dependencies:

	Called by: ag_init

	Global: none

	Dependency: query_env - 4
	Dependency: url_decode - 2

	Required library: ../2.0.0.0002/files/guardian/ag-shared.txt

=cut

sub WebFormL {
	my ($p_hash) = @_;
	my @Pairs = ();
	if ('POST' eq &query_env('REQUEST_METHOD')) {
		my $buffer = '';
		my $len = &query_env('CONTENT_LENGTH',0);
		read(STDIN, $buffer, $len);
		@Pairs = split(m!\&!, $buffer);
		}
	elsif (&query_env('QUERY_STRING')) {
		@Pairs = split(m!\&!, &query_env('QUERY_STRING'));
		}
	else {
		@Pairs = @ARGV;
		}
	local $_;
	foreach (@Pairs) {
		next unless (m!^(.*?)=(.*)$!s);
		my ($name, $value) = (&url_decode($1), &url_decode($2));
		if ($$p_hash{$name}) {
			$$p_hash{$name} .= ",$value";
			}
		else {
			$$p_hash{$name} = $value;
			}
		}
	#changed 2001-11-30
	foreach (keys %$p_hash) {
		next unless (m!^(.*)_udav$!);
		next if (defined($$p_hash{$1}));
		$$p_hash{$1} = $$p_hash{$_};
		}
	}


sub ReadFile {
	my ($file) = @_;
	my $text = '';
	my $err_msg = '';
	Err: {
		local $_;
		unless (open(FILE, "<$file")) {
			$err_msg = "unable to read file '$file' - $!";
			next Err;
			}
		unless (binmode(FILE)) {
			$err_msg = "unable to set binmode on file '$file' - $!";
			next Err;
			}
		while (defined($_ = <FILE>)) {
			$text .= $_;
			}
		close(FILE);
		}
	return ($err_msg, $text);
	}

sub WriteFile {
	my ($file, $text) = @_;
	my $err_msg = '';
	Err: {
		unless (defined($file)) {
			$err_msg = "invalid argument - 'file' parameter not defined";
			next Err;
			}
		unless (defined($text)) {
			$err_msg = "invalid argument - 'text' parameter not defined";
			next Err;
			}
		unless (open(FILE, ">$file")) {
			$err_msg = "unable to write to file '$file' - $!";
			next Err;
			}
		unless (binmode(FILE)) {
			$err_msg = "unable to set binmode on file '$file' - $!";
			next Err;
			}
		print FILE $text;
		close(FILE);
		}
	return $err_msg;
	}


=item SendMailEx

Usage:

	my $message = <<"EOM";

Hi there Bob!

How has life been treating you?

Regards,
Joe

EOM

	my ($err_msg, $trace) = &SendMailEx(
		'to'         => 'user@host.com',
		'to name'    => 'Bob User',     # *
		'from'       => 'me@host.com',
		'from name'  => 'Sally User',   # *
		'subject'    => 'Hi Sally',     # *
		'message'    => $message,
		'host'       => 'mail.foo.com', # *
		'port'       => 25,             # *
		'saveto'     => 'e:/saved_msgs',
		'max_saved_messages' => 1000,
		'handler_order' => '12345',
		'always_save' => 1,
		);
	# * optional field

	if ($err_msg) {
		print "<p><b>Error:</b> $err_msg.</p>\n";
		}
	else {
		print "<p><b>Success:</b> sent mail okay.</p>\n";
		}

	print "<p>Here is the trace:</p>\n\n";
	print "<XMP>\n$trace\n</XMP>\n";


xSendMailEx knows of 5 ways to handle a message:

	1. pipe the message to a process, such as /usr/sbin/sendmail or c:/blat.exe, defined with the 'pipeto' parameter
		If using /usr/sbin/sendmail, include the "-t" flag in the pipeto input, i.e.:
		'pipeto' => '/usr/sbin/sendmail -t',
	2. deliver to a known SMTP server, defined using the 'host' paramater
	3. auto-detect SMTP server of recipient; deliver to that server via raw sockets
	4. auto-detect SMTP server of sender; deliver to that server via raw sockets
	5. save the message to a folder, defined with the 'saveto' parameter

The options are listed above in the order of speed and reliability.  Saving the message to a folder is generally just a failover method to prevent the loss of user data - no message will actually be sent.

By default, xSendMailEx will attempt those methods in order.  You can override this with the 'handler_order' parameter, which is a string like "12345" or "54321" or "23".  If parameters 'pipeto', 'host', or 'saveto' aren't defined, this process will skip the handling methods which depend on them.

Dependencies:

	Called by: admin_main
	Called by: send_mail

	Global: @sendmail - 6

	Dependency: sendmail_datetime - 1
	Dependency: sendmail_savefile - 2
	Dependency: sendmail_socket - 3

	Required library: ../2.0.0.0002/files/guardian/ag-shared.txt

=cut

sub SendMailEx {
	my %params = @_;
	my $basename = '';
	my $full_message = '';
	my $trace = '';
	my $err_msg = '';
	Err: {
		local $_;

		# validate inputs:
		if ((not $params{'to name'}) and ($params{'to_name'})) {
			$params{'to name'} = $params{'to_name'};
			}
		if ((not $params{'from name'}) and ($params{'from_name'})) {
			$params{'from name'} = $params{'from_name'};
			}
		if ((not $params{'message'}) and ($params{'body'})) {
			$params{'message'} = $params{'body'};
			}

		foreach ('to', 'from') {
			unless ($params{$_}) {
				$err_msg = "invalid argument: SendMail routine called without required '$_' parameter";
				next Err;
				}
			}
		unless (($params{'pipeto'}) or ($params{'host'})) {
			$err_msg = "invalid argument: SendMail routine requires either a 'pipeto' or a 'host' parameter to define its mail transfer method";
			next Err;
			}

		$params{'port'} = 25 unless ($params{'port'});

		# Use strictly compliant line enders:
		my $CRLF = "\015\012";

		# build the full message:

		$full_message = '';


		if ($params{'raw'}) {
			$full_message = $params{'raw'};
			}
		else {
			for ('to', 'from') {
				if ($params{"$_ name"}) {
					$full_message .= qq!$_: <$params{$_}> "$params{"$_ name"}"$CRLF!;
					}
				else {
					$full_message .= qq!$_: <$params{$_}>$CRLF!;
					}
				}
			my $date = &sendmail_datetime(time());
			$full_message .= "Date: $date$CRLF";
			if ($params{'subject'}) {
				$full_message .= "Subject: $params{'subject'}$CRLF";
				}
			if ($params{'is_html'}) {
				$full_message .= "Content-Type: text/html$CRLF";
				}
			$full_message .= $CRLF;
			$full_message .= $params{'message'};
			}

		# Fix for bare LF

		$full_message =~ s!\012!\015\012!sg;
		$full_message =~ s!\015+!\015!sg;

		# Escape any literal CRLF . CRLF sequences (this is the end-of-message sequence in SMTP)
		$full_message =~ s!\015\012\.\015\012!\015\012\. \015\012!sg;

		# Message has been built - now send it:

		$params{'handler_order'} = '12' unless (defined($params{'handler_order'}));
		TryToSend: foreach (split(m!!, $params{'handler_order'})) {
			next TryToSend unless (m!^\d$!);

			if (($_ == 1) and ($params{'pipeto'})) {
				if (open(PIPE, "|$params{'pipeto'}")) {
					# okay... send it w/ only \n
					my $temp_fm = $full_message;
					$temp_fm =~ s!\015\012!\012!sg;
					print PIPE $temp_fm;
					close(PIPE);
					$trace = $full_message;
					last TryToSend;
					}
				$err_msg = "unable to open pipe '$params{'pipeto'}' - $!";
				next TryToSend;
				}

			if (($_ == 2) and ($params{'host'})) {
				($err_msg, $trace) = &sendmail_socket( $params{'host'}, $params{'port'}, $params{'to'}, $params{'from'}, $full_message );
				next TryToSend if ($err_msg);
				last TryToSend;
				}

			if (($_ == 5) and ($params{'saveto'})) {
				($err_msg,$basename) = &sendmail_savefile( $params{'saveto'}, $params{'max_saved_messages'}, $full_message );
				unless ($err_msg) {
					$trace = $full_message;
					}
				next TryToSend if ($err_msg);
				last TryToSend;
				}
			}
		}
	if ($params{'always_save'}) {
		if ($basename) {
			# well, they've already saved
			}
		else {
			my $x_err_msg = '';
			($x_err_msg, $basename) = &sendmail_savefile( $params{'saveto'}, $params{'max_saved_messages'}, $full_message );
			}
		if (($err_msg) and ($basename)) {
			# there was some error, but there was also a successful save to file sometime. log it:
			if (open(ERR, ">$basename.err.txt")) {
				binmode(ERR);
				print ERR "Error: $err_msg.";
				close(ERR);
				}
			}
		}
	return ($err_msg, $trace);
	}


=item sendmail_savefile



Dependencies:

	Called by: SendMailEx

	Global: none

	Dependency: none

=cut

sub sendmail_savefile {
	my ($saveto,$max_saved_messages,$full_message) = @_;
	my $basename = '';
	my $err_msg = '';
	Err: {
		$saveto =~ s!/$!!o;
		unless (-d $saveto) {
			$err_msg = "unable to save to '$saveto' - folder does not exist";
			next Err;
			}
		if ($max_saved_messages) {
			unless (opendir(DIR, $saveto)) {
				$err_msg = "unable to verify message count";
				next Err;
				}
			my @files = readdir(DIR);
			closedir(DIR);
			if ($#files > $max_saved_messages) {
				$err_msg = "not saving message to folder - already $#files file in folder, and max_saved_messges is $max_saved_messages";
				next Err;
				}
			}

		my $stime = time();
		for (1..10000) {
			next if (-e ($saveto . '/' . $stime . '_' . $_ . '.txt'));
			$basename = $saveto . '/' . $stime . '_' . $_;
			last;
			}
		unless ($basename) {
			$err_msg = "unable to find open filename - cannot save message";
			next Err;
			}
		if (open(FILE, ">$basename.txt")) {
			binmode(FILE);
			print FILE $full_message;
			close(FILE);
			}
		else {
			$err_msg = "unable to write to file '$basename.txt' - $!";
			next Err;
			}
		}
	$basename = '' if ($err_msg);
	return ($err_msg, $basename);
	}


=item sendmail_socket

Attempts to send an email message through the specified SMTP gateway.

Returns $err_msg if something goes wrong.  Returns $trace of all socket activity regardless.

Dependencies:

	Called by: SendMailEx

	Global: none

	Dependency: leansock - 1

	Required library: ../2.0.0.0002/files/guardian/ag-shared.txt

=cut

sub sendmail_socket {
	my ($host,$port,$to,$from,$raw) = @_;
	my $is_open = 0;
	my $trace = '';
	my $err_msg = '';
	Err: {
		# connect to the SMTP server
		my ($PF,$SS) = ();
		($err_msg,$PF,$SS) = &leansock($host,$port,\*MAIL);
		next Err if ($err_msg);
		$is_open = 1;
		my @commands = (
			[ 'Welcome',
				220, 0, '',
				],
			[ 'HELO',
				250, 1, "HELO $host",
				],
			[ 'Mail From',
				250, 1, "MAIL FROM:<$from>",
				],
			[ 'Recipient/To',
				250, 1, "RCPT TO:<$to>",
				],
			[ 'Data Initialize',
				354, 1, "DATA",
				],
			[ 'Data Transfer',
				250, 1, "$raw\015\012.\015\012",
				],
			);
		my $i = 0;
		for ($i = 0; $i <= $#commands; $i++) {
			my ($expect_code, $sendrecv, $send_data) = ($commands[$i][1], $commands[$i][2], $commands[$i][3]);
			if ($sendrecv) {
				$send_data .= "\015\012";
				my $data_len = length($send_data);
				my $send_len = send(*MAIL, $send_data, 0);
				unless (defined($send_len)) {
					$err_msg = "error while sending data to SMTP server - $! - $^E";
					next Err;
					}
				if ($send_len != $data_len) {
					$err_msg = "error while sending data to SMTP server; sent only $send_len of $data_len total bytes of data - $! - $^E";
					next Err;
					}
				$trace .= $send_data;
				}
			my $response_code = '';
			my $response_text = '';
			local $_;
			while (defined($_ = readline(*MAIL))) {
				$response_text .= $_;
				$trace .= $_;
				s!(\r|\n|\015|\012)!!g;#correct for MacPerl
				if ((m!^(\d\d\d)\-!) and ($1 ne '000')) {
					$response_code = $1 unless ($response_code);
					}
				elsif (m!^(\d\d\d)\r?(\s|$)!) {
					$response_code = $1 unless ($response_code);
					last;
					}
				else {
					$err_msg = "SMTP server '$host:$port' did not respond properly to the '$commands[$i][0]' command; receive server response not beginning with 3-digit number; full text: '$response_text'";
					next Err;
					}
				}
			unless ($response_code =~ m!$expect_code!) {
				$err_msg = "SMTP server '$host:$port' did not respond properly to the '$commands[$i][0]' command; expected '$expect_code' response, received '$response_code'; full text: '$response_text'";
				next Err;
				}
			}
		}
	close(*MAIL) if ($is_open);
	return ($err_msg, $trace);
	}


=item leansock

($$$$$)

Usage:
	($err_msg,$PF,$SS) = &leansock($host,$port,\*GLOBFILE,$PF,$SS);

Attempts to create and connect an unbuffered socket to $host:$port, referenced by *GLOBFILE.

Optional parameter $sock_cache_val contains cached values of getprotobyname('tcp') and PF_INET() and SOCK_STREAM().  If present, the system will forgo calling 'use Socket'.

Does not call getservbyname() because protocol is not generally know.  Expects explicit port; if you want to be psycho and ask an api for the port number, do so on your own before calling.

During benchmarks on Win2000 2x550MHz, basic Perl loop w/ 10^4 iterations of simple string assignment executed in about 2.39 seconds.  With 1 iteration, took 1.65 seconds.  With a call to "use Socket" followed by 10^4 iterations, took 2.88 seconds.  Suggests that basic Perl interpreter initialization cost of 1.65 seconds with additional 0.49 second when "use Socket" called (+33%).  For systems where initial read from text data file is pre-requisite anyway, may pay off to keep a short-term cache of static return values for Socket functions.

Dependencies:

	Called by: sendmail_socket

	Global: none

	Dependency: none

=cut

sub leansock {
	my ($host,$port,$p_socket,$PF,$SS) = @_;
	my $err_msg = '';
	Err: {
		my $addr = (gethostbyname($host))[4];
		unless ($addr) {
			$err_msg = "unable to resolve hostname '$host' to IP address - $! - $^E";
			next Err;
			}
		unless (($PF) and ($SS)) {
			undef($@);
			eval 'use Socket;';
			if ($@) {
				# yuck...
				undef($@);
				($PF, $SS) = (6, 1);
				}
			else {
				($PF, $SS) = (PF_INET(), SOCK_STREAM());
				}
			}
		unless (socket($$p_socket, $PF, $SS, scalar getprotobyname('tcp'))) {
			$err_msg = "unable to create socket - $! - $^E";
			next Err;
			}
		unless (connect($$p_socket, pack('S n a4 x8', $PF, $port, $addr))) {
			$err_msg = "unable to connect to host '$host:$port' - $! - $^E";
			close($$p_socket);
			next Err;
			}
		unless (binmode($$p_socket)) {
			$err_msg = "unable to set binmode on socket - $!";
			close($$p_socket);
			next Err;
			}
		my $h = select($$p_socket);
		$| = 1;
		select($h);
		}
	return ($err_msg,$PF,$SS);
	}




=item sendmail_datetime

Usage:
	$time_str = &sendmail_datetime($time_int);

Dependencies:

	Called by: SendMailEx

	Global: @str - 2

	Dependency: none

=cut

sub sendmail_datetime {
	local $_;
	my ($time_int) = @_;
	my ($sec, $min, $milhour, $day, $month_index, $year, $weekday_index) = gmtime($time_int);
	$year += 1900;
	my $relhour = (($milhour - 1) % 12) + 1;
	my $month = $month_index + 1;
	foreach ($milhour, $relhour, $min, $sec, $month, $day) {
		$_ = "0$_" if (1 == length($_));
		}
	my @MonthNames = ('January', 'February', 'March', 'April', 'May', 'June', 'July', 'August', 'September', 'October', 'November', 'December');
	my @WeekNames = ('Sunday', 'Monday', 'Tuesday', 'Wednesday', 'Thursday', 'Friday', 'Saturday');
	my $full_weekday = $WeekNames[$weekday_index];
	my $short_weekday = substr($full_weekday, 0, 3);
	my $full_monthname = $MonthNames[$month_index];
	my $short_monthname = substr($full_monthname, 0, 3);
	return "$short_weekday, $day $short_monthname $year $milhour:$min:$sec -0000";
	}


=item FormatDateTime



Dependencies:

	Called by: BuildMessage
	Called by: log_error

	Global: @str - 15

	Dependency: none

=cut

sub FormatDateTime {
	my ($time, $format_type, $b_format_as_gmt) = @_;
	$format_type = 0 unless ($format_type);
	$format_type = 11 if ($format_type eq 'smtp');
	$format_type = 15 if ($format_type eq 'http');
	my $date_str = '';

	$b_format_as_gmt = 1 if (($format_type == 11) or ($format_type == 15)); # force GMT for SMTP-formatted dates

	$time = 0 unless ($time); # force integer

	if ($format_type == 13) {

		if ($b_format_as_gmt) {
			$date_str = scalar gmtime( $time );
			}
		else {
			$date_str = scalar localtime( $time );
			}
		}
	else {

		my ($sec, $min, $milhour, $day, $month_index, $year, $weekday_index) = ($b_format_as_gmt) ? gmtime( $time ) : localtime( $time );

		$year += 1900;

		my $ampm = ( $milhour >= 12 ) ? 'PM' : 'AM';
		my $relhour = (($milhour - 1) % 12) + 1;
		my $month = $month_index + 1;

		# pad with leading zero:
		local $_;
		foreach ($milhour, $relhour, $min, $sec, $month, $day) {
			$_ = "0$_" if (1 == length($_));
			}

		my @MonthNames = ('January', 'February', 'March', 'April', 'May', 'June', 'July', 'August', 'September', 'October', 'November', 'December');
		my @WeekNames = ('Sunday', 'Monday', 'Tuesday', 'Wednesday', 'Thursday', 'Friday', 'Saturday');

		my $full_weekday = $WeekNames[$weekday_index];
		my $short_weekday = substr($full_weekday, 0, 3);

		my $full_monthname = $MonthNames[$month_index];
		my $short_monthname = substr($full_monthname, 0, 3);

		if ($format_type == 0) {
			$date_str = "$month/$day/$year $relhour:$min:$sec $ampm";
			}
		elsif ($format_type == 1) {
			$date_str = "$full_weekday, $full_monthname $day, $year";
			}
		elsif ($format_type == 2) {
			$date_str = "$month/$day/$year";
			}
		elsif ($format_type == 3) {
			$date_str = "$relhour:$min:$sec $ampm";
			}
		elsif ($format_type == 4) {
			$date_str = "$milhour:$min";
			}
		elsif ($format_type == 10) {
			$date_str = "$short_weekday $month/$day/$year $relhour:$min:$sec $ampm";
			}
		elsif ($format_type == 11) {
			$date_str = "$short_weekday, $day $short_monthname $year $milhour:$min:$sec -0000";
			}
		elsif ($format_type == 12) {
			$date_str = "$year-$month-$day $milhour:$min:$sec";
			}
		elsif ($format_type == 14) {
			$date_str = "$month/$day/$year $milhour:$min";
			}
		elsif ($format_type == 15) {
			$date_str = "$short_weekday, $day $short_monthname $year $milhour:$min:$sec GMT";
			}
		}

	unless ($date_str) {
		if ($format_type !~ m!^\d+$!) {
			$date_str = "invalid argument to FormatDateTime(); second parameter '" . &he($format_type) . "' not numeric";
			}
		elsif (($format_type > 15)) {
			$date_str = "invalid argument to FormatDateTime(); second parameter format_type must be integer less than 15; received $format_type";
			}
		}


	return $date_str;
	}





sub regkey_validate {
	my $p_decode = sub {
		local $_;
		my $code = defined($_[0]) ? $_[0] : '';
		my %map = ();
		my $i = 0;
		foreach (48..57,65..90,97..122) {
			$map{chr($_)} = $i % 16;
			$i++;
			}
		$code =~ s!\s|\r|\n|\015|\012!!sg;
		my $text = '';
		my $frag = '';
		$i = 0;
		while ($frag = substr($code, $i, 2)) {
			$i += 2;
			my $chn = 16 * $map{substr($frag,0,1)};
			$chn += $map{substr($frag,1,1)};
			my $ch = chr($chn);
			$text .= $ch;
			}
		$text = unpack('u',$text);
		return $text;
		};
	local $_;
	my $code = defined($_[0]) ? $_[0] : '';
	return 0 unless ($code);
	my $is_valid = 0;
	$code =~ s!BEGIN LICENSE!!sg;
	$code =~ s!END LICENSE!!sg;
	$code =~ s!\s*\n!\n!sg;
	if ($code =~ m!^\s*(.*)\s*\-\s*(.*?)\s*$!s) {
		my ($pub, $pri) = ($1, $2);
		$pri = &$p_decode($pri);
		return 0 unless ($pri =~ s!Uniq: \d+!!sg);
		return 0 unless ($pri =~ s!Prod: Guardian!!sg);
		$pri =~ s!\r|\n!!sg;
		$pub =~ s!\r|\n!!sg;
		if (&Trim($pub) eq &Trim($pri)) {
			$is_valid = 1;
			}
		}
	return $is_valid;
	};



sub force_CRLF {
	my ($p_text) = @_;
	$p_text =~ s!\015\012!\012!sg;
	$p_text =~ s!\015!\012!sg;
	$p_text =~ s!\012!\015\012!sg;
	}




sub pstr {
	local $_ = $str[$_[0]];
	my $x = 0;
	foreach $x (1..((scalar @_) - 1)) {
		my $c = (s!\$s$x!$_[$x]!g);
		#&Assert($c != 0);
		}
	#&Assert( $_ !~ m!\$s\d! );
	return $_;
	}





sub ppstr {
	local $_ = $str[$_[0]];
	#&Assert(defined($_));
	my $x = 0;
	foreach $x (1..((scalar @_) - 1)) {
		#&Assert(defined($_[$x]));
		my $c = (s!\$s$x!$_[$x]!g);
		#&Assert($c != 0);
		}
	#&Assert( $_ !~ m!\$s\d! );
	print;
	}





sub pppstr {
	local $_ = $str[$_[0]];
	my $x = 0;
	foreach $x (1..((scalar @_) - 1)) {
		my $c = (s!\$s$x!$_[$x]!g);
		#&Assert($c != 0);
		}
	#&Assert( $_ !~ m!\$s\d! );

	if ($const{'is_cmd'}) {
		print "\n$_\n";
		}
	else {
		print "<p>" . $_ . "</p>\n";
		}
	}


sub html_decode {
	local $_ = defined($_[0]) ? $_[0] : '';
	s!\&gt;!\>!g;
	s!\&lt;!\<!g;
	s!\&amp;!\&!g;
	s!\&quot;!\"!g;
	return $_;
	}






1;