view release on metacpan or  search on metacpan

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

    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) {
        return CORE::open(*$glob,$mode,$expr);
    } elsif ($mode) {
        return CORE::open(*$glob,$mode);
    } else {
        return CORE::open(*$glob);
    }
}

sub binmode (*;$) {
    my ($glob,$mode) = @_;
    $mode ||= ":raw";

    if (index($mode,":irs(") >= 0) {
        my $irs = _extract_irs($mode);
        input_record_separator($glob,$irs);
        return 1 unless $mode;
    }
    return CORE::binmode($glob,$mode);
}

sub _compile_rs {
    my $self = shift;
    my $rs = $self->{rs};

    my $q = eval { my @q = split /(?<=${rs})/,""; 1 };
    if ($q) {
	$self->{rsc} = qr/(?<=${rs})/s;
        if ($rs =~ /\?\^\w*m/) {
            $self->{rsc} = qr/(?<=${rs})/ms;
        }
	$self->{can_use_lookbehind} = 1;
    } else {
	$self->{rsc} = qr/(.*?(?:${rs}))/s;
        if ($rs =~ /\?\^\w*m/) {
            $self->{rsc} = qr/(.*?(?:${rs}))/ms;
        }
	$self->{can_use_lookbehind} = 0;
    }
    return;
}

sub READLINE {
    my $self = shift;
    if (wantarray) {
	local $/ = undef;
	$self->{buffer} .= readline($self->{handle});
	push @{$self->{records}}, $self->_split;
	$self->{buffer} = "";