#!/usr/local/bin/perl5 # -*- Mode: Perl -*- # # lib5-cgi.pl A perl library of CGI functions. # # copyright 1995 David Walker # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # You may also redistribute it and/or modify it under # the terms of the Artistic License under which Perl is distributed. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # # Ideas used in this program came from the cgi-lib.pl perl library # by Steven Brenner's and # "Managing Internet Information Services" by Lui, Peek, Jones, # Buus & Nye. Published by O'Reilly and Associates, Inc. # # Sat May 6 11:36:18 GMT-0700 1995 version 1.0.b # Fri Oct 20 12:30:04 1995 checked syntax for Perl 5, dw # Modified by Erik C. Thauvin (erik@skytouch.com) # Sun Apr 27 01:56:36 PDT 1997 # # Added FILEPATH_INFO support. package lib_cgi ; sub print_doc_header { local($content_type) = @_ ; $* = 1 ; # why do we need this? if (defined($content_type)) { print "Content-type: $content_type\n\n" ; } else { print "Content-type: text/html\n\n" ; } } sub print_page_header { local($heading) = @_ ; print "\n\n" ; print "$heading\n" ; print "\n" ; print "

$heading

\n" ; } sub print_page_trailer { print "\n\n" ; } sub error_message { local($message) = @_ ; &print_page_header("ERROR") ; print "\n

$message

\n" ; print "

\n" ; &print_page_trailer ; exit 0 ; } sub get_args_post { local($buffer) ; # $CONTENT_TYPE is only set for POST calls. &error_message('This script can only process form results.') unless ($ENV{'CONTENT_TYPE'} eq 'application/x-www-form-urlencoded') ; read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'}) ; # Split the name-value pairs @pairs = split(/&/, $buffer) ; foreach $pair (@pairs) { ($name, $value) = split(/=/, $pair) ; $value =~ tr/+/ / ; $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg ; $main::FORM{$name} = $value ; } } sub get_args_get { local($path_info) = $ENV{'FILEPATH_INFO'} || $ENV{'PATH_INFO'}; @args = split('/', $path_info) ; foreach (@args) { tr/+/ / ; ($name, $value) = split(/=/, $_) ; $main'FORM{$name} = $value ; } } sub get_args { if ($ENV{'REQUEST_METHOD'} eq 'POST') { &get_args_post ; } elsif ($ENV{'REQUEST_METHOD'} eq 'GET') { &get_args_get ; } else { &error_message("Illegal Request Method $ENV{REQUEST_METHOD}, " . "This script must be referenced using METHOD GET or POST.") ; } } # Look for evil characters sub check_for_evil_characters { # $my_character_set must be enclosed in single (') quotes. local($str,$variable_name,$my_character_set) = @_ ; if (defined($my_character_set)) { $ok_character_set = $my_character_set ; } else { $ok_character_set = '[a-zA-Z0-9_\-+. \t\/@%]' ; } if ($str !~ /^$ok_character_set+$/) { &evil_characters($variable_name,$ok_character_set) ; } $str ; # return validated string } sub evil_characters { local($variable_name,$ok_character_set) = @_ ; &error_message("The $variable_name you entered contains illegal " . "characters, legal characters are $ok_character_set. " . "Please back up and correct, then resubmit.") ; } 1 ;