#!/usr/bin/perl

# binary search maximum stack depth for arrays and hashes

# and store it in lib/Storable/Limit.pm

use Config;

use Cwd;

use File::Spec;

use strict;

my $fn = "lib/Storable/Limit.pm";

my $ptrsize = $Config{ptrsize};

my ($bad1, $bad2) = (65001, 25000);

sub QUIET () {

    (defined $ENV{MAKEFLAGS} and $ENV{MAKEFLAGS} =~ /\b(s|silent|quiet)\b/

     and !defined($ENV{TRAVIS}))

      ? 1 : 0

}

sub PARALLEL () {

    if (defined $ENV{MAKEFLAGS}

        and $ENV{MAKEFLAGS} =~ /\bj\s*(\d+)\b/

        and $1 > 1) {

        return 1;

    } else {

        return 0;

    }

}

sub is_miniperl {

    return !defined &DynaLoader::boot_DynaLoader;

}

if (is_miniperl()) {

    die "Should not run during miniperl\n";

}

my $prefix = "";

if ($^O eq "MSWin32") {

    # prevent Windows popping up a dialog each time we overflow

    # the stack

    require Win32API::File;

    Win32API::File->import(qw(SetErrorMode SEM_NOGPFAULTERRORBOX SEM_FAILCRITICALERRORS));

    SetErrorMode(SEM_NOGPFAULTERRORBOX() | SEM_FAILCRITICALERRORS());

}

# the ; here is to ensure system() passes this to the shell

elsif (system("ulimit -c 0 ;") == 0) {

    # try to prevent core dumps

    $prefix = "ulimit -c 0 ; ";

}

if (@ARGV and $ARGV[0] eq '--core') {

    $ENV{PERL_CORE} = 1;

}

my $PERL = $^X;

if ($ENV{PERL_CORE}) {

    my $path;

    my $ldlib = $Config{ldlibpthname};

    if (-d 'dist/Storable') {

        chdir 'dist/Storable';

        $PERL = "../../$PERL" unless $PERL =~ m|^/|;

    }

    if ($ldlib) {

        $path = getcwd()."/../..";

    }

    if ($^O eq 'MSWin32' and -d '../dist/Storable') {

        chdir '..\dist\Storable';

        $PERL = "..\\..\\$PERL" unless $PERL =~ /^[A-Za-z]:\\/;

    }

    $PERL = "\"$PERL\"" if $PERL =~ / /;

    if ($ldlib and $ldlib ne 'PATH') {

        $PERL = "$ldlib=$path $PERL";

    }

}

-d "lib" or mkdir "lib";

-d "lib/Storable" or mkdir "lib/Storable";

if ($^O eq "MSWin32") {

    require Win32;

    my ($str, $major, $minor) = Win32::GetOSVersion();

    if ($major < 6 || $major == 6 && $minor < 1) {

	print "Using defaults for older Win32\n";

	write_limits(500, 256);

	exit;

    }

}

my ($n, $good, $bad, $found) =

    (65000, 100, $bad1, undef);

print "probe for max. stack sizes...\n" unless QUIET;

# -I. since we're run before pm_to_blib (which is going to copy the

# file we create) and need to load our Storable.pm, not the already

# installed Storable.pm

my $mblib = '-Mblib -I.';

if ($ENV{PERL_CORE}) {

    if ($^O eq 'MSWin32') {

        $mblib = '-I..\..\lib\auto -I..\..\lib';

    } else {

        $mblib = '-I../../lib/auto -I../../lib';

    }

}

if (PARALLEL) {

    # problem with parallel builds. wait for INST_DYNAMIC linking to be done.

    # the problem is the RM_F INST_DYNAMIC race.

    print "parallel build race - wait for linker ...\n" unless QUIET;

    sleep(2.0);

}

sub cmd {

    my ($i, $try, $limit_name) = @_;

    die unless $i;

    my $code = "my \$t; \$Storable::$limit_name = -1; $try for 1..$i;dclone(\$t); print qq/ok\n/";

    my $q = ($^O eq 'MSWin32') ? '"' : "'";

    "$prefix $PERL $mblib -MStorable=dclone -e$q$code$q"

}

