File Coverage

blib/lib/CGI/WebIn.pm

Criterion	Covered	Total	%
statement	30	43	69.7
branch	8	20	40.0
condition	1	8	12.5
subroutine	7	9	77.7
pod	0	3	0.0
total	46	83	55.4

# Äëÿ ðàçðåøåíèÿ upload-à íóæíî â äèðåêòîðèþ ñî ñêðèïòîì ïîìåñòèòü ôàéë ñ
# èìåíåì ".can_upload".  ïðîòèâíîì ñëó÷àå upload çàïðåùàåñÿ.
# Åñëè æå ýòîò ôàéë çàäàí, òî äåëàåòñÿ ïîïûòêà ïðî÷èòàòü èç íåãî ïàðàìåòðû:
# dir=èìÿ_äèðåêòîðèè äëÿ çàêà÷êè
# maxsize=ìàêñèìàëüíûé_ðàçìåð çàêà÷èâàåìîãî ôàéëà
#  ëþáîì ñëó÷àå, ïî îêîí÷àíèå ðàáîòû ñêðèïòà çàêà÷àííûå ôàéëû óäàëÿþòñÿ
# (åñëè òîëüêî îíè íå áûëè ïåðåìåùåíû ñêðèïòîì â äðóãîå ìåñòî).

# TODO:
# 3. Ïîïðîáîâàòü ðåøèòü ïðîáëåìó ýêñïîðòà
# 4. Èìåíà âðåìåííûõ ôàéëîâ äîëæíû áûòü ñîâìåñòèìû ñ Ìàêîì.
# 5. Ïîääåðæêà undef â Serialize + ïðåäóïðåæäåíèÿ.

package CGI::WebIn;
use strict;
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 "".Dumper(\%IN)."";
}


# 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;
        while(my ($k,$v)=each(%$Hash)) {
          # íå ïåðåïèñûâàòü ñóùåñòâóþùèå ïåðåìåííûå
          next if exists $Bad->{$k};
          ## BUGFIX 11.07.2002 v1.10:
          ##   ðàçðåøàåòñÿ ïðèìåíÿòü òîëüêî áóêâåííî-öèôðîâûå èìåíà,
          ##   ðàíüøå èìåíà âèäà SomeModule::var ïðèâîäèëè ê äûðå
          ##   â áåçîïàñíîñòè.
          next if $k=~/[^\w\d_]/s;
          *{$to."::".$k}=ref($v)? $Hash->{$k} : \$Hash->{$k};
        }
      }
    }
  }
END_OF_FUNC


