view release on metacpan or  search on metacpan

lib/Acme/InputRecordSeparatorIsRegexp.pm  view on Meta::CPAN

package Acme::InputRecordSeparatorIsRegexp;

use 5.006;
use strict;
use warnings FATAL => 'all';
use Symbol;
use Carp;
use IO::Handle;
require Exporter;
our @ISA = 'Exporter';
our @EXPORT_OK = ('open','autochomp','input_record_separator','binmode');
our %EXPORT_TAGS = ( all =>  [ @EXPORT_OK ] );

BEGIN {
    no strict 'refs';
    *{ 'Acme::IRSRegexp' . "::" } = \*{ __PACKAGE__ . "::" };
}

our $VERSION = '0.07';

sub TIEHANDLE {
    my ($pkg, @opts) = @_;
    my $handle;
    if (@opts % 2) {
	$handle = Symbol::gensym;
    } else {
	my $fh = *{shift @opts};
        # will fail if open for $fh failed, but that's not important
	eval { CORE::open $handle, '<&+', $fh };
    }
    my $rs = shift @opts;
    my %opts = @opts;
    $opts{maxrecsize} ||= ($opts{bufsize} || 16384) / 4;
    $opts{bufsize} ||= $opts{maxrecsize} * 4;
    my $self = bless {
	%opts,
	handle => $handle,
	rs => $rs,
	records => [],
	buffer => ''
    }, $pkg;
    $self->_compile_rs;
    return $self;
}

# We abuse the PerlIO layers syntax to attach
# a regexp specification to a filehandle. This
# function extracts an ':irs(REGEXP)' layer from
# a string.
sub _extract_irs {
    my ($mode) = @_;
    
    my $irs = "";
    my $p0 = index($mode,":irs(");
    my $p1 = $p0 + 5;
    my $nest = 1;
    while ($nest) {
        my $c = eval { substr($mode,$p1++,1) };
        if ($@ || !defined($c)) {
            carp "Argument list not closed for PerlIO layer \"$irs\"";
            return;
        }
        if ($c eq "\\") {
            $c .= substr($mode,$p1++,1);
        }
        if ($c eq "(") { $nest++ }
        if ($c eq ")") { $nest-- }
        if ($nest) { $irs .= $c; }
    }
    substr($mode,$p0,length($irs)+6, "");
    $_[0] = $mode;
    return $irs;
}

sub open (*;$@) {
    no strict 'refs';        # or else bareword file handles will break
    my (undef,$mode,$expr,@list) = @_;
    if (!defined $_[0]) {
        $_[0] = Symbol::gensym;
    }
    my $glob = $_[0];
    if (!ref($glob) && $glob !~ /::/) {
        $glob = join("::",caller(0) || "", $glob);
    }

    if ($mode && index($mode,":irs(") >= 0) {
        my $irs = _extract_irs($mode);
        my $z = @list ? CORE::open *$glob, $mode, $expr, @list
                      : CORE::open *$glob, $mode, $expr;
        tie *$glob, __PACKAGE__, *$glob, $irs;
        return $z;
    }
    if (@list) {
        return CORE::open(*$glob,$mode,$expr,@list);
    } elsif ($expr) {