1#!/usr/bin/perl
2# binary search maximum stack depth for arrays and hashes
3# and report it to stdout as code to set the limits
4
5use Config;
6use Cwd;
7use File::Spec;
8use strict;
9
10my $ptrsize = $Config{ptrsize};
11my ($bad1, $bad2) = (65001, 25000);
12sub QUIET () {
13    (defined $ENV{MAKEFLAGS} and $ENV{MAKEFLAGS} =~ /\b(s|silent|quiet)\b/
14     and !defined($ENV{TRAVIS})) || @ARGV && $ARGV[0] eq "-q"
15      ? 1 : 0
16}
17sub PARALLEL () {
18    if (defined $ENV{MAKEFLAGS}
19        and $ENV{MAKEFLAGS} =~ /\bj\s*(\d+)\b/
20        and $1 > 1) {
21        return 1;
22    } else {
23        return 0;
24    }
25}
26sub is_miniperl {
27    return !defined &DynaLoader::boot_DynaLoader;
28}
29
30if (is_miniperl()) {
31    die "Should not run using miniperl\n";
32}
33my $prefix = "";
34if ($^O eq "MSWin32") {
35    # prevent Windows popping up a dialog each time we overflow
36    # the stack
37    require Win32API::File;
38    Win32API::File->import(qw(SetErrorMode SEM_NOGPFAULTERRORBOX SEM_FAILCRITICALERRORS));
39    SetErrorMode(SEM_NOGPFAULTERRORBOX() | SEM_FAILCRITICALERRORS());
40}
41# the ; here is to ensure system() passes this to the shell
42elsif (system("ulimit -c 0 ;") == 0) {
43    # try to prevent core dumps
44    $prefix = "ulimit -c 0 ; ";
45}
46my $PERL = $^X;
47if ($^O eq "MSWin32") {
48    require Win32;
49    my ($str, $major, $minor) = Win32::GetOSVersion();
50    if ($major < 6 || $major == 6 && $minor < 1) {
51	print "# Using defaults for older Win32\n";
52	write_limits(500, 256);
53	exit;
54    }
55}
56my ($n, $good, $bad, $found) =
57    (65000, 100, $bad1, undef);
58print "# probe for max. stack sizes...\n" unless QUIET;
59# -I. since we're run before pm_to_blib (which is going to copy the
60# file we create) and need to load our Storable.pm, not the already
61# installed Storable.pm
62my $mblib = '';
63if (-d 'blib') {
64    $mblib = '-Mblib -I.';
65}
66elsif (-f "Configure") {
67    $mblib = '-Ilib';
68}
69
70sub cmd {
71    my ($i, $try, $limit_name) = @_;
72    die unless $i;
73    my $code = "my \$t; \$Storable::$limit_name = -1; $try for 1..$i;dclone(\$t); print qq/ok\n/";
74    my $q = ($^O eq 'MSWin32') ? '"' : "'";
75
76    "$prefix $PERL $mblib -MStorable=dclone -e$q$code$q"
77}
78# try more
79sub good {
80    my $i = shift; # this passed
81    my $j = $i + abs(int(($bad - $i) / 2));
82    print "# Storable: determining recursion limit: $i passed, try more $j ...\n" unless QUIET;
83    $good = $i;
84    if ($j <= $i) {
85        $found++;
86    }
87    return $j;
88}
89# try less
90sub bad {
91    my $i = shift; # this failed
92    my $j = $i - abs(int(($i - $good) / 2));
93    print "# Storable: determining recursion limit: $i too big, try less $j ...\n" unless QUIET;
94    $bad = $i;
95    if ($j >= $i) {
96        $j = $good;
97        $found++;
98    }
99    return $j;
100}
101
102sub array_cmd {
103    my $depth = shift;
104    return cmd($depth, '$t=[$t]', 'recursion_limit');
105}
106
107# first check we can successfully run with a minimum level
108my $cmd = array_cmd(1);
109unless ((my $output = `$cmd`) =~ /\bok\b/) {
110    die "Cannot run probe: '$output', aborting...\n";
111}
112
113unless ($ENV{STORABLE_NOISY}) {
114    # suppress Segmentation fault messages
115    open STDERR, ">", File::Spec->devnull;
116}
117
118while (!$found) {
119    my $cmd = array_cmd($n);
120    #print "$cmd\n" unless $QUIET;
121    if (`$cmd` =~ /\bok\b/) {
122        $n = good($n);
123    } else {
124        $n = bad($n);
125    }
126}
127print "# MAX_DEPTH = $n\n" unless QUIET;
128my $max_depth = $n;
129
130($n, $good, $bad, $found) =
131  (int($n/2), 50, $n, undef);
132# pack j only since 5.8
133my $max = ($] > 5.007 and length(pack "j", 0) < 8)
134  ? ($^O eq 'MSWin32' ? 3000 : 8000)
135  : $max_depth;
136$n = $max if $n > $max;
137$bad = $max if $bad > $max;
138while (!$found) {
139    my $cmd = cmd($n, '$t={1=>$t}', 'recursion_limit_hash');
140    #print "$cmd\n" unless $QUIET;
141    if (`$cmd` =~ /\bok\b/) {
142        $n = good($n);
143    } else {
144        $n = bad($n);
145    }
146}
147if ($max_depth == $bad1-1
148    and $n == $bad2-1)
149{
150    # more likely the shell. travis docker ubuntu, mingw e.g.
151    print "# Apparently your system(SHELLSTRING) cannot catch stack overflows\n"
152      unless QUIET;
153    $max_depth = 512;
154    $n = 256;
155    print "MAX_DEPTH = $max_depth\n" unless QUIET;
156}
157print "# MAX_DEPTH_HASH = $n\n" unless QUIET;
158my $max_depth_hash = $n;
159
160# Previously this calculation was done in the macro, calculate it here
161# instead so a user setting of either variable more closely matches
162# the limits the use sees.
163
164# be fairly aggressive in trimming this, smoke testing showed
165# several apparently random failures here, eg. working in one
166# configuration, but not in a very similar configuration.
167$max_depth = int(0.6 * $max_depth);
168$max_depth_hash = int(0.6 * $max_depth_hash);
169
170my $stack_reserve = $^O eq "MSWin32" ? 32 : 16;
171if ($] ge "5.016" && !($^O eq "cygwin" && $ptrsize == 8)) {
172    $max_depth -= $stack_reserve;
173    $max_depth_hash -= $stack_reserve;
174}
175else {
176    # within the exception we need another stack depth to recursively
177    # cleanup the hash
178    $max_depth = ($max_depth >> 1) - $stack_reserve;
179    $max_depth_hash = ($max_depth_hash >> 1) - $stack_reserve * 2;
180}
181
182write_limits($max_depth, $max_depth_hash);
183
184sub write_limits {
185    my ($max_depth, $max_depth_hash) = @_;
186    print <<EOS;
187# bisected by stacksize
188\$Storable::recursion_limit = $max_depth
189  unless defined \$Storable::recursion_limit;
190\$Storable::recursion_limit_hash = $max_depth_hash
191  unless defined \$Storable::recursion_limit_hash;
192EOS
193}
194