'_processPar' => <<'END_OF_FUNC',
  # void _processPar(string $key, string $value, string $type)
  # Äîáàâëÿåò ïàðó $key=>$value â õýø %IN (ñ ðàçáîðîì ìíîãîóðîâíåâûõ õýøåé),
  # à òàêæå â õýø %GET, %POST èëè %COOKIES, â çàâèñèìîñòè îò çíà÷åíèÿ $type
  # (get, post, cookies ñîîòâåòñòâåííî).
  # Ïóñòûå ñêîáêè "{}" çàìåíÿþòñÿ íà çíà÷åíèå "{$v}"!
  sub _processPar
  { my ($k,$v,$type)=@_;
    return if !defined($k);
    $type=uc($type||"IN");

    ## BUGFIX 12.07.2002 v1.10:
    ##   äî ýòîãî áûëî s/\r//sg, ÷òî íåïðàâèëüíî ðàáîòàëî íà Ìàêå.
    $v=~s/\x0d\x0a?|\x0a\x0d?/\n/sg if defined $v && !ref $v;

    # Ïðîâåðÿåì âèä "a{10}{20}" è çàîäíî ïîëó÷àåì ïåðâûé êëþ÷
    do { push @Errors, "$type: Unknown input field format '$k'"; return } if $k!~/^([^}{\[\]]+)/sg;

    ## Ýòàï I: Ïîëó÷àåì âñå èíäåêñû, îáðàìëåííûå ñîîòâ. ñêîáêàìè.
    my @Ind = ([$1, '']);
    while(pos $k < length $k) {
      my ($i,$t);
      $k=~/\G
        \{ (
          (?:
            [^}"']* |
            ## BUGFIX 12.07.2002 v1.10:
            ##   íóæíî ïèñàòü [^"\\], à íå [^"].
            ## after slash ALWAYS must be any character.
            "(?:[^"\\]+|\\.)*" |
            '(?:[^'\\]+|\\.)*'
          )
        ) \}
      /sxgc and do { $t=$Ind[-1][1]='HASH'; push @Ind, $i=[$1, ''] }
        or ####
      $k=~/\G
        \[ (
          (?:
            [^]"']* |
            "(?:[^"\\]+|\\.)*" |
            '(?:[^'\\]+|\\.)*'
          )*
        ) \]
      /sxgc and do { $t=$Ind[-1][1]='ARRAY'; push @Ind, $i=[$1, ''] }
        or ###
      do { push @Errors, "$type: Corrupted parameter '$k'"; return };

      if($i->[0] eq "" && defined $v) {
        # Çàìåíÿåì ïóñòîé èíäåêñ ÁÅÇ ÊÀÂÛ×ÅÊ íà $v èëè -1
        $i->[0] = $t eq 'HASH'? $v : '';
      } else {
        # Óáèðàåì ñëýøè ïåðåä êàâû÷êàìè, íî òîëüêî åñëè ñòðîêà áûëà çàêîâû÷åíà.
        $i->[0]=~s/^(['"])(.*)\1$/$2/sg
          and
        $i->[0]=~s/\\(['"\\])/$1/sg;
      }
    }
    # [0] ñîäåðæèò î÷åðåäíîé èíäåêñ.
    # [1] ñîäåðæèò ÒÈÏ îáúåêòà, â êîòîðîì ýòîò èíäåêñ ÑÎÄÅÐÆÈÒÑß.

  # use Data::Dumper; print "".Dumper(\%IN)."";

    ## Ýòàï II: çàïîëíÿåì õýøè. Ê ñîæàëåíèþ, ïðèõîäèòñÿ äåëàòü
    ## öèêë ïî âñåì õýøàì è ôàêòè÷åñêè äåëàòü îäíó ðàáîòó íåñêîëüêî
    ## ðàç, ïîòîìó ÷òî ãäå-òî óæå ìîãóò ñóùåñòâîâàòü ïîëóçàïîëíåííûå
    ## õýøè.
    my   @Outs=(\%IN);
    push @Outs, \%GET     if lc($type) eq "get";
    push @Outs, \%POST    if lc($type) eq "post";
    push @Outs, \%COOKIES if lc($type) eq "cookie";
    foreach my $cur (@Outs) {
      foreach my $idx (@Ind) {
        # Òåêóùèé êëþ÷ è òèï çíà÷åíèÿ ïî ýòîìó êëþ÷ó.
        my ($i,$t) = @$idx;
        # Ïîëó÷àåì ññûëêó $r íå òî ìåñòî, êóäà íóæíî çàïèñàòü çíà÷åíèå.
        my $r;
        if(ref $cur eq 'HASH') {
          # Ðàáîòàåì ñ $cur êàê ñ õýøåì.
          $r = \$cur->{$i};
        } elsif(ref $cur eq 'ARRAY') {
          # Ðàáîòàåì ñ $cur êàê ñ ìàññèâîì.
          # Èíäåêñ -1 îçíà÷àåò "äîáàâèòü â êîíåö".
          $i = @$cur if $i eq "";
          # Íå-öèôðîâûå è ñëèøêîì áîëüøèå èíäåêñû íå äîïóñêàþòñÿ.
          do { push @Errors, "$type: Non-numeric index '$i' in '$k'"; return } if $i=~/[^\d]/s;
          do { push @Errors, "$type: Too large index '$i' in '$k'"; return } if $i>$MAX_ARRAY_IDX;
          $r = \$cur->[$i];
        }
        # Åñëè òàêîãî êëþ÷à åùå íåò, òî â $$r áóäåò undef.
        $$r = ($t eq 'HASH'? {} : $t eq 'ARRAY'? [] : '') if !defined $$r;
        # Ïðîâåðêà ñîîòâåòñòâèÿ òèïîâ.
        if(ref($$r) ne $t) {
          push @Errors, "$type: Mismatched parameter type:  key '$i' in '$k' later defined as ".(ref($$r)||"SCALAR").", not ".(!$t? "SCALAR" : $t eq 'HASH'? 'HASH' : 'ARRAY');
          return;
        }
        $$r = $v if !$t;
        $cur = $$r;
      }
    }
  }
END_OF_FUNC


'_parseURLEnc' => <<'END_OF_FUNC',
  # void _parseURLEnc(string $input, string $type)
  sub _parseURLEnc
  { my ($tosplit,$type) = @_;
    my (@pairs) = split(/[&?]/,$tosplit);
    my ($param,$value);
    foreach (@pairs) {
      ($param,$value) = split('=',$_,2);
      $param = URLDecode(defined($param)?$param:"");
      $value = URLDecode(defined($value)?$value:"");
      _processPar($param,$value,$type);
    }
  }
END_OF_FUNC


'tempnam' => <<'END_OF_FUNC',
  # string tempnam([string $Dir])
  # Âîçâðàùàåò óíèêàëüíîå (èñïîëüçóåòñÿ PID è òàéìåð) èìÿ ôàéëà â äèðåêòîðèè, óêàçàííîé â
  # ïàðàìåòðàõ. Ïî óìîë÷àíèþ - â äèðåêòîðèè, óêàçàííîé â ïåðåìåííîé îêðóæåíèÿ TMP èëè TEMP,
  # èëè, â êðàéíåì ñëó÷àå, â òåêóùåé.  êîíöå ðàáîòû ñêðèïòà âñå ôàéëû, èìåþùèå
  # èìåíà, ñãåíåðèðîâàííûå tempnam(), áóäóò óäàëåíû!
  # Âñåãäà âîçâðàùàåò ïîëíûé ïóòü ê âðåìåííîìó ôàéëó.
  sub tempnam
  { my ($dir)=@_;
    foreach my $cd ($dir,$ENV{TMP},$ENV{TEMP},"/tmp",".") {
      if(defined $cd && -d $cd && -w $cd) { $dir=$cd; last; }
    }
    my $nm=$dir."/".time()."-$$-".(++$uniq_tempnam).".tmp";
    if($nm!~m{^[/\\]}) {
      require Cwd;
      $nm=Cwd::getcwd()."/".$nm;
    }
    push(@TempFiles,$nm);
    return $nm;
  }
END_OF_FUNC


'_parseMultipart' => <<'END_OF_FUNC',
  # hash _readUplConf()
  # ×èòàåò êîíôèãóðàöèîííûé ôàéë, ðàçðåøàþùèé èëè çàïðåùàþùèé
  # çàêà÷êó â òåêóùåé äèðåêòîðèè.
  sub _readUplConf {
    open(local *F,"<$CANUPL_FILE") or return
    my %cfg=();
    while(my $st=) {
      $st=~s/^\s+|\s+$|#.*$//gs;
      next if $st eq "";
      my ($k,$v)=split(/=/,$st,2);
      $cfg{$k}=$v;
    }
    return %cfg;
  }

  # Îáðàáîòêà Multipart-äàííûõ ôîðìû
  # void _parseMultipart()
  our ($InBuf, $InLength); # our äëÿ strict
  sub _parseMultipart
  { # Óñòàíàâëèâàåì äèðåêòîðèþ è äðóãèå ïàðàìåòðû äëÿ çàêà÷êè (åñëè ðàçðåøåíà)
    my %cfg=_readUplConf(); # ñâîéñòâà çàêà÷êè

    #------- Ðàáîòà ñ STDIN ñ âîçìîæíîñòüþ "çàïèõèâàíèÿ" äàííûõ îáðàòíî â ïîòîê
    $InBuf=""; $InLength=$ENV{CONTENT_LENGTH};
    sub _readInput {
      my $sz=shift||$InLength;
      my $need=$MULTICHUNK_SIZE>$sz? $sz : $MULTICHUNK_SIZE;
      my $nBuf=length($InBuf)<$need? length($InBuf) : $need;
      my $out=substr($InBuf,0,$nBuf); $InBuf=substr($InBuf,$nBuf);
      read(STDIN,$out,$need-$nBuf,$nBuf) if $need-$nBuf>0;
      $InLength-=length($out);
      return $out;
    }
    sub _putBack
    { my ($data)=@_;
      $InBuf=$data.$InBuf;
      $InLength+=length($data);
    }
    sub _isEof { return !$InLength; }
    #-------- Êîíåö âíóòðåííèõ ôóíêöèé

    binmode(STDIN);
    # Ñíà÷àëà ÷èòàåì ðàçäåëèòåëü è ôèíàëüíûå "\r\n"
    my ($bound,$CRLF) = _readInput()=~/(^[^\r\n]*)([\r\n]*)(.*)/s; # Âûäåëÿåì ðàçäåëèòåëü ÁÅÇ \n
    _putBack($3);

    # Òåïåðü ÷èòàåì çàïèñè, çàâåðøåííûå ðàçäåëèòåëåì
    while((my $Data=_readInput()) ne "") {
      if(substr($Data,0,2) eq "--") { last; } # Ïðîâåðÿåì, íå êîíåö ëè ýòî
      # Âûäåëÿåì ÂÑÅ ñòðîêè çàãîëîâêà (äî ïóñòîé ñòðîêè).
      $Data=~/^[$CRLF]*(.*?)$CRLF$CRLF(.*)/s
        or do { push @Errors, "Malformed multipart header"; return };
      _putBack($2); # Îñòàòîê çàïèõèâàåì îáðàòíî

      # Ïîëó÷àåì çàãîëîâêè çàïèñè â %Headers
      my @Lines=split(/$CRLF/,$1);        # ñòðîêè çàãîëîâêà
      my %Headers=();
      foreach my $st (@Lines) {
        my ($k,$v)=split(/: */,$st,2);
        $Headers{lc($k)}=$v;
      }
      if(!%Headers) { push @Errors, "Malformed multipart POST (no header)"; return; }

      # Âûäåëÿåì èìÿ òýãà è èìÿ ôàéëà (åñëè çàäàíî)
      my ($name)=$Headers{'content-disposition'}=~/\bname="?([^\";]*)"?/;
      my ($filename) = $Headers{'content-disposition'}=~/\bfilename="?([^\";]*)"?/;

      # Åñëè ýòî íå çàêà÷êà, òî ÷èòàåì äàííûå è ïðîäîëæàåì
      if(!defined $filename || $filename eq "")  {
        my ($body,$i);
        $body = "";
        for($body=""; ($i=index($body,$bound))<0 && !_isEof(); ) {
          $body.=_readInput();
        }
        if($i<0) { push @Errors, "Malformed multipart POST (no boundary after body)"; return; }
        _putBack(substr($body,$i+length($bound)));  # çàïèõèâàåì îñòàòîê íàçàä
        _processPar($name,substr($body,0,$i-length($CRLF)),"post");
        next;
      }

      # Èíà÷å ýòî çàêà÷êà. Çàïèñûâàåì âðåìåííûé ôàéë.
      my $temp=defined $cfg{dir}? tempnam($cfg{dir}):tempnam();
      local *F; open(F,">$temp") or die("Cannot open temporary file $temp"); binmode(F);
      my $written=0;   # ñêîëüêî áàéò â ôàéëå
      my $stopWrite=0; # íóæíî ëè çàïèñûâàòü, èëè ïðîïóñêàòü
      while(1) {
        # Ôàéë ñëèøêîì âåëèê èëè æå çàêà÷êà çàïðåùåíà?..
        $stopWrite ||=
          !%cfg && "File not found: $CANUPL_FILE"
          || (defined $cfg{maxsize} && $written>$cfg{maxsize}) && "File exceeds limit of $cfg{maxsize} bytes";

        my $body1=_readInput();
        my $body2=_readInput(128); # äëÿ ïðîâåðêè ðàçäåëèòåëÿ äëèíîé <128 áàéò
        my $body=$body1.$body2;

        # Íàøëè êîíåö ôàéëà (ðàçäåëèòåëü)?
        if((my $i=index($body,$bound))>=0) {
          $written+=$i-length($CRLF);
          print F substr($body,0,$i-length($CRLF)) if !$stopWrite;
          _putBack(substr($body,$i+length($bound)));
          last;
        }
        $written+=length($body1);
        print F $body1 if !$stopWrite;
        _putBack($body2);
      }
      close(F);

      # Ôîðìèðóåì çíà÷åíèå ïàðàìåòðà.
      ## BUGFIX 13.07.2002:
      ##   ðàíüøå èìÿ âèäà f[] è f{} ïðèâîäèëî ê íåïðàâèëüíîìó
      ##   ñîçäàíèþ ýòîãî õýøà, ò.ê. áûëî íàñêîëüêî âûçîâîâ
      ##   _processPar ñ ñóôôèêñàìè {filename}, {file} è ò.ä.
      my %hash=();
      $hash{filename}=$filename;
      # Ôàéë ñëèøêîì áîëüøîé, ëèáî upload çàïðåùåí?..
      if($stopWrite) {
        unlink($temp);
        $hash{aborted}=$stopWrite;
      } else {
        # Èíà÷å âñå â ïîðÿäêå
        $hash{headers}=\%Headers;
        $hash{file}=$temp;
        $hash{size}=-s $temp;
        $hash{type}=$Headers{'content-type'} if $Headers{'content-type'};
      }
      # Äîáàâëÿåì ïàðàìåòð.
      _processPar($name,\%hash,"post");
    }
  }
END_OF_FUNC


'_parseCookies' => <<'END_OF_FUNC',
  # Ðàçáèðàåò ïðèøåäøèå cookies
  sub _parseCookies
  { my @Pairs = split("; *",$ENV{HTTP_COOKIE} || $ENV{COOKIE} || "");
    foreach (@Pairs) {
      my ($key,$value);
      if(/^([^=]+)=(.*)/) { $key = $1; $value = $2; } else { $key = $_; $value = ''; }
      $key=URLDecode($key);
      $value=URLDecode($value);
      my $v=Unserialize($value);
      $value=defined($v)?$v:$value;
      _processPar($key,$value,"cookie");
    }
  }
END_OF_FUNC


'ExpireCalc' => <<'END_OF_FUNC',
  # int ExpireCalc(string $tm)
  # This routine creates an expires time exactly some number of
  # hours from the current time.  It incorporates modifications from Mark Fisher.
  # Format for time $tm 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(!)
  sub ExpireCalc
  { my($time)=@_;
    my(%mult)=('s'=>1, 'm'=>60, 'h'=>60*60, 'd'=>60*60*24, 'M'=>60*60*24*30, 'y'=>60*60*24*365);
    my($offset);
    if(lc($time) eq 'now') { $offset = 0; }
    elsif($time=~/^([+-](?:\d+|\d*\.\d*))([mhdMy]?)/) { $offset = ($mult{$2} || 1)*$1; }
    else { return $time; }
    return (time+$offset);
  }
END_OF_FUNC


'Expires' => <<'END_OF_FUNC',
  # int Expires(int $time, string $format)
  # This internal routine creates date strings suitable for use in
  # cookies ($format="cookie") and HTTP headers ($format="http" or nothing).
  # (They differ, unfortunately.) Thanks to Fisher Mark for this.
  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 = ExpireCalc($time);  return $time unless $time =~ /^\d+$/;
    # cookies use '-' as date separator, HTTP uses ' '
    my($sc) = ' '; $sc = '-' if $format eq "cookie";
    my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
    return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
         $WDAY[$wday],$mday,$MON[$mon],$year+1900,$hour,$min,$sec);
  }
