io Programmo 27/IOPROG_27.ISO/SOFT/PERLPAD3.ZIP/PERLPAD3.CAB/Web.ppm

Text File | 1999-02-06 | 10.3 KB | 360 lines

Web Functions
Author: Dion Almaer ([e-mail])
package Web;
require 5.000;
require Exporter;
use FileHandle;

@ISA    = qw(Exporter);
@EXPORT = qw(html DebugHTML ErrorHTML Header DieHandle
             ParseForm ParseMulti SendFile ThisURL);

use strict;
my $template_dir = $main::VAR{'templates'} || '/www/templates';
$Web::header     = 0;

# -----------------------------------------------------------------------
# Subroutine: html  -  Runs through a template sub'in ~variable~
# -----------------------------------------------------------------------
sub html
{
    my $template = shift || die "No Template File given";;
    my $OH       = shift || \*STDOUT;
    my $delim    = shift || $Web::delim || '~';

    #
    # since this is called recursively, we need unique filehandle names
    #
    my $IH = new FileHandle "<$template";

    # make sure it exists please :)
    unless (defined($IH)) { &ErrorHTML("Couldn't open $template"); }

    #
    # use non-buffered output
    #
    my ($oldfh) = select(STDOUT); $| = 1; select($oldfh);
    #
    # turn relative ref into absolute ref
    #
    $template = "$template_dir/$template" unless $template =~ m.^/.;

    if ($::READING{$template} == 1) {
    return 0;                     # avoid infinite loop
    } else {
    $::READING{$template} = 1;
    }

    while (<$IH>){
    #
    # implement #include directive in templates
    #
    if (/^\#include \s*(.*\S)\s*$/i){
    #if (/#include (file=|virtual=)?\s*(.*)/i){ # implements SSI
        my $file = $2;
        #$file =~ s/-->$//g;                      implements SSI
        $file =~ s/\"//g;

            if ($OH) {
              &html($file, $OH);
            } else {
              &html($file);
            }
        next;
    }
    s/$delim([^$delim]+)$delim/$main::VAR{$1}/g;
        s/$delim{2}/$delim/g;
    print $OH $_;
    }
    delete $::READING{$template};
    close $IH;
    1;
}
# END of html
# -------------------------------------------------------------------------

# -------------------------------------------------------------------------
# Subroutine: Header - print the content-type header arg = mime|text/html
#                      sets $Web::header = 1 to show that a header is there
# -------------------------------------------------------------------------
sub Header
{
   my $type = shift || 'text/html';
   print "Content-type: $type\n\n" unless $Web::header++;
}

# -----------------------------------------------------------------------
# Subroutine: ErrorHTML  -  Print out the Error to the Web Page :)
# -----------------------------------------------------------------------
sub ErrorHTML
{
   my ($error, $exit) = @_;
   &Web::Header;
   print "<H1>$error</H1>\n";
   exit if $exit;
}
# END of ErrorHTML
# -------------------------------------------------------------------------

# ----------------------------------------------------------------------------
# Subroutine: DebugHTML - Print out the given message
# ----------------------------------------------------------------------------
sub DebugHTML
{
   my $msg   = shift or die 'No Message given to DebugHtml';
   my $exit  = shift;

   &Header;
   print "$msg\n";
   exit if $exit;
}

# ----------------------< Function: ParseForm() >------------------------- #
# Parse the INPUT from a <FORM> to produce $FORM{name} = value;
# ------------------------------------------------------------------------ #
sub ParseForm
{
   my ($check) = @_;
   my ($pair, @pairs, $input, $name, $value);

   # Check the METHOD used on the form
   # POST: read input from STDIN
   # GET : use the query string

   # Put all the input into $input
   if($ENV{'REQUEST_METHOD'} eq "GET") {
       $input = $ENV{'QUERY_STRING'};
   } else {
       read(STDIN, $input, $ENV{'CONTENT_LENGTH'});
   }

   &CheckInput($input) unless $check;

   # Now we have the raw data lets split it at the "&"
   @pairs = split(/&/, $input);

   # Now lets get an array, indexed by the variable name w/ the values

   foreach $pair (@pairs)
   {
     $pair =~ tr/+/ /;                     # Change the "+"'s to " "

     ($name, $value) = split(/=/, $pair);  # Split name=value into 2 pieces

     $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg; # %xx -> Hex

     if ($main::FORM{$name}) {
        $main::FORM{$name} .= "\0$value";     # Create the Associative Array
     } else {
        $main::FORM{$name} = $value;          # Create the Associative Array
     }
   }
   return %main::FORM;
}
# --------------------------< End ParseForm() >--------------------------- #

