File Coverage

blib/lib/Test/MockCommand/ScalarReadline.pm

Criterion	Covered	Total	%
statement	61	61	100.0
branch	24	26	92.3
condition	6	9	66.6
subroutine	5	5	100.0
pod	0	1	0.0
total	96	102	94.1

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__