*
* VMS-specific routines for perl5
*
- * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
- * 2002, 2003, 2004, 2005, 2006, 2007 by Charles Bailey and others.
+ * Copyright (C) 1993-2013 by Charles Bailey and others.
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
- *
- * Please see Changes*.* or the Perl Repository Browser for revision history.
*/
/*
};
#pragma member_alignment restore
-#if __CRTL_VER >= 70300000 && !defined(__VAX)
-
-static int set_feature_default(const char *name, int value)
-{
- int status;
- int index;
-
- index = decc$feature_get_index(name);
-
- status = decc$feature_set_value(index, 1, value);
- if (index == -1 || (status == -1)) {
- return -1;
- }
-
- status = decc$feature_get_value(index, 1);
- if (status != value) {
- return -1;
- }
-
-return 0;
-}
-#endif
-
/* Older versions of ssdef.h don't have these */
#ifndef SS$_INVFILFOROP
# define SS$_INVFILFOROP 3930
/* bug workarounds if needed */
int decc_bug_devnull = 1;
-int decc_dir_barename = 0;
int vms_bug_stat_filename = 0;
static int vms_debug_on_exception = 0;
}
/*}}}*/
+/* Routine to remove the 2-byte prefix from the translation of a
+ * process-permanent file (PPF).
+ */
+static inline unsigned short int
+S_remove_ppf_prefix(const char *lnm, char *eqv, unsigned short int eqvlen)
+{
+ if (*((int *)lnm) == *((int *)"SYS$") &&
+ eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
+ ( (lnm[4] == 'O' && !strcmp(lnm,"SYS$OUTPUT")) ||
+ (lnm[4] == 'I' && !strcmp(lnm,"SYS$INPUT")) ||
+ (lnm[4] == 'E' && !strcmp(lnm,"SYS$ERROR")) ||
+ (lnm[4] == 'C' && !strcmp(lnm,"SYS$COMMAND")) ) ) {
+
+ memmove(eqv, eqv+4, eqvlen-4);
+ eqvlen -= 4;
+ }
+ return eqvlen;
+}
+
/*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
int
Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
if (retsts == SS$_NOLOGNAM) break;
- /* PPFs have a prefix */
- if (
-#if INTSIZE == 4
- *((int *)uplnm) == *((int *)"SYS$") &&
-#endif
- eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
- ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
- (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
- (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
- (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
- memmove(eqv,eqv+4,eqvlen-4);
- eqvlen -= 4;
- }
+ eqvlen = S_remove_ppf_prefix(uplnm, eqv, eqvlen);
cp2 += eqvlen;
*cp2 = '\0';
}
if ((retsts == SS$_IVLOGNAM) ||
(retsts == SS$_NOLOGNAM)) { continue; }
+ eqvlen = strlen(eqv);
}
else {
retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
if (retsts == SS$_NOLOGNAM) continue;
+ eqvlen = S_remove_ppf_prefix(uplnm, eqv, eqvlen);
eqv[eqvlen] = '\0';
}
- eqvlen = strlen(eqv);
break;
}
}
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);
if (aTHX != NULL)
#endif
#ifdef SECURE_INTERNAL_GETENV
- flags = (PL_curinterp ? PL_tainting : will_taint) ?
+ flags = (PL_curinterp ? TAINTING_get : will_taint) ?
PERL__TRNENV_SECURE : 0;
#endif
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;
/* 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;
+ secure = PL_curinterp ? TAINTING_get : will_taint;
}
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;
else {
if (sys) {
/* Impose security constraints only if tainting */
- secure = PL_curinterp ? PL_tainting : will_taint;
- saverr = errno; savvmserr = vaxc$errno;
+ secure = PL_curinterp ? TAINTING_get : will_taint;
}
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;
}
my_strlcpy(cmd, "Show Logical *", sizeof(cmd));
if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
my_strlcat(cmd," /Table=", sizeof(cmd));
- cmddsc.dsc$w_length = my_strlcat(cmd, env_tables[i]->dsc$a_pointer, env_tables[i]->dsc$w_length + 1);
+ cmddsc.dsc$w_length = my_strlcat(cmd, env_tables[i]->dsc$a_pointer, sizeof(cmd));
}
else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
flags = defflags | CLI$M_NOCLISYM;
while (1) {
char *cp1, *cp2, *key;
unsigned long int sts, iosb[2], retlen, keylen;
- register U32 hash;
+ U32 hash;
sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
if (sts & 1) sts = iosb[0] & 0xffff;
/* vmssetuserlnm
* sets a user-mode logical in the process logical name table
* used for redirection of sys$error
- *
- * Fix-me: The pTHX is not needed for this routine, however doio.c
- * is calling it with one instead of using a macro.
- * A macro needs to be added to vmsish.h and doio.c updated to use it.
- *
*/
void
-Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
+Perl_vmssetuserlnm(const char *name, const char *eqv)
{
$DESCRIPTOR(d_tab, "LNM$PROCESS");
struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
char *vmsname;
char *rslt;
unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
- unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
+ unsigned long int cxt = 0, aclsts, fndsts;
+ int rmsts = -1;
struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
struct myacedef {
unsigned char myace$b_length;
Perl_my_chdir(pTHX_ const char *dir)
{
STRLEN dirlen = strlen(dir);
+ const char *dir1 = dir;
/* zero length string sometimes gives ACCVIO */
- if (dirlen == 0) return -1;
- const char *dir1;
+ if (dirlen == 0) {
+ SETERRNO(EINVAL, SS$_BADPARAM);
+ return -1;
+ }
/* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
* This does not work if DECC$EFS_CHARSET is active. Hack it here
* so that existing scripts do not need to be changed.
*/
- dir1 = dir;
while ((dirlen > 0) && (*dir1 == ' ')) {
dir1++;
dirlen--;
info->fp = PerlIO_open(mbx, mode);
} else {
info->fp = (PerlIO *) freopen(mbx, mode, stdin);
- Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
+ vmssetuserlnm("SYS$INPUT", mbx);
}
if (!info->fp && info->out) {
info->fp = PerlIO_open(mbx, mode);
} else {
info->fp = (PerlIO *) freopen(mbx, mode, stdout);
- Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
+ vmssetuserlnm("SYS$OUTPUT", mbx);
}
if (info->in) {
} else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
+ /* Let the child inherit standard input, unless it's a directory. */
+ Stat_t st;
+ if (my_trnlnm("SYS$INPUT", in, 0)) {
+ if (flex_stat(in, &st) != 0 || S_ISDIR(st.st_mode))
+ *in = '\0';
+ }
+
info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
if (info->out) {
info->out->pipe_done = &info->out_done;
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);
len += n_len;
if (e_len > 0) {
if (decc_efs_charset) {
- buf[len] = '^';
- len++;
- memcpy(&buf[len], e_spec, e_len);
- len += e_len;
- } else {
- set_vaxc_errno(RMS$_DIR);
- set_errno(ENOTDIR);
+ if (e_len == 4
+ && (toupper(e_spec[1]) == 'D')
+ && (toupper(e_spec[2]) == 'I')
+ && (toupper(e_spec[3]) == 'R')) {
+
+ /* Corner case: directory spec with invalid version.
+ * Valid would have followed is_dir path above.
+ */
+ SETERRNO(ENOTDIR, RMS$_DIR);
+ return NULL;
+ }
+ else {
+ buf[len] = '^';
+ len++;
+ memcpy(&buf[len], e_spec, e_len);
+ len += e_len;
+ }
+ }
+ else {
+ SETERRNO(ENOTDIR, RMS$_DIR);
return NULL;
}
}
const char *cp2;
int dirlen;
unsigned short int trnlnm_iter_count;
- int cmp_rslt;
+ int cmp_rslt, outchars_added;
if (utf8_fl != NULL)
*utf8_fl = 0;
}
}
}
- /* This is already UNIX or at least nothing VMS understands */
+
+ cp1 = rslt;
+ cp2 = spec;
+
+ /* This is already UNIX or at least nothing VMS understands,
+ * so all we can reasonably do is unescape extended chars.
+ */
if (cmp_rslt) {
- my_strlcpy(rslt, spec, VMS_MAXRSS);
+ while (*cp2) {
+ cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
+ cp1 += outchars_added;
+ }
+ *cp1 = '\0';
if (vms_debug_fileify) {
fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
}
return rslt;
}
- cp1 = rslt;
- cp2 = spec;
dirend = strrchr(spec,']');
if (dirend == NULL) dirend = strrchr(spec,'>');
if (dirend == NULL) dirend = strchr(spec,':');
if (dirend == NULL) {
- strcpy(rslt,spec);
+ while (*cp2) {
+ cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
+ cp1 += outchars_added;
+ }
+ *cp1 = '\0';
if (vms_debug_fileify) {
fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
}
*(cp1++) = '/';
}
if ((*cp2 == '^')) {
- /* EFS file escape, pass the next character as is */
- /* Fix me: HEX encoding for Unicode not implemented */
- cp2++;
+ cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
+ cp1 += outchars_added;
}
else if ( *cp2 == '.') {
if (*(cp2+1) == '.' && *(cp2+2) == '.') {
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++;
}
}
/* Translate the rest of the filename. */
while (*cp2) {
- int dot_seen;
- dot_seen = 0;
+ int dot_seen = 0;
switch(*cp2) {
/* Fixme - for compatibility with the CRTL we should be removing */
/* spaces from the file specifications, but this may show that */
*(cp1++) = '?';
break;
case '^':
- /* Fix me hex expansions not implemented */
- cp2++; /* '^.' --> '.' and other. */
- if (*cp2) {
- if (*cp2 == '_') {
- cp2++;
- *(cp1++) = ' ';
- } else {
- *(cp1++) = *(cp2++);
- }
- }
+ cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
+ cp1 += outchars_added;
break;
case ';':
if (decc_filename_unix_no_version) {
return result;
}
-
+/* A convenience macro for copying dots in filenames and escaping
+ * them when they haven't already been escaped, with guards to
+ * avoid checking before the start of the buffer or advancing
+ * beyond the end of it (allowing room for the NUL terminator).
+ */
+#define VMSEFS_DOT_WITH_ESCAPE(vmsefsdot,vmsefsbuf,vmsefsbufsiz) STMT_START { \
+ if ( ((vmsefsdot) > (vmsefsbuf) && *((vmsefsdot) - 1) != '^' \
+ || ((vmsefsdot) == (vmsefsbuf))) \
+ && (vmsefsdot) < (vmsefsbuf) + (vmsefsbufsiz) - 3 \
+ ) { \
+ *((vmsefsdot)++) = '^'; \
+ } \
+ if ((vmsefsdot) < (vmsefsbuf) + (vmsefsbufsiz) - 2) \
+ *((vmsefsdot)++) = '.'; \
+} STMT_END
/*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
static char *int_tovmsspec
(const char *path, char *rslt, int dir_flag, int * utf8_flag) {
char *dirend;
char *lastdot;
- register char *cp1;
+ char *cp1;
const char *cp2;
unsigned long int infront = 0, hasdir = 1;
int rslt_len;
dirend = strrchr(path,'/');
if (dirend == NULL) {
- char *macro_start;
- int has_macro;
-
- /* If we get here with no UNIX directory delimiters, then this is
- not a complete file specification, either garbage a UNIX glob
- specification that can not be converted to a VMS wildcard, or
- it a UNIX shell macro. MakeMaker wants shell macros passed
- through AS-IS,
-
- utf8 flag setting needs to be preserved.
+ /* If we get here with no Unix directory delimiters, then this is an
+ * ambiguous file specification, such as a Unix glob specification, a
+ * shell or make macro, or a filespec that would be valid except for
+ * unescaped extended characters. The safest thing if it's a macro
+ * is to pass it through as-is.
*/
- hasdir = 0;
-
- has_macro = 0;
- macro_start = strchr(path,'$');
- if (macro_start != NULL) {
- if (macro_start[1] == '(') {
- has_macro = 1;
- }
- }
- if ((decc_efs_charset == 0) || (has_macro)) {
+ if (strstr(path, "$(")) {
my_strlcpy(rslt, path, VMS_MAXRSS);
if (vms_debug_fileify) {
fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
}
return rslt;
}
+ hasdir = 0;
}
else if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
if (!*(dirend+2)) dirend +=2;
if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
- if (decc_efs_charset == 0) {
- if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
- }
+ if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
}
cp1 = rslt;
}
PerlMem_free(trndev);
}
- else {
+ else if (hasdir) {
*(cp1++) = '[';
if (*cp2 == '.') {
if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
for (; cp2 < dirend; cp2++) {
if (*cp2 == '/') {
if (*(cp2-1) == '/') continue;
- if (*(cp1-1) != '.') *(cp1++) = '.';
+ if (cp1 > rslt && *(cp1-1) != '.') *(cp1++) = '.';
infront = 0;
}
else if (!infront && *cp2 == '.') {
if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
- if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
- else if (*(cp1-2) == '[') *(cp1-1) = '-';
+ if (cp1 > rslt && (*(cp1-1) == '-' || *(cp1-1) == '[')) *(cp1++) = '-'; /* handle "../" */
+ else if (cp1 > rslt + 1 && *(cp1-2) == '[') *(cp1-1) = '-';
else {
*(cp1++) = '-';
}
}
else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
(*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
- if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
+ if (cp1 > rslt && *(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
*(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
if (!*(cp2+3)) {
*(cp1++) = '.'; /* Simulate trailing '/' */
else cp2 += 3; /* Trailing '/' was there, so skip it, too */
}
else {
- if (decc_efs_charset == 0)
+ if (decc_efs_charset == 0) {
+ if (cp1 > rslt && *(cp1-1) == '^')
+ cp1--; /* remove the escape, if any */
*(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
+ }
else {
- *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
- *(cp1++) = '.';
+ VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
}
}
}
else {
- if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
+ if (!infront && cp1 > rslt && *(cp1-1) == '-') *(cp1++) = '.';
if (*cp2 == '.') {
- if (decc_efs_charset == 0)
+ if (decc_efs_charset == 0) {
+ if (cp1 > rslt && *(cp1-1) == '^')
+ cp1--; /* remove the escape, if any */
*(cp1++) = '_';
+ }
else {
- *(cp1++) = '^';
- *(cp1++) = '.';
+ 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;
}
}
- if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
+ if (cp1 > rslt && *(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
if (hasdir) *(cp1++) = ']';
- if (*cp2) cp2++; /* check in case we ended with trailing '..' */
- /* fixme for ODS5 */
+ if (*cp2 && *cp2 == '/') cp2++; /* check in case we ended with trailing '/' */
no_type_seen = 0;
if (cp2 > lastdot)
no_type_seen = 1;
*(cp1++) = '?';
cp2++;
case ' ':
- *(cp1)++ = '^';
+ if (cp2 >= path && (cp2 == path || *(cp2-1) != '^')) /* not previously escaped */
+ *(cp1)++ = '^';
*(cp1)++ = '_';
cp2++;
break;
case '.':
if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
decc_readdir_dropdotnotype) {
- *(cp1)++ = '^';
- *(cp1)++ = '.';
+ VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
cp2++;
/* trailing dot ==> '^..' on VMS */
case '|':
case '<':
case '>':
- *(cp1++) = '^';
+ 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:
fprintf(stderr,"Can't open output file %s as stdout",out);
exit(vaxc$errno);
}
- if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
+ if (out != NULL) vmssetuserlnm("SYS$OUTPUT", out);
if (err != NULL) {
if (strcmp(err,"&1") == 0) {
dup2(fileno(stdout), fileno(stderr));
- Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
+ vmssetuserlnm("SYS$ERROR", "SYS$OUTPUT");
} else {
FILE *tmperr;
if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
{
exit(vaxc$errno);
}
- Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
+ vmssetuserlnm("SYS$ERROR", err);
}
}
#ifdef ARGPROC_DEBUG
_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] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
- tabvec[tabidx]->dsc$w_length = 0;
+ tabvec[tabidx]->dsc$w_length = len;
tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
- tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
- tabvec[tabidx]->dsc$a_pointer = NULL;
- _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
+ tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_S;
+ 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);
}
if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
{
char *unixified, *unixwild, *tplate, *base, *end, *cp1, *cp2;
- register int tmplen, reslen = 0, dirs = 0;
+ int tmplen, reslen = 0, dirs = 0;
if (!wildspec || !fspec) return 0;
/* Check access before stat; otherwise stat does not
* accurately report whether it's a directory.
*/
- if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
+ if (!strstr(dir, "::") /* sys$check_access doesn't do remotes */
+ && !cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
/* cando_by_name has already set errno */
Safefree(dir);
return NULL;
dd->context = 0;
dd->count = 0;
dd->flags = 0;
- /* By saying we always want the result of readdir() in unix format, we
- * are really saying we want all the escapes removed. Otherwise the caller,
- * having no way to know whether it's already in VMS format, might send it
- * through tovmsspec again, thus double escaping.
+ /* By saying we want the result of readdir() in unix format, we are really
+ * saying we want all the escapes removed, translating characters that
+ * must be escaped in a VMS-format name to their unescaped form, which is
+ * presumably allowed in a Unix-format name.
*/
- dd->flags = PERL_VMSDIR_M_UNIXSPECS;
+ dd->flags = decc_filename_unix_report ? PERL_VMSDIR_M_UNIXSPECS : 0;
dd->pat.dsc$a_pointer = dd->pattern;
dd->pat.dsc$w_length = strlen(dd->pattern);
dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
tmpsts = lib$find_file
(&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
- if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
+ if (dd->context == 0)
+ tmpsts = RMS$_NMF; /* None left. (should be set, but make sure) */
+
if (!(tmpsts & 1)) {
- set_vaxc_errno(tmpsts);
switch (tmpsts) {
+ case RMS$_NMF:
+ break; /* no more files considered success */
case RMS$_PRV:
- set_errno(EACCES); break;
+ SETERRNO(EACCES, tmpsts); break;
case RMS$_DEV:
- set_errno(ENODEV); break;
+ SETERRNO(ENODEV, tmpsts); break;
case RMS$_DIR:
- set_errno(ENOTDIR); break;
+ SETERRNO(ENOTDIR, tmpsts); break;
case RMS$_FNF: case RMS$_DNF:
- set_errno(ENOENT); break;
+ SETERRNO(ENOENT, tmpsts); break;
default:
- set_errno(EVMSERR);
+ SETERRNO(EVMSERR, tmpsts);
}
Safefree(buff);
return NULL;
/* In Unix report mode, remove the ".dir;1" from the name */
/* if it is a real directory. */
- if (decc_filename_unix_report || decc_efs_charset) {
+ if (decc_filename_unix_report && decc_efs_charset) {
if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
Stat_t statbuf;
int ret_sts;
memcpy(dd->entry.d_name, n_spec, n_len + e_len);
dd->entry.d_name[n_len + e_len] = '\0';
- dd->entry.d_namlen = strlen(dd->entry.d_name);
+ dd->entry.d_namlen = n_len + e_len;
/* Convert the filename to UNIX format if needed */
if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
{
char *junk, *tmps = NULL;
- register size_t cmdlen = 0;
+ size_t cmdlen = 0;
size_t rlen;
- register SV **idx;
+ SV **idx;
STRLEN n_a;
idx = mark;
struct dsc$descriptor_s *vmscmd;
struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
- register char *s, *rest, *cp, *wordbreak;
+ char *s, *rest, *cp, *wordbreak;
char * cmd;
int cmdlen;
- register int isdcl;
+ int isdcl;
vmscmd = (struct dsc$descriptor_s *)PerlMem_malloc(sizeof(struct dsc$descriptor_s));
if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
}
else { cp = vmsspec; rest = s; }
+
+ /* If the first word is quoted, then we need to unquote it and
+ * escape spaces within it. We'll expand into the resspec buffer,
+ * then copy back into the cmd buffer, expanding the latter if
+ * necessary.
+ */
+ if (*rest == '"') {
+ char *cp2;
+ char *r = rest;
+ bool in_quote = 0;
+ int clen = cmdlen;
+ int soff = s - cmd;
+
+ for (cp2 = resspec;
+ *rest && cp2 - resspec < (VMS_MAXRSS - 1);
+ rest++) {
+
+ if (*rest == ' ') { /* Escape ' ' to '^_'. */
+ *cp2 = '^';
+ *(++cp2) = '_';
+ cp2++;
+ clen++;
+ }
+ else if (*rest == '"') {
+ clen--;
+ if (in_quote) { /* Must be closing quote. */
+ rest++;
+ break;
+ }
+ in_quote = 1;
+ }
+ else {
+ *cp2 = *rest;
+ cp2++;
+ }
+ }
+ *cp2 = '\0';
+
+ /* Expand the command buffer if necessary. */
+ if (clen > cmdlen) {
+ cmd = (char *)PerlMem_realloc(cmd, clen);
+ if (cmd == NULL)
+ _ckvmssts_noperl(SS$_INSFMEM);
+ /* Where we are may have changed, so recompute offsets */
+ r = cmd + (r - s - soff);
+ rest = cmd + (rest - s - soff);
+ s = cmd + soff;
+ }
+
+ /* Shift the non-verb portion of the command (if any) up or
+ * down as necessary.
+ */
+ if (*rest)
+ memmove(rest + clen - cmdlen, rest, s - soff + cmdlen - rest);
+
+ /* Copy the unquoted and escaped command verb into place. */
+ memcpy(r, resspec, cp2 - resspec);
+ cmd[clen] = '\0';
+ cmdlen = clen;
+ rest = r; /* Rewind for subsequent operations. */
+ }
+
if (*rest == '.' || *rest == '/') {
char *cp2;
for (cp2 = resspec;
isdcl = 1;
if (suggest_quote) *suggest_quote = 1;
} else {
- register char *filespec = strpbrk(s,":<[.;");
+ char *filespec = strpbrk(s,":<[.;");
rest = wordbreak = strpbrk(s," \"\t/");
if (!wordbreak) wordbreak = s + strlen(s);
if (*s == '$') check_img = 0;
int
my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
{
- register char *cp, *end, *cpd;
+ char *cp, *end, *cpd;
char *data;
- register unsigned int fd = fileno(dest);
- register unsigned int fdoff = fd / sizeof(unsigned int);
+ unsigned int fd = fileno(dest);
+ unsigned int fdoff = fd / sizeof(unsigned int);
int retval;
int bufsize = itmsz * nitm + 1;
#else /* __CRTL_VER < 70300000 */
- register int i;
+ int i;
int sts;
long int bintime[2], len = 2, lowbit, unixtime,
secscale = 10000000; /* seconds --> 100 ns intervals */
int
Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
{
+ dSAVE_ERRNO; /* fstat may set this even on success */
if (!fstat(fd, &statbufp->crtl_stat)) {
char *cptr;
char *vms_filename;
statbufp->st_ctime = _toloc(statbufp->st_ctime);
}
# endif
+ RESTORE_ERRNO;
return 0;
}
return -1;
dXSARGS;
char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
workbuff[NAM$C_MAXRSS*1 + 1];
- int counter, num_entries;
+ SSize_t counter, num_entries;
/* ODS-5 ups this, but we want to be consistent, so... */
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_");
/* In Unix report mode, remove the ".dir;1" from the name */
/* if it is a real directory */
- if (decc_filename_unix_report || decc_efs_charset) {
+ if (decc_filename_unix_report && decc_efs_charset) {
if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
Stat_t statbuf;
int ret_sts;
/* Start of DECC RTL Feature handling */
+#if __CRTL_VER >= 70300000 && !defined(__VAX)
+
+static int
+set_feature_default(const char *name, int value)
+{
+ int status;
+ int index;
+ char val_str[10];
+
+ /* If the feature has been explicitly disabled in the environment,
+ * then don't enable it here.
+ */
+ if (value > 0) {
+ status = simple_trnlnm(name, val_str, sizeof(val_str));
+ if (status) {
+ val_str[0] = _toupper(val_str[0]);
+ if (val_str[0] == 'D' || val_str[0] == '0' || val_str[0] == 'F')
+ return 0;
+ }
+ }
+
+ index = decc$feature_get_index(name);
+
+ status = decc$feature_set_value(index, 1, value);
+ if (index == -1 || (status == -1)) {
+ return -1;
+ }
+
+ status = decc$feature_get_value(index, 1);
+ if (status != value) {
+ return -1;
+ }
+
+ /* Various things may check for an environment setting
+ * rather than the feature directly, so set that too.
+ */
+ vmssetuserlnm(name, value ? "ENABLE" : "DISABLE");
+
+ return 0;
+}
+#endif
+
/* C RTL Feature settings */
/* 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;
vms_unlink_all_versions = 0;
}
- /* Dectect running under GNV Bash or other UNIX like shell */
#if __CRTL_VER >= 70300000 && !defined(__VAX)
+ /* 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$EFS_CASE_PRESERVE", 1);
- set_feature_default("DECC$EFS_CHARSET", 1);
set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 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);
+ set_feature_default("DECC$ARGV_PARSE_STYLE", 1); /* Requires extended parse. */
+ set_feature_default("DECC$EFS_CHARSET", 1);
#endif
/* hacks to see if known bugs are still present for testing */
/* 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;
decc_bug_devnull = 0;
}
- /* UNIX directory names with no paths are broken in a lot of places */
- decc_dir_barename = 1;
- status = simple_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
- val_str[0] = _toupper(val_str[0]);
- if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
- decc_dir_barename = 1;
- else
- decc_dir_barename = 0;
- }
-
#if __CRTL_VER >= 70300000 && !defined(__VAX)
s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
if (s >= 0) {
#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;
* LIB$INITIALIZE section. In our case, the array only has one entry.
*/
#pragma extern_model save
-#pragma extern_model strict_refdef "LIB$INITIALIZE" gbl,noexe,nowrt,noshr,long
+#pragma extern_model strict_refdef "LIB$INITIALIZE" nopic,gbl,nowrt,noshr,long
extern void (* const vmsperl_unused_global_2[])() =
{
vmsperl_set_features,