retsts = SS$_NOLOGNAM;
for (i = 0; environ[i]; i++) {
if ((eq = strchr(environ[i],'=')) &&
+ lnmdsc.dsc$w_length == (eq - environ[i]) &&
!strncmp(environ[i],uplnm,eq - environ[i])) {
eq++;
for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
}
}
else if (!ivlnm) {
- if (idx == 0) {
+ if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
midx = my_maxidx((char *) lnm);
for (idx = 0, cp1 = eqv; idx <= midx; idx++) {
lnmlst[1].bufadr = cp1;
(retsts == SS$_NOLOGNAM)) { continue; }
}
else {
- idx -= 1;
retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
if (retsts == SS$_NOLOGNAM) continue;
char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
unsigned long int idx = 0;
int trnsuccess, success, secure, saverr, savvmserr;
- int midx;
+ int midx, flags;
SV *tmpsv;
midx = my_maxidx((char *) lnm) + 1;
return eqv;
}
else {
- if ((cp2 = strchr(lnm,';')) != NULL) {
- strcpy(uplnm,lnm);
- uplnm[cp2-lnm] = '\0';
- idx = strtoul(cp2+1,NULL,0) + 1;
- lnm = uplnm;
- }
/* Impose security constraints only if tainting */
if (sys) {
/* Impose security constraints only if tainting */
secure = PL_curinterp ? PL_tainting : will_taint;
saverr = errno; savvmserr = vaxc$errno;
}
- else secure = 0;
- success = vmstrnenv(lnm,eqv,idx,
- secure ? fildev : NULL,
+ else {
+ secure = 0;
+ }
+
+ flags =
#ifdef SECURE_INTERNAL_GETENV
- secure ? PERL__TRNENV_SECURE : 0
+ secure ? PERL__TRNENV_SECURE : 0
#else
- 0
+ 0
#endif
- );
+ ;
+
+ /* For the getenv interface we combine all the equivalence names
+ * of a search list logical into one value to acquire a maximum
+ * value length of 255*128 (assuming %ENV is using logicals).
+ */
+ flags |= PERL__TRNENV_JOIN_SEARCHLIST;
+
+ /* If the name contains a semicolon-delimited index, parse it
+ * off and make sure we only retrieve the equivalence name for
+ * that index. */
+ if ((cp2 = strchr(lnm,';')) != NULL) {
+ strcpy(uplnm,lnm);
+ uplnm[cp2-lnm] = '\0';
+ idx = strtoul(cp2+1,NULL,0);
+ lnm = uplnm;
+ flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
+ }
+
+ success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
+
/* Discard NOLOGNAM on internal calls since we're often looking
* for an optional name, and this "error" often shows up as the
* (bogus) exit status for a die() call later on. */
{
char *buf, *cp1, *cp2;
unsigned long idx = 0;
- int midx;
+ int midx, flags;
static char *__my_getenv_len_eqv = NULL;
int secure, saverr, savvmserr;
SV *tmpsv;
return buf;
}
else {
- if ((cp2 = strchr(lnm,';')) != NULL) {
- strcpy(buf,lnm);
- buf[cp2-lnm] = '\0';
- idx = strtoul(cp2+1,NULL,0) + 1;
- lnm = buf;
- }
if (sys) {
/* Impose security constraints only if tainting */
secure = PL_curinterp ? PL_tainting : will_taint;
saverr = errno; savvmserr = vaxc$errno;
}
- else secure = 0;
- *len = vmstrnenv(lnm,buf,idx,
- secure ? fildev : NULL,
+ else {
+ secure = 0;
+ }
+
+ flags =
#ifdef SECURE_INTERNAL_GETENV
- secure ? PERL__TRNENV_SECURE : 0
+ secure ? PERL__TRNENV_SECURE : 0
#else
- 0
+ 0
#endif
- );
+ ;
+
+ flags |= PERL__TRNENV_JOIN_SEARCHLIST;
+
+ if ((cp2 = strchr(lnm,';')) != NULL) {
+ strcpy(buf,lnm);
+ buf[cp2-lnm] = '\0';
+ idx = strtoul(cp2+1,NULL,0);
+ lnm = buf;
+ flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
+ }
+
+ *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
+
/* Discard NOLOGNAM on internal calls since we're often looking
* for an optional name, and this "error" often shows up as the
* (bogus) exit status for a die() call later on. */
$DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
$DESCRIPTOR(local,"_LOCAL");
+ if (!lnm) {
+ set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
+ return SS$_IVLOGNAM;
+ }
+
for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
*cp2 = _toupper(*cp1);
if (cp1 - lnm > LNM$C_NAMLENGTH) {
for (curtab = 0; tabvec[curtab]; curtab++) {
if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
int i;
- for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
+ for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
if ((cp1 = strchr(environ[i],'=')) &&
+ lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
!strncmp(environ[i],lnm,cp1 - environ[i])) {
#ifdef HAS_SETENV
return setenv(lnm,"",1) ? vaxc$errno : 0;
}
if (!fp) return 0; /* we're hosed */
- fprintf(fp,"$! 'f$verify(0)\n");
+ fprintf(fp,"$! 'f$verify(0)'\n");
fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
fprintf(fp,"$ perl_define = \"define/nolog\"\n");
fprintf(fp,"$c=c+perl_popen_cmd2\n");
fprintf(fp,"$x=perl_popen_cmd3\n");
fprintf(fp,"$c=c+x\n");
- fprintf(fp,"$! --- get rid of global symbols\n");
- fprintf(fp,"$ perl_del/symbol/global perl_popen_in\n");
- fprintf(fp,"$ perl_del/symbol/global perl_popen_err\n");
- fprintf(fp,"$ perl_del/symbol/global perl_popen_out\n");
- fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd0\n");
- fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd1\n");
- fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd2\n");
- fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd3\n");
fprintf(fp,"$ perl_on\n");
- fprintf(fp,"$ 'c\n");
+ fprintf(fp,"$ 'c'\n");
fprintf(fp,"$ perl_status = $STATUS\n");
fprintf(fp,"$ perl_del 'perl_cfile'\n");
fprintf(fp,"$ perl_exit 'perl_status'\n");
{
static int handler_set_up = FALSE;
unsigned long int sts, flags = CLI$M_NOWAIT;
- unsigned int table = LIB$K_CLI_GLOBAL_SYM;
+ /* The use of a GLOBAL table (as was done previously) rendered
+ * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
+ * environment. Hence we've switched to LOCAL symbol table.
+ */
+ unsigned int table = LIB$K_CLI_LOCAL_SYM;
int j, wait = 0;
char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
char in[512], out[512], err[512], mbx[512];
} /* end of my_pclose() */
-#if defined(__CRTL_VER) && __CRTL_VER >= 70100322
+#if defined(__CRTL_VER) && __CRTL_VER >= 70200000
/* Roll our own prototype because we want this regardless of whether
* _VMS_WAIT is defined.
*/
/* fall through if this child is not one of our own pipe children */
-#if defined(__CRTL_VER) && __CRTL_VER >= 70100322
+#if defined(__CRTL_VER) && __CRTL_VER >= 70200000
/* waitpid() became available in the CRTL as of VMS 7.0, but only
* in 7.2 did we get a version that fills in the VMS completion
* of the current process.
*/
-#endif /* defined(__CRTL_VER) && __CRTL_VER >= 70100322 */
+#endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
{
$DESCRIPTOR(intdsc,"0 00:00:01");
if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
getredirection(argcp,argvp);
+#if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
+ {
+# include <reentrancy.h>
+ (void) decc$set_reentrancy(C$C_MULTITHREAD);
+ }
+#endif
return;
}
/*}}}*/
* Minor modifications to original routines.
*/
+/* readdir may have been redefined by reentr.h, so make sure we get
+ * the local version for what we do here.
+ */
+#ifdef readdir
+# undef readdir
+#endif
+#if !defined(PERL_IMPLICIT_CONTEXT)
+# define readdir Perl_readdir
+#else
+# define readdir(a) Perl_readdir(aTHX_ a)
+#endif
+
/* Number of elements in vms_versions array */
#define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
dd->pat.dsc$w_length = strlen(dd->pattern);
dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
dd->pat.dsc$b_class = DSC$K_CLASS_S;
+#if defined(USE_ITHREADS)
+ New(1308,dd->mutex,1,perl_mutex);
+ MUTEX_INIT( (perl_mutex *) dd->mutex );
+#else
+ dd->mutex = NULL;
+#endif
return dd;
} /* end of opendir() */
{
(void)lib$find_file_end(&dd->context);
Safefree(dd->pattern);
+#if defined(USE_ITHREADS)
+ MUTEX_DESTROY( (perl_mutex *) dd->mutex );
+ Safefree(dd->mutex);
+#endif
Safefree((char *)dd);
}
/*}}}*/
/*}}}*/
/*
+ * Read the next entry from the directory -- thread-safe version.
+ */
+/*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
+int
+Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
+{
+ int retval;
+
+ MUTEX_LOCK( (perl_mutex *) dd->mutex );
+
+ entry = readdir(dd);
+ *result = entry;
+ retval = ( *result == NULL ? errno : 0 );
+
+ MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
+
+ return retval;
+
+} /* end of readdir_r() */
+/*}}}*/
+
+/*
* Return something that can be used in a seekdir later.
*/
/*{{{ long telldir(DIR *dd)*/
projects / p5sagit/p5-mst-13.2.git / blobdiff