#
# perl library for cgi scripts - version 1.1j
# published under the GNU General Public License (GPL)
# see the file COPYING for details ..
# should work with perl4 and perl5
#
# (c) rasca gmelch, berlin 1995
# internet: rasca@marie.physik.tu-berlin.de
# fido-net: 2:2410/305.4
#
# function list: --------------
### send_header ($title, $headline)
### send_footer ($footer)
### parse_form ()
### split_it ($string)
### parse_query ()
### parse_stdin ()
### read_stdin ()
### request_method ()
### remote_host ()
### remote_client ()
### remote_agent ()
### send_mail ($to, $from, $subject, $mailtext)
### lock_file ($filename)
### unlock_file ($filename)
### log_it ($string, $filename)
### htmlUmlaut ($string)
### url_ref ()
## configuration part ###############################################
# now in an extern file :)
$pos = rindex ($0, "/");
if ( $pos >= 0 ) {
$base = substr ($0, 0, $pos);
} else {
$base = ".";
}
require "$base/perlwww.cfg";
## end of configuration part ########################################
### send_header ($title, $headline)
# if $headline is ommited the title is used as the string for the headline
#
sub send_header {
local ($title, $headline) = @_;
if ($headline eq "") {
$headline = $title;
}
$headline = &htmlUmlaut ($headline);
print ("Content-Type: text/html\r\n\r\n");
print ("\n\n");
print ("\n\t$title\n\n");
print ("\n");
if ($Lib_lang eq "de") {
print ("$Lib_header_de\n");
} else {
print ("$Lib_header_en\n");
}
print ("$headline
\n
\n");
}
### send_footer ($footer)
# '$footer' is added after the '(c) ..'-stuff
#
sub send_footer {
local ($footer) = @_;
local ($tmp);
print ("
\n\n\n");
if ($Lib_lang eq "de") {
$footer = "$Lib_footer_de\n
\n$footer\n";
} else {
$footer = "$Lib_footer_en\n
\n$footer\n";
}
if (($tmp = &url_ref()) ne "") {
#
# add a "back"-link
#
$footer =~ s/__BACK__/[Back<\/A>]/;
} else {
$footer =~ s/__BACK__//;
}
print ("$footer");
print ("\n\n\n\n");
}
### parse_form ()
#
# use this function to parse the information of a form
# not depending on a GET or POST method
#
sub parse_form {
local (%info);
if (&request_method() eq "POST") {
%info = &parse_stdin();
} else {
%info = &parse_query();
}
return (%info);
}
### split_it ($string)
# split a string, seperated by '&' and '='
# needed from parse_query() and parse_stdin()
#
sub split_it {
local ($key, $value);
local (%query);
foreach (split (/&/, $_[0])) {
($key, $value) = split (/=/);
$value =~ s/\+/ /g;
$value =~ s/%([0-9A-F]{2})/pack ('C', hex ($1))/eig;
$query{$key} = $value;
}
return (%query);
}
### parse_query ()
# returns an assoziative arry of QUERY_STRING
#
sub parse_query {
local (%query);
%query = &split_it ($ENV{'QUERY_STRING'});
if ($query{'lang'} ne "") {
$Lib_lang = $query{'lang'};
}
return (%query);
}
### parse_stdin ()
# read and parse the stdin [method must be 'POST']
#
sub parse_stdin {
local ($data);
local (%vars);
$data = &read_stdin();
%vars = &split_it($data);
if ($vars{'lang'} ne "") {
$Lib_lang = $vars{'lang'};
}
return (%vars);
}
### read_stdin ()
# read 'content-lenght' from stdin
#
sub read_stdin {
local ($stdin);
local ($len);
$len = $ENV{'CONTENT_LENGTH'};
if ($len > 0) {
read (STDIN, $stdin, $len);
} else {
$stdin = "";
}
return ($stdin);
}
### request_method ()
# returns the request method (POST, GET, ..)
#
sub request_method {
if ($ENV{'REQUEST_METHOD'} ne "") {
return ($ENV{'REQUEST_METHOD'});
} else {
return ("");
}
}
### remote_host ()
# returns the remote hostname or - if not set - the IP number
# of the remote host
#
sub remote_host {
local ($host);
if ($ENV{'REMOTE_HOST'} eq "") {
return ($ENV{'REMOTE_ADDR'});
} else {
return ($ENV{'REMOTE_HOST'});
}
}
### remote_client ()
# returns the remote client program
#
sub remote_client {
local ($client);
if ($ENV{'HTTP_USER_AGENT'} ne "") {
($client) = split (/\s+/, $ENV{'HTTP_USER_AGENT'});
} else {
$client = "";
}
return ($client);
}
### remote_agent ()
# returns the remote client program and the additional infos
# in HTTP_USER_AGENT
#
sub remote_agent {
local ($agent);
if ($ENV{'HTTP_USER_AGENT'} ne "") {
$agent = $ENV{'HTTP_USER_AGENT'};
} else {
$agent = "";
}
return ($agent);
}
### send_mail ($to, $from, $subject, $mailtext)
# sends an email to 'to' ..
#
sub send_mail {
local ($to, $from, $subject, $mailtext) = @_;
local ($mail);
if ($to ne "") {
$mail = "Subject: $subject\n";
$mail .= "From: $from\n\n";
$mail .= "$mailtext\n";
open (LIB_PIPE, "| $Lib_MTA $to");
print (LIB_PIPE $mail);
close (LIB_PIPE);
return (1);
} else {
return (0);
}
}
### lock_file ($filename)
# create a lock file, e.g. create "/var/log/foo.log.LCK" if
# the $filename has the value "/var/log/foo.log".
# the function blocks if it can not lock until $try has approached 0,
# it returns '-1' for fatal error, '1' on sucsess and '0' when timed
# out.
#
sub lock_file {
local ($file) = @_;
local ($try) = 50;
local ($pfile, $lfile);
umask (0022);
if ($file eq "") {
return (-1);
}
$pfile = $file . ".$$"; # we need an extra file, $$ makes it unique
$lfile = $file . ".LCK"; # the name of the lock-file
unless (open (LIB_PFILE, ">$pfile")) {
# do we have write permissions?
return (-1);
}
print (LIB_PFILE "$$\n");
close (LIB_PFILE);
while ((-f $lfile) || (!link ($pfile, $lfile))) {
sleep (1);
$try--;
if ($try < 1) {
unlink ($pfile);
return (0);
}
}
return (1);
}
### unlock_file ($filename)
# unlock a locked file
#
sub unlock_file {
local ($file) = @_;
unlink ($file . ".LCK");
unlink ($file . ".$$");
}
### log_it ($string, $filename)
# for logging .., returns '0' when it fails.
#
sub log_it {
local ($str, $file) = @_;
local ($date);
umask (0022);
if ($file ne "") {
if (&lock_file($file) == 1) {
unless (open (LIB_LOG, ">>$file")) {
# do we have write permissions?
return (0);
}
$date = `$Lib_date_prg`; chop $date;
$str = $date . "\t" . $str . "\n";
print (LIB_LOG $str);
close (LIB_LOG);
&unlock_file($file);
return (1);
}
}
return (0);
}
### htmlUmlaut ($string)
# replace üäö etc.. for 7bit-clean HTML files
# input is LATIN-ISO
#
sub htmlUmlaut {
local ($str) = @_;
$str =~ s/ä/ä/g;
$str =~ s/ö/ö/g;
$str =~ s/ü/ü/g;
$str =~ s/Ä/Ä/g;
$str =~ s/Ö/Ö/g;
$str =~ s/Ü/Ü/g;
$str =~ s/ß/ß/g;
return ($str);
}
### url_ref ()
# returns the referred URL
#
# CGI/1.1 does not specify a variable for the referenced document
# from which the cgi program was called, so try different variables
# which are included by different servers and clients (HTTP_*)
#
sub url_ref {
local ($url) = "";
local ($alias);
if ($ENV{'HTTP_REFERER'} ne "") {
$url = $ENV{'HTTP_REFERER'};
} else {
$url = $ENV{'REFERER_URL'};
}
if ($url eq "") {
# still empty .. hmm.. it's a server side include on a NCSA 1.4.2?
# let's try the next common used variable
if ($ENV{'DOCUMENT_URI'} ne "") {
$url="http://$ENV{'SERVER_NAME'}:$ENV{SERVER_PORT}$ENV{'DOCUMENT_URI'}";
} else {
# arghh.. we had no luck :(
return ("");
}
}
foreach $alias (@Lib_aliases) {
if ($url =~ /\/\/$alias\//) {
$url =~ s/\/\/$alias\//\/\/$Lib_hostname\//;
last;
}
}
return ($url);
}