[Patch Perl@12856] MULTIPLICITY on VMS

Message-Id: <011112123409.27041@DUPHY4.Physics.Drexel.Edu>

p4raw-id: //depot/perl@12958

6 files changed, 38 insertions, 19 deletions

diff --git a/ext/Cwd/Cwd.xs b/ext/Cwd/Cwd.xs
index a82404f156..19d3afd744 100644
--- a/ext/Cwd/Cwd.xs
+++ b/ext/Cwd/Cwd.xs
@@ -70,7 +70,8 @@ bsd_realpath(path, resolved)
 	char *resolved;
 {
 #ifdef VMS
-       return Perl_rmsexpand((char*)path, resolved, NULL, 0);
+       dTHX;
+       return Perl_rmsexpand(aTHX_ (char*)path, resolved, NULL, 0);
 #else
 	struct stat sb;
 	int n, rootd, serrno;
diff --git a/perlio.c b/perlio.c
index 1a21e25bd6..8e8b859e5d 100644
--- a/perlio.c
+++ b/perlio.c
@@ -38,6 +38,11 @@
 #define PERL_IN_PERLIO_C
 #include "perl.h"
 
+#ifdef PERL_IMPLICIT_CONTEXT
+#undef dSYS
+#define dSYS dTHX
+#endif
+
 #include "XSUB.h"
 
 int
diff --git a/vms/ext/Stdio/Stdio.xs b/vms/ext/Stdio/Stdio.xs
index 64bd75017a..75d87b371a 100644
--- a/vms/ext/Stdio/Stdio.xs
+++ b/vms/ext/Stdio/Stdio.xs
@@ -174,7 +174,7 @@ binmode(fh)
 	    }
            /* appearances to the contrary, this is an freopen substitute */
            name = sv_2mortal(newSVpvn(filespec,strlen(filespec)));
-           if (PerlIO_openn(Nullch,acmode,-1,0,0,fp,1,&name) == Nullfp) XSRETURN_UNDEF;
+           if (PerlIO_openn(aTHX_ Nullch,acmode,-1,0,0,fp,1,&name) == Nullfp) XSRETURN_UNDEF;
            if (iotype != '-' && ret != -1 && PerlIO_setpos(fp,&pos) == -1) XSRETURN_UNDEF;
 	    if (ret == -1) { set_errno(saverrno); set_vaxc_errno(savevmserrno); }
 	    XSRETURN_YES;
diff --git a/vms/gen_shrfls.pl b/vms/gen_shrfls.pl
index 07b6f8ec31..04161d491e 100644
--- a/vms/gen_shrfls.pl
+++ b/vms/gen_shrfls.pl
@@ -167,9 +167,9 @@ if ($use_mymalloc) {
 }
 
 if ($use_perlio) {
-  $preprocess_list = "${dir}perl.h,${dir}perliol.h";
+  $preprocess_list = "${dir}perl.h+${dir}perlapi.h,${dir}perliol.h";
 } else {
-  $preprocess_list = "${dir}perl.h";
+  $preprocess_list = "${dir}perl.h+${dir}perlapi.h";
 }
 
 $used_expectation_enum = $used_opcode_enum = 0; # avoid warnings
