view release on metacpan or  search on metacpan

WebOut.pm  view on Meta::CPAN

    @Headers = ();
    $$rRootBuf = '';
  }
  # Åñëè íè÷åãî íå èçìåíèëîñü, âûõîäèì
  return if tied(*STDOUT) && ref tied(*STDOUT) eq __PACKAGE__."::Tie";
  tie(*STDOUT, __PACKAGE__."::Tie", \*STDOUT, tied(*STDOUT));
}


# Ïðîâåðÿåò, èñïîëüçóåòñÿ ëè áèáëèîòåêà Web-ñêðèïòîì èëè îáû÷íûì
sub IsWebMode() { 
  return $ENV{SCRIPT_NAME}? 1 : 0 
}


# Ïîñëàíû ëè çàãîëîâêè?
sub HeadersSent { 
  return $HeadersSent;
}

WebOut.pm  view on Meta::CPAN

# Ïåðåõâàò âûõîäíîãî ïîòîêà. Èñïîëüçîâàíèå:
# $grabbed = grab { 
#     print 'Hello!' 
# } catch {
#     die "An error occurred while grabbing the output: $@";
# };
# èëè òî æå, íî áåç catch: 
# $grabbed = grab { print 'Hello!' };
sub grab(&@)
{ my ($func, $catch)=@_;
  my $Buf = CGI::WebOut->new; 
  $@ = undef; eval { &$func() };
  if ($@ && $catch) { chomp($@); local $_ = $@; &$catch; }
  return $Buf->buf;
}


# static Header($header)
# Óñòàíàâëèâàåò çàãîëîâîê îòâåòà.
sub Header($)
{ my ($head)=@_;
  if ($HeadersSent) {
    eval { require Carp } 
      and Carp::carp("Oops... Header('$head') called after content had been sent to browser!\n"); 
    return undef; 
  }
  push(@Headers, $head);
  return 1;
}


