view release on metacpan or  search on metacpan

WebOut.pm  view on Meta::CPAN

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) {