File Coverage

blib/lib/CGI/WebOut.pm

Criterion	Covered	Total	%
statement	135	263	51.3
branch	41	120	34.1
condition	10	21	47.6
subroutine	31	56	55.3
pod	14	25	56.0
total	231	485	47.6

#
# Ãàðàíòèðóåò, ÷òî âûâîä ÷åðåç print ìîæíî áåçîïàñíî íàïðàâèòü â áðàóçåð.
# Òî åñòü, áóôåðèçóåò åãî, ñëåäèò çà çàãîëîâêàìè, à òàêæå çà òåì, ÷òîáû
# çàãîëîâîê Content-type âñåãäà âûâîäèëñÿ ïåðåä òåêñòîì äîêóìåíòà.
# Ïîìèìî âñåãî ýòîãî, ñëåäèò çà îøèáêàìè, âîçíèêàþùèìè â ñêðèïòå, è
# ïåðåíàïðàâëÿåò èõ â áðàóçåð (â âèäå êîììåíòàðèåâ èëè âèäèìîãî òåêñòà).
# Òàêæå ïîçâîëÿåò âûáîðî÷íî ïåðåõâàòûâàòü âûõîäíîé ïîòîê ñêðèïòà äëÿ
# ïîñëåäóþùåé îáðàáîòêè: $text = grab { print "Hello" }.
# Â îáùåì, ïîëíàÿ ýìóëÿöèÿ ïîâåäåíèÿ PHP.
package CGI::WebOut;
our $VERSION = "2.25";

use strict;
use Exporter; our @ISA=qw(Exporter);
our @EXPORT=qw(
  ER_NoErr
  ER_Err2Browser
  ER_Err2Comment
  ER_Err2Plain
  ErrorReporting
  grab
  echo
  SetAutoflush
  NoAutoflush
  UseAutoflush
  Header
  HeadersSent
  Redirect
  ExternRedirect
  NoCache
  Flush
  try catch warnings throw
);


##
## Êîíñòàíòû
##
sub ER_NoErr { 0 }                # Çàïðåòèòü âûâîä îá îøèáêàõ
sub ER_Err2Browser { 1 }          # Îøèáêè è ïðåäóïðåæäåíèÿ íàïðàâèòü â áðàóçåð
sub ER_Err2Comment { 2 }          # Òî æå, íî â âèäå -êîììåíòàðèåâ
sub ER_Err2Plain { 3 }            # Òî æå, íî â âèäå plain-òåêñòà


##
## Âíóòðåííèå ïåðåìåííûå
##
#our $DEBUG = "/wo";              # îòëàäî÷íûé ðåæèì - çàäàåò èìÿ ôàéëà.
our $DEBUG = undef;              # îòëàäî÷íûé ðåæèì - çàäàåò èìÿ ôàéëà.
our $UseAutoflush = 1;           # Ðåæèì àâòîñáðîñà âêëþ÷åí
our $HeadersSent = 0;            # ïðèçíàê: çàãîëîâêè óæå ïîñëàíû
our @Headers = ();               # çàãîëîâêè îòâåòà
our $NoCached = 0;               # äîêóìåíò íå êýøèðóåòñÿ
our $Redirected = 0;             # áûëà ïåðåàäðåñàöèÿ
our $ErrorReporting = 1;         # âûâîä îøèáîê â áðàóçåð âêëþ÷åí
our @Errors = ();                # çäåñü íàêàïëèâàþòñÿ îøèáêè
our @Warns = ();                 # ïðåäóïðåæäåíèÿ