# Ñáðàñûâàåò ñîäåðæèìîå ãëàâíîãî áóôåðà â áðàóçåð.
sub Flush() { 
  # Îòêëþ÷àåì âíóòðåííþþ áóôåðèçàöèþ Perl-à
  local $| = 1; 
  # Åñëè çàãîëîâêè åùå íå îòîñëàíû, îòîñëàòü èõ
  if (!$HeadersSent && IsWebMode()) {
    my $ContType="text/html";
    unshift(@Headers,"X-Powered-By: CGI::WebOut v$VERSION (http://www.dklab.ru/chicken/4.html), (C) by Dmitry Koterov");
    # Èùåì Content-type, ÷òîáû ïîòîì îòïðàâèòü åãî â êîíöå
    for (my $i=0; $i<@Headers; $i++) {
      if ($Headers[$i]=~/^content-type: *(.*)$/i) {
        $ContType = $1; splice(@Headers, $i, 1); $i--;

WebOut.pm  view on Meta::CPAN

  local @Warns = @Errors>@SvErrors? @Errors[@SvErrors..$#Errors] : ();
  # Âîññòàíàâëèâàåì ñîîáùåíèÿ îá îøèáêàõ
  @Errors = @SvErrors;
  # Çàïóñêàåì îáðàáîò÷èêè â ïîðÿäêå èõ ïîÿâëåíèÿ
  map { &$_() } @Hand;
  # Âîçâðàùàåì çíà÷åíèå, êîòîðîå âåðíóë try-áëîê
  return wantarray? @Result: $Result[0];
}

# Âîçâðàùàåò ôóíêöèþ-çàìûêàíèå, êîòîðàÿ âûçûâàåò òåëî catch-áëîêà.
sub catch(&;@) 
{ my ($body, @Hand)=@_;
  return (sub { if($@) { chomp($@); local $_=$@; &$body($_) } }, @Hand);
}

# Âîçâðàùàåò ôóíêöèþ-çàìûêàíèå, êîòîðàÿ âûçûâàåò òåëî warnings-áëîêà.
sub warnings(&;@) 
{ my ($body,@Hand)=@_;
  return (sub { &$body(@Warns) }, @Hand);
}

# Âûáðàñûâàåò èñêëþ÷åíèå.
sub throw($) { 
  die(ref($_[0])? $_[0] : "$_[0]\n") 
}


# bool SetAutoflush([bool $mode])
# Óñòàíàâëèâàåò ðåæèì ñáðîñà áóôåðà echo: åñëè $mode=1, òî ðàçðåøàåò åãî àâòîñáðîñ ïîñëå
# êàæäîãî âûâîäà print èëè echo, èíà÷å - çàïðåùàåò (ñáðîñ äîëæåí ïðîèçâîäèòüñÿ ïî Flush()).
# Âîçâðàùàåò ïðåäûäóùèé óñòàíîâëåííûé ðåæèì àâòîñáðîñà.
sub SetAutoflush(;$)
{ my ($mode)=@_;
  my $old = $UseAutoflush;
  if (defined $mode) { $UseAutoflush = $mode; }
  return $old;
}

# bool NoAutoflush()
# Çàïðåùàåò ñáðàñûâàòü áóôåð ïîñëå êàæäîãî echo.
# Âîçâðàùàåò ïðåäûäóùèé ñòàòóñ àâòîñáðîñà.
sub NoAutoflush() {
  return SetAutoflush(0);
}


# bool UseAutoflush()
# Ðàçðàøàåò ñáðàñûâàòü áóôåð ïîñëå êàæäîãî echo.
# Âîçâðàùàåò ïðåäûäóùèé ñòàòóñ àâòîñáðîñà.
sub UseAutoflush() {
  return SetAutoflush(1);
}


# Ïåðåíàïðàâëÿåò íà äðóãîé URL (ìîæåò áûòü âíóòðåííèì ðåäèðåêòîì)
sub Redirect($)
{ my ($url) = @_;
  $Redirected = Header("Location: $url");
  exit;
}


# Ïåðåíàïðàâëÿåò ÁÐÀÓÇÅÐ íà äðóãîé URL
sub ExternRedirect($)
{ my ($url) = @_;
  if ($url !~ /^\w+:/) {
    # Îòíîñèòåëüíûé àäðåñ.
    if ($url !~ m{^/}) {
      my $sn = $ENV{SCRIPT_NAME};
      $sn =~ s{/+[^/]*$}{}sg;
      $url = "$sn/$url";
    }
    # Äîáàâèòü èìÿ õîñòà.
    $url = "http://$ENV{SERVER_NAME}$url";
  }
  $Redirected = Header("Location: $url");
  exit;
}


# Çàïðåùàåò êýøèðîâàíèå äîêóìåíòà áðàóçåðîì
sub NoCache()
{ return 1 if $NoCached++;
  Header("Expires: Mon, 26 Jul 1997 05:00:00 GMT") or return undef;
  Header("Last-Modified: ".gmtime(time)." GMT") or return undef;
  Header("Cache-Control: no-cache, must-revalidate") or return undef;
  Header("Pragma: no-cache") or return undef;
  return 1;
}


# int ErrorReporting([int $level])
# Óñòàíàâëèâàåò ðåæèì âûâîäà îøèáîê:
# 0 - îøèáêè íå âûâîäÿòñÿ
# 1 - îøèáêè âûâîäÿòñÿ â áðàóçåð
# 2 - îøèáêè âûâîäÿòñÿ â áðàóçåð â âèäå êîììåíòàðèåâ
# Åñëè ïàðàìåòð íå çàäàí, ðåæèì íå ìåíÿåòñÿ.
# Âîçâðàùàåò ïðåäûäóùèé ñòàòóñ âûâîäà.
sub ErrorReporting(;$)
{ my ($lev)=@_;
  my $old = $ErrorReporting;
  $ErrorReporting = $lev if defined $lev;
  return $old;
}


# Äîáàâëÿåò ñîîáùåíèå îá îøèáêå ê ìàññèâó îøèáîê.
sub Warning($)
{ my ($msg)=@_;
  push(@Errors, $msg);
}


# Ïå÷àòàåò âñå íàêîïèâøèåñÿ ñîîáùåíèÿ îá îøèáêàõ.
# Ýòà ôóíêöèÿ âûçûâàåòñÿ â ìîìåíò, êîãäà STDOUT íàõîäèòñÿ â "ïîäâåøåííîì" ñîñòîÿíèè, 
# ïîýòîìó èñïîëüçîâàíèå print ÇÀÏÐÅÙÅÍÎ!!!
sub __PrintAllErrors()
{ local $^W = undef;
  # http://forum.dklab.ru/perl/symbiosis/Fastcgi+WeboutUtechkaPamyati.html
  if(!@Errors || !$ErrorReporting){
    @Errors=(); 
          return ; 
  }
  if (IsWebMode) {
    if ($ErrorReporting == ER_Err2Browser) {
      # ìàëî ëè, êàêèå òàì áûëè òàáëèöû...
      echo "</script>","</xmp>","</pre>","</table>"x6,"</tt>"x2,"</i>"x2,"</b>"x2,"</div>"x10,"\n";