view release on metacpan or  search on metacpan

t/read-variations.inc  view on Meta::CPAN

    while ($go and @coderefs > 1) {
        my $code = shift @coderefs;
        $code->($fh, \$dest) or $go = 0;
        push @lno, $fh->input_line_number . "-" . $.;
        push @tell, $mytell->($fh);
        if ($go and length $dest and $do_ungetc) {
            $fh->ungetc( ord(substr $dest, -1, 1, '') );
            push @lno, $fh->input_line_number . "-" . $.;
            push @tell, $mytell->($fh);
        }
    }
    while ($go and $coderefs[0]->($fh, \$dest)) {
        push @lno, $fh->input_line_number . "-" . $.;
        push @tell, $mytell->($fh);
    }
    push @lno, $fh->input_line_number . "-" . $.;
    push @tell, $mytell->($fh);
    push @lno, $fh->input_line_number . "-" . $.;

    $tell_result_sequence{$is_io_coderef} = join ",", @tell;
    $lno_result_sequence{$is_io_coderef} = join ",", @lno;
    return $dest;
}

sub readsub {
    my $segs = shift;

    return unless @$segs;
    return shift @$segs;
}

sub segment_input {
    my ($str, $seglen) = @_;

    my @seg;
    while (length $str) {
        push @seg, substr $str, 0, $seglen, '';
    }
    return \@seg;
}

sub build_read_code {
    my ($use_sysread, $block_sizes) = @_;
    my $read = $use_sysread ? 'sysread' : 'read';

    my @readcode;

    unless ($use_sysread) {
        my @linewise_readcode = (
            '$_ = <$fh>; return unless defined; $$dest .= $_',
            '$_ = $fh->getline; return unless defined; $$dest .= $_',
            '$$dest .= join "", <$fh>; return',
            '$$dest .= join "", $fh->getlines; return',
        );
        @readcode = map( { {SrcCode => $_} }
            @linewise_readcode,
            map ({'local $/; '.$_} @linewise_readcode),
            map ({'local $/="oo"; '.$_} @linewise_readcode),
            '$_ = $fh->getc; return unless defined; $$dest .= $_',
        );
        push @readcode, map { {SrcCode => "local \$/=''; $_", ParaMode => 1} } @linewise_readcode;
    }

    my $readcall_template = <<'ENDCODE';
       my $got = __READCALL__;
       unless (defined $got) {
           $$dest = "*** FAIL: __READ__ returned undef ***";
           return;
       }
       $got or return;
       $$dest .= $_;
ENDCODE
    $readcall_template =~ s/__READ__/$read/g;
    foreach my $blocksize (@$block_sizes) {
        foreach my $readcall ("$read \$fh, \$_, $blocksize", "\$fh->$read(\$_, $blocksize)") {
            my $fullcode = $readcall_template;
            $fullcode =~ s/__READCALL__/$readcall/g;
            push @readcode, {SrcCode => $readcall, FullSrcCode => $fullcode};
        }
    }

    foreach my $rc (@readcode) {
        $rc->{FullSrcCode} ||= $rc->{SrcCode};
        my $src = "sub { my (\$fh, \$dest) = \@_ ; $rc->{FullSrcCode} ; return 1 }";
        $rc->{CodeRef} = eval $src;
        die "eval [$src]: $@" if $@;
    }

    return @readcode;
}

1;