view release on metacpan or  search on metacpan

WebOut.pm  view on Meta::CPAN

  $$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};
}

WebOut.pm  view on Meta::CPAN

## 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];
}