view release on metacpan or  search on metacpan

lib/Test/MockCommand/ScalarReadline.pm  view on Meta::CPAN

package Test::MockCommand::ScalarReadline;
use strict;
use warnings;
use Carp qw(croak);

require Exporter;
use vars qw(@ISA @EXPORT_OK);
@ISA = qw(Exporter);
@EXPORT_OK = qw(scalar_readline);

sub scalar_readline {
    croak "scalar context but no second parameter" unless wantarray() || @_ > 1;

    # return empty array or undef if there's no data
    if ((!defined $_[0]) || $_[0] eq '') {
	return () if wantarray();
	$_[1] = 0;
	return undef;
    }

    # slurp mode: $/ = undef
    if (not defined $/) {
	return ($_[0]) if wantarray();
	$_[1] = length $_[0];
	return $_[0];
    }

    # record mode: $/ = \$record_size
    if (ref $/ eq 'SCALAR' && ${$/} > 0) {
	# scalar wanted: return the first record
	if (! wantarray()) {
	    my $out = substr($_[0], 0, ${$/});
	    $_[1] = length $out;
	    return $out;
	}

	# list wanted: return all records
	my ($offset, $length, @out) = (0, length $_[0]);
	while ($offset < $length) {
	    push @out, substr($_[0], $offset, ${$/});
	    $offset += ${$/};
	}
	return @out;
    }

    # paragraph mode: $/ = ''
    my $rs = $/;
    my $paras = 0;
    if ($rs eq '') {
	$rs = "\n\n";
	$paras = 1;
    }

    # regular or paragraph mode: scalar wanted
    if (! wantarray()) {
	my $found = index $_[0], $rs;
	if ($found < 0) {
	    $_[1] = length $_[0];
	    return $_[0];
	}
	else {
	    $_[1] = $found + length $rs;
	    if ($paras) { while (substr($_[0], $_[1], 1) eq "\n") { $_[1]++; } }
	    return substr($_[0], 0, $found + length $rs);
	}
    }

    # regular or paragraph mode: list wanted
    my @out;
    my $pos = 0;
    while ((my $found = index $_[0], $rs, $pos) >= 0) {
	my $next = $found + length $rs;
	push @out, substr($_[0], $pos, $next - $pos);
	if ($paras) { while (substr($_[0], $next, 1) eq "\n") { $next++; } }
	$pos = $next;
    }
    push @out, substr($_[0], $pos) if $pos < length $_[0];

    return @out;
}

1;
__END__

=head1 NAME

Test::MockCommand::ScalarReadline - reads scalars using $/ behaviour

=head1 SYNOPSIS

 use Test::MockCommand::ScalarReadline qw(scalar_readline);

 my $s = "Hello\nWorld\n";

 $/ = "\n";  my @x = scalar_readline($s); # returns ("Hello\n", "World\n");
 $/ = "xyz"; my @x = scalar_readline($s); # returns ("Hello\nWorld\n");
 $/ = "or";  my @x = scalar_readline($s); # returns ("Hello\nWor", "ld\n");

 my $record_size = 3; $/ = \$record_size;
 my @x = scalar_readline($string); # returns ("Hel", "lo\n", "Wor", "ld\n");

 # can also be used in scalar context to get one line at a time
 my ($line, $chars_to_cut);
 while (defined ($line = scalar_readline($s, $chars_to_cut))) {
     # ...
     $s = substr($s, $chars_to_cut);