view release on metacpan or  search on metacpan

WebIn.pm  view on Meta::CPAN

our $VERSION = '2.03';
our @EXPORT=qw(
  %IN 
  %GET 
  %POST 
  %COOKIES 
  SetCookie 
  DropCookie
);


####################### Êîíñòàíòû, óïðàâëÿþùèå ðàáîòîé #####################
our $CANUPL_FILE = ".can_upload";  # èìÿ ôàéëà, ðàçðåøàþùåãî çàêà÷êó
our $MULTICHUNK_SIZE = 20000;      # äëèíà áëîêà ñ÷èòûâàíèÿ STDIN-à
our $MAX_ARRAY_IDX = 10000;        # ìàêñèìàëüíî âîçìîæíûé èíäåêñ N â a[N]
our $uniq_tempnam = 0; # temp files counter
our @TempFiles = ();   # all temp files (to delete after end)
our @Errors = ();      # all query parsing errors

# Íàñòðîéêè ñåðèàëèçàöèè.
# Íåêîòîðûå âíóòðåííèå íàñòðîå÷íûå ïåðåìåííûå. Ôàêòè÷åñêè, îíè èñïîëüçóþòñÿ 
# â êà÷åñòâå êîíñòàíò. Ëó÷øå âñåãî èõ íèêîãäà íå òðîãàòü. Ýòè êîíñòàíòû 
# äîëæíû ñîñòîÿòü èç îäíîãî ñèìâîëà!
our $Div1 = ".";    # ALWAYS should be one nondigit!!!
our $Div2 = ".";    # may be the same as $Div1


####################### Ïðåðåìåííûå ñ äàííûìè áðàóçåðà #####################
our %IN = ();                          # Äàííûå ôîðìû 
our %GET = ();                         # Äàííûå GET
our %POST = ();                        # Äàííûå POST
our %COOKIES = ();                     # Âñå ïðèøåäøèå Cookies
our %IMPORT_MOD = ();                  # Ìîäóëè, çàòðåáîâàâøèå èìïîðò ïåðåìåííûõ (êëþ÷è)


# void _reparseAll()
# Parses all the input data.
sub _reparseAll {
  if($ENV{QUERY_STRING}) {
    _parseURLEnc($ENV{QUERY_STRING},"get"); 
  }
  if(uc($ENV{REQUEST_METHOD}) eq "POST") {
    if(exists($ENV{'CONTENT_TYPE'}) && $ENV{'CONTENT_TYPE'}=~m|^\s*multipart/form-data|i) {
      _parseMultipart();
    } else {
      read(STDIN,my $data,$ENV{CONTENT_LENGTH});
      _parseURLEnc($data,"post");
    }
  }
  if($ENV{HTTP_COOKIE} || $ENV{COOKIE}) {
    _parseCookies();
  }
# use Data::Dumper; print "<pre>".Dumper(\%IN)."</pre>";
}


# void import(...) 
# Called on 'use'.
sub import
{ my ($pkg, $opt)=@_;
  my $caller = caller();
  export_vars($opt, $caller) if $opt;
  no strict;
  foreach (@EXPORT) {
    my ($type, $name) = /^([%@\$]?)(.*)$/s;
    if ($type eq '%') {
      *{$caller."::".$name} = \%{$name};
    } elsif ($type eq '') {
      *{$caller."::".$name} = \&{$name};
    }
  }
}


# Deletes temporary files if present.
sub END
{ map { unlink($_) } @TempFiles if @TempFiles;
}

# list of string GetErrors()
# Returns all errors collected while parsing the form input data
# (for example, too large autoarray index).
sub GetErrors {
  return @Errors;
}


# Encoding and decoding.
sub URLEncode { my ($s)=@_; $s=~s{([^-_A-Za-z0-9./])}{sprintf("%%%02X", ord $1)}sge; return $s }
sub URLDecode { my ($s)=@_; $s=~tr/+/ /; $s=~s/%([0-9A-Fa-f]{2})/chr(hex($1))/esg; return $s }


my %CODE = (
'export_vars' => <<'END_OF_FUNC',
  # void export_vars(sting $options, string $toPkg)
  # Export EGPC-variables from %GET, %POST etc.
  sub export_vars
  { my ($opt, $to)=@_;
    if(!scalar(@_)) {
      # Âûçîâ áåç ïàðàìåòðîâ - îáîéòè è ýêñïîðòèðîâàòü âî âñå ìîäóëè-êëèåíòû
      while(my ($mod,$opt)=each(%IMPORT_MOD)) {
        export_vars($opt,$mod);
      }
    } else {
      # Âûçîâ ñ ïàðàìåòðàìè - ýêñïîðò ïåðåìåííûõ òîëüêî â óêàêçàííûé ìîäóëü
      return if !$opt;
      $opt="gpces" if lc($opt) eq "a" || $opt eq "1";
      # Ñîõðàíÿåì èíôîðìàöèþ î òîì, ÷òî ìîäóëü "õî÷åò" ýêñïîðòèðîâàíèÿ è 
      # â äàëüíåéøåì. Íàïðèìåð, ïðè âûçîâå SetCookie() ñîîòâåòñòâóþùàÿ 
      # ïåðåìåííàÿ ñîçäàñòñÿ íå òîëüêî â %COOKIES, íî è âî âñåõ ìîäóëÿõ.
      $IMPORT_MOD{$to}=$opt;
      # Ýêñïîðòèðóåì åùå íå ñóùåñòâóþùèå ïåðåìåííûå
      no strict;
      my $Bad=\%{$to."::"};
      foreach my $op (split //,$opt) {
        $op=lc($op);
        my $Hash = 
          $op eq "g" && \%GET ||
          $op eq "p" && \%POST ||
          $op eq "c" && \%COOKIES ||
          $op eq "e" && \%ENV || next;