[ID 20000325.010] warnings stuff

Here's a lexical warnings demo using with the sysreadline() function
that doubtless we've all written a zillion times.  It brings
up two matters about warnings::warn and warnings::enabled --

1) I think Perl need's a warn to pass one's caller's warnings
   mask to one's callees.  Otherwise, when you have a level
   of indirection as I have here, you lose everything.

2) How does one control carp/croak vs cluck/confess?  I seem to be
   getting the second set, but the source seems to show getting the
   first set.

--tom

use Symbol 'qualify_to_ref';

use Carp qw/:DEFAULT cluck/;
use strict;

sub sysreadline(*;$);
sub _readupto(*$;$);

sub sysreadline(*;$) {

    # HOW DO I get my caller's mask to pass to my child?
    # how come he doesn't percolate up through to a different
    # package?  oh.  cause it's lexical.  hm...

    if    (@_ == 1) { return _readupto($_[0], "\n")  } 
    elsif (@_ == 2) { return _readupto($_[0], "\n", $_[1])  } 
    else { confess "usage: \$data = sysreadline(FH, [timeout])" } 
    # XXX: don't break the proto!
}

sub _readupto(*$;$) {

    my $fh = qualify_to_ref(shift, caller);
    unless (defined fileno($fh)) { 
       # THIS DOES NOT "WORK" to get the right ones
       if (warnings::enabled("closed")) {
	   warnings::warn("closed", "sysreadline from closed filehandle\n");
       }
       return undef;
    }

    my $EOL = shift;
    my $timeout = @_ ? shift : undef;
    my $buffer = '';
    my $starttime = time();

    my($inmask,$outmask) = ('', '');
    vec($inmask, fileno($fh), 1) = 1;

    until (length($buffer) && substr($buffer, -length($EOL)) eq $EOL) { 
	unless (select($outmask = $inmask, undef, undef, $timeout)) {
	    return $buffer;
	} 
	$timeout -= time() - $starttime if defined $timeout;
	my $char;
	unless (sysread($fh, $char, 1)) {
	    return length($buffer) ? $buffer : undef;
	} 
	$buffer .= $char;
	last if defined $timeout && $timeout < 0;
    }
    return $buffer;
} 

my $pid = open(KID, "|-");
die "cannot fork: $!" unless defined $pid;
if ($pid) {
    select((select(KID), $|=1)[0]);
    print KID "ready "; 	    sleep 1;
    print KID "or not\nboys\nfor "; sleep 2;
    print KID "here we come!\n";    sleep 3;
    close KID;
    print "status $?\n";
    exit;
} 

# KID is below

# this doesn't work!
use warnings qw/FATAL io/;

my $data;
while (1) {
    $data = sysreadline(STDIN);

    #$data = sysreadline(STDIN,0.75);  # shows time-out argument
    #$data = sysreadline(XSTDIN);   # shows error on bad FH
    #$data = _readupto(STDIN,'r',0.5);

    unless (defined $data) {
	print "[End of file]\n";
	last;
    } 
    unless (length $data) {
	print "[Time out]\n";
	next;
    }
    print "child got <$data>\n";
} 

exit !close STDIN;

• Re: [ID 20000325.010] warnings stuff by Tom Christiansen
• [ID 20000325.010] warnings stuff by Tom Christiansen
• RE: [ID 20000325.010] warnings stuff by Marquess,P,Paul,NEL38 R
• Re: [ID 20000325.010] warnings stuff by Hugo