# ----------------------< Function: ParseMulti() >------------------------ #
# Parse the INPUT from a MULTIPART <FORM> to produce $FORM{name} = value;
# ------------------------------------------------------------------------ #
sub ParseMulti
{
    my (%FORM, $input, @input, $delim, @file, $varname);

    # Read in ALL the input
    read(STDIN, $input, $ENV{'CONTENT_LENGTH'});
    @input = split("\r\n", $input);

    $delim = shift @input;

    print "<PRE>Input<BR>$input</PRE><BR>" if $Web::DEBUG;

    foreach (@input)
    {
        if( /Content-Disposition:.+?name="([\w\d\.]+)";\s+filename="(.*)"/i ) {
            $varname=$1;
            $FORM{$varname.'-filename'} = $2; #filename
        } elsif ( /Content-Disposition:.+?name="([\w\d\.]+)"/i ) {
            $varname = $1;
        } elsif ( /Content-Type/i ) { # Ignore
            next;
        } elsif( /$delim/ ) {
            while($FORM{$varname} ) { $varname .= '0'; } ##ensures unique name
            my $i;
            for($i=1; $i < scalar(@file); $i++) { #skip the first one $i=1
                my $a = $file[$i];
                if( $i== @file - 1) {
                    $FORM{"$varname"} .= $a;
                }else{
                    $FORM{"$varname"} .= "$a\r\n";
                }
            }
            undef @file; #reset @file for new variable
        } else {
            push(@file, $_);
        }
    }
    ###now get form vars from query_string
    return %FORM;
}
# --------------------------< End ParseMulti() >-------------------------- #

# ----------------------------------------------------------------------------
# Subroutine: SendFile - Given a filename on the system it sends it to the user
#            NOTE: This function must be called before any headers are printed!
# ----------------------------------------------------------------------------
sub SendFile
{
    my $name  = shift;
    local($/) = undef;

    open (FILE, $name)
        || return "Cannot open file '$name' for input because of $!";
    print "Content-Type: application/octet-stream\n";
    print "Content-Disposition: inline;filename=$name\n\n";
    binmode(FILE);   ##I think this binmode stuff allows function to work
    binmode(STDOUT); ##on WinNT/Win95
    select(STDOUT);
    $|=1;
    print <FILE>;
    close FILE;
    return;
}

# -----------------------< Function: CheckInput() > ---------------------- #
# Check for NULL Input and if so exit with a HTML Error                    #
# Usage: CheckInput($string)                                               #
# ------------------------------------------------------------------------ #
sub CheckInput
{
   my($input) = @_;

   if ($input eq "")
   {
     my $thisurl = &ThisURL;

   print <<"EOF";
Content-type: text/html

<HTML>
<HEAD>
<TITLE>Error - No Form Used</TITLE>
</HEAD>
<BODY>
<H1 align=center>Please use the HTML FORM Provided</h1>
This program has been accessed without a valid query string.
Please use the associated FORM at
<A HREF="$thisurl">$thisurl</A>
<P>
</BODY>
</HTML>
EOF

   exit(1);
   }
}

# -------------------------< End CheckInput() >--------------------------- #

# -----------------------< Function: ThisURL() >-------------------------- #
# Return the Address of the CGI                                            #
# ------------------------------------------------------------------------ #
sub ThisURL {
  return 'http://' . $ENV{'SERVER_NAME'} . $ENV{'SCRIPT_NAME'};
}
# --------------------------< End ThisURL() >----------------------------- #

# ----------------------------------------------------------------------------
# Die Handling  -  if program dies it will print happy thoughts
# ----------------------------------------------------------------------------
sub DieHandle {
  $SIG{"__DIE__"} = sub {
      my $why = shift;
    chomp $why;
    &Web::Header;
    print "ERROR: $why\n";
    exit 0;
  }
}

1; # Return TRUE to show that mr.require worked :)

__END__

=head1 NAME

Web.pm - Module for CGI processing

=head1 DESCRIPTION

This module holds routines for processing Web pages

=head1 FUNCTIONS

o B<ParseForm>($dontcheck)

  Returns a hash of $FORM{name} = value; from a html <FORM>
  (e.g. where <INPUT NAME=name VALUE=value>)

  If $dontcheck is true then it won't check for input to the
  script

o B<ParseMulti>

  Same as ParseForm, but it parses a multipart document
  (e.g. <FORM ENCTYPE="multipart/form-data">)
  You would use this if you were uploading files etc.

o B<html>($template, $outputhandle, $delimiter)

  This function runs through the template html file and
  replaces any variables within the delimiter and
  outputs the result to the output handle. It replaces
  ~foo~ with $::VAR{foo} (if ~ is the delimiter)

  $template = html file w/ the delimited special variables
  $outputhandle = defaults to STDOUT but can be routed to a
                  file
  $delimiter = text between 2 delimiters are replaced,
               defaults to ~

o B<Header>($mimetype)

  This function will print the Content-type header unless
  if has already done so.

o B<SendFile>($filename)

  Given a filename this function sends a file to the user.

o B<DebugHTML>($msg, $exit)

  This function prints out $msg to STDOUT.
  it will exit if $exit is true.

o B<ThisURL>

  Simply returns the URL of the script that called this function

o B<CheckInput>

  If no input has been given to the script this function will print
  out an error message and quit


=head1 EXAMPLE

  use Web;

  %::VAR = &ParseForm;

  &Header;
  &html('/www/foo.html');


  The above script would take in data from a form and replace the
  the variables it got with ones in the template and print
  to STDOUT