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($_ = )) { 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 "Document moved: $nexturl"; $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 "Document moved: $nexturl"; $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 "

Error: no filters applied to this request.

\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' => '
Guardian v' . $VERSION . ' is © 2003 by Fluid Dynamics Software
', '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($_ = )) { 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 "\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 = ®key_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 "

Assertion Error:
Package: $package
File: $file
Line: $line


"; } =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 = ''; 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 .= ""; # 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 .= ""; } elsif ($$p_visited{$basefile}) { $return_text .= ""; } 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 .= "

Error: $err.

\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!\&!\&!g; s!\>!\>!g; s!\ 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($_ = )) { $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 "

Error: $err_msg.

\n"; } else { print "

Success: sent mail okay.

\n"; } print "

Here is the trace:

\n\n"; print "\n$trace\n\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 "

" . $_ . "

\n"; } } sub html_decode { local $_ = defined($_[0]) ? $_[0] : ''; s!\>!\>!g; s!\<!\