=head1 Name

Text::Wigwam::Modules::Core::Cgi - A Wigwam module.

=head1 Description

This module contains directives useful for accessing CGI environment
variables, and managing query strings and other forms of web encoded data.

=head1 Directives

=cut

package Text::Wigwam::Directives::cgi;

use strict;
no warnings 'uninitialized';
use Text::Wigwam::Const qw(:all);

our $VERSION = '0.01';

sub _proto_post{ [ ] }
sub _post{
    my ($Api) = @_;
    unless( $Api->global_exists( 'post_data' ) ){
        if( $ENV{'REQUEST_METHOD'} eq 'POST' ){
            $Api->new_global( 'GLOBAL', 'post_data' );
            my $RawInput;
            read( STDIN, $RawInput, $ENV{'CONTENT_LENGTH'} );
            # Store it in Globals facility for subsequent requests
            $Api->set_global( post_data => $RawInput );
        }
    }
    return make_struc(
        $Api,
        split( /&/, $Api->get_global('post_data') )
    );
}

=head2 #cgi::post

Retrieves a URI encoded query string via the POST method and returns a hash
complex containing the decoded data.

=cut

sub _proto_get_query{ [ ] }
sub _get_query{
    my ($Api) = @_;
    my $qstr;
    if( $ENV{'REQUEST_METHOD'} eq 'POST' ){
        unless( $Api->global_exists( 'post_data' ) ){
            $Api->new_global( 'GLOBAL', 'post_data' );
            my $RawInput;
            read( STDIN, $RawInput, $ENV{'CONTENT_LENGTH'} );
            # Store it in Globals facility for subsequent requests
            $Api->set_global( post_data => $RawInput );
        }
        return make_struc(
            $Api,
            split(/&/,$Api->get_global('post_data'))
        );
    }
    return make_struc( $Api, split( /&/, $ENV{QUERY_STRING} ) );
}

=head2 #cgi::get_query

Retrieves a URI encoded query string based upon the relevant GET or POST
method and returns a hash complex containing the decoded data.

=cut

sub _proto_env{ [ ] }
sub _env{ return \%ENV }

=head2 #cgi::env

Returns a reference to Perl's %ENV hash.

=cut

sub _proto_parse_query{ [ STRING ] }
sub _parse_query{ return make_struc( $_[0], split( /&/, $_[0]->get_arg ) ) }

=head2 #cgi::parse_query I<string>

