package CGI::Simple;
require 5.004;

use strict;
# use warnings;  # during testing
use SelfLoader;
use vars qw ( $DISABLE_UPLOADS $POST_MAX $VERSION );
$VERSION = "0.01";
$DISABLE_UPLOADS = 1;
$POST_MAX = 102400;  # use a post max of 100K, set to -1 for no limits

=head1 NAME

CGI::Simple - A Simple totally OO CGI interface that is CGI.pm compliant

=head1 SYNOPSIS

    use CGI::Simple;
    $CGI::Simple::POST_MAX = 1024;

    $q = new CGI::Simple;
    $q = new CGI::Simple( { 'foo'=>'1', 'bar'=>[2,3,4] } );
    $q = new CGI::Simple( 'foo=1&bar=2&bar=3&bar=4' );
    $q = new CGI::Simple( \*FILEHANDLE );

    $q->save( \*FILEHANDLE );

    @params = $q->param;
    $value = $q->param('foo');
    @values = $q->param('foo');

    %fields = $q->Vars;

    @keywords = $q->keywords;

    $q->param( 'foo', 'some', 'new', 'values' );
    $q->param( -name=>'foo', -value=>'bar' );
    $q->param( -name=>'foo', -value=>['bar','baz'] );

    $q->append( -name=>'foo', -value=>'bar' );
    $q->append( -name=>'foo', -value=>['some', 'new', 'values'] );

    $q->delete('foo');
    $q->delete_all;

    $decoded = $q->url_decode($encoded);
    $encoded = $q->url_encode($unencoded);
    $param = $q->escapeHTML('  < >&"'."\n".'<>&"');

    dienice( $q->cgi_error ) if $q->cgi_error;

=head1 DESCRIPTION

CGI::Simple provides a lightweight drop in replacement for CGI.pm. It has 
an identical OO interface to CGI.pm for parameter parsing. Multipart/form-data 
encoding is not supported. It has no HTML output functionality outside of an 
escapeHTML() method. There is no header method either.

A list of the supported methods is given above. For full specifics see the 
extensive CGI.pm pod. Unlike CGI.pm this module has a default $POST_MAX setting 
of 100K This should be more than adequate for most purposes. If you wish 
to change this you must set it before you call the new() constructor, just as 
with CGI.pm

=head2 EXPORT

Nothing. $POST_MAX and $DISABLE_UPLOADS globals from CGI.pm used

=head1 BUGS

As this is 0.01 there are almost bound to be some. Unlike CGI.pm which tries 
to accept all filehandle like objects only \*FH and $fh are accepted by 
CGI::Simple as file accessors.

=head1 AUTHOR

Dr James Freeman E<lt>jfreeman@tassie.net.auE<gt>

This package is free software and is provided ``as is'' without express or 
implied warranty. It may be used, redistributed and/or modified under the terms 
of the Perl Artistic License (see http://www.perl.com/perl/misc/Artistic.html)

=head1 CREDITS

The entire interface and key sections of code come from CGI.pm by Lincoln Stein. 
Hopefully Randall Schwartz will go over the code with his eagle eye to iron out 
the bugs. Then again he may just flame me :-) I enjoyed writing this anyway.

Jeff Pinyan picked the first bug - the gauntlet is laid down:

Cristians: 0   Lions: 13
Japhy:1        Rest: 0

=head1 SEE ALSO

CGI.pm by Lincoln Stein

=cut


sub new {
    my ( $class, $init ) = @_;
    $class = ref($class) || $class;
    my $self  = {};
    bless $self, $class;
    $self->init($init);
  return $self;
}

sub init {
    my ( $self, $init ) = @_;
    if ( ! defined $init ) {
        $self->initialise;
    }
    elsif ( (ref $init) =~ m/HASH/i ) {
        for my $param( keys %{$init} ) {
            $self->{$param} = (ref $init->{$param}) ? $init->{$param} : [$init->{$param}];
    	}
    }
    elsif ( (ref $init) =~ m/GLOB/i ) { 
        $self->init_from_file($init);
    }
    else {
        $self->parse_params($init);
    }
}

sub initialise {
    my $self = shift;
    my $data;
    my ( $type, $length, $method ) = @ENV{'CONTENT_TYPE','CONTENT_LENGTH','REQUEST_METHOD'};
	if ( defined $type and $type =~ m|^multipart/form-data| ) {
        $self->cgi_error( "Can't process multipart/form-data encoding" );
      return undef;
    }
    if ( $POST_MAX != -1 and $length > $POST_MAX ) {
        $self->cgi_error( "$length bytes on STDIN exceeds POST_MAX!" );
      return undef;
    }
	if ( $method eq 'POST') {
		read( STDIN, $data, $length );
        unless ( $length == length $data ) {
            $self->cgi_error( "Bad read! wanted $length, got ".(length $data) );
          return undef;
        }
        # uncomment this if you want to use query string and POST at the same time (not recommended)
        # $data .= $ENV{'QUERY_STRING'};
	}
	elsif ( $method =~/^(GET|HEAD)$/ ) {
		$data = $ENV{'QUERY_STRING'};
	    $data ||= $ENV{'REDIRECT_QUERY_STRING'} || '';
	}
    else {
        $self->cgi_error("Unknown method $method");
      return undef;
    }
    unless ( $data ) {
        $self->cgi_error("No data recieved via $method");
       return undef;
    }
    $data =~ s/%00//g;   # prevent null byte hacks
    $data =~ tr/\000//d;
    $self->parse_params($data);
}