# Ê ñîæàëåíèþ, âìåñòî òîãî, ÷òîáû õðàíèòü òåêóùèé è êîðíåâîé ÎÁÚÅÊÒÛ âûâîäà,
# ïðèõîäèòñÿ õðàíèòü ëèøü ÑÒÐÎÊÎÂÛÅ ÁÓÔÅÐÀ. Äåëî â òîì, ÷òî õðàíåíèå îáúåêòà
# óâåëè÷èâàåò åãî ñ÷åò÷èê ññûëîê, à çíà÷èò, åñëè â ïðîãðàììå âñòðåòèòñÿ:
#   $b = new CGI::WebOut();
#   ...
#   $b = undef;
# òî äåñòðóêòîð äëÿ $b âûçâàí íå áóäåò (ò.ê. ññûëêà íà íåãî çàïèñàíà â $CurObj).
# Åñëè æå õðàíèòü â îáúåêòàõ ññûëêè íà ñòðîêîâûå áóôåðà, à ññûëêè íà ñàìè
# îáúåêòû äîïîëíèòåëüíî ÍÅ õðàíèòü, äåñòðóêòîð âûçûâàåòñÿ, êàê íàäî.
#
# Ýòî âñå òàêæå îçíà÷àåò, ÷òî ïîëó÷èòü â ýòîì ìîäóëå ññûëêó íà òåêóùèé
# ÎÁÚÅÊÒ ÂÛÂÎÄÀ íåëüçÿ íèêàê. Ìîæíî ëèøü ïîëó÷èòü ññûëêó íà åãî áóôåð.
# Òàêèì îáðàçîì, echo âñåãäà ðàáîòàåò ñî ñòðîêîâûì áóôåðîì, íî ÍÅ îáúåêòîì.
our $rRootBuf = \(my $s="");     # ãëàâíûé áóôåð âûâîäà
our $rCurBuf;                    # òåêóùèé áóôåð âûâîäà

#
# Algorythm is:
# 1. Tie STDOUT to newly created CGI::WebOut::Tie.
# 2. Constructor CGI::WebOut::Tie->RIEHANDLE creates new objecc CGI::WebOut
#    and stores its reference in its property. It is IMPORTANT that there
#    are NO other reserences to this object stored in some other place.
# 3. That's why, when STDOUT is untied (in END or during global destruction)
#    CGI::WebOut object is destroyed too.
# 4. In destructor CGI::WebOut->DESTROY works code: if this object is the
#    first (root), Flush() is called and errors are printed.
#


# Synopsis: use CGI::WebOut($restart=0)
# Ïðè ïîäêëþ÷åíèè ïðîâåðÿåò ñâÿçûâàíèå STDOUT è, åñëè ñâÿùàííîñòè íåò èëè
# îíà ïîìåíÿëàñü, óñòàíàâëèâàåò åå íà ñåáÿ.
#
# Âíèìàíèþ ïîëüçîâàòåëåé FastCGI: import ðàáîòàåò íå òàê, êàê õîòåëîñü áû.
# Íàïðèìåð, åñëè â öèêëå ñ äâóìÿ èòåðàöèÿìè íàïèñàòü use CGI::WebOut, òî
# ðåàëüíî import áóäåò âûçâàí òîëüêî 1 ðàç. Çàòî åñëè äâàæäû íàïèñàòü ýòó æå
# êîìàíäó, òî import âûçîâåòñÿ äâàæäû. Ãàðàíòèðîâàííî import çàïóñêàåòñÿ
# ñëåäóþùåé êîíñòðóêöèåé: eval("use CGI::WebOut(1)"). Åå ðåêîìåíäóåòñÿ
# âñòàâëÿòü âíóòðü öèêëà îáðàáîòêè ïîäêëþ÷åíèé FastCGI.
#
# Åñëè ïàðàìåòð $restart ðàâåí true, òî âñå ïðîèñõîäèò òàê, áóäòî áû
# çàãîëîâêè îòâåòà åùå íèêîãäà íå ïîñûëàëèñü.


##
## Îáùåäîñòóïíûå ñòàòè÷åñêèå ôóíêöèè.
##

