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

use Test::More;

use File::Spec;
use File::Temp qw( tempdir );
use Log::Dispatch;
use Log::Dispatch::File::Locked;
use POSIX qw( :sys_wait_h );
use Try::Tiny;

my $ChildCount = 10;
for my $close_after_write ( 0, 1 ) {
    my @v = _run_children($close_after_write);
    subtest(
        "close_after_write = $close_after_write",
        sub {
            _test_file_locked(@v);
        }
    );
}

done_testing();

sub _run_children {
    my $close_after_write = shift;

    my $dir = tempdir( CLEANUP => 1 );
    my $file = File::Spec->catfile( $dir, 'lock-test.log' );

    my $logger = _dispatch_for_file( $close_after_write, $file );

    my %pids;
    for ( 1 .. $ChildCount ) {
        if ( my $pid = fork ) {
            $pids{$pid} = 1;
        }
        else {
            _write_to_file( $close_after_write, $file );
            exit 0;
        }
    }

    my %exit_status;
    try {
        local $SIG{ALRM}
            = sub { die 'Waited 10 seconds for children to exit' };
        alarm 10;

        while ( keys %pids ) {
            my $pid = waitpid( -1, WNOHANG );
            if ( delete $pids{$pid} ) {
                $exit_status{$pid} = $?;
            }
        }
    };

    return ( $file, $@, \%exit_status );
}

sub _write_to_file {
    my $close_after_write = shift;
    my $file              = shift;

    my $dispatch = _dispatch_for_file( $close_after_write, $file );

    # The sleep makes a deadlock much more likely if the locking logic is not
    # working correctly. Without it each child process runs so quickly that
    # they are unlikely to step on each other.
    $dispatch->info(1);
    sleep 1;
    $dispatch->info(2);
    $dispatch->info(3);

    return;
}

sub _dispatch_for_file {
    my $close_after_write = shift;
    my $file              = shift;

    return Log::Dispatch->new(
        outputs => [
            [
                'File::Locked',
                filename          => $file,
                mode              => 'append',
                close_after_write => $close_after_write,
                min_level         => 'debug',
                newline           => 1,
            ]
        ],
    );
}

sub _test_file_locked {
    my $file  = shift;
    my $exc   = shift;
    my $exits = shift;

    is(
        $exc,
        q{},
        'no exception forking children and writing to file'
    );

    is(
        keys %{$exits},
        $ChildCount,
        "$ChildCount children exited",
    );

    for my $pid ( keys %{$exits} ) {
        is(
            $exits->{$pid},
            0,
            "$pid exited with 0"
        );
    }

    _test_file_content($file);
}

sub _test_file_content {
    my $file = shift;

    open my $fh, '<', $file
        or die "Cannot read $file: $!";
    my @lines;
    while ( defined( my $line = <$fh> ) ) {
        chomp $line;
        push @lines, $line;
    }

    close $fh or die $!;

    return if is_deeply(
        [ sort @lines ],
        [ (1) x $ChildCount, (2) x $ChildCount, (3) x $ChildCount ],
        'file contains expected content'
    );

    open my $diag_fh, '<', $file or die $!;
    diag(
        do { local $/ = undef; <$diag_fh> }
    );
    close $diag_fh or die $!;
}