@@ -180,7 +180,7 @@ if ($docc) {
 else {
   open(CPP,"$cpp_file") or die "$0: Can't read preprocessed file $cpp_file: $!\n";
 }
-%checkh = map { $_,1 } qw( thread bytecode byterun proto perlio );
+%checkh = map { $_,1 } qw( thread bytecode byterun proto perlio perlvars intrpvar thrdvar );
 $ckfunc = 0;
 LINE: while (<CPP>) {
   while (/^#.*vmsish\.h/i .. /^#.*perl\.h/i) {
diff --git a/vms/sockadapt.c b/vms/sockadapt.c
index b4a0534f74..e7b207cbdc 100644
--- a/vms/sockadapt.c
+++ b/vms/sockadapt.c
@@ -34,10 +34,12 @@
 #if ((((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000)) && defined(DECCRTL_SOCKETS))
 #else
 void setnetent(int stayopen) {
-  croak("Function \"setnetent\" not implemented in this version of perl");
+  dTHX;
+  Perl_croak(aTHX_ "Function \"setnetent\" not implemented in this version of perl");
 }
 void endnetent() {
-  croak("Function \"endnetent\" not implemented in this version of perl");
+  dTHX;
+  Perl_croak(aTHX_ "Function \"endnetent\" not implemented in this version of perl");
 }
 #endif
 
@@ -49,29 +51,37 @@ void endnetent() {
 #if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000)
 #else
   void sethostent(int stayopen) {
-    croak("Function \"sethostent\" not implemented in this version of perl");
+    dTHX;
+    Perl_croak(aTHX_ "Function \"sethostent\" not implemented in this version of perl");
   }
   void endhostent() {
-    croak("Function \"endhostent\" not implemented in this version of perl");
+    dTHX;
+    Perl_croak(aTHX_ "Function \"endhostent\" not implemented in this version of perl");
   }
   void setprotoent(int stayopen) {
-    croak("Function \"setprotoent\" not implemented in this version of perl");
+    dTHX;
+    Perl_croak(aTHX_ "Function \"setprotoent\" not implemented in this version of perl");
   }
   void endprotoent() {
-    croak("Function \"endprotoent\" not implemented in this version of perl");
+    dTHX;
+    Perl_croak(aTHX_ "Function \"endprotoent\" not implemented in this version of perl");
   }
   void setservent(int stayopen) {
-    croak("Function \"setservent\" not implemented in this version of perl");
+    dTHX;
+    Perl_croak(aTHX_ "Function \"setservent\" not implemented in this version of perl");
   }
   void endservent() {
-    croak("Function \"endservent\" not implemented in this version of perl");
+    dTHX;
+    Perl_croak(aTHX_ "Function \"endservent\" not implemented in this version of perl");
   }
   __sockadapt_my_hostent_t gethostent() {
-    croak("Function \"gethostent\" not implemented in this version of perl");
+    dTHX;
+    Perl_croak(aTHX_ "Function \"gethostent\" not implemented in this version of perl");
     return (__sockadapt_my_hostent_t )NULL; /* Avoid MISSINGRETURN warning, not reached */
   }
   __sockadapt_my_servent_t getservent() {
-    croak("Function \"getservent\" not implemented in this version of perl");
+    dTHX;
+    Perl_croak(aTHX_ "Function \"getservent\" not implemented in this version of perl");
     return (__sockadapt_my_servent_t )NULL; /* Avoid MISSINGRETURN warning, not reached */
   }
 #endif
@@ -80,15 +90,18 @@ void endnetent() {
     /* Work around things missing/broken in SOCKETSHR. */
 
 __sockadapt_my_netent_t getnetbyaddr( __sockadapt_my_addr_t net, int type) {
-  croak("Function \"getnetbyaddr\" not implemented in this version of perl");
+  dTHX;
+  Perl_croak(aTHX_ "Function \"getnetbyaddr\" not implemented in this version of perl");
   return (struct netent *)NULL; /* Avoid MISSINGRETURN warning, not reached */
 }
 __sockadapt_my_netent_t getnetbyname( __sockadapt_my_name_t name) {
-  croak("Function \"getnetbyname\" not implemented in this version of perl");
+  dTHX;
+  Perl_croak(aTHX_ "Function \"getnetbyname\" not implemented in this version of perl");
   return (struct netent *)NULL; /* Avoid MISSINGRETURN warning, not reached */
 }
 __sockadapt_my_netent_t getnetent() {
-  croak("Function \"getnetent\" not implemented in this version of perl");
+  dTHX;
+  Perl_croak(aTHX_ "Function \"getnetent\" not implemented in this version of perl");
   return (__sockadapt_my_netent_t )NULL; /* Avoid MISSINGRETURN warning, not reached */
 }
 
diff --git a/vms/vms.c b/vms/vms.c
index 1150ea3859..5ad498bb4e 100644
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -5917,7 +5917,7 @@ Perl_my_localtime(pTHX_ const time_t *timep)
 # endif
   dst = -1;
 #ifndef RTL_USES_UTC
-  if (tz_parse(&when, &dst, 0, &offset)) {   /* truelocal determines DST*/
+  if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
       when = whenutc - offset;                   /* pseudolocal time*/
   }
 # endif