Parses the URI encoded I<string> and returns a reference to a hash reference
containing the decoded data.

 [!! #define Query #cgi::parse_query "name.first=Fred&name.last=Mertz" !!]
 First name: [!! Query.name.first !!], Last name: [!! Query.name.last !!]
 [!!
  /* output:
   First name: Fred, Last name: Mertz
  */
 !!]

=cut

sub _proto_make_query { [ HASH ] }
sub _make_query {
    my $struc = $_[0]->get_arg;
    my $arr = collapse_struc( $_[0], $struc, '', [] );
    my $query = [];
    for my $key ( @$arr ){
        my $val = encode($_[0]->explicit_get_value($struc,'.',$key));
#        $val =~ s/\#/%23/gs;
        $val =~ s/\=/%3D/gs;
        $val =~ s/\&/%26/gs;
        push( @$query, encode( $key )."=$val" );
    }
    return join( "&", @$query );
}

=head2 #cgi::make_query I<hash>

Performs the reverse of C<#cgi::parse_query>. Returns a URI encoded string
generated from I<hash>.

 [!!
  #cgi::make_query %<
    one   "single"
    two   "twice that of one"
    three "more than you need"
  >
  /* output (order will vary):
   three=more+than+you+need&one=single&two=twice+that+of+one
  */
 !!]

=cut

sub _proto_parse_cookies{ [ STRING ] }
sub _parse_cookies{
    return make_struc( $_[0], split ( /;\s+/, $_[0]->get_arg ) );
}

=head2 #cgi::parse_cookies I<http_cookies>

Returns a reference to a hash complex containing decoded data generated from
encoded I<http_cookies> data.

 [!! #define cookies #cgi::parse_cookies "foo.bar=bazz; bar.foo=quux" !!]
 foo.bar = [!! cookies.foo.bar !!]
 bar.foo = [!! cookies.bar.foo !!]
 [!!
  /* output:
   foo.bar = bazz
   bar.foo = quux
  */
 !!]

=cut

## Experimental: make_cookies
sub _proto_make_cookies{ [ HASH ] }
sub _make_cookies{
    my $struc = $_[0]->get_arg;
    my $arr = collapse_struc( $_[0], $struc, '', [] );
    my $cookies = [];
    for my $key ( @$arr ){
        my $val = encode($_[0]->explicit_get_value($struc,'.',$key));
        $val =~ s/; /%3B+/gs;
        $val =~ s/\=/%3D/gs;
        $val =~ s/\&/%26/gs;
        push( @$cookies, encode( $key )."=$val" );
    }
    return join( "; ", @$cookies );
}

=head2 #cgi::make_cookies I<hash>

Performs the reverse of C<#cgi::parse_cookies> - returns an encoded string
generated from I<hash> which is suitable for use as an http-cookie.

 [!!
  #cgi::make_cookies %<
    one   "single"
    two   "twice that of one"
    three "more than you need"
  >
  /* output (order will vary):
   three=more+than+you+need; one=single; two=twice+that+of+one
  */
 !!]

=cut

sub _proto_encode{ [ STRING ] }
sub _encode{ encode( $_[0]->get_arg) }

=head2 #cgi::encode I<string>

Returns a URI encoded version of I<string>.

 [!!
  #cgi::encode "Four score & seven years ago"
  /* output:
   Four+score+&+seven+years+ago
  */
 !!]

=cut

sub _proto_decode{ [ STRING ] }
sub _decode{ decode( $_[0]->get_arg) }

=head2 #cgi::decode I<string>

Returns a URI decoded version of I<string>.

 [!!
  #cgi::decode "Four+score+&+seven+years+ago"
  /* output:
   Four score & seven years ago
  */
 !!]

=cut

## Support routines begin here...

sub make_struc {
    my( $Api, @arr ) = @_;
    my $hash = {};
    for my $NameValue ( @arr ) {
        my ( $key, $val ) = split ( /=/, $NameValue);
        fill_hash( $Api, $hash, decode( $key ), decode( $val ) );
    }
    return $hash;
}

sub fill_hash {
    my( $Api, $hash, $name, $value ) = @_;
    $name =~ s/[^\\.:\w]/_/gs;         # remove unsupported characters
#    $name =~ s/([.:]){2,}/$1/gs;       # remove sequential id chars
    $name =~ s/^[.:]//s;               # remove leading id chars
    $name =~ s/[.:]$//s;               # remove trailing id chars
    if( $Api->explicit_is_defined($hash,'.',$name) ){
        my $exval = $Api->explicit_get_value($hash,'.',$name);
        if ($Api->is_list($exval)) {
            push( @$exval, $value );
            return;
        }
        $value = [$exval, $value];
    }
    $Api->explicit_set_alias($hash,'.',$name,$value) unless $name eq '';
}

sub decode{
    $_ = shift;
    tr/+/ /;
    s/%([\dA-Fa-f][\dA-Fa-f])/pack ( "C", hex($1) )/eg;
    return $_;
}

sub encode{
    my $str = shift;
    $str =~ s/\#/%23/gs;
    $str =~ s/([^a-zA-Z0-9_.!~*'() -=&])/sprintf "%%%02X", ord($1)/egs;
    $str =~ tr/ /+/;
    return $str;
}

#sub _proto_collapse_struc{ [ HASH|ARRAY ] }
#sub _collapse_struc{ collapse_struc( $_[0], $_[0]->get_arg, '', [] ) }


## Returns an array ref containing all pathnames which reference
## a scalar, array or hash within a given structure.

sub collapse_struc{
    my( $Api, $struc, $path, $arr )  = @_;
     # Scalar
    unless(my $stype=$Api->ref_type($struc)){ push(@$arr,"$path$struc") }
     # Hash
    elsif( $stype eq 'HASH' ){
        for my $key ( keys %$struc ){
            next unless defined( $struc->{$key} );
            push( @$arr, "$path$key" ) and next
              unless my $type = $Api->ref_type( $struc->{$key} ); # Scalar
            collapse_struc(
                $Api,
                $struc->{$key},
                ($type eq 'ARRAY' ? "$path$key:" : "$path$key."),
                $arr
            ) if $type =~ /^(HASH|ARRAY)/; # Ignore other data types
        }
    }
     # Array
    elsif( $stype eq 'ARRAY' ){
        for (my $count=0; $count < scalar @$struc; ++$count){
            next unless defined( $struc->[$count] );
            push( @$arr, "$path$count" ) and next
              unless my $type = $Api->ref_type( $struc->[$count] );
            collapse_struc(
                $Api,
                $struc->[$count],
                ($type eq 'ARRAY' ? "$path$count:" : "$path$count."),
                $arr
            ) if $type =~ /^(HASH|ARRAY)/;
        }
    }
    return $arr;
}

1;

__END__

