Maintain UAF context across calls to sys$check_access in cando_by_name.
[p5sagit/p5-mst-13.2.git] / vms / genconfig.pl
1 #!/usr/bin/perl
2 # Habit . . .
3 #
4 # Extract info from Config.VMS, and add extra data here, to generate Config.sh
5 # Edit the static information after __END__ to reflect your site and options
6 # that went into your perl binary.  In addition, values which change from run
7 # to run may be supplied on the command line as key=val pairs.
8 #
9 # Rev. 16-Feb-1998  Charles Bailey  bailey@newman.upenn.edu
10 #
11
12 #==== Locations of installed Perl components
13 $prefix='perl_root';
14 $builddir="$prefix:[000000]";
15 $installbin="$prefix:[000000]";
16 $installscript="$prefix:[000000]";
17 $installman1dir="$prefix:[man.man1]";
18 $installman3dir="$prefix:[man.man3]";
19 $installprivlib="$prefix:[lib]";
20 $installsitelib="$prefix:[lib.site_perl]";
21
22 unshift(@INC,'lib');  # In case someone didn't define Perl_Root
23                       # before the build
24
25 if ($ARGV[0] eq '-f') {
26   open(ARGS,$ARGV[1]) or die "Can't read data from $ARGV[1]: $!\n";
27   @ARGV = ();
28   while (<ARGS>) {
29     chomp;
30     push(@ARGV,split(/\|/,$_));
31   }
32   close ARGS;
33 }
34
35 if (-f "config.vms") { $infile = "config.vms"; $outdir = "[-]"; }
36 elsif (-f "[.vms]config.vms") { $infile = "[.vms]config.vms"; $outdir = "[]"; }
37 elsif (-f "config.h") { $infile = "config.h"; $outdir = "[]";}
38
39 if ($infile) { print "Generating Config.sh from $infile . . .\n"; }
40 else { die <<EndOfGasp;
41 Can't find config.vms or config.h to read!
42         Please run this script from the perl source directory or
43         the VMS subdirectory in the distribution.
44 EndOfGasp
45 }
46 $outdir = '';
47 open(IN,"$infile") || die "Can't open $infile: $!\n";
48 open(OUT,">${outdir}Config.sh") || die "Can't open ${outdir}Config.sh: $!\n";
49
50 $time = localtime;
51 $cf_by = (getpwuid($<))[0];
52 $archsufx = `Write Sys\$Output F\$GetSyi("HW_MODEL")` > 1024 ? 'AXP' : 'VAX';
53 ($vers = $]) =~ tr/./_/;
54 $installarchlib = VMS::Filespec::vmspath($installprivlib);
55 $installarchlib =~ s#\]#.VMS_$archsufx.$vers\]#;
56 $installsitearch = VMS::Filespec::vmspath($installsitelib);
57 $installsitearch =~ s#\]#.VMS_$archsufx\]#;
58 ($osvers = `Write Sys\$Output F\$GetSyi("VERSION")`) =~ s/^V?(\S+)\s*\n?$/$1/;
59
60 print OUT <<EndOfIntro;
61 # This file generated by GenConfig.pl on a VMS system.
62 # Input obtained from:
63 #     $infile
64 #     $0
65 # Time: $time
66
67 package='perl5'
68 CONFIG='true'
69 cf_time='$time'
70 cf_by='$cf_by'
71 ccdlflags='undef'
72 cccdlflags='undef'
73 mab='undef'
74 libpth='/sys\$share /sys\$library'
75 ld='Link'
76 lddlflags='/Share'
77 ranlib='undef'
78 ar='undef'
79 eunicefix=':'
80 hint='none'
81 hintfile='undef'
82 useshrplib='define'
83 usemymalloc='n'
84 usevfork='true'
85 spitshell='write sys\$output '
86 dlsrc='dl_vms.c'
87 binexp='$installbin'
88 man1ext='rno'
89 man3ext='rno'
90 arch='VMS_$archsufx'
91 archname='VMS_$archsufx'
92 bincompat3='undef'
93 d_bincompat3='undef'
94 osvers='$osvers'
95 prefix='$prefix'
96 builddir='$builddir'
97 installbin='$installbin'
98 installscript='$installscript'
99 installman1dir='$installman1dir'
100 installman3dir='$installman3dir'
101 installprivlib='$installprivlib'
102 installarchlib='$installarchlib'
103 installsitelib='$installsitelib'
104 installsitearch='$installsitearch'
105 path_sep='|'
106 startperl='\$ perl 'f\$env("procedure")' 'p1' 'p2' 'p3' 'p4' 'p5' 'p6' 'p7' 'p8' !
107 \$ exit++ + ++\$status != 0 and \$exit = \$status = undef;'
108 EndOfIntro
109
110 foreach (@ARGV) {
111   ($key,$val) = split('=',$_,2);
112   if ($key eq 'cc') {  # Figure out which C compiler we're using
113     my($cc,$ccflags) = split('/',$val,2);
114     my($d_attr);
115     $ccflags = "/$ccflags";
116     if ($ccflags =~s!/DECC!!ig) { 
117       $cc .= '/DECC';
118       $cctype = 'decc';
119       $d_attr = 'undef';
120     }
121     elsif ($ccflags =~s!/VAXC!!ig) {
122       $cc .= '/VAXC';
123       $cctype = 'vaxc';
124       $d_attr = 'undef';
125     }
126     elsif (`$val/NoObject/NoList _nla0:/Version` =~ /GNU C version (\S+)/) {
127       $cctype = 'gcc';
128       $d_attr = 'define';
129       print OUT "gccversion='$1'\n";
130     }
131     elsif ($archsufx eq 'VAX' &&
132            # Check exit status too, in case message is turned off
133            ( `$val/NoObject/NoList /prefix=all _nla0:` =~ /IVQUAL/ ||
134               $? == 0x38240 )) {
135       $cctype = 'vaxc';
136       $d_attr = 'undef';
137     }
138     else {
139       $cctype = 'decc';
140       $d_attr = 'undef';
141     }
142     print OUT "vms_cc_type='$cctype'\n";
143     print OUT "d_attribute_format='$d_attr'\n";
144     # XXX The following attributes may be able to use $d_attr, too.
145     print OUT "d_attribute_malloc='undef'\n";
146     print OUT "d_attribute_nonnull='undef'\n";
147     print OUT "d_attribute_noreturn='undef'\n";
148     print OUT "d_attribute_pure='undef'\n";
149     print OUT "d_attribute_unused='undef'\n";
150     print OUT "d_attribute_warn_unused_result='undef'\n";
151     print OUT "cc='$cc'\n";
152     if ( ($cctype eq 'decc' and $archsufx eq 'VAX') || $cctype eq 'gcc') {
153       # gcc and DECC for VAX requires filename in /object qualifier, so we
154       # have to remove it here.  Alas, this means we lose the user's
155       # object file suffix if it's not .obj.
156       $ccflags =~ s#/obj(?:ect)?=[^/\s]+##i;
157     }
158     $debug = $optimize = '';
159     while ( ($qual) = $ccflags =~ m|(/(No)?Deb[^/]*)|i ) {
160       $debug = $qual;
161       $ccflags =~ s/$qual//;
162     }
163     while ( ($qual) = $ccflags =~ m|(/(No)?Opt[^/]*)|i ) {
164       $optimize = $qual;
165       $ccflags =~ s/$qual//;
166     }
167     $usethreads = ($ccflags =~ m!/DEF[^/]+USE_5005THREADS!i and
168                    $ccflags !~ m!/UND[^/]+USE_5005THREADS!i);
169     print OUT "usethreads='",($usethreads ? 'define' : 'undef'),"'\n";;
170     $optimize = "$debug$optimize";
171     print OUT "ccflags='$ccflags'\n";
172     print OUT "optimize='$optimize'\n";
173     $dosock = ($ccflags =~ m!/DEF[^/]+VMS_DO_SOCKETS!i and
174                $ccflags !~ m!/UND[^/]+VMS_DO_SOCKETS!i);
175     print OUT "d_vms_do_sockets=",$dosock ? "'define'\n" : "'undef'\n";
176     print OUT "d_socket=",$dosock ? "'define'\n" : "'undef'\n";
177     print OUT "d_sockpair=",$dosock ? "'define'\n" : "'undef'\n";
178     print OUT "d_gethent=",$dosock ? "'define'\n" : "'undef'\n";
179     print OUT "d_sethent=",$dosock ? "'define'\n" : "'undef'\n";
180     print OUT "d_select=",$dosock ? "'define'\n" : "'undef'\n";
181     print OUT "i_netdb=",$dosock ? "'define'\n" : "'undef'\n";
182     print OUT "i_niin=",$dosock ? "'define'\n" : "'undef'\n";
183     print OUT "i_neterrno=",$dosock ? "'define'\n" : "'undef'\n";
184     print OUT "d_gethbyname=",$dosock ? "'define'\n" : "'undef'\n";
185     print OUT "d_gethbyaddr=",$dosock ? "'define'\n" : "'undef'\n";
186     print OUT "d_getpbyname=",$dosock ? "'define'\n" : "'undef'\n";
187     print OUT "d_getpbynumber=",$dosock ? "'define'\n" : "'undef'\n";
188     print OUT "d_getsbyname=",$dosock ? "'define'\n" : "'undef'\n";
189     print OUT "d_getsbyport=",$dosock ? "'define'\n" : "'undef'\n";
190     print OUT "d_endhent=",$dosock ? "'define'\n" : "'undef'\n";
191     print OUT "d_getpent=",$dosock ? "'define'\n" : "'undef'\n";
192     print OUT "d_setpent=",$dosock ? "'define'\n" : "'undef'\n";
193     print OUT "d_endpent=",$dosock ? "'define'\n" : "'undef'\n";
194     print OUT "d_getsent=",$dosock ? "'define'\n" : "'undef'\n";
195     print OUT "d_setsent=",$dosock ? "'define'\n" : "'undef'\n";
196     print OUT "d_endsent=",$dosock ? "'define'\n" : "'undef'\n";
197     print OUT "netdb_name_type=",$dosock ? "'char *'\n" : "'undef'\n";
198     print OUT "netdb_host_type=",$dosock ? "'char *'\n" : "'undef'\n";
199     print OUT "netdb_hlen_type=",$dosock ? "'int'\n" : "'undef'\n";
200     print OUT "d_gethostprotos=",$dosock ? "'define'\n" : "'undef'\n";
201     print OUT "d_getnetprotos=",$dosock ? "'define'\n" : "'undef'\n";
202     print OUT "d_getservprotos=",$dosock ? "'define'\n" : "'undef'\n";
203     print OUT "d_getprotoprotos=",$dosock ? "'define'\n" : "'undef'\n";
204
205     if ($dosock and $cctype eq 'decc' and $ccflags =~ /DECCRTL_SOCKETS/) {
206       print OUT "selecttype='fd_set'\n";
207       print OUT "d_getnbyaddr='define'\n";
208       print OUT "d_getnbyname='define'\n";
209       print OUT "d_getnent='define'\n";
210       print OUT "d_setnent='define'\n";
211       print OUT "d_endnent='define'\n";
212       print OUT "netdb_net_type='long'\n";
213     }
214     else {
215       print OUT "selecttype='int'\n";
216       print OUT "d_getnybname='undef'\n";
217       print OUT "d_getnybaddr='undef'\n";
218       print OUT "d_getnent='undef'\n";
219       print OUT "d_setnent='undef'\n";
220       print OUT "d_endnent='undef'\n";
221       print OUT "netdb_net_type='undef'\n";
222     }
223
224     if ($cctype eq 'decc') {
225       $rtlhas  = 'define';
226       print OUT "useposix='true'\n";
227       ($ccver,$vmsver) = `$cc/VERSION` =~ /V(\S+) on .*V(\S+)$/;
228       # Best guess; the may be wrong on systems which have separately
229       # installed the new CRTL.
230       if ($ccver >= 5.2 and $vmsver >= 7) { $rtlnew = 'define'; }
231       else                                { $rtlnew = 'undef';  }
232     }
233     else { $rtlhas = $rtlnew = 'undef';  print OUT "useposix='false'\n"; }
234     foreach (qw[ d_stdstdio d_stdio_ptr_lval d_stdio_cnt_lval d_stdiobase
235                  d_locconv d_setlocale i_locale d_mbstowcs d_mbtowc
236                  d_wcstombs d_wctomb d_mblen d_mktime d_strcoll d_strxfrm ]) {
237       print OUT "$_='$rtlhas'\n";
238     }
239     print OUT "d_stdio_ptr_lval_sets_cnt='undef'\n";
240     print OUT "d_stdio_ptr_lval_nochange_cnt='undef'\n";
241     foreach (qw[ d_gettimeod d_uname d_truncate d_wait4 d_index
242                  d_pathconf d_fpathconf d_sysconf d_sigsetjmp ]) {
243       print OUT "$_='$rtlnew'\n";
244     }
245     next;
246   }
247   elsif ($key eq 'exe_ext') { 
248     my($nodot) = $val;
249     $nodot =~ s!\.!!;
250     print OUT "so='$nodot'\ndlext='$nodot'\n";
251   }
252   elsif ($key eq 'obj_ext') { print OUT "dlobj='dl_vms$val'\n";     }
253   print OUT "$key='$val'\n";
254 }
255
256 # Are there any other logicals which TCP/IP stacks use for the host name?
257 $myname = $ENV{'ARPANET_HOST_NAME'}  || $ENV{'INTERNET_HOST_NAME'} ||
258           $ENV{'MULTINET_HOST_NAME'} || $ENV{'UCX$INET_HOST'}      ||
259           $ENV{'TCPWARE_DOMAINNAME'} || $ENV{'NEWS_ADDRESS'};
260 if (!$myname) {
261   ($myname) = `hostname` =~ /^(\S+)/;
262   if ($myname =~ /IVVERB/) {
263     warn "Can't determine TCP/IP hostname" if $dosock;
264     $myname = '';
265   }
266 }
267 $myname = $ENV{'SYS$NODE'} unless $myname;
268 ($myhostname,$mydomain) = split(/\./,$myname,2);
269 print OUT "myhostname='$myhostname'\n" if $myhostname;
270 if ($mydomain) {
271   print OUT "mydomain='.$mydomain'\n";
272   print OUT "perladmin='$cf_by\@$myhostname.$mydomain'\n";
273   print OUT "cf_email='$cf_by\@$myhostname.$mydomain'\n";
274 }
275 else {
276   print OUT "perladmin='$cf_by'\n";
277   print OUT "cf_email='$cf_by'\n";
278 }
279 chomp($hwname = `Write Sys\$Output F\$GetSyi("HW_NAME")`);
280 $hwname = $archsufx if $hwname =~ /IVKEYW/;  # *really* old VMS version
281 print OUT "myuname='VMS $myname $osvers $hwname'\n";
282
283 # Before we read the C header file, find out what config.sh constants are
284 # equivalent to the C preprocessor macros
285 if (open(SH,"${outdir}config_h.SH")) {
286   while (<SH>) {
287     next unless m%^#(?!if).*\$%;
288     s/^#//; s!(.*?)\s*/\*.*!$1!;
289     my(@words) = split;
290     $words[1] =~ s/\(.*//;  # Clip off args from macro
291     # Did we use a shell variable for the preprocessor directive?
292     if ($words[0] =~ m!^\$(\w+)!) { $pp_vars{$words[1]} = $1; }
293     if (@words > 2) {  # We may also have a shell var in the value
294       shift @words;              #  Discard preprocessor directive
295       my($token) = shift @words; #  and keep constant name
296       my($word);
297       foreach $word (@words) {
298         next unless $word =~ m!\$(\w+)!;
299         $val_vars{$token} = $1;
300         last;
301       }
302     }
303   }
304   close SH;
305 }
306 else { warn "Couldn't read ${outdir}config_h.SH: $!\n"; }
307 $pp_vars{UNLINK_ALL_VERSIONS} = 'd_unlink_all_versions';  # VMS_specific
308
309 # OK, now read the C header file, and retcon statements into config.sh
310 while (<IN>) {  # roll through the comment header in Config.VMS
311   last if /config-start/;
312 }
313
314 while (<IN>) {
315   chop;
316   while (/\\\s*$/) {  # pick up contination lines
317     my $line = $_;
318     $line =~ s/\\\s*$//;
319     $_ = <IN>;
320     s/^\s*//;
321     $_ = $line . $_;
322   }              
323   next unless my ($blocked,$un,$token,$val) =
324                  m%^(\/\*)?\s*\#\s*(un)?def\w*\s+([A-Za-z0-9]\w+)\S*\s*(.*)%;
325   if (/config-skip/) {
326     delete $pp_vars{$token} if exists $pp_vars{$token};
327     delete $val_vars{$token} if exists $val_vars{$token};
328     next;
329   }
330   $val =~ s!\s*/\*.*!!; # strip off trailing comment
331   my($had_val); # Maybe a macro with args that we just #undefd or commented
332   if (!length($val) and $val_vars{$token} and ($un || $blocked)) {
333     print OUT "$val_vars{$token}=''\n" unless exists $done{$val_vars{$token}};
334     $done{$val_vars{$token}}++;
335     delete $val_vars{$token};
336     $had_val = 1;
337   }
338   $state = ($blocked || $un) ? 'undef' : 'define';
339   if ($pp_vars{$token}) {
340     print OUT "$pp_vars{$token}='$state'\n" unless exists $done{$pp_vars{$token}};
341     $done{$pp_vars{$token}}++;
342     delete $pp_vars{$token};
343   }
344   elsif (not length $val and not $had_val) {
345     # Wups -- should have been shell var for C preprocessor directive
346     warn "Constant $token not found in config_h.SH\n";
347     $token = lc $token;
348     $token = "d_$token" unless $token =~ /^i_/;
349     print OUT "$token='$state'\n";
350   }
351   next unless length $val;
352   $val =~ s/^"//; $val =~ s/"$//;               # remove end quotes
353   $val =~ s/","/ /g;                            # make signal list look nice
354   # Library directory; convert to VMS syntax
355   $val = VMS::Filespec::vmspath($val) if ($token =~ /EXP$/);
356   if ($val_vars{$token}) {
357     print OUT "$val_vars{$token}='$val'\n" unless exists $done{$val_vars{$token}};
358     if ($val_vars{$token} =~ s/exp$//) {
359       print OUT "$val_vars{$token}='$val'\n" unless exists $done{$val_vars{$token}};;
360     }
361     $done{$val_vars{$token}}++;
362     delete $val_vars{$token};
363   }
364   elsif (!$pp_vars{$token}) {  # Haven't seen it previously, either
365     warn "Constant $token not found in config_h.SH (val=|$val|)\n";
366     $token = lc $token;
367     print OUT "$token='$val'\n";
368     if ($token =~ s/exp$//) {print OUT "$token='$val'\n";}
369   }
370 }
371 close IN;
372 # Special case -- preprocessor manifest "VMS" is defined automatically
373 # on VMS systems, but is also used erroneously by the Perl build process
374 # as the manifest for the obsolete variable $d_eunice.
375 print OUT "d_eunice='undef'\n";  delete $pp_vars{VMS};
376
377 # XXX temporary -- USE_5005THREADS is currently on CC command line
378 delete $pp_vars{'USE_5005THREADS'};
379
380 foreach (sort keys %pp_vars) {
381   warn "Didn't see $_ in $infile\n";
382 }
383 foreach (sort keys %val_vars) {
384   warn "Didn't see $_ in $infile(val)\n";
385 }
386
387 if (open(OPT,"${outdir}crtl.opt")) {
388   while (<OPT>) {
389     next unless m#/(sha|lib)#i;
390     chomp;
391     if (/crtl/i || /gcclib/i) { push(@crtls,$_); }
392     else                      { push(@libs,$_);  }
393   }
394   close OPT;
395   print OUT "libs='",join(' ',@libs),"'\n";
396   push(@crtls,'(DECCRTL)') if $cctype eq 'decc';
397   print OUT "libc='",join(' ',@crtls),"'\n";
398 }
399 else { warn "Can't read ${outdir}crtl.opt - skipping 'libs' & 'libc'"; }
400
401 if (open(PL,"${outdir}patchlevel.h")) {
402   while (<PL>) {
403     if    (/^#define PERL_VERSION\s+(\S+)/) {
404       print OUT "PERL_VERSION='$1'\n";
405       print OUT "PATCHLEVEL='$1'\n";    # XXX compat
406     }
407     elsif (/^#define PERL_SUBVERSION\s+(\S+)/) {
408       print OUT "PERL_SUBVERSION='$1'\n";
409       print OUT "SUBVERSION='$1'\n";    # XXX compat
410     }
411   }
412   close PL;
413 }
414 else { warn "Can't read ${outdir}patchlevel.h - skipping 'PATCHLEVEL'"; }
415
416 # simple pager support for perldoc                                             
417 if    (`most not..file` =~ /IVVERB/) {
418   $pager = 'more';
419   if (`more nl:` =~ /IVVERB/) { $pager = 'type/page'; }
420 }
421 else { $pager = 'most'; }
422 print OUT "pager='$pager'\n";
423
424 close OUT;