END_OF_FUNC


'SetCookie' => <<'END_OF_FUNC',
  # void SetCookie(string $name, string $value [,int $expire][,$path][,$domain][bool $secure])
  # Óñòàíàâëèâàåò cookie ñ èìåíåì $name è çíà÷åíèå $value ($value ìîæåò áûòü ñëîæíûì îáúåêòîì
  # - â ÷àñòíîñòè, ññûëêîé íà ìàññèâ èëè õýø).
  # Åñëè $value íå çàäàí (undef), cookie óäàëÿåòñÿ.
  # Åñëè $expire íå çàäàí, âðåìÿ æèçíè ñòàíîâèòñÿ áåñêîíå÷íûì. Åñëè çàäàí, íî ðàâåí
  # íóëþ - ñîçäàåòñÿ one-session cookie.
  # Ïàðàìåòð $expire ìîæíî çàäàâàòü â âèäå, êîòîðûé "ïîíèìàåò" ôóíêöèÿ ExpireCalc().
  sub SetCookie
  { my ($name,$value,$expires,$path,$domain,$secure)=@_;
    my $NeedDel=0;

  # [12.03.2002] Ìîæíî è áåç ýòîãî.
  # if(!defined $path) {
  #   $path=$ENV{SCRIPT_NAME};
  #   $path=~s{/[^/]*$}{}sg;
  #   $path.="/";
  # }

    if(!defined $expires) { $expires="+20y"; }
    if(!defined $value)   { $value=""; $expires="-3y"; $NeedDel=1; }

    my @Param;
    push(@Param,URLEncode($name)."=".URLEncode(Serialize($value)));
    push(@Param,"domain=$domain") if defined $domain;
    push(@Param,"path=$path") if defined $path;
    push(@Param,"expires=".Expires($expires,"cookie")) if $expires;
    push(@Param,'secure') if $secure;

    my $cook="Set-Cookie: ".join("; ",@Param);
    eval {
      local ($SIG{__WARN__},$SIG{__DIE__})=(sub {}, sub {});
      require CGI::WebOut;
    };
    if($@) {
      # Åñëè íå âûøëî çàãðóçèòü CGI::WebOut, òî ïðîñòî ïå÷àòàåì.
      print $cook . "\r\n";
    } else {
      CGI::WebOut::Header($cook);
    }
    if(!$NeedDel) { _processPar($name,$value,"cookie"); }
      else { _processPar($name,undef,"cookie"); }
    # Ýêñïîðòèðóåì Cookie âî âñå íóæíûå ìîäóëè
    export_vars();
  }