# void retieSTDOUT($restart=false)
# Çàïîìèíàåì ñòàðûé STDOUT (äëèííîå íàçâàíèå - ñïåöèàëüíî, ÷òîáû íå
# çëîóïîòðåáëÿëè!) è óñòàíàâëèâàåò ñâîé ïåðåõâàò÷èê íà STDOUT.  ñëó÷àå,
# åñëè ñâîé ïåðåõâàò÷èê óæå óñòàíîâëåí, íè÷åãî íå äåëàåò.
my $numReties;
sub retieSTDOUT
{ my ($needRestart) = @_;
  $needRestart ||= !$numReties++;
  # Handle all warnings and errors.
  $SIG{__WARN__} = sub { &Warning(($_[0] !~ /^\w+:/ ? "Warning: " : "").shift) };
  $SIG{__DIE__} = sub { return if ref $_[0]; &Warning(($_[0] !~ /^\w+:/ ? "Fatal: " : "").shift) };
  # Åñëè íà÷àò íîâûé ñêðèïò, ñáðàñûâàåì ïðèçíàê îòñûëêè çàãîëîâêîâ.
  if ($needRestart) {
    $HeadersSent = $Redirected = $NoCached = 0;
    @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;
}


# static int echo(...)
# Âûâîäèò ñïèñîê àãðóìåíòîâ â ÒÅÊÓÙÈÉ àêòèâíûé áóôåð. Åñëè ýòîò
# áóôåð íàïðàâëåí íåïîñðåäñòâåííî â áðàóçåð, âûçûâàåò Flush().
# Âîçâðàùàåò ÷èñëî âûâåäåííûõ ñèìâîëîâ.
sub echo {
  #  ñëó÷àå íàëè÷èÿ undef-çíà÷åíèé â ñïèñêå äåëàåì òî æå,
  # ÷òî è print.
  if(grep {!defined $_} @_) {
    # Åñëè ìîäóëÿ íåò - íå ñòðàøíî, ïðîñòî íè÷åãî íå ïå÷àòàåòñÿ.
    eval { require Carp }
      and Carp::carp("Use of uninitialized value in print");
  }
  my $txt = join("", map { defined $_? $_:"" } @_);
  return if $txt eq "";
  $$rCurBuf .= $txt;
  Flush() if $UseAutoflush && $rCurBuf == $rRootBuf;
  return length($txt);
}


# Ïåðåõâàò âûõîäíîãî ïîòîêà. Èñïîëüçîâàíèå:
# $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--;
        next;
      }
      if ($Headers[$i]=~m/^location: /i) {
        $Redirected = 1;
      }
    }
    if (!$Redirected) {
      push(@Headers, "Content-type: $ContType");
      my $headers = join("\n",@Headers)."\n\n";
      # Prepend the output buffer with headers data.
      # So we output the buffer and headers in ONE print call (it is
      # more transparent for calling code if it ties STDOUT by himself).
      $$rRootBuf = $headers.$$rRootBuf;
    } else {
      # Only headers should be sent.
      my $headers = join("\n",@Headers)."\n\n";
      _RealPrint($headers);
    }
    $HeadersSent = 1;
  }
  # Îòïðàâèòü áóôåð è î÷èñòèòü åãî
  _Debug("Flush: len=%d", length($$rRootBuf));
  if (!$Redirected) {
    _RealPrint($$rRootBuf);
  }
  $$rRootBuf = "";
  return 1;
}


# constructor new($refToNewBuf=undef)
# Äåëàåò òåêóùèì íîâûé áóôåð âûâîäà.
sub new
{ my ($class, $rBuf)=@_;
  $rBuf = \(my $b="") if !defined $rBuf;
  my $this = bless {
    rPrevBuf => $rCurBuf,
    rCurBuf  => $rBuf,
  }, $class;
  $rCurBuf = $rBuf;
  _Debug("[%s] New: prevSt=%s, curSt=%s", $this, $this->{rPrevBuf}, $this->{rCurBuf});
  return $this;
}


