}
}
if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
- else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
- retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
+ else if (retsts == LIB$_NOSUCHSYM ||
retsts == SS$_NOLOGNAM) {
+ /* Unsuccessful lookup is normal -- no need to set errno */
+ return 0;
+ }
+ else if (retsts == LIB$_INVSYMNAM ||
+ retsts == SS$_IVLOGNAM ||
+ retsts == SS$_IVLOGTAB) {
set_errno(EINVAL); set_vaxc_errno(retsts);
}
else _ckvmssts_noperl(retsts);
static char *__my_getenv_eqv = NULL;
char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
unsigned long int idx = 0;
- int success, secure, saverr, savvmserr;
+ int success, secure;
int midx, flags;
SV *tmpsv;
if (sys) {
/* Impose security constraints only if tainting */
secure = PL_curinterp ? TAINTING_get : will_taint;
- saverr = errno; savvmserr = vaxc$errno;
}
else {
secure = 0;
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. */
- if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
return success ? eqv : NULL;
}
unsigned long idx = 0;
int midx, flags;
static char *__my_getenv_len_eqv = NULL;
- int secure, saverr, savvmserr;
+ int secure;
SV *tmpsv;
midx = my_maxidx(lnm) + 1;
if (sys) {
/* Impose security constraints only if tainting */
secure = PL_curinterp ? TAINTING_get : will_taint;
- saverr = errno; savvmserr = vaxc$errno;
}
else {
secure = 0;
}
}
- /* 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. */
- if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
return *len ? buf : NULL;
}
vmsdir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
cp1 = strpbrk(trndir,"]:>");
+ if (cp1 && *(cp1+1) == ':') /* DECNet node spec with :: */
+ cp1 = strpbrk(cp1+2,"]:>");
+
if (hasfilename || !cp1) { /* filename present or not VMS */
if (trndir[0] == '.') {
/* We've picked up everything up to the directory file name.
Now just add the type and version, and we're set. */
if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
- strcat(buf,".dir;1");
+ strcat(buf,".dir");
else
- strcat(buf,".DIR;1");
+ strcat(buf,".DIR");
+ if (!decc_filename_unix_no_version)
+ strcat(buf,";1");
PerlMem_free(trndir);
PerlMem_free(vmsdir);
return buf;
rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
}
else { /* No; just work with potential name */
- if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
+ if (dirfab.fab$l_sts == RMS$_FNF
+ || dirfab.fab$l_sts == RMS$_DNF
+ || dirfab.fab$l_sts == RMS$_FND)
+ dirnam = savnam;
else {
int fab_sts;
fab_sts = dirfab.fab$l_sts;
}
}
else { /* This is a top-level dir. Add the MFD to the path. */
- cp1 = my_esa;
- cp2 = buf;
- while ((*cp1 != ':') && (*cp1 != '\0')) *(cp2++) = *(cp1++);
- strcpy(cp2,":[000000]");
- cp1 += 2;
- strcpy(cp2+9,cp1);
+ cp1 = strrchr(my_esa, ':');
+ assert(cp1);
+ memmove(buf, my_esa, cp1 - my_esa + 1);
+ memmove(buf + (cp1 - my_esa) + 1, "[000000]", 8);
+ memmove(buf + (cp1 - my_esa) + 9, cp1 + 2, retlen - (cp1 - my_esa + 2));
+ buf[retlen + 7] = '\0'; /* We've inserted '000000]' */
}
}
sts = rms_free_search_context(&dirfab);
PerlMem_free(tmp);
for (; cp2 <= dirend; cp2++) {
if ((*cp2 == '^')) {
- /* EFS file escape, pass the next character as is */
- /* Fix me: HEX encoding for Unicode not implemented */
- *(cp1++) = *(++cp2);
- /* An escaped dot stays as is -- don't convert to slash */
- if (*cp2 == '.') cp2++;
+ /* EFS file escape -- unescape it. */
+ cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added) - 1;
+ cp1 += outchars_added;
}
- if (*cp2 == ':') {
+ else if (*cp2 == ':') {
*(cp1++) = '/';
if (*(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
}
VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
}
}
- else *(cp1++) = *cp2;
+ else {
+ int out_cnt;
+ cp2 += copy_expand_unix_filename_escape(cp1, cp2, &out_cnt, utf8_flag);
+ cp2--; /* we're in a loop that will increment this */
+ cp1 += out_cnt;
+ }
infront = 1;
}
}
case '|':
case '<':
case '>':
- if (cp2 > path && *(cp2-1) != '^') /* not previously escaped */
+ if (cp2 >= path && *(cp2-1) != '^') /* not previously escaped */
*(cp1++) = '^';
*(cp1++) = *(cp2++);
break;
case ';':
- /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
- * which is wrong. UNIX notation should be ".dir." unless
- * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
- * changing this behavior could break more things at this time.
- * efs character set effectively does not allow "." to be a version
- * delimiter as a further complication about changing this.
- */
- if (decc_filename_unix_report != 0) {
+ /* If it doesn't look like the beginning of a version number,
+ * or we've been promised there are no version numbers, then
+ * escape it.
+ */
+ if (decc_filename_unix_no_version) {
*(cp1++) = '^';
}
+ else {
+ size_t all_nums = strspn(cp2+1, "0123456789");
+ if (all_nums > 5 || *(cp2 + all_nums + 1) != '\0')
+ *(cp1++) = '^';
+ }
*(cp1++) = *(cp2++);
break;
default:
_ckvmssts_noperl(lib$find_file_end(&context));
}
-static int child_st[2];/* Event Flag set when child process completes */
-
-static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
-
-static unsigned long int exit_handler(void)
-{
-short iosb[4];
-
- if (0 == child_st[0])
- {
-#ifdef ARGPROC_DEBUG
- PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
-#endif
- fflush(stdout); /* Have to flush pipe for binary data to */
- /* terminate properly -- <tp@mccall.com> */
- sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
- sys$dassgn(child_chan);
- fclose(stdout);
- sys$synch(0, child_st);
- }
- return(1);
-}
-
-static void sig_child(int chan)
-{
-#ifdef ARGPROC_DEBUG
- PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
-#endif
- if (child_st[0] == 0)
- child_st[0] = 1;
-}
-
-static struct exit_control_block exit_block =
- {
- 0,
- exit_handler,
- 1,
- &exit_block.exit_status,
- 0
- };
static void
pipe_and_fork(pTHX_ char **cmargv)
tabvec[tabidx]->dsc$w_length = len;
tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_S;
- tabvec[tabidx]->dsc$a_pointer = PerlMem_malloc(len + 1);
+ tabvec[tabidx]->dsc$a_pointer = (char *)PerlMem_malloc(len + 1);
if (tabvec[tabidx]->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
my_strlcpy(tabvec[tabidx]->dsc$a_pointer, eqv, len + 1);
}
int max_name_len = 39;
AV *in_array = (AV *)SvRV(ST(0));
- num_entries = av_len(in_array);
+ num_entries = av_tindex(in_array);
/* All the names start with PL_. */
strcpy(ultimate_name, "PL_");
*/
if (value > 0) {
status = simple_trnlnm(name, val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
+ if (status) {
val_str[0] = _toupper(val_str[0]);
if (val_str[0] == 'D' || val_str[0] == '0' || val_str[0] == 'F')
return 0;
/* Allow an exception to bring Perl into the VMS debugger */
vms_debug_on_exception = 0;
status = simple_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
+ if (status) {
val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
vms_debug_on_exception = 1;
/* Debug unix/vms file translation routines */
vms_debug_fileify = 0;
status = simple_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
+ if (status) {
val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
vms_debug_fileify = 1;
/* enable it so that the impact can be studied. */
vms_bug_stat_filename = 0;
status = simple_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
+ if (status) {
val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
vms_bug_stat_filename = 1;
/* Create VTF-7 filenames from Unicode instead of UTF-8 */
vms_vtf7_filenames = 0;
status = simple_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
+ if (status) {
val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
vms_vtf7_filenames = 1;
/* unlink all versions on unlink() or rename() */
vms_unlink_all_versions = 0;
- status = simple_trnlnm
- ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
+ status = simple_trnlnm("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
+ if (status) {
val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
vms_unlink_all_versions = 1;
/* Detect running under GNV Bash or other UNIX like shell */
gnv_unix_shell = 0;
status = simple_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
+ if (status) {
gnv_unix_shell = 1;
set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
vms_unlink_all_versions = 1;
vms_posix_exit = 1;
+ /* Reverse default ordering of PERL_ENV_TABLES. */
+ defenv[0] = &crtlenvdsc;
+ defenv[1] = &fildevdsc;
}
/* Some reasonable defaults that are not CRTL defaults */
set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
/* PCP mode requires creating /dev/null special device file */
decc_bug_devnull = 0;
status = simple_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
+ if (status) {
val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
decc_bug_devnull = 1;
#else
status = simple_trnlnm
("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
+ if (status) {
val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
decc_disable_to_vms_logname_translation = 1;
#ifndef __VAX
status = simple_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
+ if (status) {
val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
decc_efs_case_preserve = 1;
#endif
status = simple_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
+ if (status) {
val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
decc_filename_unix_report = 1;
}
}
status = simple_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
+ if (status) {
val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
decc_filename_unix_only = 1;
}
}
status = simple_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
+ if (status) {
val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
decc_filename_unix_no_version = 1;
}
}
status = simple_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
+ if (status) {
val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
decc_readdir_dropdotnotype = 1;
/* USE POSIX/DCL Exit codes - Recommended, but needs to default to */
/* for strict backward compatibility */
- status = simple_trnlnm
- ("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
+ status = simple_trnlnm("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
+ if (status) {
val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
vms_posix_exit = 1;
https://perl5.git.perl.org / perl5.git / blobdiff