Commit | Line | Data |
---|---|---|
dd7f75e0 RU |
1 | #!/usr/bin/perl |
2 | # binary search maximum stack depth for arrays and hashes | |
2a0bbd31 | 3 | # and report it to stdout as code to set the limits |
dd7f75e0 | 4 | |
e58927f4 RU |
5 | use Config; |
6 | use Cwd; | |
3d79e577 | 7 | use File::Spec; |
c0e3b4b5 | 8 | use strict; |
e58927f4 | 9 | |
c0e3b4b5 TC |
10 | my $ptrsize = $Config{ptrsize}; |
11 | my ($bad1, $bad2) = (65001, 25000); | |
dd7f75e0 | 12 | sub QUIET () { |
e58927f4 | 13 | (defined $ENV{MAKEFLAGS} and $ENV{MAKEFLAGS} =~ /\b(s|silent|quiet)\b/ |
2a0bbd31 | 14 | and !defined($ENV{TRAVIS})) || @ARGV && $ARGV[0] eq "-q" |
dd7f75e0 RU |
15 | ? 1 : 0 |
16 | } | |
17 | sub 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 | } | |
26 | sub is_miniperl { | |
27 | return !defined &DynaLoader::boot_DynaLoader; | |
28 | } | |
29 | ||
30 | if (is_miniperl()) { | |
2a0bbd31 | 31 | die "Should not run using miniperl\n"; |
c0e3b4b5 | 32 | } |
7ec112d2 | 33 | my $prefix = ""; |
c0e3b4b5 TC |
34 | if ($^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()); | |
dd7f75e0 | 40 | } |
7ec112d2 TC |
41 | # the ; here is to ensure system() passes this to the shell |
42 | elsif (system("ulimit -c 0 ;") == 0) { | |
43 | # try to prevent core dumps | |
44 | $prefix = "ulimit -c 0 ; "; | |
45 | } | |
e58927f4 | 46 | my $PERL = $^X; |
c8435d23 TC |
47 | if ($^O eq "MSWin32") { |
48 | require Win32; | |
49 | my ($str, $major, $minor) = Win32::GetOSVersion(); | |
50 | if ($major < 6 || $major == 6 && $minor < 1) { | |
2a0bbd31 | 51 | print "# Using defaults for older Win32\n"; |
c8435d23 TC |
52 | write_limits(500, 256); |
53 | exit; | |
54 | } | |
55 | } | |
dd7f75e0 | 56 | my ($n, $good, $bad, $found) = |
c0e3b4b5 | 57 | (65000, 100, $bad1, undef); |
2a0bbd31 | 58 | print "# probe for max. stack sizes...\n" unless QUIET; |
c0e3b4b5 TC |
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 | |
2a0bbd31 TC |
62 | my $mblib = ''; |
63 | if (-d 'blib') { | |
64 | $mblib = '-Mblib -I.'; | |
dd7f75e0 | 65 | } |
2a0bbd31 TC |
66 | elsif (-f "Configure") { |
67 | $mblib = '-Ilib'; | |
dd7f75e0 | 68 | } |
dd7f75e0 RU |
69 | |
70 | sub cmd { | |
c0e3b4b5 | 71 | my ($i, $try, $limit_name) = @_; |
dd7f75e0 | 72 | die unless $i; |
c8435d23 | 73 | my $code = "my \$t; \$Storable::$limit_name = -1; $try for 1..$i;dclone(\$t); print qq/ok\n/"; |
c0e3b4b5 TC |
74 | my $q = ($^O eq 'MSWin32') ? '"' : "'"; |
75 | ||
7ec112d2 | 76 | "$prefix $PERL $mblib -MStorable=dclone -e$q$code$q" |
dd7f75e0 RU |
77 | } |
78 | # try more | |
79 | sub good { | |
80 | my $i = shift; # this passed | |
81 | my $j = $i + abs(int(($bad - $i) / 2)); | |
2a0bbd31 | 82 | print "# Storable: determining recursion limit: $i passed, try more $j ...\n" unless QUIET; |
dd7f75e0 RU |
83 | $good = $i; |
84 | if ($j <= $i) { | |
85 | $found++; | |
86 | } | |
87 | return $j; | |
88 | } | |
89 | # try less | |
90 | sub bad { | |
91 | my $i = shift; # this failed | |
92 | my $j = $i - abs(int(($i - $good) / 2)); | |
2a0bbd31 | 93 | print "# Storable: determining recursion limit: $i too big, try less $j ...\n" unless QUIET; |
dd7f75e0 RU |
94 | $bad = $i; |
95 | if ($j >= $i) { | |
96 | $j = $good; | |
97 | $found++; | |
98 | } | |
99 | return $j; | |
100 | } | |
101 | ||
c8435d23 TC |
102 | sub 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 | |
108 | my $cmd = array_cmd(1); | |
109 | unless ((my $output = `$cmd`) =~ /\bok\b/) { | |
110 | die "Cannot run probe: '$output', aborting...\n"; | |
111 | } | |
112 | ||
3d79e577 TC |
113 | unless ($ENV{STORABLE_NOISY}) { |
114 | # suppress Segmentation fault messages | |
115 | open STDERR, ">", File::Spec->devnull; | |
116 | } | |
c8435d23 | 117 | |
dd7f75e0 | 118 | while (!$found) { |
c8435d23 | 119 | my $cmd = array_cmd($n); |
dd7f75e0 | 120 | #print "$cmd\n" unless $QUIET; |
c8435d23 | 121 | if (`$cmd` =~ /\bok\b/) { |
dd7f75e0 RU |
122 | $n = good($n); |
123 | } else { | |
124 | $n = bad($n); | |
125 | } | |
126 | } | |
2a0bbd31 | 127 | print "# MAX_DEPTH = $n\n" unless QUIET; |
dd7f75e0 RU |
128 | my $max_depth = $n; |
129 | ||
130 | ($n, $good, $bad, $found) = | |
131 | (int($n/2), 50, $n, undef); | |
132 | # pack j only since 5.8 | |
133 | my $max = ($] > 5.007 and length(pack "j", 0) < 8) | |
134 | ? ($^O eq 'MSWin32' ? 3000 : 8000) | |
c0e3b4b5 | 135 | : $max_depth; |
dd7f75e0 RU |
136 | $n = $max if $n > $max; |
137 | $bad = $max if $bad > $max; | |
dd7f75e0 | 138 | while (!$found) { |
c0e3b4b5 | 139 | my $cmd = cmd($n, '$t={1=>$t}', 'recursion_limit_hash'); |
dd7f75e0 | 140 | #print "$cmd\n" unless $QUIET; |
c8435d23 | 141 | if (`$cmd` =~ /\bok\b/) { |
dd7f75e0 RU |
142 | $n = good($n); |
143 | } else { | |
144 | $n = bad($n); | |
145 | } | |
146 | } | |
147 | if ($max_depth == $bad1-1 | |
148 | and $n == $bad2-1) | |
149 | { | |
2a4dadc5 | 150 | # more likely the shell. travis docker ubuntu, mingw e.g. |
2a0bbd31 | 151 | print "# Apparently your system(SHELLSTRING) cannot catch stack overflows\n" |
dd7f75e0 RU |
152 | unless QUIET; |
153 | $max_depth = 512; | |
154 | $n = 256; | |
155 | print "MAX_DEPTH = $max_depth\n" unless QUIET; | |
156 | } | |
2a0bbd31 | 157 | print "# MAX_DEPTH_HASH = $n\n" unless QUIET; |
dd7f75e0 RU |
158 | my $max_depth_hash = $n; |
159 | ||
c0e3b4b5 TC |
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 several | |
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); | |
2a0bbd31 | 168 | $max_depth_hash = int(0.6 * $max_depth_hash); |
c0e3b4b5 TC |
169 | |
170 | my $stack_reserve = $^O eq "MSWin32" ? 32 : 16; | |
171 | if ($] ge "5.016" && !($^O eq "cygwin" && $ptrsize == 8)) { | |
172 | $max_depth -= $stack_reserve; | |
173 | $max_depth_hash -= $stack_reserve; | |
174 | } | |
175 | else { | |
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 | ||
a2d15b8e TC |
182 | write_limits($max_depth, $max_depth_hash); |
183 | ||
184 | sub write_limits { | |
185 | my ($max_depth, $max_depth_hash) = @_; | |
2a0bbd31 | 186 | print <<EOS; |
c0e3b4b5 TC |
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; | |
c0e3b4b5 | 192 | EOS |
a2d15b8e | 193 | } |