END_OF_FUNC


'DropCookie' => <<'END_OF_FUNC',
  # void DropCookie(string $name [,$path] [,$domain])
  # Óäàëÿåò cookie ñ èìåíåì $name. Ïàðàìåòðû $path è $domain
  # äîëæíû òî÷íî ñîâïàäàòü ñ òåìè, êîòîðûå áûëè çàäàíû ïðè
  # óñòàíîâêå Cookie.
  sub DropCookie
  { my ($name,$path,$domain)=@_;
    SetCookie($name,undef,undef,$path,$domain);
  }
END_OF_FUNC


'Serialize' => <<'END_OF_FUNC',
  # string Serialize(mixed @args)
  # Óïàêîâûâàåò â ñòðîêó ëþáîé (ïðàêòè÷åñêè) îáúåêò. Òàê ÷òî íå îáÿçàòåëüíî ïåðåäàâàòü
  # ýòîé ôóíêöèè ññûëêó - ìîæíî ïðÿìî îáúåêò öåëèêîì.
  # ( ýòîì ñëó÷àå îí áóäåò ðàññìîòðåí êàê ñïèñîê).
  # Íåëüçÿ óïàêîâûâàòü îáúåêòû, ñîäåðæàùèå ññûëêè íà ôóíêöèè è äåñêðèïòîðû ôàéëîâ.
  #  ñëó÷àå îøèáêè âîçâðàùàåò undef è âûâîäèò warning.
  sub Serialize
  { my $st="L".($#_+1).$Div2;
    foreach my $Arg (@_) {
      while((my $Ref=ref($Arg)) eq "REF") { $st.="r"; $Arg=$$Arg; }
      if(ref($Arg) ne "") { $st.="r"; }
      if(ref($Arg) eq "") { $st.=length($Arg).$Div1.$Arg; }
      elsif(ref($Arg) eq "SCALAR") { $st.=length($$Arg).$Div1.$$Arg; }
      elsif(ref($Arg) eq "ARRAY") { $st.=Serialize(@$Arg); }
      elsif(ref($Arg) eq "HASH") { $st.="H".Serialize(%$Arg); }
      else { warn("Serialize: invalid field type '".ref($Arg)."'"); return undef; }
    }
    return $st;
  }
END_OF_FUNC


'Unserialize' => <<'END_OF_FUNC',
  # mixed _Unserialize(string $st)
  # Internal function.
  sub _Unserialize
  { my ($st,$TotalLen)=@_;
    # Ñ÷èòàåì ÷èñëî ññûëîê
    my $RefCount;
    for($RefCount=0; substr($st,$RefCount,1) eq "r"; $RefCount++) {;}
    $$TotalLen+=$RefCount; $st=substr($st,$RefCount);
    # Îïðåäåëÿåì òèï
    my $Type="S";   # Ìîæåò áûòü åùå: "HL" (äà, 2 ñèìâîëà!!!) èëè "L"
    if(substr($st,0,1) eq "H") { $Type="H"; $st=substr($st,2); $$TotalLen+=2; }
      elsif(substr($st,0,1) eq "L") { $Type="L"; $$TotalLen++; $st=substr($st,1); }
    # Âûïîëíÿåì äåéñòâèÿ â çâàèñèìîñòè îò òèïà
    my $PResult;
    if($Type eq "S") {
      # Ýòî - îáû÷íàÿ ñòðîêà.
      my $len=substr($st,0,my $p=index($st,$Div1));  # 0123.aaabbb
      $st=substr($st,$p+1); $$TotalLen+=$p+1+$len;   # ^   ^p
      # Ðàñïàêîâûâàåì èñõîäíóþ ñòðîêó
      my $s=substr($st,0,$len); $PResult=\$s;
    } elsif($Type eq "L" || $Type eq "H") {
      my @Unpack;
      my $size=substr($st,0,my $p=index($st,$Div2));
      $st=substr($st,$p+1); $$TotalLen+=$p+1;
      foreach my $i (0..$size-1) {
        my $len; push(@Unpack,_Unserialize($st,\$len));
        $$TotalLen+=$len;
        $st=substr($st,$len);
      }
      if($Type eq "L") { $PResult=\@Unpack; } else { my %Hash=@Unpack; $PResult=\%Hash; }
    }
    # We have the pointer to the object $PResult. Returning the (n-1)-th reference on it.
    for(my $i=0; $i<$RefCount; $i++) { my $tmp=$PResult; $PResult=\$tmp; }
    if(ref($PResult) eq "ARRAY") { return wantarray?@$PResult:@$PResult[0]; }
      elsif(ref($PResult) eq "HASH") { return %$PResult; }
        else { return $$PResult; }
  }


  # mixed _Unserialize(string $st)
  # Ðàñïàêîâûâàåò ñòðîêó, ñîçäàííóþ ðàíåå ïðè ïîìîùè Serialize(). Âîçâðàùàåò òî, ÷òî
  # áûëî êîãäà-òî ïåðåäàíî â ïàðàìåòðàõ Serialize.
  #  ñëó÷àå îøèáêè âîçâðàùàåò undef è âûäàåò warning.
  sub Unserialize
  { return undef if !defined $_[0];
    my @Result=(); my $err=0;
    local $SIG{__WARN__}=sub { $err=1; };
    local $SIG{__DIE__}=sub { $err=1; };
    eval { @Result=_Unserialize($_[0]); };
    if($err||$@) { return undef; }
    return wantarray?@Result:$Result[0];
  }
END_OF_FUNC
);

#eval join("", values %CODE);

our $AUTOLOAD;
sub AUTOLOAD {
  my ($pkg, $sub) = $AUTOLOAD =~ /^(.*)::(.*)$/s or return;
  return if $pkg ne __PACKAGE__;
  eval($CODE{$sub} or return);
  goto &$sub;
}

_reparseAll();

return 1;
__END__