# ==================================================================== # @(#) Perl CGI related functions module # ==================================================================== # $What: cgi-lib.pm$ # # Written by David Boldt 30 Aug 2000 # # $Log: cgi_lib.pm,v $ # Revision 1.1 2006/07/27 21:42:58 dboldt # Initial revision # # -------------------------------------------------------------------- package cgi_lib; ($ME = $0) =~ s#^.*/##; $SENDMAIL = '/usr/lib/sendmail'; # -------------------------------------------------------------------- # Print content type # -------------------------------------------------------------------- sub http_header () { print "Content-type: text/html; charset=iso-8859-1\n\n"; } # -------------------------------------------------------------------- # This subroutine takes a text string and used it as the # and first level header of the out-going html document # An optional argument is accepted for other HEAD information # -------------------------------------------------------------------- sub html_header ($;$) { my ($document_title,$header_stuff) = @_; &http_header(); print "<html>\n"; print " <head>\n"; print " <title>$document_title\n"; print "$header_stuff"; print " \n\n"; print " \n"; print "

$document_title

\n"; } # -------------------------------------------------------------------- # This subroutine finishes off the html stream # -------------------------------------------------------------------- sub html_trailer () { print " \n"; print "\n"; } # -------------------------------------------------------------------- # Convert radio button to Yes or No # -------------------------------------------------------------------- sub YorN ($) { my ($setting) = @_; if ($setting) { return 'Yes'; } else { return 'No'; } } # -------------------------------------------------------------------- # Forward user to existing URL, and exit # -------------------------------------------------------------------- sub refer_url ($) { my ($url) = @_; print "Location: $url\n\n"; exit; } # -------------------------------------------------------------------- # send mail message to specified email ids # -------------------------------------------------------------------- sub mail_message () { my ($subject, $to, $body, $from, $cc) = @_; local (*MESSAGE); return 1 unless $to; open(MESSAGE, "| $SENDMAIL -t"); # Create mail headers print MESSAGE "To: $to\n"; print MESSAGE "Cc: $cc\n" if ($cc);; print MESSAGE "From: $from\n" if ($from); print MESSAGE "Subject: $subject\n\n"; # Write the message body print MESSAGE $body; close(MESSAGE); } # -------------------------------------------------------------------- # Output missing-field error page and exit # -------------------------------------------------------------------- sub missing_mandatory_field (@) { my (@list) = @_; # If no list of errors, just return return unless (@list); &html_header("Incomplete Form"); print <<"__HTML__"; # print everything up till a given token

The form you just submitted is missing some important information. Please use the Back button to return to the form to add the following information:

__HTML__ print "

\n";
    foreach $_ (@list) {
	print "   $_\n";
    }
    print "

\n"; &html_trailer(); exit; } # -------------------------------------------------------------------- # Output display error page and quit # -------------------------------------------------------------------- sub web_exit ($;$) { my ($title,$text) = @_; if (! $text) { if (! $title) { $title = 'WebServer Difficulty'; } else { $text = $title; } $text = "

A processing error has occured that keeps us from displaying the requested information. Email has been sent to the my WebMaster notifying them of this problem. Our apologies for this inconvenience, please try this page again soon.

\n"; } &html_header($title); print $text; &html_trailer(); exit; } # -------------------------------------------------------------------- # Take a filename # Open a file to append after locking # -------------------------------------------------------------------- sub open_file_with_lock (\*$) { use Fcntl ':flock'; # import LOCK_* constants my ($fh, $filename) = @_; my ($file_op); # overwrite or append $file_op = '>>' if ($filename =~ s/^>>//); $file_op = '>' if ($filename =~ s/^>//); $file_op = '>>' unless $file_op; # default is open in append mode # create file if it does not already exist system("touch $filename") unless -f $filename; chmod 0664, $filename; open($fh,"${file_op}$filename") || return undef; # lock the file flock($filename,LOCK_EX); # and, in case someone appended while we were waiting... seek($fh, 0, 2); return $fh; } # -------------------------------------------------------------------- # Take a filename and file handle, # unlock (remove associated hard link) and close the file # return nothing # -------------------------------------------------------------------- sub close_file_with_lock (\*$) { use Fcntl ':flock'; # import LOCK_* constants my ($fh,$filename) = @_; flock($filename,LOCK_UN); close($fh); } # -------------------------------------------------------------------- # Load associative array FORM with values # creates global variable: @FORM_order # returns a hash of variables and values # -------------------------------------------------------------------- sub load_FORM () { my ($buffer); my (%FORM); my (@pairs); my ($name, $value); if ($ENV{'REQUEST_METHOD'} eq 'POST' || $ENV{'REQUEST_METHOD'} eq 'post') { # method POST specifies form values will come from stdin read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'}); } elsif ($ENV{'REQUEST_METHOD'} eq 'GET' || $ENV{'REQUEST_METHOD'} eq 'get') { # method POST specifies form values will come from var 'QUERY_STRING' $buffer = $ENV{'QUERY_STRING'}; } else { $buffer = "@ARGV"; # makes debugging easier } if ($buffer && ($buffer !~ /=/)) { $buffer = "query=$buffer"; } # split the name-value pairs on '&' @pairs = split(/&/, $buffer); foreach $pair (@pairs) { # Convert plus's to spaces $pair =~ tr/+/ /; # Split into name and value on first '=' ($name, $value) = split(/=/, $pair, 2); # Convert %XX from hex numbers to alphanumeric $name =~ s/%(..)/pack("c",hex($1))/ge; $value =~ s/%(..)/pack("c",hex($1))/ge; # Associate key and value $FORM{$name} .= "\0" if defined($FORM{$name}); # \0 is the multiple separator $FORM{$name} .= $value; push(@FORM_order,$name) unless grep { $_ eq $name } @FORM_order; } # Now all the form variables are in the %FORM associative array return %FORM; } # -------------------------------------------------------------------- # make sure the form has been completely filled out # -------------------------------------------------------------------- sub check_mandatory_fields (**) { local (*form, *mandatory) = @_; my ($key); my (@check_box_list,$mandatory_item); my (@missing_fields); my ($form_name); foreach $key (keys %mandatory) { if (substr($key, -2, 2) eq '.*') { push(@check_box_list, $key); } else { unless ($form{$key}) { push(@missing_fields, $key); } } } foreach $mandatory_item (@check_box_list) { next unless ($key); $found = 0; foreach $key (keys %form) { if ($key =~ /^$mandatory_item/i) { $found = 1; last; } } push(@missing_fields, $key) if (! $found); } #print join("\n", @missing_fields), "\n"; $form_name = $FORM_NAME || "form"; if (@missing_fields) { &html_header("Incomplete Information Provided"); print "

You are missing required information in these fields:\n"; print "

\n"; foreach $key (@missing_fields) { print "

$mandatory{$key}
\n"; } print "

\n"; print "

Please return to the $form_name using the "Back""; print " button to provide this information.\n"; &html_trailer(); exit; } } # -------------------------------------------------------------------- # run regular expression against variable, and return untainted value # -------------------------------------------------------------------- sub sanitize ($;$) { my ($text, $ok_chars) = @_; my ($goodtext); $ok_chars ||= '-a-zA-Z0-9_.@'; # default safe characters ($goodtext = $text) =~ s/[^$ok_chars]/_/g; $goodtext =~ /(.*)/; # create untainted variable, $1 return $1; }