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