Lots of VMS changes. vms/gen_shrfls.pl (which parses header files)

needs rewriting now that we use perlvars.h and foovar.h:
	Subject: [PATCH] 5.004_54 under VMS (fwd)

p4raw-id: //depot/perl@374

dosish.h

@@ -75,6 +75,14 @@
  */
 #undef USEMYBINMODE
 
+/* Stat_t:
+ *	This symbol holds the type used to declare buffers for information
+ *	returned by stat().  It's usually just struct stat.  It may be necessary
+ *	to include <sys/stat.h> and <sys/types.h> to get any typedef'ed
+ *	information.
+ */
+#define Stat_t struct stat
+
 /* USE_STAT_RDEV:
  *	This symbol is defined if this system has a stat structure declaring
  *	st_rdev

handy.h

@@ -65,7 +65,7 @@
 #endif /* NeXT */
 
 #ifndef HAS_BOOL
-# ifdef UTS
+# if defined(UTS) || defined(VMS)
 #  define bool int
 # else
 #  define bool char

intrpvar.h

@@ -51,7 +51,7 @@ PERLVAR(Istatusvalue,	I32)		/* $? */
 PERLVAR(Istatusvalue_vms,	U32)		
 #endif
 
-PERLVAR(Istatcache,	struct stat)	/* _ */
+PERLVAR(Istatcache,	Stat_t)	/* _ */
 PERLVAR(Istatgv,	GV *)		
 PERLVARI(Istatname,	SV *,	Nullsv)	
 

os2/os2ish.h

@@ -25,6 +25,14 @@
  */
 #undef USEMYBINMODE
 
+/* Stat_t:
+ *	This symbol holds the type used to declare buffers for information
+ *	returned by stat().  It's usually just struct stat.  It may be necessary
+ *	to include <sys/stat.h> and <sys/types.h> to get any typedef'ed
+ *	information.
+ */
+#define Stat_t struct stat
+
 /* USE_STAT_RDEV:
  *	This symbol is defined if this system has a stat structure declaring
  *	st_rdev

perl.c

@@ -913,6 +913,7 @@ print \"  \\@INC:\\n    @INC\\n\";");
 
     /* now parse the script */
 