# try more

sub good {

    my $i = shift; # this passed

    my $j = $i + abs(int(($bad - $i) / 2));

    print "Storable: determining recursion limit: $i passed, try more $j ...\n" unless QUIET;

    $good = $i;

    if ($j <= $i) {

        $found++;

    }

    return $j;

}

# try less

sub bad {

    my $i = shift; # this failed

    my $j = $i - abs(int(($i - $good) / 2));

    print "Storable: determining recursion limit: $i too big, try less $j ...\n" unless QUIET;

    $bad = $i;

    if ($j >= $i) {

        $j = $good;

        $found++;

    }

    return $j;

}

sub array_cmd {

    my $depth = shift;

    return cmd($depth, '$t=[$t]', 'recursion_limit');

}

# first check we can successfully run with a minimum level

my $cmd = array_cmd(1);

unless ((my $output = `$cmd`) =~ /\bok\b/) {

    die "Cannot run probe: '$output', aborting...\n";

}

unless ($ENV{STORABLE_NOISY}) {

    # suppress Segmentation fault messages

    open STDERR, ">", File::Spec->devnull;

}

while (!$found) {

    my $cmd = array_cmd($n);

    #print "$cmd\n" unless $QUIET;

    if (`$cmd` =~ /\bok\b/) {

        $n = good($n);

    } else {

        $n = bad($n);

    }

}

print "MAX_DEPTH = $n\n" unless QUIET;

my $max_depth = $n;

($n, $good, $bad, $found) =

  (int($n/2), 50, $n, undef);

# pack j only since 5.8

my $max = ($] > 5.007 and length(pack "j", 0) < 8)

  ? ($^O eq 'MSWin32' ? 3000 : 8000)

  : $max_depth;

$n = $max if $n > $max;

$bad = $max if $bad > $max;

while (!$found) {

    my $cmd = cmd($n, '$t={1=>$t}', 'recursion_limit_hash');

    #print "$cmd\n" unless $QUIET;

    if (`$cmd` =~ /\bok\b/) {

        $n = good($n);

    } else {

        $n = bad($n);

    }

}

if ($max_depth == $bad1-1

    and $n == $bad2-1)

{

    # more likely the shell. travis docker ubuntu, mingw e.g.

    print "Error: Apparently your system(SHELLSTRING) cannot catch stack overflows\n"

      unless QUIET;

    $max_depth = 512;

    $n = 256;

    print "MAX_DEPTH = $max_depth\n" unless QUIET;

}

print "MAX_DEPTH_HASH = $n\n" unless QUIET;

my $max_depth_hash = $n;

# Previously this calculation was done in the macro, calculate it here

# instead so a user setting of either variable more closely matches

# the limits the use sees.

# be fairly aggressive in trimming this, smoke testing showed several

# several apparently random failures here, eg. working in one

# configuration, but not in a very similar configuration.

$max_depth = int(0.6 * $max_depth);

$max_depth_hash = int(0.6 * $max_depth);

my $stack_reserve = $^O eq "MSWin32" ? 32 : 16;

if ($] ge "5.016" && !($^O eq "cygwin" && $ptrsize == 8)) {

    $max_depth -= $stack_reserve;

    $max_depth_hash -= $stack_reserve;

}

else {

    # within the exception we need another stack depth to recursively

    # cleanup the hash

    $max_depth = ($max_depth >> 1) - $stack_reserve;

    $max_depth_hash = ($max_depth_hash >> 1) - $stack_reserve * 2;

}

write_limits($max_depth, $max_depth_hash);

sub write_limits {

    my ($max_depth, $max_depth_hash) = @_;

    my $f;

    open $f, ">", $fn or die "$fn $!";

    print $f <

# bisected by stacksize

\$Storable::recursion_limit = $max_depth

  unless defined \$Storable::recursion_limit;

\$Storable::recursion_limit_hash = $max_depth_hash

  unless defined \$Storable::recursion_limit_hash;

1;

EOS

    close $f

      or die "Failed to close $fn: $!\n";

}