[webtool.pl]
--
package webtool;
use strict;
;##                                          ##
;## Copyright (C) 2000-2002 by Junro YOSHINO ##
;##                                          ##
;## Package for CGI                          ##
;##                                          ##
;#--------------------------------------------
;# parse_form_data(\%decoded_data [, "GET"][, "POST"][, MAX_LENGTH])
;#    gets form data sent as a query string or an HTTP request body,
;#    parses them and returns them by using %decoded_data.
;#
;#     Its argument "GET" or "POST" limit its methods of getting data.
;#    If only "GET" is given, it gets data from only a query string
;#    (GET method).  If only "POST" is given, it gets data from only an
;#    HTTP request body (POST method).  If both of or neither of them are
;#    given, It gets data by either GET or POST method.
;#
;#     Its argument MAX_LENGTH limit the maximam receiving data length when
;#    it gets data by POST method.  By default, the receivable data length
;#    is unlimited.
;#
;#     The decoded data VALUE can be refered as $decoded_data{'KEY'}.
;#
;#     The undecoded raw data string ("KEY=VALUE&KEY=VALUE ...") is also
;#    returned as the function value.
;#----------------------------
;#  sanitize(\$str [, IGNORE_ENTITY])
;#     substitutes a left angle bracket (<) with "&lt;", a right angle
;#     bracket (>) with "&gt;", an ampersand character (&) with "&amp;",
;#     a double quotation character (") with "&quot;" and a single quotation
;#     character (') with "&#39;" in $str.
;#
;#      If its argument IGNORE_ENTITY is boolean true, it ignores entity
;#     references.  For example, it replaces &quot; with &amp;quot;.
;#     Conversely, its argument IGNORE_ENTITY is boolean false or default,
;#     it retains all entity references in $str.
;#---------------------
;#  url_decode(\$str)
;#     decodes urlencoded $str.
;#---------------------
;#  url_encode(\$str)
;#     urlencodes $str.
;#---------------------------------------
sub parse_form_data {
    my ($decoded_data, @arg) = @_;
    my $max_length = -1;
    my $allowGET  = ($arg[0] eq "GET"  || $arg[1] eq "GET")  ? 1 : 0;
    my $allowPOST = ($arg[0] eq "POST" || $arg[1] eq "POST") ? 1 : 0;
    if($allowGET && $allowPOST){
        $max_length = $arg[2] if $arg[2] ne "";
    }elsif($allowPOST){
        $max_length = $arg[1] if $arg[1] ne "";
    }
    if(! ($allowGET or $allowPOST)){
        $allowGET  = 1;
        $allowPOST = 1;
        $max_length = $arg[0] if $arg[0] ne "";
    }

    my $form_info;
    my $read_length = $ENV{'CONTENT_LENGTH'};
    if($allowGET && $ENV{'REQUEST_METHOD'} eq "GET"){
        $form_info = $ENV{'QUERY_STRING'};
    }elsif($allowPOST && $ENV{'REQUEST_METHOD'} eq "POST"){
        $read_length = $max_length if ($max_length != -1 && $max_length < $read_length);
        read(STDIN, $form_info, $read_length);
    }

    foreach my $key_value (split(/&/, $form_info)) {
        my ($key, $value) = split(/=/, $key_value);
        url_decode(\$value);
        if(defined $decoded_data->{$key}){
            $decoded_data->{$key} =
              join("\0", $decoded_data->{$key}, $value);
        }else{
            $decoded_data->{$key} = $value;
        }
    }
    return $form_info;
}

sub sanitize {
    my ($str, $ignore_entity) = @_;
    $$str =~ s/</<lt;/g;
    $$str =~ s/>/<gt;/g;
    $$str =~ s/"/<quot;/g;
    $$str =~ s/'/<#39;/g;
    $$str =~ s/&(#?[a-zA-Z\d]+);/<$1;/g unless $ignore_entity;
    $$str =~ s/&/&amp;/g;
    $$str =~ tr/</&/;
}

sub url_decode {
    my ($str) = @_;
    $$str =~ tr/+/ /;
    $$str =~ s/%([\dA-Fa-f][\dA-Fa-f])/pack("C", hex($1))/eg;
}    

sub url_encode {
    my ($str) = @_;
    $$str =~ s/([^\.\*\-_a-zA-Z0-9 ])/sprintf("%%%02lX",unpack("C",$1))/eg;
    $$str =~ s/ /+/g;
}

1;
--
Copyright (C) Junro YOSHINO <yoshinok@muf.biglobe.ne.jp>