#!/usr/bin/perl
# Copyright 03/12/99 Sun Microsystems, Inc. All Rights Reserved.
# "@(#)xcgi.pl	1.4 99/03/12 Sun Microsystems"


# convert this from stand-alone program to one that can be
# "required" by other perl scripts

# xcgi - Perl replacement for C based uncgi and envcgi
# Writes CGI post parameters out to environment variables with WWW_ prefix


sub dontNeedAnymore {
# Change PATH_TRANSLATED env var. to correctly point at cgi
$ptrans = $ENV{'PATH_TRANSLATED'};
#$ptrans =~ s/docs/cgi-bin/;
$ptrans =~ s#public#public/netfile#;
$ENV{'PATH_TRANSLATED'} = $ptrans;
$pre = "WWW_";

# Extract cgi path from PATH_TRANSLATED for dictionary read
$inpath = substr($ptrans, 0, (length($ptrans)-length($ENV{'PATH_INFO'})+1));

# Open the dictionary and read it in
$wordfile = ".all";
undef($words);
if (open(WORDS, $inpath.$wordfile)) {
    @words = <WORDS>;
    $words = join("", @words);
    close(WORDS);
    study($words);
}
}

sub doRequestEnv {

$pre = "WWW_";
# If it's a form POST, read in the post variables for processing
# Step through params and write them out to the environment with prefix
if ($ENV{'REQUEST_METHOD'} =~ /POST/) {
    read(STDIN, $post, $ENV{'CONTENT_LENGTH'});
    %params = &parse_params($post);
    $pre = 'WWW_';
    while (($key, $val) = each(%params)) { 
		$ENV{$pre.$key} = $val;
    }
} elsif ($ENV{'REQUEST_METHOD'} =~ /GET|HEAD/) {
# If it's neither, then we're in deep doodoo. Prints an error if it fails.
} else {
    print "Content-type: text/plain\n\nError: HTTP Data Type error.\n";
    print "Please contact your System Administrator.\n";
    die "HTTP Data type error: $!\n";
}

# If there's a query string, stuff them into the environment
undef($args);
if ($ENV{'QUERY_STRING'}) {
    @query = split('\&', $ENV{'QUERY_STRING'});
    foreach $item (@query) {
		$item =~ s/[\r\n]*$//;            # drop newlines, but might not be there
		while ($item =~ /^.*=.*=/) {      # handle = in values
			$item =~ s/^(.*=.*)=(.*)/$1 _ $2/;
		}
		($key, $val) = split('=', $item); # Split line on =
		$val =~ s/ _ /=/g;
		$ENV{$pre.$key} = $val;	          # Write out to environment
    }
    # also stuff them into the args to the cgi (old style)
    foreach $item (@query) { $args .= "$item "; }
}

}

sub dontNeed2 {
# Run script (with args) and pipe in return to an array. Prints error if fails.
# Script call method is a 'safe' method from WWW Security FAQ
if (!(open(RETURN, "-|") || exec "$ptrans", $args)) {
    print "Content-type: text/plain\n\nError: CGI return error.\n";
    print "Please contact your System Administrator.\n";
    die "CGI Error: $!\n";
}
@input = <RETURN>;

# Do the token replacement using the consolidated dictionary.
if ($words) {
    foreach $line (@input) {
		$line =~ s/_z(\d*)_/&getwords($1,$words)/ge;
		print $line;
    }
} else {
    print (join("", @input),"\n");
}

close(RETURN);

}

# ---------------------------------------------------------------------
# getwords ------------------------------------------------------------
# Search/replaces tokens (_z###_) from text with associated strings
# from replacement file. Strings delimited with ||'s
# Unescape the escaped chars ()?*
sub getwords {
    local($num, $text) = @_;
    local($out);
    $text =~ /_z${num}_ \|([^\|]+)\|/;
    $out = $1;
    $out =~ s/\\([\[\]\{\}\(\)\.\|\*\?\+\\\$\^])/$1/g;
    return $out." ";
}

# cgi-utils -----------------------------------------------------------
sub unescape {
    local($todecode) = @_;
    $todecode =~ tr/+/ /;       # pluses become spaces
    $todecode =~ s/%([0-9A-Ha-h]{2})/pack("c",hex($1))/ge;
    return $todecode;
}

sub escape {
    local($toencode) = @_;
    local($forbidden)=join('',grep($_=pack('c',$_),0x00..0xFF));
    $forbidden=~tr/a-zA-Z0-9_//d;
    $toencode=~s/($forbidden)/sprintf("%%%x",ord($1))/eg;
    return $toencode;
}

sub parse_params {
    local($tosplit) = @_;
    local(@pairs) = split('&',$tosplit);
    local($param,$value,%parameters);
    foreach (@pairs) {
        ($param,$value) = split('=');
        $param = &unescape($param);
        $value = &unescape($value);
        unless ($parameters{$param}) {
            $parameters{$param} = $value;
        } else {
            $parameters{$param} .= "$;$value";
        }
    }
    return %parameters;
}





1;