source: branches/stable/cgi-bin/CommonWeb.pm@ 534

# ipdb/cgi-bin/CommonWeb.pm
###
# SVN revision info
# $Date: 2011-11-15 23:08:14 +0000 (Tue, 15 Nov 2011) $
# SVN revision $Rev: 507 $
# Last update by $Author: kdeugau $
###

package CommonWeb;

use strict;             
use warnings;
use Exporter;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);

$VERSION     = 1.00;
@ISA         = qw(Exporter);
@EXPORT_OK      = qw(&parse_post &printFooter &printHeader &printError &printAndExit &desanitize &cleanInput &desanitize);

@EXPORT      = (); #export nothing by default
%EXPORT_TAGS = ( ALL => [qw( &parse_post &printFooter &printHeader &printError
                                &printAndExit &desanitize &cleanInput )],
                 lean    => [qw( &parse_post &printFooter &printHeader &printError
                                &printAndExit &cleanInput )]
                );

sub parse_post {
  my $buffer;
  if ($ENV{'REQUEST_METHOD'} eq "GET") {
    $buffer=$ENV{'QUERY_STRING'}
  } elsif ($ENV{'REQUEST_METHOD'} eq 'POST' && $ENV{'CONTENT_TYPE'} eq "application/x-www-form-urlencoded") {
    read(STDIN, $buffer, $ENV{CONTENT_LENGTH});
  } else {
    $buffer = $ENV{'QUERY_STRING'};
    $buffer || read(STDIN, $buffer, $ENV{CONTENT_LENGTH});
  }
  my @pairs = split(/&/, $buffer);
  my %webvarLocal;
  foreach my $pair (@pairs) {
    my ($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;
    $webvarLocal{$name} = $value;
  }
  return %webvarLocal;
}


sub printHeader {
  my $title = shift;
  my $webpath = shift;
  print "Content-type: text/html\n\n";
# This doesn't work well.  Must investigate.
#  my $realm = shift;
#  print qq(WWW-Authenticate: Basic realm="$realm"\n) if $realm;
  open FILE, "../header.inc"
        or carp $!;
  my $html = join('',<FILE>);
  close FILE;

  $html =~ s/\$\$TITLE\$\$/$title/;
  $html =~ s/\$\$WEBPATH\$\$/$webpath/g;
# Necessary for mangling arbitrary bits of the header
  my $i=0;
  while (defined(my $param = shift)) {
    $html =~ s/\$\$EXTRA$i\$\$/$param/g;
    $i++;
  }
  print $html;
}

sub printFooter
{
  open FILE, "../footer.inc"
        or croak $!;
  while (<FILE>) 
  {
    print;
  }
  close FILE;
}

sub printError($)
{
        my $errStr = $_[0];
        print qq(
        <center><p class="regular"> $errStr </p>
        <input type="button" value="Back" onclick="history.go(-1)">
        </center>
        );
}

sub printAndExit($)
{
        my $errStr = $_[0];
        print qq(
        <center><p class="regular"> $errStr </p>
        <input type="button" value="Back" onclick="history.go(-1)">
        </center>
        );
        printFooter();
        exit(0);
}

# needs a reference to the webvar hash.
# takes out backticks and single quotes
sub cleanInput($)
{
        my $hashRef = $_[0];

        foreach my $key (keys %$hashRef) 
        {
                $hashRef->{$key} =~ s/`/\\`/g;
                $hashRef->{$key} =~ s/'/\'/g;
        }
}

# undoes clean input.  takes a string as an arg.
sub desanitize($)
{
        my $string = $_[0];
        $string =~ s/\\`/`/g;
        $string =~ s/\\'/'/g;
        return $string;
}

# indicate that the module loaded okay.
1;