# Âîññòàíàâëèâàåò ïðåäûäóùèé àêòèâíûé îáúåêò âûâîäà
sub DESTROY
{ my ($this)=@_;
  _Debug("[%s] DESTROY: prevSt=%s, curSt=%s", $this, $this->{rPrevBuf}, $this->{rCurBuf});

  # Åñëè ýòî ïîñëåäíèé îáúåêò, òî âûïîëíÿåì äåéñòâèÿ, êîòîðûå íóæíî îáÿçàòåëüíî
  # çàêîí÷èòü ê ìîìåíòó çàâåðøåíèÿ ïðîãðàììû. Òî åñòü, ýòîò ó÷àñòîê êîäà âûïîëíÿåòñÿ
  # òîãäà è òîëüêî òîãäà, êîãäà âûçûâàåòñÿ DESTROY äëÿ îáúåêòà, ñâÿçàííîãî ñ
  # STDOUT, òî åñòü ïåðåä ñàìûì çàâåðøåíèåì ïðîãðàììû (ïî îøèáêå èëè íåò - íå âàæíî).
  # Âñå ýòè ñëîæíîñòè íóæíû òîëüêî ïîòîìó, ÷òî, îêàçûâàåòñÿ, â Perl íåëüçÿ
  # îáúÿâèòü ôóíêöèþ, êîòîðàÿ áóäåò ãàðàíòèðîâàíî âûçûâàòüñÿ â êîíöå, îñîáåííî ïðè
  # ôàòàëüíîé îøèáêå... Îäíàêî ìîæíî ñîçäàòü íåêîòîðûé îáúåêò, êîòîðûé ïðè óíè÷òîæåíèè
  # âûçîâåò ñâîé äåñòðóêòîð. Òàêèì îáúåêòîì äëÿ íàñ áóäåò îáúåêò, ñâÿçàííûé
  # ñ STDOUT. Íàì ýòî æèçíåííî íåîáõîäèìî, ïîòîìó ÷òî íóæíî ëþáîé öåíîé âûâåñòè
  # çàãîëîâêè è, âîçìîæíî, ñîîáùåíèÿ î âîçíèêøèõ îøèáêàõ. Ýòî, ñîáñòâåííî, è
  # äåëàåòñÿ çäåñü.
  if ($rCurBuf == $rRootBuf) {
    # Âûçûâàåìàÿ îòñþäà ôóíêöèÿ ÍÅ ÌÎÆÅÒ èñïîëüçîâàòü print è STDOUT, ïîòîìó ÷òî
    # â ìîìåíò ïðîõîæäåíèÿ ýòîé òî÷êè STDOUT íè ê ÷åìó íå "ïðèâÿçàí", íî
    # Perl-ó êàæåòñÿ, ÷òî ïðèâÿçàí, ïîýòîìó ãåíåðèðóåòñÿ GP Fault.
    &__PrintAllErrors() if @Errors;
    Flush();
    return;
  }
  $rCurBuf = $this->{rPrevBuf};
}


# string method buf()
# Âûçûâàåòñÿ äëÿ ïîëó÷åíèÿ äàííûõ èç áóôåðà âûâîäà.
sub buf {
  return ${$_[0]->{rCurBuf}};
}



##
## Ñëóæåáíûå ôóíêöèè è ìåòîäû.
##

# constructor _newRoot()
# Creates the new ROOT (!!!) buffer. Called internally while tying STDOUT.
sub _newRoot {
  $$rRootBuf = "";
  $rCurBuf = undef;
  goto &new;
}


# Package import.
sub import {
  my ($pkg, $needRestart)=@_;
  retieSTDOUT($needRestart);
  goto &Exporter::import;
}


# Äåñòðóêòîð ïàêåòà. Ñëåäèò çà òåì, ÷òîáû âñå îáúåêòû áûëè óäàëåíû â
# ïðàâèëüíîì ïîðÿäêå. Âûçûâàåòñÿ ÄÎ ôàçû "global destruction", ÷òî
# íàì è íóæíî. Ïðàâäà, åñòü ñâåäåíèÿ, ÷òî èíîãäà END ÍÅ âûçûâàåòñÿ
# (â ñëó÷àå êàêèõ-òî îøèáîê), îäíàêî è â ýòîì ñëó÷àå âñå áóäåò ðàáîòàòü
# êîððåêòíî (ñì. _RealPrint).
sub END {
  return if !tied(*STDOUT) || ref tied(*STDOUT) ne __PACKAGE__."::Tie";
  CGI::WebOut::_Debug("CGI::WebOut::END");
  my $this = tied(*STDOUT);
  my ($handle, $obj) = ($this->{handle}, $this->{prevObj});
  CGI::WebOut::Tie::tieobj(*$handle, $obj)
}


# static _RealPrint()
# Prints the data to "native" STDOUT handler.
sub _RealPrint {
  my $obj = tied(*STDOUT);
  _Debug("_RealPrint: STDOUT tied: %s", $obj);
  my $txt = join("", @_);
  return if $txt eq "";
  if ($obj) {
    if (ref $obj eq "CGI::WebOut::Tie") {
      return $obj->parentPrint(@_)
    } else {
      print STDOUT @_;
    }
  } else {
    # Sometimes, during global destruction, STDOUT is already untied
    # but print still does not work. I don't know, why. This workaround
    # works always.
    open(local *H, ">&STDOUT");
    return print H @_;
  }
}