+    SETERRNO(0,SS$_NORMAL);
     error_count = 0;
     if (yyparse() || error_count) {
 	if (minus_c)
@@ -1823,7 +1824,7 @@ SV *sv;
      *
      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
      * proceeds as follows:
-     *   If DOSISH:
+     *   If DOSISH or VMSISH:
      *     + look for ./scriptname{,.foo,.bar}
      *     + search the PATH for scriptname{,.foo,.bar}
      *
@@ -1833,11 +1834,20 @@ SV *sv;
      */
 
 #ifdef VMS
+#  ifdef ALWAYS_DEFTYPES
+    len = strlen(scriptname);
+    if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
+	int hasdir, idx = 0, deftypes = 1;
+	bool seen_dot = 1;
+
+	hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
+#  else
     if (dosearch) {
 	int hasdir, idx = 0, deftypes = 1;
 	bool seen_dot = 1;
 
 	hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
+#  endif
 	/* The first time through, just add SEARCH_EXTS to whatever we
 	 * already have, so we can check for default file types. */
 	while (deftypes ||

perl.h

@@ -75,7 +75,7 @@ register struct op *op asm(stringify(OP_IN_REGISTER));
 
 #define NOOP (void)0
 
-#define WITH_THR(s) do { dTHR; s; } while (0)
+#define WITH_THR(s) STMT_START { dTHR; s; } STMT_END
 
 /*
  * SOFT_CAST can be used for args to prototyped functions to retain some

plan9/plan9ish.h

@@ -60,6 +60,14 @@
  */
 #undef USEMYBINMODE
 
+/* Stat_t:
+ *	This symbol holds the type used to declare buffers for information
+ *	returned by stat().  It's usually just struct stat.  It may be necessary
+ *	to include <sys/stat.h> and <sys/types.h> to get any typedef'ed
+ *	information.
+ */
+#define Stat_t struct stat
+
 /* USE_STAT_RDEV:
 *	This symbol is defined if this system has a stat structure declaring
 *	st_rdev

pp.c

@@ -3526,7 +3526,7 @@ is_an_int(char *s, STRLEN l)
 }
 
 static int
-div128(SV *pnum, char *done)
+div128(SV *pnum, bool *done)
                           		    /* must be '\0' terminated */
 
 {

proto.h

@@ -48,7 +48,7 @@ I32	block_gimme _((void));
 int	block_start _((int full));
 void	boot_core_UNIVERSAL _((void));
 void	call_list _((I32 oldscope, AV* list));
-I32	cando _((I32 bit, I32 effective, struct stat* statbufp));
+I32	cando _((I32 bit, I32 effective, Stat_t* statbufp));
 #ifndef CASTNEGFLOAT
 U32	cast_ulong _((double f));
 #endif

t/lib/thread.t

@@ -4,7 +4,7 @@ BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
     require Config; import Config;
-    if ($Config{'ccflags'} !~ /-DUSE_THREADS\b/) {
+    if ($Config{'ccflags'} !~ /USE_THREADS\b/) {
 	print "1..0\n";
 	exit 0;
     }
@@ -49,6 +49,6 @@ join $t;
 
 # test that sleep lets other thread run
 $t = new Thread \&islocked,"ok 8\n";
-sleep 2;
+sleep 6;
 print "ok 9";
 join $t;

t/lib/timelocal.t

@@ -19,6 +19,9 @@ use Time::Local;
    [2010, 10, 12, 14, 13, 12],
   );
 
+# use vmsish 'time' makes for oddness around the Unix epoch
+if ($^O eq 'VMS') { $time[0][2]++ }
+
 print "1..", @time * 2 + 5, "\n";
 
 $count = 1;

t/op/nothread.t

@@ -9,7 +9,7 @@ BEGIN
   @INC = "../lib";
   require Config;
   import Config;
-  if ($Config{'ccflags'} =~ /-DUSE_THREADS\b/)
+  if ($Config{'ccflags'} =~ /USE_THREADS\b/)
    {
     print "1..0\n";
     exit 0;

taint.c

@@ -55,10 +55,12 @@ taint_env(void)
 	if (!svp || *svp == &sv_undef)
 	    break;
 	if (SvTAINTED(*svp)) {
+	    dTHR;
 	    TAINT;
 	    taint_proper("Insecure %s%s", "$ENV{DCL$PATH}");
 	}
 	if ((mg = mg_find(*svp, 'e')) && MgTAINTEDDIR(mg)) {
+	    dTHR;
 	    TAINT;
 	    taint_proper("Insecure directory in %s%s", "$ENV{DCL$PATH}");
 	}

thrdvar.h

@@ -30,7 +30,7 @@ PERLVAR(Tmarkstack_max,	I32 *)
 
 PERLVAR(TSv,		SV *)		
 PERLVAR(TXpv,		XPV *)		
-PERLVAR(Tstatbuf,	struct stat)		
+PERLVAR(Tstatbuf,	Stat_t)		
 #ifdef HAS_TIMES
 PERLVAR(Ttimesbuf,	struct tms)		
 #endif
@@ -66,7 +66,7 @@ PERLVARI(Tcurcop,	COP * VOL,	&compiling)
 PERLVAR(Tin_eval,	VOL int)	/* trap "fatal" errors? */
 PERLVAR(Tdelaymagic,	int)		/* ($<,$>) = ... */
 PERLVAR(Tdirty,		bool)		/* In the middle of tearing things down? */
-PERLVAR(Tlocalizing,	U8)		/* are we processing a local() list? */
+PERLVAR(Tlocalizing,	int)		/* are we processing a local() list? */
 
 PERLVAR(Tcxstack,	PERL_CONTEXT *)		
 PERLVARI(Tcxstack_ix,	I32,	-1)	

toke.c

@@ -1068,6 +1068,7 @@ incl_perldb(void)
 
 	if (pdb)
 	    return pdb;
+	SETERRNO(0,SS$_NORMAL);
 	return "BEGIN { require 'perl5db.pl' }";
     }
     return "";

unixish.h

@@ -42,6 +42,14 @@
  */
 #undef USEMYBINMODE
 
+/* Stat_t:
+ *	This symbol holds the type used to declare buffers for information
+ *	returned by stat().  It's usually just struct stat.  It may be necessary
+ *	to include <sys/stat.h> and <sys/types.h> to get any typedef'ed
+ *	information.
+ */
+#define Stat_t struct stat
+
 /* USE_STAT_RDEV:
  *	This symbol is defined if this system has a stat structure declaring
  *	st_rdev

vms/config.vms

@@ -76,7 +76,8 @@
  * when Perl is built.  Please do not change it by hand; make
  * any changes to FndVers.Com instead.
  */
-#define ARCHLIB_EXP "/perl_root/lib/VMS_VAX/5_004"     /**/
+#define ARCHLIB_EXP "/perl_root/lib/VMS_VAX/5_00454"   /**/
+
 #define ARCHLIB ARCHLIB_EXP	/*config-skip*/
 
 /* ARCHNAME:

vms/descrip.mms

@@ -74,7 +74,7 @@ OBJVAL = $(MMS$TARGET_NAME)$(O)
 .endif
 
 # Updated by fndvers.com -- do not edit by hand
-PERL_VERSION = 5_004  #
+PERL_VERSION = 5_00454#
 
 .ifdef DECC_SOCKETS
 SOCKET=1
@@ -130,7 +130,7 @@ POSIX =
 .else
 XTRAOBJS = 
 LIBS1 = $(XTRAOBJS)
-DBGSPECFLAGS = /Show=(Source,Include,Expansion)
+DBGSPECFLAGS = /Show=All
 .ifdef decc
 # Some versions of DECCRTL on AXP have a bug in chdir() which causes the change
 # to persist after the image exits, even when this was not requested, iff
@@ -370,10 +370,9 @@ archcorefiles :  $(ac1) $(ac2) $(ac3) $(ac4) $(ac5) $(ac6) $(ac7) $(ac8) $(ac9)
 
 miniperl : $(DBG)miniperl$(E)
 	@ Continue
-miniperl_objs = miniperlmain$(O), $(obj)
 $(MINIPERL_EXE) :  miniperlmain$(O), $(DBG)libperl$(OLB) $(CRTL)
 	Link $(LINKFLAGS)/NoDebug/NoMap/NoFull/NoCross/Exe=$(MMS$TARGET) miniperlmain$(O), $(DBG)libperl$(OLB)/Library/Include=globals $(CRTLOPTS)
-$(DBG)miniperl$(E) :  $(miniperl_objs), $(DBG)libperl$(OLB) $(CRTL)
+$(DBG)miniperl$(E) :  miniperlmain$(O), $(DBG)libperl$(OLB) $(CRTL)
 	Link $(LINKFLAGS)/Exe=$(MMS$TARGET) miniperlmain$(O),$(DBG)libperl$(OLB)/Library/Include=globals  $(CRTLOPTS)
 
 $(DBG)libperl$(OLB) : $(obj)

vms/fndvers.com

@@ -58,7 +58,7 @@ $ If .not.teststs Then Exit teststs
 $!
 $ If teststs.ne.1 ! current values in config.vms are appropriate
 $ Then
-$   token = """""""""VMS_''arch'  /**/"""""""""
+$   token = """""""""VMS_''arch'""""""""  /**/"
 $   Call update_file "''p2'" "#define ARCHNAME" "''token'"
 $   teststs = $Status
 $   If .not.teststs Then Exit teststs

vms/gen_shrfls.pl

@@ -39,7 +39,7 @@
 
 $debug = $ENV{'GEN_SHRFLS_DEBUG'};
 
-print "gen_shrfls.pl Rev. 14-Dec-1996\n" if $debug;
+print "gen_shrfls.pl Rev. 03-Nov-1997\n" if $debug;
 
 if ($ARGV[0] eq '-f') {
   open(INP,$ARGV[1]) or die "Can't read input file $ARGV[1]: $!\n";
@@ -150,7 +150,7 @@ sub scan_var {
   $line =~ s/\[.*//;
   $line =~ s/=.*//;
   $line =~ s/\W*;?\s*$//;
-  $line =~ s/\(void//;
+  $line =~ s/\W*\)\s*\(.*$//; # closing paren for args stripped in previous stmt
   print "\tfiltered to \\$line\\\n" if $debug > 1;
   if ($line =~ /(\w+)$/) {
     print "\tvar name is \\$1\\" . ($const ? ' (const)' : '') . "\n" if $debug > 1;
@@ -216,6 +216,12 @@ sub scan_func {
     &scan_enum($_);
     last LINE unless $_ = <CPP>;
   }
+  while (/^#.*thread\.h/i .. /^#.*perl\.h/i) {
+    print "thread.h>> $_" if $debug > 2;
+    if (/\s*^EXT/) { &scan_var($_);  }
+    else        { &scan_func($_); }
+    last LINE unless $_ = <CPP>;
+  }
   while (/^#.*proto\.h/i .. /^#.*perl\.h/i) {
     print "proto.h>> $_" if $debug > 2;
     if (/\s*^EXT/) { &scan_var($_);  }
@@ -373,7 +379,7 @@ sub scan_func {
   my $minor = int(($] * 1000 - $major) * 100 + 0.5) & 0xFF;  # range 0..255
   print OPTBLD "GSMATCH=LEQUAL,$major,$minor\n";
   foreach (@symfiles) {
-    print OPTBLD "CLUSTER=\$\$TRANSFER_VECTOR,,,$_.$objsuffix\n";
+    print OPTBLD "CLUSTER=\$\$TRANSFER_VECTOR,,,$_$objsuffix\n";
   }
 }
 elsif (@symfiles) { $incstr .= ',' . join(',',@symfiles); }

vms/genconfig.pl

@@ -6,7 +6,7 @@
 # that went into your perl binary.  In addition, values which change from run
 # to run may be supplied on the command line as key=val pairs.
 #
-# Rev.  3-Dec-1996  Charles Bailey  bailey@genetics.upenn.edu
+# Rev. 10-Nov-1997  Charles Bailey  bailey@newman.upenn.edu
 #
 
 #==== Locations of installed Perl components
@@ -78,10 +78,9 @@
 eunicefix=':'
 hint='none'
 hintfile=''
-shrplib='define'
+useshrplib='define'
 usemymalloc='n'
 usevfork='true'
-useposix='false'
 spitshell='write sys\$output '
 dlsrc='dl_vms.c'
 binexp='$installbin'
@@ -146,7 +145,21 @@
       # object file suffix if it's not .obj.
       $ccflags =~ s#/obj(?:ect)?=[^/\s]+##i;
     }
+    $debug = $optimize = '';
+    while ( ($qual) = $ccflags =~ m|(/(No)?Deb[^/]*)|i ) {
+      $debug = $qual;
+      $ccflags =~ s/$qual//;
+    }
+    while ( ($qual) = $ccflags =~ m|(/(No)?Opt[^/]*)|i ) {
+      $optimize = $qual;
+      $ccflags =~ s/$qual//;
+    }
+    $optimize = "$debug$optimize";
     print OUT "ccflags='$ccflags'\n";
+    print OUT "optimize='$optimize'\n";
+    $usethreads = ($ccflags =~ m!/DEF[^/]+USE_THREADS!i and
+                   $ccflags !~ m!/UND[^/]+USE_THREADS!i);
+    print OUT "usethreads='$usethreads'\n";
     $dosock = ($ccflags =~ m!/DEF[^/]+VMS_DO_SOCKETS!i and
                $ccflags !~ m!/UND[^/]+VMS_DO_SOCKETS!i);
     print OUT "d_vms_do_sockets=",$dosock ? "'define'\n" : "'undef'\n";
@@ -156,9 +169,13 @@
     print OUT "d_select=",$dosock ? "'define'\n" : "'undef'\n";
     print OUT "i_niin=",$dosock ? "'define'\n" : "'undef'\n";
     print OUT "i_neterrno=",$dosock ? "'define'\n" : "'undef'\n";
+    if ($dosock and $cctype eq 'decc' and $ccflags =~ /DECCRTL_SOCKETS/) {
+      print OUT "selecttype=fd_set\n";
+    }
+    else { print OUT "selecttype=int\n"; }
 
-    if ($cctype eq 'decc') { $rtlhas  = 'define'; }
-    else                   { $rtlhas  = 'undef';  }
+    if ($cctype eq 'decc') { $rtlhas  = 'define'; print OUT "useposix='true'\n";  }
+    else                   { $rtlhas  = 'undef';  print OUT "useposix='false'\n"; }
     foreach (qw[ d_stdstdio d_stdio_ptr_lval d_stdio_cnt_lval d_stdiobase
                  d_locconv d_setlocale i_locale d_mbstowcs d_mbtowc
                  d_wcstombs d_wctomb d_mblen d_mktime d_strcoll d_strxfrm ]) {

vms/test.com

@@ -111,7 +111,7 @@ $| = 1;
 
 @ARGV = grep($_,@ARGV);  # remove empty elements due to "''p1'" syntax
 
-if ($ARGV[0] eq '-v') {
+if (lc($ARGV[0]) eq '-v') {
     $verbose = 1;
     shift;
 }