view release on metacpan or  search on metacpan

t/memory-protection.t  view on Meta::CPAN

                }
                else {
                    is $count, 0, "[#$i] String MISSING"
                        or diag "Found $count copies of string #$i\nString: $string";
                }
            }
        }
    }, @$strings;
}

done_testing;
exit;

##############################################################################

sub dump_core { kill 'QUIT', $$ }

sub file_grep {
    my $filepath = shift;
    my @strings = @_;

    my $counter = 0;
    my %counts = map { $_ => $counter++ } @strings;
    my @counts = map { 0 } @strings;

    my $pattern = join('|', map { quotemeta($_) } @strings);

    my $overlap = (max map { length } @strings) - 1;

    open(my $fh, '<:raw', $filepath) or die "open failed: $!\n";

    my $previous;
    while (read $fh, my $block, $BLOCK_SIZE) {
        substr($block, 0, 0, substr($previous, -$overlap)) if defined $previous;

        while ($block =~ /($pattern)/gs) {
            ++$counts[$counts{$1}];
        }
        $previous = substr($block, $overlap);
    }
    die "read error: $!" if $fh->error;

    return @counts;
}

sub run_test {
    my $code = shift;
    my @strings = @_;

    my $seed = random_bytes(32);

    pipe(my $read, my $write) or die "pipe failed: $!\n";

    defined(my $pid = fork) or die "fork failed: $!\n";
    if (!$pid) { # child
        close($read);

        my $exit_status = run_doomed_child($code, $seed);
        my $dumped = $exit_status & 127 && $exit_status & 128;

        my @decoded_strings = map { decode_b64($_) } @strings;

        my @matches = file_grep('core', @decoded_strings);
        print $write join('|', $dumped, -f 'core' ? 1 : 0, @matches);
        close($write);

        POSIX::_exit(0);
    }

    close($write);
    my $results = do { local $/; <$read> };

    waitpid($pid, 0);
    my $exit_status = $? >> 8;
    $exit_status == 0 or die "test environment exited non-zero: $exit_status\n";

    return split(/\|/, $results);
}

sub run_doomed_child {
    my $code = shift;
    my $seed = shift;

    unlink('core') or die "unlink failed: $!\n" if -f 'core';

    defined(my $pid = fork) or die "fork failed: $!\n";
    if (!$pid) { # child
        $code->();
        dump_core();        # doomed
        POSIX::_exit(1);    # paranoid
    }

    waitpid($pid, 0);
    return $?;
}