view release on metacpan or  search on metacpan

lib/Test/File/Contents.pm  view on Meta::CPAN

sub files_eq_or_diff($$;$$) {
    my ($f1, $f2, $desc, $opts) = @_;
    ($opts, $desc) = ($desc, $opts) if ref $desc eq 'HASH';
    @_ = ($f1, $f2, $desc, $opts, sub {
        diff _resolve($f1), _resolve($f2), {
            CONTEXT     => $opts->{context},
            STYLE       => $opts->{style},
            FILENAME_A  => $f1,
            FILENAME_B  => $f2,
        };
    });
    goto &_files_eq;
}

sub _files_eq {
    my ($f1, $f2, $desc, $opts, $diag) = @_;
    ($opts, $desc) = ($desc, $opts) if ref $desc eq 'HASH';

    my @contents;
    for my $f ($f1, $f2) {
        my $file = _resolve($f);
        push @contents => _slurp($file, $opts->{encoding});
        next if defined $contents[-1];
        return $Test->ok(0, $desc)
            || $Test->diag("    Could not open file $file: $!");
    }

    return $Test->ok(
        $contents[0] eq $contents[1],
        $desc || "$f1 and $f2 contents are the same",
    ) || $Test->diag($diag->());
}

sub _compare {
    my $file = _resolve(shift);
    my ($code, $opts, $desc, $err) = @_;
    local $Test::Builder::Level = 2;
    my $contents = _slurp($file, $opts->{encoding});
    if (defined $contents) {
        return $Test->ok(scalar $code->($contents), $desc)
            || $Test->diag("    $err");
    } else {
        return $Test->ok(0, $desc)
            || $Test->diag("    Could not open file $file: $!");
    }
}

sub _slurp {
    my ($file, $encoding) = @_;
    my $layer = !$encoding  ? ''
        : $encoding =~ '^:' ? $encoding
        :                     ":encoding($encoding)";
    open my $fh, "<$layer", $file or return;
    return '' if eof $fh;
    # Don't use `local $/; return <$fh>;`, it does not work on Windows.
    # See https://rt.perl.org/Ticket/Display.html?id=127668 for details.
    return join '', <$fh>;
}

sub _resolve {
    $_[0] =~ m{/} ? File::Spec->catfile(split m{/}, shift) : shift;
}

1;

__END__

=pod

=head1 AUTHOR

Kirrily Robert

David E. Wheeler

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2016 by David E. Wheeler.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut