File Coverage

blib/lib/Acme/InputRecordSeparatorIsRegexp.pm

Criterion	Covered	Total	%
statement	229	301	76.0
branch	73	114	64.0
condition	28	55	50.9
subroutine	32	36	88.8
pod	5	6	83.3
total	367	512	71.6

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) {
        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} = "";
	my @rec = splice @{$self->{records}};
	if (@rec && $self->{autochomp}) {
	    $self->chomp( @rec );
	}
	return @rec;
    }
    # want scalar
    if (!@{$self->{records}}) {
	$self->_populate_buffer;
    }
    my $rec = shift @{$self->{records}};
    if (defined($rec) && $self->{autochomp}) {
	$self->chomp( $rec );
    }
    return $rec;
}

sub _populate_buffer {
    my $self = shift;
    my $handle = $self->{handle};
    return if !$handle || eof($handle);

    my @rec;
    {
	my $buffer = '';
	my $n = read $handle, $buffer, $self->{bufsize};
	$self->{buffer} .= $buffer;
	@rec = $self->_split;
	redo if !eof($handle) && @rec == 1;
    }
    push @{$self->{records}}, @rec;
    $self->{buffer} = '';
    if (eof($handle)) {
	return;
    }

    if (@{$self->{records}} > 1) {
	$self->{buffer} = pop @{$self->{records}};
    }
    return;
}

sub EOF {
    my $self = shift;
    foreach my $rec (@{$self->{records}}, $self->{buffer}) {
	return if length($rec) > 0;
    }
    return eof($self->{handle});
}

sub _split {
    my $self = shift;
    if (!defined $self->{can_use_lookbehind}) {
	$self->_compile_rs;
    }
    my $rs = $self->{rsc};
    my @rec = split $rs, $self->{buffer};
    if ($self->{can_use_lookbehind}) {
	return @rec;
    } else {
	return grep length, @rec;
    }
}

sub CLOSE {
    my $self = shift;
    $self->_clear_buffer;
    my $z = close $self->{handle};
    # delete $self->{handle};
    return $z;
}

sub _clear_buffer {
    my $self = shift;
    $self->{buffer} = '';
    $self->{records} = [];
}

sub OPEN {
    my ($self, $mode, @args) = @_;
    if ($self->{handle}) {
	# close $self->{handle};
    }
    my $z = CORE::open $self->{handle}, $mode, @args;
    if ($z) {
	$self->_clear_buffer;
    }
    return $z;
}

sub FILENO {
    my $self = shift;
    return fileno($self->{handle});
}

sub WRITE {
    my ($self, $buf, $len, $offset) = @_;
    $offset ||= 0;
    if (!defined $len) {
	$len = length($buf)-$offset;
    }
    $self->PRINT( substr($buf,$offset,$len) );
}

sub PRINT {
    my ($self, @msg) = @_;
    if ($self->TELL() != tell($self->{handle})) {
	$self->SEEK(0,1);
    } else {
	$self->_clear_buffer;
    }
    print {$self->{handle}} @msg;
}

sub PRINTF {
    my ($self, $template, @args) = @_;
    $self->PRINT(sprintf($template,@args));
}

sub READ {
    my $self = shift;
    my $bufref = \$_[0];
    my (undef, $len, $offset) = @_;
    my $nread = 0;

    while ($len > 0 && @{$self->{records}}) {
	if (length($self->{records}[0])>=$len) {
	    my $rec = shift @{$self->{records}};
	    my $reclen = length($rec);
	    substr( $$bufref, $offset, $reclen, $rec);
	    $len -= $reclen;
	    $offset += $reclen;
	    $nread += $reclen;
	} else {
	    my $rec = substr($self->{records}[0], 0, $len, "");
	    substr( $$bufref, $offset, $len, $rec);
	    $offset += $len;
	    $nread += $len;
	    $len = 0;
	}
    }
    if ($len > 0 && length($self->{buffer}) > 0) {
	my $reclen = length($self->{buffer});
	if ($reclen >= $len) {
	    my $rec = substr( $self->{buffer}, 0, $len, "" );
	    substr( $$bufref, $offset, $len, $rec );
	    $offset += $len;
	    $nread += $len;
	    $len = 0;
	} else {
	    substr( $$bufref, $offset, $reclen, $self->{buffer} );
	    $self->{buffer} = "";
	    $offset += $reclen;
	    $nread += $reclen;
	    $len -= $reclen;
	}
    }
    if ($len > 0) {
	return $nread + read $self->{handle}, $$bufref, $len, $offset;
    } else {
	return $nread;
    }
}

sub GETC {
    my $self = shift;
    if (@{$self->{records}}==0 && 0 == length($self->{buffer})) {
	$self->_populate_buffer;
    }

    if (@{$self->{records}}) {
	my $c = substr( $self->{records}[0], 0, 1, "" );
	if (0 == length($self->{records}[0])) {
	    shift @{$self->{records}};
	}
	return $c;
    } elsif (0 != length($self->{buffer})) {
	my $c = substr( $self->{buffer}, 0, 1, "" );
	return $c;
    } else {
	# eof?
	return undef;
    }
}

sub BINMODE {
    my $self = shift;
    my $handle = $self->{handle};
    if (@_) {
	CORE::binmode $handle, @_;
    } else {
	CORE::binmode $handle;
    }
}

sub SEEK {
    my ($self, $pos, $whence) = @_;

    if ($whence == 1) {
	$whence = 0;
	$pos += $self->TELL;
    }

    # easy implementation:
    #     on any seek, clear records, buffer

    $self->_clear_buffer;
    seek $self->{handle}, $pos, $whence;

    # more sophisticated implementation
    #     on a seek forward, remove bytes from the front
    #     of buffered data
}

sub TELL {
    my $self = shift;
    # virtual cursor position is actual position on the file handle
    # minus the length of any buffered data
    my $tell = tell $self->{handle};
    $tell -= length($self->{buffer});
    $tell -= length($_) for @{$self->{records}};
    return $tell;
}


no warnings 'redefine';
sub IO::Handle::input_record_separator {
    my $self = shift;
    if (ref($self) eq 'GLOB' || ref(\$self) eq 'GLOB') {
        if (tied(*$self)) {
            if (ref(tied(*$self)) eq __PACKAGE__) {
                return input_record_separator($self,@_);
            }
            my $z = eval { (tied *$self)->input_record_separator(@_) };
            if ($@) {
                carp "input_record_separator is not supported on tied handle";
            }
            return $z;
        }
        if (!@_) { return $/ }
        $self = tie *$self, __PACKAGE__, $self, quotemeta($/);
        return input_record_separator($self,@_);
    } else {
        carp "input to input_record_separator was not a handle";
        return;
    }
}


sub input_record_separator {
    my $self = shift;
    if (ref($self) eq 'GLOB' || ref(\$self) eq 'GLOB') {
        if (!tied *$self) {
            if (!@_) {
                return IO::Handle::input_record_separator(*$self);
            }
            $self = tie *$self, __PACKAGE__, $self, quotemeta($/);
        } else {
            $self = tied *$self;
        }
    }
    if (@_) {
	$self->{rs} = shift;
	delete $self->{can_use_lookbehind};
    }
    $self->_compile_rs;
    return $self->{rs};
}

sub autochomp {
    my $self = shift;
    if (ref($self) eq 'GLOB' || ref(\$self) eq 'GLOB') {
        if (!tied *$self) {
            if (!@_) {
                return 0;
            }
            $self = tie *$self, __PACKAGE__, $self, quotemeta($/);
        } else {
            $self = tied *$self;
        }
    }
    my $val = $self->{autochomp} || 0;
    if (@_) {
        $self->{autochomp} = 0+!!$_[0];
    }
    return 0+$val;
}

sub chomp {
    my $self = shift;
    my $removed = 0;
    my $rs = $self->{rs};
    foreach my $line (@_) {
	$line =~ s/($rs)$//;
	if (defined($1)) {
	    $removed += length($1);
	}
    }
    return $removed;
}

1; #

__END__