# Äëÿ îòëàäêè - âûâîäèò ñîîáùåíèå â ôàéë
my $opened;
sub _Debug {
  return if !$DEBUG;
  my ($msg, @args) = @_;

  # Detect "global destruction" stage.
  my $gd = '';
  {
    local $SIG{__WARN__} = sub { $gd .= $_[0] };
    warn("test");
    $gd =~ s/^.*? at \s+ .*? \s+ line \s+ \d+ \s+//sx;
    $gd =~ s/^\s+|[\s.]+$//sg;
    $gd = undef if $gd !~ /global\s*destruction/i;
  }
  local $^W;
  open(local *F, ($opened++? ">>" : ">").$DEBUG); binmode(F);
  print F sprintf($msg, map { defined $_? $_ : "undef" } @args) . ($gd? " ($gd)" : "")."\n";
}


##
## Äëÿ ïåðåõâàòà âûâîäà print-à
##

{{{
##
## This class is used to tie some Perl variable to specified $object
## WITHOUT calling TIE* method of ref($object). Unfortunately Perl
## does not support
##   tied(thing) = something;
## construction. Instead of this use:
##   tie(thing, "CGI::WebOut::TieMediator", something).
## See tieobj() below.
##
package CGI::WebOut::TieMediator;
#sub TIESCALAR { return $_[1] }
#sub TIEARRAY  { return $_[1] }
#sub TIEHASH   { return $_[1] }
sub TIEHANDLE { return $_[1] }
}}}


{{{
##
## This class is used to tie objects to filehandle.
## Synopsis:
##   tie(*STDOUT, "CGI::WebOut::Tie", \*STDOUT, tied(*STDOUT));
## All the parent methods is virtually inherited. So you
## may call print(*FH, ...), close(*FH, ...) etc.
## All the output is redirected to current CGI::WebOut object.
## This class is used internally by the main module.
##
package CGI::WebOut::Tie;

# The same as tie(), but ties existed object to the handle.
sub tieobj {
# return $_[1]? tie($_[0], "CGI::WebOut::TieMediator", $_[1]) : untie($_[0]);
  return tie($_[0], "CGI::WebOut::TieMediator", $_[1]);
}

## Fully overriden methods.
sub WRITE  { shift; goto &CGI::WebOut::echo; }
sub PRINT  { shift; goto &CGI::WebOut::echo; }
sub PRINTF { shift; @_ = sprintf(@_); goto &CGI::WebOut::echo; }

# Creates the new tie. Saves the old object and handle reference.
# See synopsis above.
sub TIEHANDLE
{ my ($cls, $handle, $prevObj) = @_;
  CGI::WebOut::_Debug("TIEHANDLE(%s, %s, %s)", $cls, $handle, $prevObj);
  return bless {
    handle  => $handle,
    prevObj => $prevObj,
    outObj  => CGI::WebOut->_newRoot($rRootBuf),
  }, $cls;
}

sub DESTROY {
  CGI::WebOut::_Debug("[%s] DESTROY", $_[0]);
}

## Methods, inherited from parent.
sub CLOSE
{ my ($this) = @_;
  CGI::WebOut::Flush();
  $this->parentCall(sub { close(*{$this->{handle}}) });
}
sub BINMODE
{ my ($this) = @_;
  $this->parentCall(sub { binmode(*{$this->{handle}}) });
}
sub FILENO
{ my ($this) = @_;
  # Do not call Flush() here, because it is incompatible with CGI::Session.
  # E.g. the following code will not work if Flush() is uncommented:
  #   use CGI::WebOut;
  #   use CGI::Session;
  #   my $session = new CGI::Session(...);
  #   SetCookie(...); # says that "headers are already sent"
  #CGI::WebOut::Flush();
  $this->parentCall(sub { return fileno(*{$this->{handle}}) });
  return 0;
}

# Untie process is fully transparent for parent. For example, code:
#   tie(*STDOUT, "T1");
#   eval "use CGI::WebOut"; #***
#   print "OK!";
#   untie(*STDOUT);
# generates EXACTLY the same sequence of call to T1 class, as this
# code without ***-marked line.
# Unfortunately we cannot retie CGI::WebOut::Tie back to the object
# in UNTIE() - when the sub finishes, Perl hardly remove tie.
our $doNotUntie = 0;
sub UNTIE
{ my ($this, $nRef) = @_;
  return if $doNotUntie;
  my $handle = $this->{handle};
  CGI::WebOut::_Debug("UNTIE prev=%s, cur=%s", $this->{prevObj}, tied(*$handle));
  # Destroy output object BEFORE untie parent.
  $this->{outObj} = undef;
  # Untie parent object.
  if ($this->{prevObj}) {
    tieobj(*$handle, $this->{prevObj});
    $this->{prevObj} = undef; # release ref
    untie(*$handle); # call parent untie
    $this->{prevObj} = tied(*$handle);
  }
}

# void method parentPrint(...)
# Prints using parent print method.
sub parentPrint
{ my $this = shift;
  my $params = \@_;
  CGI::WebOut::_Debug("parentPrint('%s')", join "", @$params);
  $this->parentCall(sub { print STDOUT @$params });
}

# void method parentCall($codeRef)
# Calls $codeRef in the context of object, previously tied to handle.
# After call context is switched back, as if nothing has happened.
# Returns the same that $codeRef had returned.
sub parentCall
{ my ($this, $sub) = @_;
  my ($handle, $obj) = ($this->{handle}, $this->{prevObj});
  my $save = tied(*$handle);
  if ($obj) {
    tieobj(*$handle, $obj)
  } elsif ($save) {
    local $doNotUntie = 1;
    local $^W;
    untie(*$handle);
  }
  CGI::WebOut::_Debug("parentCall for STDOUT=%s", $obj);
  my @result = eval { wantarray? $sub->() : scalar $sub->() };
  if ($save) {
    tieobj(*$handle, $save);
  } elsif ($obj) {
    local $doNotUntie = 1;
    local $^W;
    untie(*$handle);
  }
  return wantarray? @result : $result[0];
}
}}}


