The London Perl and Raku Workshop takes place on 26th Oct 2024. If your company depends on Perl, please consider sponsoring and/or attending.
BEGIN {				# Magic Perl CORE pragma
    chdir 't' if -d 't';
    unshift @INC,'../lib';
}

# get configuration information
require Config;
Config->import;
my $threads_ok= $Config{useithreads} || $Config{useithreads};

# be as strict and verbose as possible
use strict;
use warnings;

my $ok_tests_per_module;
my $no_tests_per_module;
BEGIN { $ok_tests_per_module= 21, $no_tests_per_module= 19 } #BEGIN

# initializations
use Test::More tests => 2 * ( $ok_tests_per_module + $no_tests_per_module );
my @modules=  qw( threads forks );
my $initial_ok=  <<"TEXT";
Installing 'threadsforks' checking logic for Makefile.PL
TEXT
my $initial_no=  <<"TEXT";

************************************************************************
* This distribution requires a version of Perl that has threads enabled
* or which has the forks.pm module installed.  Unfortunately, this does
* not appear to be the case for $^X.
* 
* Please install a threaded version of Perl, or the "forks" module
* before trying to install this distribution again.
************************************************************************

TEXT
my $manifest= <<"TEXT";
threadsforks                threads/forks test (added by Devel::ThreadsForks)
TEXT

# make sure we start clean
my @files=    qw(
 Makefile.PL
 MANIFEST
 STDERR.1
 STDERR.2
 STDOUT.1
 STDOUT.2
 threadsforks
);
unlink(@files); # handy during development / fix previous failures

# try both modules
diag "we can check for threads" if $threads_ok;
foreach my $module (@modules) {

    # tests with allowing Makefile.PL to run to completion
    SKIP: {

        # sorry, can't test
        if ( $module eq 'threads' and !$threads_ok ) {
            diag "Skipping $ok_tests_per_module tests on unthreaded perl";
            skip( "no threads on unthreaded perl", $ok_tests_per_module );
        }

        # set up MANIFEST
        ok( open( OUT, ">MANIFEST" ), "Failed to open MANIFEST: $!" );
        ok( close OUT, "Failed to close MANIFEST: $!" );
        ok( -e "MANIFEST", "Check if MANIFEST exists" );

        # set up code for success
        my $initial_code= <<"CODE";
# fake loading of $module.pm
BEGIN { \$INC{'$module.pm'}= 'loaded' } #BEGIN
BEGIN { eval "use Devel::ThreadsForks" } #BEGIN
open( OUT, '>size' );  # cannot use STDOUT first run
print OUT \$Devel::ThreadsForks::SIZE;
close OUT;
CODE
        ( my $final_code= $initial_code ) =~
          s#(ThreadsForks)"#$1; 1" || do 'threadsforks'#;

        # set up Makefile.PL
        ok( open( OUT, ">Makefile.PL" ), "Failed to open Makefile.PL: $!" );
        print OUT $initial_code;
        ok( close OUT, "Failed to close Makefile.PL: $!" );
        ok( -e "Makefile.PL", "Check if Makefile.PL exists" );

        # checks for first time
        my $result=
          system( "$^X -I../blib/lib Makefile.PL 2>STDERR.1 >STDOUT.1" ) >> 8;
        is( $result, 0, "call 1 ok" );
        my $size= -s 'threadsforks';
        is( slurp('size'), $size, 'contents of size first time' );
        ok( unlink('size'), 'unlink size' );
        is( slurp('STDOUT.1'), '', 'contents of STDOUT first time' );
        is( slurp('STDERR.1'), $initial_ok, 'contents of STDERR first time' );
        is( slurp('Makefile.PL'), $final_code, 'contents of Makefile.PL' );
        is( slurp('MANIFEST'), $manifest, 'contents of MANIFEST' );

        # checks for second time
        $result=
          system( "$^X -I../blib/lib Makefile.PL 2>STDERR.2 >STDOUT.2" ) >> 8;
        is( $result, 0, "call 2 ok" );
        is( slurp('size'), $size, 'contents of size first time' );
        ok( unlink('size'), 'unlink size' );
        is( slurp('STDOUT.2'), '', 'contents of STDOUT second time' );
        is( slurp('STDERR.2'), '', 'contents of STDERR second time' );
        is( slurp('Makefile.PL'), $final_code, 'contents of Makefile.PL' );
        is( slurp('MANIFEST'), $manifest, 'contents of MANIFEST' );

        # cleanup
        is( unlink(@files), scalar(@files), 'make sure we end up cleanly' );
    } #SKIP

    # tests not allowing Makefile.PL to run to completion
    SKIP: {

        # sorry, can't test with threaded perl
        if ($threads_ok) {
            diag "Skipping $no_tests_per_module tests on threaded perl";
            skip( "no failure on threaded perl", $no_tests_per_module );
        }

        # sorry, can't test is forks is installed
        elsif ( eval "use forks; 1" ) {
            diag "Skipping $no_tests_per_module tests on perl with forks installed";
            skip( "no failure if forks installed", $no_tests_per_module );
        }

        # set up MANIFEST
        ok( open( OUT, ">MANIFEST" ), "Failed to open MANIFEST: $!" );
        ok( close OUT, "Failed to close MANIFEST: $!" );
        ok( -e "MANIFEST", "Check if MANIFEST exists" );

        # set up code for success
        my $initial_code= <<"CODE";
BEGIN { eval "use Devel::ThreadsForks" } #BEGIN
open( OUT, '>size' );  # should never get executed
print OUT \$Devel::ThreadsForks::SIZE;
close OUT;
CODE
        ( my $final_code= $initial_code ) =~
          s#(ThreadsForks)"#$1; 1" || do 'threadsforks'#;

        # set up Makefile.PL
        ok( open( OUT, ">Makefile.PL" ), "Failed to open Makefile.PL: $!" );
        print OUT $initial_code;
        ok( close OUT, "Failed to close Makefile.PL: $!" );
        ok( -e "Makefile.PL", "Check if Makefile.PL exists" );

        # checks for first time
        my $result=
          system( "$^X -I../blib/lib Makefile.PL 2>STDERR.1 >STDOUT.1" ) >> 8;
        is( $result, 1, "call 1 no" );
        ok( !-e 'size', "should not have seen size" );
        unlink('size'); #just in case it *was* created
        is( slurp('STDOUT.1'), '', 'contents of STDOUT first time' );
        is( slurp('STDERR.1'), $initial_ok . $initial_no,
          'contents of STDERR first time' );
        is( slurp('Makefile.PL'), $final_code, 'contents of Makefile.PL' );
        is( slurp('MANIFEST'), $manifest, 'contents of MANIFEST' );

        # checks for second time
        $result=
          system( "$^X -I../blib/lib Makefile.PL 2>STDERR.2 >STDOUT.2" ) >> 8;
        is( $result, 1, "call 2 no" );
        ok( !-e 'size', "should not have seen size" );
        unlink('size'); #just in case it *was* created
        is( slurp('STDOUT.2'), '', 'contents of STDOUT second time' );
        is( slurp('STDERR.2'), $initial_no, 'contents of STDERR second time' );
        is( slurp('Makefile.PL'), $final_code, 'contents of Makefile.PL' );
        is( slurp('MANIFEST'), $manifest, 'contents of MANIFEST' );

        # cleanup
        is( unlink(@files), scalar(@files), 'make sure we end up cleanly' );
    } #SKIP
}

#-------------------------------------------------------------------------------
#  IN: 1 filename
# OUT: 1 contents

sub slurp { open IN, $_[0]; undef $/; <IN> } #slurp
#-------------------------------------------------------------------------------