diff options
Diffstat (limited to 'vms')
| -rw-r--r-- | vms/descrip_mms.template | 2 | ||||
| -rw-r--r-- | vms/subconfigure.com | 113 | ||||
| -rw-r--r-- | vms/vms.c | 65 | ||||
| -rw-r--r-- | vms/vmsish.h | 3 |
4 files changed, 165 insertions, 18 deletions
diff --git a/vms/descrip_mms.template b/vms/descrip_mms.template index 206740890e..0bd08de57b 100644 --- a/vms/descrip_mms.template +++ b/vms/descrip_mms.template @@ -240,7 +240,7 @@ INSTPERL = perl # Space-separated list of "dynamic" extensions which should be built for # run-time dynamic loading. -dynamic_ext = Fcntl Errno IO Opcode Data::Dumper attrs re VMS::Stdio VMS::DCLsym B SDBM_File POSIX +dynamic_ext = $extensions # Space-separated list of "static" extensions to build into perlshr (case counts). MYEXT = DynaLoader diff --git a/vms/subconfigure.com b/vms/subconfigure.com index d96c845a80..6b6483a9a1 100644 --- a/vms/subconfigure.com +++ b/vms/subconfigure.com @@ -449,6 +449,8 @@ $ if ("''Use_Threads'".eqs."T") $ THEN $ perl_arch = "''perl_arch'-thread" $ perl_archname = "''perl_archname'-thread" +$ perl_d_old_pthread_create_joinable = "undef" +$ perl_old_pthread_create_joinable = " " $ ELSE $ perl_d_old_pthread_create_joinable = "undef" $ perl_old_pthread_create_joinable = " " @@ -1097,11 +1099,11 @@ $ DEASSIGN SYS$ERROR $ if (teststatus.nes."1") $ THEN $! Okay, off64_t failed. Must not exist -$ perl_d_off64t = "undef" +$ perl_d_off64_t = "undef" $ ELSE -$ perl_d_off64t="define" +$ perl_d_off64_t="define" $ ENDIF -$ WRITE_RESULT "d_off64t is ''perl_d_off64t'" +$ WRITE_RESULT "d_off64_t is ''perl_d_off64_t'" $! $! Check to see if gethostname exists $! @@ -1487,6 +1489,52 @@ $ ENDIF $ ENDIF $ WRITE_RESULT "d_fcntl is ''perl_d_fcntl'" $! +$! Check for memchr +$! +$ OS +$ WS "#ifdef __DECC +$ WS "#include <stdlib.h> +$ WS "#endif +$ WS "#include <string.h> +$ WS "int main() +$ WS "{" +$ WS "char * place; +$ WS "place = memchr(""foo"", 47, 3) +$ WS "exit(0); +$ WS "}" +$ CS +$ DEFINE SYS$ERROR _NLA0: +$ DEFINE SYS$OUTPUT _NLA0: +$ on error then continue +$ on warning then continue +$ 'Checkcc' temp.c +$ savedstatus = $status +$ teststatus = f$extract(9,1,savedstatus) +$ if (teststatus.nes."1") +$ THEN +$ perl_d_memchr="undef" +$ DEASSIGN SYS$OUTPUT +$ DEASSIGN SYS$ERROR +$ ELSE +$ If (Needs_Opt.eqs."Yes") +$ THEN +$ link temp.obj,temp.opt/opt +$ else +$ link temp.obj +$ endif +$ savedstatus = $status +$ teststatus = f$extract(9,1,savedstatus) +$ DEASSIGN SYS$OUTPUT +$ DEASSIGN SYS$ERROR +$ if (teststatus.nes."1") +$ THEN +$ perl_d_memchr="undef" +$ ELSE +$ perl_d_memchr="define" +$ ENDIF +$ ENDIF +$ WRITE_RESULT "d_memchr is ''perl_d_memchr'" +$! $! Check for access $! $ OS @@ -1782,6 +1830,52 @@ $ perl_i_niin="undef" $ ENDIF $ WRITE_RESULT "i_niin is ''perl_i_niin'" $! +$! Check for <netinet/tcp.h> +$! +$ if ("''Has_Dec_C_Sockets'".eqs."T").or.("''Has_Socketshr'".eqs."T") +$ THEN +$ OS +$ WS "#ifdef __DECC +$ WS "#include <stdlib.h> +$ WS "#endif +$ WS "#include <stdio.h> +$ if ("''Has_Socketshr'".eqs."T") +$ THEN +$ WS "#include <socketshr.h>" +$ else +$ WS "#include <netdb.h> +$ endif +$ WS "#include <netinet/tcp.h>" +$ WS "int main() +$ WS "{" +$ WS "exit(0); +$ WS "}" +$ CS +$ DEFINE SYS$ERROR _NLA0: +$ DEFINE SYS$OUTPUT _NLA0: +$ on error then continue +$ on warning then continue +$ 'Checkcc' temp.c +$ If (Needs_Opt.eqs."Yes") +$ THEN +$ link temp.obj,temp.opt/opt +$ else +$ link temp.obj +$ endif +$ teststatus = f$extract(9,1,$status) +$ DEASSIGN SYS$OUTPUT +$ DEASSIGN SYS$ERROR +$ if (teststatus.nes."1") +$ THEN +$ perl_i_netinettcp="undef" +$ ELSE +$ perl_i_netinettcp="define" +$ ENDIF +$ ELSE +$ perl_i_netinettcp="undef" +$ ENDIF +$ WRITE_RESULT "i_netinettcp is ''perl_i_netinettcp'" +$! $! Check for endhostent $! $ if ("''Has_Dec_C_Sockets'".eqs."T").or.("''Has_Socketshr'".eqs."T") @@ -2396,13 +2490,17 @@ $ DEASSIGN SYS$ERROR $ if (teststatus.nes."1") $ THEN $ perl_d_sched_yield="undef" +$ perl_sched_yield = " " $ ELSE $ perl_d_sched_yield="define" +$ perl_sched_yield = "sched_yield" $ ENDIF $ ELSE $ perl_d_sched_yield="undef" +$ perl_sched_yield = " " $ ENDIF $ WRITE_RESULT "d_sched_yield is ''perl_d_sched_yield'" +$ WRITE_RESULT "sched_yield is ''perl_sched_yield'" $! $! Check for generic pointer size $! @@ -2736,6 +2834,7 @@ $! $ WC "# This file generated by Configure.COM on a VMS system." $ WC "# Time: " + perl_cf_time $ WC "" +$ WC "CONFIGDOTSH=true" $ WC "package='" + perl_package + "'" $ WC "CONFIG='" + perl_config + "'" $ WC "cf_time='" + perl_cf_time + "'" @@ -2788,6 +2887,7 @@ $ WC "d_gethent='" + perl_d_gethent + "'" $ WC "d_getsent='" + perl_d_getsent + "'" $ WC "d_select='" + perl_d_select + "'" $ WC "i_niin='" + perl_i_niin + "'" +$ WC "i_netinettcp='" + perl_i_netinettcp + "'" $ WC "i_neterrno='" + perl_i_neterrno + "'" $ WC "d_stdstdio='" + perl_d_stdstdio + "'" $ WC "d_stdio_ptr_lval='" + perl_d_stdio_ptr_lval + "'" @@ -3160,7 +3260,7 @@ $ WC "d_nextkey64='" + perl_d_nextkey64 + "'" $ WC "i_poll='" + perl_i_poll + "'" $ WC "i_inttypes='" + perl_i_inttypes + "'" $ WC "d_int64t='" + perl_d_int64t + "'" -$ WC "d_off64t='" + perl_d_off64t + "'" +$ WC "d_off64_t='" + perl_d_off64_t + "'" $ WC "d_fstat64='" + perl_d_fstat64 + "'" $ WC "d_ftruncate64='" + perl_d_ftruncate64 + "'" $ WC "d_lseek64='" + perl_d_lseek64 + "'" @@ -3192,7 +3292,11 @@ $ WC "seedfunc='" + perl_seedfunc + "'" $ WC "sig_num_init='" + perl_sig_num_with_commas + "'" $ WC "i_sysmount='" + perl_i_sysmount + "'" $ WC "d_fstatfs='" + perl_d_fstatfs + "'" +$ WC "d_memchr='" + perl_d_memchr + "'" $ WC "d_statfsflags='" + perl_d_statfsflags + "'" +$ WC "fflushNULL='define'" +$ WC "fflushall='undef'" +$ WC "d_stdio_stream_array='undef'" $ WC "i_sysstatvfs='" + perl_i_sysstatvfs + "'" $ WC "i_machcthreads='" + perl_i_machcthreads + "'" $ WC "i_pthread='" + perl_i_pthread + "'" @@ -3210,6 +3314,7 @@ $ WC "i_sysmman='" + perl_i_sysmman + "'" $ WC "installusrbinperl='" + perl_installusrbinperl + "'" $ WC "crosscompile='" + perl_crosscompile + "'" $ WC "multiarch='" + perl_multiarch + "'" +$ WC "sched_yield='" + perl_sched_yield + "'" $! $! ##WRITE NEW CONSTANTS HERE## $! @@ -106,6 +106,18 @@ vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen}, {0, 0, 0, 0}}; $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM"); +#if defined(USE_THREADS) + /* We jump through these hoops because we can be called at */ + /* platform-specific initialization time, which is before anything is */ + /* set up--we can't even do a plain dTHR since that relies on the */ + /* interpreter structure to be initialized */ + struct perl_thread *thr; + if (PL_curinterp) { + thr = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv); + } else { + thr = NULL; + } +#endif if (!lnm || !eqv || idx > LNM$_MAX_INDEX) { set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0; @@ -159,8 +171,22 @@ vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, if (eqvlen > 1024) { set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU); eqvlen = 1024; - if (ckWARN(WARN_MISC)) - warner(WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm); + /* Special hack--we might be called before the interpreter's */ + /* fully initialized, in which case either thr or PL_curcop */ + /* might be bogus. We have to check, since ckWARN needs them */ + /* both to be valid if running threaded */ +#if defined(USE_THREADS) + if (thr && PL_curcop) { +#endif + if (ckWARN(WARN_MISC)) { + warner(WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm); + } +#if defined(USE_THREADS) + } else { + warner(WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm); + } +#endif + } strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen); } @@ -188,7 +214,6 @@ vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, } /* end of vmstrnenv */ /*}}}*/ - /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/ /* Define as a function so we can access statics. */ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx) @@ -260,9 +285,19 @@ my_getenv(const char *lnm, bool sys) char * my_getenv_len(const char *lnm, unsigned long *len, bool sys) { - char buf[LNM$C_NAMLENGTH+1], *cp1, *cp2; + char *buf, *cp1, *cp2; unsigned long idx = 0; - + static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1]; + SV *tmpsv; + + if (PL_curinterp) { /* Perl interpreter running -- may be threaded */ + /* Set up a temporary buffer for the return value; Perl will + * clean it up at the next statement transition */ + tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1)); + if (!tmpsv) return NULL; + buf = SvPVX(tmpsv); + } + else buf = __my_getenv_len_eqv; /* Assume no interpreter ==> single thread */ for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1); if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) { getcwd(buf,LNM$C_NAMLENGTH); @@ -285,7 +320,8 @@ my_getenv_len(const char *lnm, unsigned long *len, bool sys) #endif ))) return buf; - else return Nullch; + else + return Nullch; } } /* end of my_getenv_len() */ @@ -1083,6 +1119,7 @@ Pid_t my_waitpid(Pid_t pid, int *statusp, int flags) { struct pipe_details *info; + dTHR; for (info = open_pipes; info != NULL; info = info->next) if (info->pid == pid) break; @@ -3381,6 +3418,7 @@ bool vms_do_exec(char *cmd) { + dTHR; if (vfork_called) { /* this follows a vfork - act Unixish */ vfork_called--; if (vfork_called < 0) { @@ -3445,6 +3483,7 @@ unsigned long int do_spawn(char *cmd) { unsigned long int sts, substs, hadcmd = 1; + dTHR; TAINT_ENV(); TAINT_PROPER("spawn"); @@ -4499,17 +4538,19 @@ flex_fstat(int fd, Stat_t *statbufp) } /* end of flex_fstat() */ /*}}}*/ -/*{{{ int flex_stat(char *fspec, Stat_t *statbufp)*/ +/*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/ int -flex_stat(char *fspec, Stat_t *statbufp) +flex_stat(const char *fspec, Stat_t *statbufp) { dTHR; char fileified[NAM$C_MAXRSS+1]; + char temp_fspec[NAM$C_MAXRSS+300]; int retval = -1; + strcpy(temp_fspec, fspec); if (statbufp == (Stat_t *) &PL_statcache) - do_tovmsspec(fspec,namecache,0); - if (is_null_device(fspec)) { /* Fake a stat() for the null device */ + do_tovmsspec(temp_fspec,namecache,0); + if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */ memset(statbufp,0,sizeof *statbufp); statbufp->st_dev = encode_dev("_NLA0:"); statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC; @@ -4528,12 +4569,12 @@ flex_stat(char *fspec, Stat_t *statbufp) * the file with null type, specify this by calling flex_stat() with * a '.' at the end of fspec. */ - if (do_fileify_dirspec(fspec,fileified,0) != NULL) { + if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) { retval = stat(fileified,(stat_t *) statbufp); if (!retval && statbufp == (Stat_t *) &PL_statcache) strcpy(namecache,fileified); } - if (retval) retval = stat(fspec,(stat_t *) statbufp); + if (retval) retval = stat(temp_fspec,(stat_t *) statbufp); if (!retval) { statbufp->st_dev = encode_dev(statbufp->st_devnam); # ifdef RTL_USES_UTC diff --git a/vms/vmsish.h b/vms/vmsish.h index 06ad647169..8f630189b7 100644 --- a/vms/vmsish.h +++ b/vms/vmsish.h @@ -66,6 +66,7 @@ /* Note that we do, in fact, have this */ #define HAS_GETENV_SV +#define HAS_GETENV_LEN #ifndef DONT_MASK_RTL_CALLS # ifdef getenv @@ -624,7 +625,7 @@ int my_sigprocmask (int, sigset_t *, sigset_t *); #endif I32 cando_by_name (I32, I32, char *); int flex_fstat (int, Stat_t *); -int flex_stat (char *, Stat_t *); +int flex_stat (const char *, Stat_t *); int trim_unixpath (char *, char*, int); int my_vfork (); bool vms_do_aexec (SV *, SV **, SV **); |