# Since v2.0 AutoLoader is not used.
#use AutoLoader 'AUTOLOAD';
#return 1;
#__END__


# Èñïîëüçîâàíèå try-catch-throw:
# try {
#   êîä, êîòîðûé ìîæåò âûëåòåòü ïî îøèáêå
#   èëè êîòîðûé ãåíåðèðóåò èñêëþ÷åíèå ñ ïîìîùüþ throw
# } catch {
#   èìÿ èñêëþ÷åíèÿ èëè ñîîáùåíèå îá îøèáêå - â $_
# } warnings {
#   ñïèñîê ïðîèçîøåäøèõ îøèáîê è ïðåäóïðåæäåíèé â @_
# }
# Áëîêè catch è warnings âûïîëíÿþòñÿ â ïîðÿäêå èõ ïîÿâëåíèÿ è ìîãóò îòñóòñòâîâàòü.
sub try (&;@)
{ my ($try,@Hand) = @_;
  # Ìû ÍÅ ìîæåì èñïîëüçîâàòü local äëÿ ñîõðàíåíèÿ @Errors ïî ñëåäóþùåé ïðèñèíå.
  # Åñëè â &$try âûâåäóòñÿ ïðåäóïðåæäåíèÿ, à ïîòîì áóäåò âûçâàí exit(),
  # òî äî êîíöà try() óïðàâëåíèå òàê è íå äîéäåò. Åñëè áû ìû èñïîëüçîâàëè
  # local, òî ýòè ïðåäóïðåæäåíèÿ â @Errors ïîòåðÿëèñü áû. Òàê êàê èñïîëüçóåòñÿ
  # ñîõðàíåíèå âî âðåìåííîé ïåðåìåííîé, ïðåäóïðåæäåíèÿ â @Errors îñòàíóòñÿ íà
  # ìåñòå è âûâåäóòñÿ íà ýêðàí.
  my @SvErrors = @Errors;
  # Çàïóñêàåì try-áëîê
  my @Result = eval { &$try };
  # Óïðàâëåíèå ïîïàëî ñþäà, åñëè âíóòðè êîäà íå áûëî âûçîâà exit().
  #  ïðîòèâíîì ñëó÷àå ïðîèñîäèò âûëåò èç ôóíêöèè è èç ïðîãðàììû.
  # Ïîëó÷àåì âñå âîçíèêøèå ïðåäóïðåæäåíèÿ. Ïðè÷åì çàïèñûâàåì èõ â
  # ïåðåìåííóþ òèïà local, ÷òîáû ýòà ïåðåìåííûÿ áûëà âèäíà âíóòðè
  # warnings-ôóíêöèè (ñì. íèæå).
  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 "","","","