The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use strict;
use warnings;

use lib 't/lib';

use Test::AnyOf;
use Test::More 0.88;

use File::LibMagic;

{
    my %standard = (
        'foo.foo' => [
            'ASCII text',
            qr{text/plain},
            qr{us-ascii},
        ],
        'foo.c' => [
            [ 'ASCII C program text', 'C source, ASCII text' ],
            qr{text/x-c},
            qr{us-ascii},
        ],
    );

    my $flm = File::LibMagic->new();

    subtest(
        'standard magic file',
        sub {
            isa_ok( $flm, 'File::LibMagic' );
            _test_flm( $flm, \%standard );
        }
    );
}

{
    my %custom = (
        'foo.foo' => [
            'A foo file',
            qr{text/plain},
            qr{us-ascii},
        ],
        'foo.c' => [
            [ 'ASCII text', 'ASCII C program text', 'C source, ASCII text' ],
            qr{text/(?:plain|(?:x-)?c)},
            qr{us-ascii},
        ],
    );

    my $flm = File::LibMagic->new('t/samples/magic');

    subtest(
        'custom magic file',
        sub {
            isa_ok( $flm, 'File::LibMagic' );
            _test_flm( $flm, \%custom );
        }
    );
}

sub _test_flm {
    my $flm   = shift;
    my $tests = shift;

    for my $file ( sort keys %{$tests} ) {
        my $path = "t/samples/$file";

        subtest(
            'old API',
            sub { _test_old_oo_api( $flm, $path, @{ $tests->{$file} } ); },
        );

        subtest(
            'new API',
            sub { _test_new_oo_api( $flm, $path, @{ $tests->{$file} } ); },
        );
    }
}

sub _test_old_oo_api {
    my $flm      = shift;
    my $file     = shift;
    my $desc     = shift;
    my $mime     = shift;
    my $encoding = shift;

    like(
        $flm->checktype_filename($file),
        qr/$mime(?:; charset=$encoding)?/,
        "checktype_filename $file"
    );

    is_any_of(
        $flm->describe_filename($file),
        ref $desc ? $desc : [$desc],
        "describe_filename $file",
    );

    my $data = do {
        local $/;
        open my $fh, '<', $file or die $!;
        <$fh>;
    };

    like(
        $flm->checktype_contents($data),
        qr/$mime(?:; charset=$encoding)?/,
        "checktype_contents $file"
    );

    like(
        $flm->checktype_contents( \$data ),
        qr/$mime(?:; charset=$encoding)?/,
        "checktype_contents $file as ref"
    );

    is_any_of(
        $flm->describe_contents($data),
        ref $desc ? $desc : [$desc],
        "describe_contents $file"
    );

    is_any_of(
        $flm->describe_contents( \$data ),
        ref $desc ? $desc : [$desc],
        "describe_contents $file as ref"
    );
}

sub _test_new_oo_api {
    my $flm  = shift;
    my $file = shift;
    my @args = @_;

    subtest(
        "info_from_filename $file",
        sub {
            _test_info( $flm->info_from_filename($file), @args );
        },
    );

    subtest(
        "info_from_string $file",
        sub {
            open my $fh, '<', $file or die $!;
            my $string = do { local $/; <$fh> };
            close $fh;
            _test_info( $flm->info_from_string($string), @args );
        },
    );

    subtest(
        "info_from_string $file as ref",
        sub {
            open my $fh, '<', $file or die $!;
            my $string = do { local $/; <$fh> };
            close $fh;
            _test_info( $flm->info_from_string( \$string ), @args );
        },
    );

    subtest(
        "info_from_handle $file",
        sub {
            open my $fh, '<', $file or die $!;
            _test_info( $flm->info_from_handle($fh), @args );
            my $content = do { local $/; <$fh> };
            ok(
                length $content,
                'info_from_handle resets pos after reading'
            );
        },
    );

    subtest(
        "info_from_handle $file - handle from scalar ref",
        sub {
            open my $fh, '<', $file or die $!;
            my $string = do { local $/; <$fh> };
            close $fh;

            open $fh, '<', \$string;
            _test_info( $flm->info_from_handle($fh), @args );
        },
    );
}

sub _test_info {
    my $info     = shift;
    my $desc     = shift;
    my $mime     = shift;
    my $encoding = shift;

    is_any_of(
        $info->{description},
        ref $desc ? $desc : [$desc],
        'description'
    );

    like(
        $info->{mime_type},
        qr/$mime/,
        'mime_type',
    );

    like(
        $info->{encoding},
        $encoding,
        'encoding'
    );

    like(
        $info->{mime_with_encoding},
        qr/$mime; charset=$encoding/,
        'mime_with_encoding'
    );
}

{
    {
        package My::Magic::Subclass;

        use base qw( File::LibMagic );

        sub checktype_filename { 'text/x-test-passes' }
    }

    subtest(
        'subclass of File::LibMagic',
        sub {
            my $subclass = My::Magic::Subclass->new();
            isa_ok( $subclass, 'My::Magic::Subclass' );
            is(
                $subclass->checktype_filename('t/samples/missing'),
                'text/x-test-passes',
                'checktype_filename is overridden'
            );
        }
    );
}

done_testing();