Acme-InputRecordSeparatorIsRegexp
view release on metacpan or search on metacpan
lib/Acme/InputRecordSeparatorIsRegexp.pm view on Meta::CPAN
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;
}
lib/Acme/InputRecordSeparatorIsRegexp.pm view on Meta::CPAN
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;
}
lib/Acme/InputRecordSeparatorIsRegexp.pm view on Meta::CPAN
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;
lib/Acme/InputRecordSeparatorIsRegexp.pm view on Meta::CPAN
$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;
lib/Acme/InputRecordSeparatorIsRegexp.pm view on Meta::CPAN
}
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;
lib/Acme/InputRecordSeparatorIsRegexp.pm view on Meta::CPAN
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__) {
lib/Acme/InputRecordSeparatorIsRegexp.pm view on Meta::CPAN
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__
=head1 NAME
lib/Acme/InputRecordSeparatorIsRegexp.pm view on Meta::CPAN
L<"open"> function, for example:
my $th = Acme::InputRecordSeparatorIsRegexp->open( $regex, '<', $filename,
{ bufsize => 65336 } );
=head2 bufsize
The amount of data, in bytes, to read from the input stream at
a time. For performance reasons, this should be at least a few kilobytes.
B<For the module to work correctly, it should also be much larger
than the length of any sequence of characters that could be construed
as a line ending.>
=head1 ALIAS
The package C<Acme::IRSRegexp> is an alias for
C<Acme::InputRecordSeparatorIsRegexp>, allowing you to write
use Acme::InputRecordSeparatorIsRegexp;
tie *$fh, 'Acme::IRSRegexp',
lib/Acme/InputRecordSeparatorIsRegexp.pm view on Meta::CPAN
test plan:
read methods
------------
READLINE
scalar context
list context
READ
with and without offset
length < = > buffer allocated
before and after populate buffer (i.e., after scalar READLINE)
GETC
with and without populated buffer (after SCALAR READLINE)
at eof
EOF
with buffer populated
SEEK & TELL
move around, keep reading
t/02-readline.t view on Meta::CPAN
ok($z, 'open ok');
ok($t->{handle} && $t->{handle} ne *$fh, 'handle internals set after open');
ok(fileno($fh), '$fh has fileno');
my %le;
my $last;
while (<$fh>) {
$zz .= $_;
if ($last) {
ok($last =~ /123$/ || $last =~ /V45$/ || $last =~ /X67$/,
'correct line ending')
or diag length($last), $last;
}
$le{ substr($_, -3) }++;
$last = $_;
}
ok($yy eq $zz, 'output equals expected input');
my $x = <$fh>;
ok(!defined($x), 'no read on exhausted filehandle');
$z = close $fh;
ok($z, 'CLOSE ok');
$x = <$fh>;
t/03-seektell.t view on Meta::CPAN
my (@tell, @seek);
push @tell, tell($fh);
while (<$fh>) {
push @seek, $_;
push @tell, tell($fh);
if (@seek > 1) {
ok( $seek[-2] =~ /1.3$/ || $seek[-2] =~ /T.4$/ ||
$seek[-2] =~ /E....D$/, 'correct line ending' )
or diag $seek[-2], "\n\n", $seek[-1],
"\n\n", length($seek[-2]),"\t",length($seek[-1]);
}
}
# don't close
while (@seek) {
my $i = int(rand(@seek));
my $t = splice @tell, $i, 1;
my $s = splice @seek, $i, 1;
seek($fh, $t, 0);
t/03b-seektell.t view on Meta::CPAN
my (@tell, @seek);
push @tell, tell($fh);
while (<$fh>) {
push @seek, $_;
push @tell, tell($fh);
if (@seek > 1) {
ok( $seek[-2] =~ /1.3$/ || $seek[-2] =~ /T.4$/ ||
$seek[-2] =~ /E....D$/, 'correct line ending' )
or diag $seek[-2], "\n\n", $seek[-1],
"\n\n", length($seek[-2]),"\t",length($seek[-1]);
}
}
# don't close
while (@seek) {
my $i = int(rand(@seek));
my $t = splice @tell, $i, 1;
my $s = splice @seek, $i, 1;
seek($fh, $t, 0);
t/04-longline.t view on Meta::CPAN
use Test::More;
use Acme::InputRecordSeparatorIsRegexp 'open';
use strict;
use warnings;
# handle the case where the length of a record is much larger
# than the size of the read buffer
my $yy = "";
for (1..20) {
$yy .= "x" x 9999;
if (rand() < 0.333333) {
$yy .= "\n";
} elsif (rand() < 0.5) {
$yy .= "\r";
} else {
t/04-longline.t view on Meta::CPAN
my (@tell, @seek);
push @tell, tell($fh);
while (<$fh>) {
push @seek, $_;
push @tell, tell($fh);
if (@seek > 1) {
ok( $seek[-2] =~ /[\r\n]$/, 'correct line ending' )
or diag $seek[-2], "\n\n", $seek[-1],
"\n\n", length($seek[-2]),"\t",length($seek[-1]);
}
}
# don't close
while (@seek) {
my $i = int(rand(@seek));
my $t = splice @tell, $i, 1;
my $s = splice @seek, $i, 1;
seek($fh, $t, 0);
t/04b-longline.t view on Meta::CPAN
use Test::More;
use Acme::InputRecordSeparatorIsRegexp 'binmode';
use strict;
use warnings;
# handle the case where the length of a record is much larger
# than the size of the read buffer
if ($] < 5.010000) {
diag "readline on this package is sloooow for Perl $]. ",
"Skipping this set of tests which is a near duplicate of ",
"another set of tests.";
ok(1, "# skip $0 tests on Perl $]");
done_testing();
exit;
}
t/04b-longline.t view on Meta::CPAN
my (@tell, @seek);
push @tell, tell($fh);
while (<$fh>) {
push @seek, $_;
push @tell, tell($fh);
if (@seek > 1) {
ok( $seek[-2] =~ /[\r\n]$/, 'correct line ending' )
or diag $seek[-2], "\n\n", $seek[-1],
"\n\n", length($seek[-2]),"\t",length($seek[-1]);
}
}
# don't close
while (@seek) {
my $i = int(rand(@seek));
my $t = splice @tell, $i, 1;
my $s = splice @seek, $i, 1;
seek($fh, $t, 0);
t/05-readwrite.t view on Meta::CPAN
}
ok(tell($fh) == 4 * 300, "tell correct after print statements");
$z = seek $fh, 100, 0;
ok($z, 'seek said it was successful');
ok(tell($fh) == 100, 'tell/seek consistent');
my $c = getc($fh);
ok($c eq 'y', 'found "y" as expected at 100 position');
ok(tell($fh) == 101, "tell=101 after read 1 char");
my $x = <$fh>;
ok(defined($x), "readline ok");
ok(length($x) == 99, "read line has correct length");
ok($x =~ /y\n$/, "read line has expected line ending");
ok(tell($fh) == 200, 'got tell after readline');
my $newmsg = "A new message at pos 200\n";
$z = print $fh $newmsg;
ok($z, 'print ok');
$x = <$fh>;
ok(defined($x), 'readline after print ok');
ok(length($x) == 100 - length($newmsg), 'expected line length')
or diag length($x)," ",$x;
ok($x =~ /z\r\n/, 'expected line ending');
$z = seek($fh,0,0);
ok($z, 'seek 0,0 ok');
ok(tell($fh) == 0, 'seek 0 0 worked');
$x = <$fh>;
ok($x =~ /xxxx\r$/, 'read line correctly');
ok(tell($fh) == 100, 'tell correct after 1 readline');
$x = <$fh>;
ok($x =~ /yyyyy\n$/, 'read line 2');
ok(tell($fh) == 200, 'tell after 2 readline');
$x = <$fh>;
ok($x eq $newmsg, 'read line 3: new message');
ok(tell($fh) == 200 + length($newmsg), 'tell after 3 newline');
$x = <$fh>;
ok($x =~ /zzz\r\n$/, 'readline 4');
ok(tell($fh) == 300, 'tell after 4 readline');
ok(close $fh, 'close ok');
ok(unlink "t/test05.txt", 'remove test file');
done_testing();
t/06-DATA.t view on Meta::CPAN
my (@tell, @seek);
push @tell, tell(DAT);
while (<DAT>) {
push @seek, $_;
push @tell, tell(DAT);
if (@seek > 1) {
ok( $seek[-2] =~ /1.43$/ || $seek[-2] =~ /T.44$/ ||
$seek[-2] =~ /E....XD$/, 'correct line ending' )
or diag $seek[-2], "\n\n", $seek[-1],
"\n\n", length($seek[-2]),"\t",length($seek[-1]);
}
}
# don't close
while (@seek) {
my ($s,$t);
my $i = int(rand(@seek));
$t = splice @tell, $i, 1;
$s = splice @seek, $i, 1;
t/06b-DATA.t view on Meta::CPAN
my (@tell, @seek);
push @tell, tell(DATA);
while (<DATA>) {
push @seek, $_;
push @tell, tell(DATA);
if (@seek > 1) {
ok( $seek[-2] =~ /1.43$/ || $seek[-2] =~ /T.44$/ ||
$seek[-2] =~ /E....XD$/, 'correct line ending' )
or diag $seek[-2], "\n\n", $seek[-1],
"\n\n", length($seek[-2]),"\t",length($seek[-1]);
}
}
# don't close
while (@seek) {
my ($s,$t);
my $i = int(rand(@seek));
$t = splice @tell, $i, 1;
$s = splice @seek, $i, 1;
t/07-memory.t view on Meta::CPAN
my (@tell, @seek);
push @tell, tell($fh);
while (<$fh>) {
push @seek, $_;
push @tell, tell($fh);
if (@seek > 1) {
ok( $seek[-2] =~ /1.3$/ || $seek[-2] =~ /T.4$/ ||
$seek[-2] =~ /E....D$/, 'correct line ending' )
or diag $seek[-2], "\n\n", $seek[-1],
"\n\n", length($seek[-2]),"\t",length($seek[-1]);
}
}
while (@seek) {
my $i = int(rand(@seek));
my $t = splice @tell, $i, 1;
my $s = splice @seek, $i, 1;
seek($fh, $t, 0);
my $u = readline($fh);
t/07b-memory.t view on Meta::CPAN
my (@tell, @seek);
push @tell, tell($fh);
while (<$fh>) {
push @seek, $_;
push @tell, tell($fh);
if (@seek > 1) {
ok( $seek[-2] =~ /1.3$/ || $seek[-2] =~ /T.4$/ ||
$seek[-2] =~ /E....D$/, 'correct line ending' )
or diag $seek[-2], "\n\n", $seek[-1],
"\n\n", length($seek[-2]),"\t",length($seek[-1]);
}
}
while (@seek) {
my $i = int(rand(@seek));
my $t = splice @tell, $i, 1;
my $s = splice @seek, $i, 1;
seek($fh, $t, 0);
my $u = readline($fh);
t/08-chomp.t view on Meta::CPAN
use Test::More;
use Acme::InputRecordSeparatorIsRegexp 'open';
use strict;
use warnings;
# handle the case where the length of a record is much larger
# than the size of the read buffer
my $yy = "";
for (1..20) {
$yy .= "x" x 9999;
if (rand() < 0.333333) {
$yy .= "\n";
} elsif (rand() < 0.5) {
$yy .= "\r";
} else {
t/08-chomp.t view on Meta::CPAN
my (@tell, @seek);
push @tell, tell($fh);
while (<$fh>) {
push @seek, $_;
push @tell, tell($fh);
if (@seek > 1) {
ok( $seek[-2] =~ /[\r\n]$/, 'correct line ending' )
or diag $seek[-2], "\n\n", $seek[-1],
"\n\n", length($seek[-2]),"\t",length($seek[-1]);
my $x = $seek[-2];
my $u = tied(*$fh)->chomp($x);
ok($u==1 || $u==2, 'chomp line');
ok($x !~ /[\r\n]$/, 'line ending was chomped')
or diag "\$u on failed chomp was $u\n";
ok(length($x) == 9999, 'length after chomp');
}
}
# don't close
while (@seek) {
my $i = int(rand(@seek));
my $t = splice @tell, $i, 1;
my $s = splice @seek, $i, 1;
seek($fh, $t, 0);
t/08b-chomp.t view on Meta::CPAN
use Test::More;
use Acme::InputRecordSeparatorIsRegexp 'binmode';
use strict;
use warnings;
# handle the case where the length of a record is much larger
# than the size of the read buffer
my $yy = "";
for (1..20) {
$yy .= "x" x 9999;
if (rand() < 0.333333) {
$yy .= "\n";
} elsif (rand() < 0.5) {
$yy .= "\r";
} else {
t/08b-chomp.t view on Meta::CPAN
my (@tell, @seek);
push @tell, tell($fh);
while (<$fh>) {
push @seek, $_;
push @tell, tell($fh);
if (@seek > 1) {
ok( $seek[-2] =~ /[\r\n]$/, 'correct line ending' )
or diag $seek[-2], "\n\n", $seek[-1],
"\n\n", length($seek[-2]),"\t",length($seek[-1]);
my $x = $seek[-2];
my $u = tied(*$fh)->chomp($x);
ok($u==1 || $u==2, 'chomp line');
ok($x !~ /[\r\n]$/, 'line ending was chomped')
or diag "\$u on failed chomp was $u\n";
ok(length($x) == 9999, 'length after chomp');
}
}
# don't close
while (@seek) {
my $i = int(rand(@seek));
my $t = splice @tell, $i, 1;
my $s = splice @seek, $i, 1;
seek($fh, $t, 0);
t/09-autochomp.t view on Meta::CPAN
use Test::More;
use Acme::InputRecordSeparatorIsRegexp 'open','autochomp';
use strict;
use warnings;
# handle the case where the length of a record is much larger
# than the size of the read buffer
my $yy = "";
for (1..20) {
$yy .= "x" x 9999;
if (rand() < 0.333333) {
$yy .= "\n";
} elsif (rand() < 0.5) {
$yy .= "\r";
} else {
t/09-autochomp.t view on Meta::CPAN
my (@tell, @seek);
push @tell, tell($fh);
while (<$fh>) {
push @seek, $_;
push @tell, tell($fh);
if (@seek > 1) {
ok( $seek[-2] !~ /[\r\n]$/, 'line ending was chomped' )
or diag $seek[-2], "\n\n", $seek[-1],
"\n\n", length($seek[-2]),"\t",length($seek[-1]);
ok( length($seek[-2]) == 9999, 'autochomped line length' );
my $x = $seek[-2];
my $u = tied(*$fh)->chomp($x);
ok($u==0, 'chomp return value for already chomped');
ok($x eq $seek[-2], 'already chomped line not changed');
}
}
# don't close
t/09b-autochomp.t view on Meta::CPAN
use Test::More;
use Acme::InputRecordSeparatorIsRegexp 'binmode','autochomp';
use strict;
use warnings;
# handle the case where the length of a record is much larger
# than the size of the read buffer
my $yy = "";
for (1..20) {
$yy .= "x" x 9999;
if (rand() < 0.333333) {
$yy .= "\n";
} elsif (rand() < 0.5) {
$yy .= "\r";
} else {
t/09b-autochomp.t view on Meta::CPAN
my (@tell, @seek);
push @tell, tell($fh);
while (<$fh>) {
push @seek, $_;
push @tell, tell($fh);
if (@seek > 1) {
ok( $seek[-2] !~ /[\r\n]$/, 'line ending was chomped' )
or diag $seek[-2], "\n\n", $seek[-1],
"\n\n", length($seek[-2]),"\t",length($seek[-1]);
ok( length($seek[-2]) == 9999, 'autochomped line length' );
my $x = $seek[-2];
my $u = tied(*$fh)->chomp($x);
ok($u==0, 'chomp return value for already chomped');
ok($x eq $seek[-2], 'already chomped line not changed');
}
}
# don't close
t/10-input-record-separator.t view on Meta::CPAN
use Test::More;
use Acme::InputRecordSeparatorIsRegexp ':all';
use strict;
use warnings;
# handle the case where the length of a record is much larger
# than the size of the read buffer
my $yy = "";
my $xx = "AAA";
my $ii = 0;
while (length($xx) < 4) {
for (1..500) {
$yy .= $ii++ . ":" . $xx++
}
if (rand() < 0.333333) {
$yy .= "\n";
} elsif (rand() < 0.5) {
$yy .= "\r";
} else {
$yy .= "\r\n";
}
t/10-input-record-separator.t view on Meta::CPAN
my $correct = 0;
my $incorrect = 0;
while (<$f4>) {
push @seek, $_;
push @tell, tell($f4);
if (@seek > 1) {
if ($seek[-2] =~ /[\r\n]$/) {
$correct++;
} else {
diag $seek[-2], "\n\n", $seek[-1],
"\n\n", length($seek[-2]),"\t",length($seek[-1]);
$incorrect++;
}
}
}
ok($correct > 0 && $incorrect == 0, 'all line endings correct');
while (@seek) {
my $i = int(rand(@seek));
my $t = splice @tell, $i, 1;
my $s = splice @seek, $i, 1;
t/10b-input-record-separator.t view on Meta::CPAN
use Test::More;
use Acme::InputRecordSeparatorIsRegexp ':all';
use strict;
use warnings;
# handle the case where the length of a record is much larger
# than the size of the read buffer
my $yy = "";
my $xx = "AAA";
my $ii = 0;
while (length($xx) < 4) {
for (1..500) {
$yy .= $ii++ . ":" . $xx++
}
if (rand() < 0.333333) {
$yy .= "\n";
} elsif (rand() < 0.5) {
$yy .= "\r";
} else {
$yy .= "\r\n";
}
t/10b-input-record-separator.t view on Meta::CPAN
my $correct = 0;
my $incorrect = 0;
while (<$f4>) {
push @seek, $_;
push @tell, tell($f4);
if (@seek > 1) {
if ($seek[-2] =~ /[\r\n]$/) {
$correct++;
} else {
diag $seek[-2], "\n\n", $seek[-1],
"\n\n", length($seek[-2]),"\t",length($seek[-1]);
$incorrect++;
}
}
}
ok($correct > 0 && $incorrect == 0, 'all line endings correct');
while (@seek) {
my $i = int(rand(@seek));
my $t = splice @tell, $i, 1;
my $s = splice @seek, $i, 1;
( run in 0.793 second using v1.01-cache-2.11-cpan-65fba6d93b7 )