—# -*- Mode: perl -*-
#
# $Id: Stdout.pm,v 0.1 2001/04/22 17:57:04 ram Exp $
#
# Copyright (c) 1998-2001, Raphael Manfredi
# Copyright (c) 2000-2001, Christophe Dehaudt
#
# You may redistribute only under the terms of the Artistic License,
# as specified in the README file that comes with the distribution.
#
# HISTORY
# $Log: Stdout.pm,v $
# Revision 0.1 2001/04/22 17:57:04 ram
# Baseline for first Alpha release.
#
# $EndLog$
#
use
strict;
package
CGI::MxScreen::Tie::Stdout;
#
# The purpose of this class is to trap all STDOUT output and redirect it
# to /dev/null until it is time for us to generate something, i.e. after
# headers have been emitted. This is meant as a safety guard to ignore
# any buggy HTML generation before ->display is called on the target screen.
#
# CGI::MxScreen normally unties STDOUT when it is about to generate headers.
# However, in exceptional circumstances, we may have errors generated before
# STDOUT could be untied. Therefore, the about-to-be-discarded data are
# inspected and if we see something looking like a header, we untie ourselves
# automatically.
#
require
Tie::Handle;
require
CGI::MxScreen::Tie::Sinkable;
@ISA
=
qw(Tie::Handle CGI::MxScreen::Tie::Sinkable)
;
use
Carp::Datum;
use
Log::Agent;
use
Symbol;
#
# (TIEHANDLE)
#
# Initial tieing.
#
sub
TIEHANDLE {
DFEATURE
my
$f_
;
my
$self
=
bless
gensym(),
shift
;
open
(
$self
,
">&STDOUT"
) || logdie
"can't save STDOUT: $!"
;
open
(STDOUT,
">/dev/null"
) || logdie
"can't reopen STDOUT: $!"
;
return
DVAL
$self
;
}
#
# (WRITE)
#
# Intercept writes
#
sub
WRITE {
DFEATURE
my
$f_
;
my
$self
=
shift
;
my
(
$buf
,
$len
,
$offset
) =
@_
;
return
DVOID
unless
$len
;
#
# If we see "Content-Type:", or something that looks like a header,
# then someone is trying to reply before we were untied explicitely.
# Let's become transparent by untie-ing ourselves.
#
# For this to work, we assume header names will be emitted in one single
# "print" statement, at least.
#
if
(
$buf
=~ /^[\w-]+:/m) {
logtrc
'info'
,
"header emitted, STDOUT becoming transparent"
;
untie
*main::STDOUT
;
$self
->CLOSE;
syswrite
(STDOUT,
$buf
,
$len
,
$offset
);
return
DVOID;
}
#
# Determine caller
#
my
(
$pkg
,
$filename
,
$line
);
my
$i
= 0;
do
{
(
$pkg
,
$filename
,
$line
) =
caller
(
$i
++)
}
while
(
$pkg
eq __PACKAGE__ ||
$pkg
eq
'Tie::Handle'
);
#
# Strip all trailing "\n" before logging.
#
$len
--
while
$len
&&
substr
(
$buf
,
$offset
+
$len
- 1, 1) =~ /^[\r\n]/;
logerr
"STDOUT discarded (at %s, line %d): %s"
,
$filename
,
$line
,
substr
(
$buf
,
$offset
,
$len
);
return
DVOID;
}
#
# (CLOSE)
#
# Restore orginal STDOUT
# NB: unties STDOUT as a side effect.
#
sub
CLOSE {
DFEATURE
my
$f_
;
my
$self
=
shift
;
logdie
"$self already closed"
unless
defined
fileno
(
$self
);
untie
*STDOUT
;
open
(STDOUT,
">&="
.
fileno
(
$self
)) || logdie
"can't restore STDOUT: $!"
;
close
$self
;
return
DVOID;
}
#
# (DESTROY)
#
# Destructor: closes original STDOUT if not already done.
#
sub
DESTROY {
DFEATURE
my
$f_
;
my
$self
=
shift
;
return
DVOID
unless
defined
fileno
(
$self
);
$self
->CLOSE;
return
DVOID;
}
1;
=head1 NAME
CGI::MxScreen::Tie::Stdout - Discard STDOUT output
=head1 SYNOPSIS
# Not meant to be used directly
=head1 DESCRIPTION
This class is used by C<CGI::MxScreen> to discard any STDOUT output made
until
the C<display()> routine is called. All discarded output is logged,
with
the origin of the call, identifying the culprit.
Upon an unexpected reception of something that looks like an HTTP header,
it automatically becomes transparent and removes itself.
=head1 AUTHOR
Raphael Manfredi F<E<lt>Raphael_Manfredi
@pobox
.comE<gt>>
=head1 SEE ALSO
CGI::MxScreen(3).