#!/usr/bin/perl
#
#
#
#
# 25.11.1998 WE Linux-Download eingebaut
# last update 12.10.1998 kk
#
# getting arguments, must bee at first for correct settings and librarys !
%query = &parse_form;
#
# Required Librariers
# --------------------------------------------------------
eval {
# settings first !
require ("./settings.download");
# einige h„ufig verwendete Funktionen
require ("./dl-lib.pl");
# Konfiguration der Registrierungs-DB
require ("./admin/db.cfg");
# Lesen und Schreiben in Registrierungs-DB
require ("./db-lib.pl");
};
if ($@) { &cgierr ("Error in libraries. Check that they exist, permissions are set correctly and that they compile. Reason: $@"); }
$| = 1; # Flush Output Right Away
eval { &main; }; # Trap any fatal errors so the program hopefully
if ($@) { &cgierr("fatal error: $@"); } # never produces that nasty 500 server error page.
exit; # There are only two exit calls in the script, here and in in &cgierr.
sub main {
$page_is_out = 0;
$param="";
if ($query{'v'}) {
$v=$query{'v'};
if ($v ne "m") { &check_referer; }
$bs=$query{'bs'};
$pro=$query{'pro'};
$param="ok";
if ($v eq "m" || $v eq "reg_ok") {
if ($bs eq "win") {
if ($pro eq "base3") {
# iss-base 3.0
require ("." . $lang_ref . "/dl_iss3-win.pl");
}
else {
# iss-base 4.0
require ("." . $lang_ref . "/dl_iss4-win.pl");
}
}
else {
$bs="lnx";
if ($pro eq "base3") {
# iss-base 3.0
require ("." . $lang_ref . "/dl_iss3-lnx.pl");
}
else {
# iss-base 4.0
require ("." . $lang_ref . "/dl_iss4-lnx.pl");
}
}
}
elsif ($v eq "txt") {
# erst registrieren, dann downloaden
require ("." . $lang_ref . "/reg_hinweis.pl");
}
elsif ($v eq "reg_hin") {
# Registrierungsseite
require ("." . $lang_ref . "/form_download.pl");
}
elsif ($v eq "h") {
# Haftungsseite und echte Links
if ($pro eq "base3" ) {
# iss-base 3.0 z.Z. nur bei Oberberg
$forward_ref = $alt_germany;
}
else {
$forward_ref = "";
}
require ("." . $lang_ref . "/reg_haftung.pl");
}
elsif ($v eq "reg") {
if ($query{'reg_aktion'}) {
$reg_aktion = $query{'reg_aktion'};
if ($reg_aktion eq $submit_ok) {
$email = $query{'email'};
$pruef="ok";
&check_email_addr;
&check_required;
if ($pruef ne "ok") {
&check_registered;
}
if ($pruef eq "ok") {
&db_anmeldung;
&form_mailcode;
$page_is_out = 1;
}
else {
$v="txt";
&html_print_headers;
if ($email_ok eq "notOk") {
&email_err;
}
else {
&fields_err;
}
require ("." . $lang_ref . "/form_download.pl");
}
}
else {
#/*reg_aktion=verwerfen*/;
&form_dl_init;
require ("." . $lang_ref . "/form_download.pl");
} # /* reg_aktion */
} # /* isset $reg_aktion */
}
else {
# nicht aus unserem Skript referenziert
&cgierr("This command is not allowed here !");
}
if ($page_is_out == 0) {
&html_print_headers;
# die oben geladene Seite ausgeben
&html_page_out;
}
}
else {
&cgierr("Command not valid !");
}
}
exit;
sub parse_form {
# --------------------------------------------------------
# Parses the form input and returns a hash with all the name
# value pairs. Removes SSI and any field with "---" as a value
# (as this denotes an empty SELECT field.
my (@pairs, %in);
my ($buffer, $pair, $name, $value);
if ($ENV{'REQUEST_METHOD'} eq 'GET') {
@pairs = split(/&/, $ENV{'QUERY_STRING'});
}
elsif ($ENV{'REQUEST_METHOD'} eq 'POST') {
read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'});
@pairs = split(/&/, $buffer);
}
else {
&cgierr('error in parse_form. reason: unkown request_method.');
}
PAIR: foreach $pair (@pairs) {
($name, $value) = split(/=/, $pair);
$name =~ tr/+/ /;
$name =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
$value =~ tr/+/ /;
$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
$value =~ s///g;
if ($value eq "---") { next PAIR; }
$in{$name} = $value;
}
return %in;
}
sub query_out {
# ---------------------------------------------
# parse give query string and build new query string where locals
# overwrite globals
#
my (@pairs, %in);
my ($mbs,$mv,$mmy_lang,$mpro,$mmirror,$buffer, $pair, $name, $value);
@pairs = split(/&/, $_[0]);
#print $_[0] . "
";
PAIR: foreach $pair (@pairs) {
($name, $value) = split(/=/, $pair);
$in{$name} = $value;
#print $name . "xxx" . $value;
}
if ( $in{'bs'} ) {
$mbs=$in{'bs'};
} else {
$mbs=$bs;
}
if ( $in{'v'} ) {
$mv=$in{'v'};
} else {
$mv=$v;
}
if ( $in{'pro'} ) {
$mpro=$in{'pro'};
} else {
$mpro=$pro;
}
if ( $in{'may_lang'} ) {
$mmay_lang=$in{'may_lang'};
} else {
$mmy_lang=$my_lang;
}
if ( $in{'mirror'} ) {
$mmirror=$in{'mirror'};
} else {
$mmirror=$mirror;
}
print qq?bs=$mbs&my_lang=$mmy_lang&v=$mv&pro=$mpro&mirror=$mmirror;
}
sub check_referer {
# Dont allow users to use download script from other then our site
local($check_referer) = 0;
if ($ENV{'HTTP_REFERER'}) {
foreach $referer (@referers) {
if ($ENV{'HTTP_REFERER'} =~ m|https?://([^/]*)$referer|i) {
$check_referer = 1;
last;
}
}
}
#else {
# $check_referer = 1;
#}
if ($check_referer != 1) { &cgierr('Refering not allowed from this site') }
}
sub cgierr {
# --------------------------------------------------------
# Displays any errors and prints out FORM and ENVIRONMENT
# information. Useful for debugging.
if ($query{'mirror'} eq 'debug') {
if (!$html_headers_printed) {
print "Content-type: text/plain\n\n";
$html_headers_printed = 1;
}
print "\nCGI Error: $!\n";
print "Message: $_[0]\n\n";
print "_________Form Variables __________\n";
foreach $key (sort keys %in) {
print "$key: \t$in{$key}\n";
}
print "\n_________Environment Variables__________\n";
foreach $env (sort keys %ENV) {
print "$env: \t$ENV{$env}\n";
}
print "\n";
}
else
{
if (!$html_headers_printed) {
print "Content-type: text/html\n\n";
$html_headers_printed = 1;
}
print qq
Server Error
Server error
The reason is:
$_[0]
Please send me an e-mail webmaster\@halstenbach.de
;
}
exit;
}