#-----------------------------------------------
#
#  Author: Konkov Eugen
#  E-Mail: kes-kes@yandex.ru
#  WWW: http://kes.net.ua
#
#-----------------------------------------------


package CGI::WebIn2;
use strict;
use JSON;
use Exporter;

our $VERSION = '1.00';
our @ISA= qw( Exporter );
our @EXPORT=qw(
  %GET
  %POST
  %COOKIES
  SetCookie
);

#use CGI::WebOut;

#--------------------------------------
#use PrintData;



#######################################
#   Global data
#--------------------------------------
our $POSTDATA= undef;
our %COOKIES= ();
our %POST= ();
our %GET= ();
our $_WARN= 1;
my $contentParsers= {
  'application/x-www-form-urlencoded' => \&urlDataDecode,
  'text/json' => \&jsonDataDecode,
  };



#######################################
#   Encoding and decoding.
#--------------------------------------
#
#  WWW: http://www.ietf.org/rfc/rfc2396.txt
#      Data characters that are allowed in a URI but do not have a reserved
#  purpose are called unreserved.  These include upper and lower case
#  letters, decimal digits, and a limited set of punctuation marks and
#  symbols.
#
#      unreserved  = alphanum | mark
#      mark        = "-" | "_" | "." | "!" | "~" | "*" | "'" | "(" | ")"
#
#--------------------------------------
sub escape { my ($s)=@_; $s=~s{([^A-Za-z0-9_.\-!~*'()])}{sprintf("%%%02X", ord $1)}ge; return $s; }
sub unescape { my ($s)=@_; $s=~tr/+/ /; $s=~s/%([0-9A-Fa-f]{2})/chr(hex($1))/ge; return $s; }



#######################################
#   Data read/parsing
#--------------------------------------
# read CONTENT_LENGTH number of bytes from STDIN and return it
sub readData {
  my $data;
  # you can check CONTENT_LENGTH and stop data reading if it does not fit your requirements
  # else more you can save an incoming data to a file
  read( STDIN, $data, $ENV{'CONTENT_LENGTH'} );
  return $data;
  }


#--------------------------------------
sub parseData {
  my( $data, $order )= @_;

  %COOKIES= %{ cookieDecode( $ENV{HTTP_COOKIE} || $ENV{COOKIE} ) };

  $_= $ENV{REQUEST_METHOD};
  SWITCH: {
    /^POST$/ && do {
      if( defined $contentParsers->{ $ENV{CONTENT_TYPE} } ) {
        %POST= %{ $contentParsers->{ $ENV{CONTENT_TYPE} }->( $data ) };
        }
       else {
        warn "No handler is registred for CONTENT_TYPE => $ENV{CONTENT_TYPE}" if $_WARN;
        }
      last SWITCH;};

    /^GET$/ && do {
      # Because of we always pass URL we always get QUERY_STRING so we always must decode it (see below)
      last SWITCH;};

    warn "Unknown request method: '$_'";
    }

  %GET= %{ urlDataDecode( $ENV{QUERY_STRING} ) };
  #TODO: join all incoming data to one hash
  }


#--------------------------------------
sub registerContentParser {
  my( $contentType, $handler )= @_;

  my $oldHandler= $contentParsers->{ $contentType };
  $contentParsers->{ $contentType }= $handler; #FIX? Must I check that $handler variable is the function pointer
  return $oldHandler;
  }


#--------------------------------------
sub urlDataDecode {
  my( $data )= @_;

  my $dataHash= {};
  my @dataList = split( /[&;]/, $data );

  # convert each parameter into name = value pairs, store them in the %dataHash hash
  # and convert values from URL encoding
  foreach my $i (0 .. $#dataList) {
   $dataList[$i] =~ s/\+/ /g; # Convert plus's to spaces
   #FIX? check how data is passed and may be unescape only $value later and not $key, $value now
   my( $key, $value )= split( /=/, unescape( $dataList[$i] ), 2 ); # Split into key and value. splits on the first =.

   # Associate key and value
   $dataHash->{$key}= $value; # if same variables are passed last will win
   }

  return $dataHash;
  }


#--------------------------------------
sub jsonDataDecode {
	 my( $data )= @_;
  return jsonToObj( $data );
  }


#######################################
#            C O O K I E S
#--------------------------------------
my $cookieObj= {};


#--------------------------------------
sub expires {
  my( $time,$format )= @_;
  $format||= 'http';

  my(@MON)= qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
  my(@WDAY)= qw/Sun Mon Tue Wed Thu Fri Sat/;

  # pass through preformatted dates for the sake of expire_calc()
  $time= expire_calc($time);
  return $time unless $time =~ /^\d+$/;

  # make HTTP/cookie date string from GMT'ed time
  # (cookies use '-' as date separator, HTTP uses ' ')
  my $sc= ' ';
  $sc= '-' if $format eq "cookie";
  my( $sec, $min, $hour, $mday, $mon, $year, $wday )= gmtime($time);
  $year+= 1900;
  return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
                 $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
  }


#--------------------------------------
# This internal routine creates an expires time exactly some number of
# hours from the current time.  It incorporates modifications from
# Mark Fisher.
#
#   Format for time can be in any of the forms...
#   "now" -- expire immediately
#   "+180s" -- in 180 seconds
#   "+2m" -- in 2 minutes
#   "+12h" -- in 12 hours
#   "+1d"  -- in 1 day
#   "+3M"  -- in 3 months
#   "+2y"  -- in 2 years
#   "-3m"  -- 3 minutes ago(!)
#   If you don't supply one of these forms, we assume you are
#   specifying the date yourself
#
#--------------------------------------
sub expire_calc {
  my($time) = @_;

  my $offset;
  my(%mult) = ('s'=>1, 'm'=>60, 'h'=>60*60, 'd'=>60*60*24, 'M'=>60*60*24*30, 'y'=>60*60*24*365);

  if( !$time || (lc($time) eq 'now') ) {
    $offset = 0; }
  elsif( $time=~/^\d+/ ) {
    return $time; }
  elsif( $time =~ /^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)$/ ) {
    $offset= ($mult{$2} || 1) *$1; }
  else {
    return $time; }

  return (time+$offset);
  }


#--------------------------------------
sub cookieDecode {
  my( $data )= @_;

  my $dataHash= {};
  my @dataList = split( /[;]/, $data );

  # convert each parameter into name = value pairs, store them in the %dataHash hash
  # and convert values from URL encoding
  foreach my $i (0 .. $#dataList) {
   my( $key, $value )= map    { s/^\s*(.+?)\s*$/$1/; $_ }    split( /=/, unescape( $dataList[$i] ), 2 ); # Split into key and value. splits on the first '=' sign. Ignore all traling spaces

   # Associate key and value
   if( !defined $dataHash->{$key} ) { # if same variables are passed first will win
     # "!!*data*" -- unescape to "!*data*"; "!*data*" -- convert to object; "*data*" -- leave untuched
     ($dataHash->{$key}= unescape($value)) =~ s/^!(!.*)|^!([^!].*)/ defined $1? $1: jsonToObj($2) /e;
     }
   }

  return $dataHash;
  }


#--------------------------------------
sub cookieEncode {
  my( $cookie )= @_;

  my $data= 'Set-Cookie: ';
  #Check params
  $cookie->{params}{expires}= expires( $cookie->{params}{expires} ) if defined $cookie->{params}{expires};

  #Serialize data
  my $value= $cookie->{value};
  if( ref($value) =~ /^ARRAY$|^HASH$/ ) {
    $value= '!'. objToJson( $value );
    }

  #FIX? Is it usefull to escape name
  $data.= $cookie->{name}. '='. escape( $value );
  while( my( $name, $value ) = each %{ $cookie->{params} } ) {
   $data.= '; '. $name;
   $data.= '='. $value if( defined $value ); #param have value dislike 'secure'
   }

  return $data;
  }


#--------------------------------------
sub SetCookie {
  my( $name, $value, $params, $print )= @_;
  $print= 1 if( !defined $print );

  $cookieObj->{$name}{name}= $name;
  $cookieObj->{$name}{value}= $value;
  $cookieObj->{$name}{params}= $params;
  $cookieObj->{$name}{encoded}= cookieEncode( $cookieObj->{$name} );

  print $cookieObj->{$name}{encoded}. "\n" if( $print );
  }


#######################################
#               I N I T
#######################################



#######################################
#               M A I N
#######################################
$POSTDATA= readData();
parseData( $POSTDATA );

return 1;
__END__


* CONTENT_TYPE - POST data type
* REQUEST_METHOD - The query method that was used.
* QUERY_STRING - The query parameters as passed via the GET method.
* CONTENT_LENGTH - The length in bytes of POST data.
* HTTP_COOKIE - The cookies the browser returned to the server.
  REMOTE_USER - The username of the person who logged in via HTTP Basic authentication or CoSign.
  REMOTE_ADDR - The IP address of the browser.
  HTTP_REFERER - The URL of the referring page as supplied by the browser.
  HTTP_USER_AGENT - The User-Agent header as supplied by the browser.

* - used variables