sub parse_params {
    my ( $self, $data ) = @_;
	unless ($data =~ /[&=;]/) {
	    $self->{'keywords'} = [$self->parse_keywordlist($data)];
      return;
	}
    my @pairs = split /[&;]/, $data;
    for my $pair(@pairs) {
    	my ( $param, $value ) = split '=', $pair, 2;
      next unless $param;
    	$value = '' unless defined $value;
    	$param = url_decode( $self, $param );
    	$value = url_decode( $self, $value );
    	push @{$self->{$param}}, $value;
    }
}

sub parse_keywordlist {
    my( $self, $keywords ) = @_;
    $keywords = $self->url_decode($keywords);
    my @keywords = split /\s+/, $keywords;
  return @keywords;
}

sub param {
    my ( $self, $param, @values ) = @_;
    # set values using -name=>'foo',-value=>'bar' syntax
    if ( defined $param and $param eq '-name' ) {
        my ( $param, undef, $value ) = @values;
        $self->{$param} = (ref $value) ? $value : [$value];
      return;
    }
    # if multiple values passed we also assume set param
    if ( @values ) {
        $self->{$param} = [@values];
      return;
    }
    unless ( defined $param ) {
        my @params = grep { ! /^\.cgi_error/ } keys %{$self};
      return sort @params;
    }
    if (defined $self->{$param}) {
       my @values = @{$self->{$param}};
     return wantarray ? @values : $values[0];
    }
  return undef;
}

sub url_decode {
    my ( $self, $decode ) = @_;
  return undef unless defined $decode;
    $decode =~ tr/+/ /;
    $decode =~ s/%([a-fA-F0-9]{2})/ pack "C", hex $1 /eg;
  return $decode;
}

sub cgi_error {
    my ( $self, $err ) = @_;
    $self->{'.cgi_error'} = $err if defined $err;
  return $self->{'.cgi_error'};
}

sub init_from_file {
    my ( $self, $fh ) = @_;
    local $/ = "\n";
    while (my $pair = <$fh>) {
        chomp $pair;
      return if $pair eq '=';
        $self->parse_params($pair);
    }
}

# these next subs will only be loaded on demand by Selfloader
# they can be safely deleted if you do not call them
__DATA__
sub url_encode {
    my ( $self, $encode ) = @_;
  return undef unless defined $encode;
    $encode =~ s/([^A-Za-z0-9\-_.!~*'() ])/ uc sprintf "%%%02x",ord $1 /eg;
    $encode =~ tr/ /+/;
  return $encode;
}

sub Vars {
    my $self = shift;
    my @hash_list = ();
    my @params = $self->param;
    for my $param(@params) {
        my @values = $self->param($param);
        push @hash_list, ($param, (join "\0", @values));
    }
  return @hash_list;
}        

sub append {
    my ( $self, undef, $param, undef, $value ) = @_;
    my @values = ref $value ? @{$value} : ($value);
    push @{$self->{$param}}, $_ for @values;
}
    
sub keywords {
    my $self = shift;
  return @{$self->{'keywords'}} if defined $self->{'keywords'};
  return undef;
}

sub delete {
    my ( $self, $param ) = @_;
  return undef unless defined $self->{$param};
    delete $self->{$param};
}   

sub delete_all {
    my $self = shift;
    undef %{$self};
}

sub escapeHTML {
    my ( $self, $escape ) = @_;
  return undef unless defined $escape ;
    # make the required escapes
    $escape =~ s/&/&amp/g;
    $escape =~ s/"/&quot;/g;
    $escape =~ s/</&lt;/g;
    $escape =~ s/>/&gt;/g;
    # change tabs to 4 spaces
    $escape =~ s/\t/    /g;
    # make the whitespace escapes  
    $escape =~ s/( {2,})/"&nbsp;" x length $1/eg;
    # make the brower bugfix escapes as seen on source of
    # CGI.pm. Doing this globally should do no harm
    $escape =~ s/\x8b/&#139;/g;
    $escape =~ s/\x9b/&#155;/g;
    # uncomment to change newlines to <br> if desired
    # $escape =~  s/\n/<br>\n/g;
  return $escape;
}
    
sub save {
    my ( $self, $fh ) = @_;
    local ( $,, $\ ) = ( '', '' );
    unless ( $fh and fileno $fh ) {
        $self->cgi_error('Invalid filehandle');
      return undef;
    }
    for my $param($self->param) {
        for my $value ( $self->param($param) ) {;
            print $fh $self->url_encode($param), '=', $self->url_encode($value), "\n";
        }
    }
    print $fh "=\n";
}
__END__