This patch makes a version of unixify available for calling with out an
implicit context, which is needed for threaded perl as several routines
do not have a thread context.
This is the second of a multi-part conversion to remove access
violations when internal perl warning and error routines, and memory
allocation routines are called with a null pointer for the implicit context.
By removing the implicit context from these routines, it will cause a
compile time error on threaded perl should one of the affected routines
sneak back into this code.
Patches to do:
* Refactor tounixpath, (unixpath)
* Refactor fileify_dirspec (fileify)
* Refactor tovmsspec, (vmsify)
* Refactor rmsexpand
* Refactor all cases where a implicit context is not needed
and fix cases where a null context is present not to call
internal perl routines that will access violate.
* fgetname needs a wrapper, it is not returning the correct
names when DECC$FILENAME_UNIX_REPORT is enabled.
This is all needed for me to proceed with the testing of VMS perl in a
UNIX compatible mode. Currently most of the tests are passing.
-John
[EMAIL PROTECTED]
Personal Opinion Only
--- /ref3_root/perl/vms/vms.c Sun Dec 7 09:19:05 2008
+++ vms/vms.c Sun Dec 7 09:35:46 2008
@@ -296,6 +296,8 @@
static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts,
int *);
+static char * int_tounixspec(const char *spec, char *buf, int * utf8_fl);
+
/* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
#define PERL_LNM_MAX_ALLOWED_INDEX 127
@@ -6733,300 +6735,367 @@
char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int
*utf8_fl)
{ return do_pathify_dirspec(dir,buf,1,utf8_fl); }
+/* Internal tounixspec routine that does not use a thread context */
+static char *
+int_tounixspec(const char *spec, char *buf, int * utf8_fl) {
-/*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
-static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int *
utf8_fl)
-{
- static char __tounixspec_retbuf[VMS_MAXRSS];
- char *dirend, *rslt, *cp1, *cp3, *tmp;
- const char *cp2;
- int devlen, dirlen, retlen = VMS_MAXRSS;
- int expand = 1; /* guarantee room for leading and trailing slashes */
- unsigned short int trnlnm_iter_count;
- int cmp_rslt;
- if (utf8_fl != NULL)
- *utf8_fl = 0;
-
- if (spec == NULL) return NULL;
- if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
- if (buf) rslt = buf;
- else if (ts) {
- Newx(rslt, VMS_MAXRSS, char);
- }
- else rslt = __tounixspec_retbuf;
+ char *dirend, *cp1, *cp3, *tmp;
+ const char *cp2;
+ int devlen, dirlen, retlen = VMS_MAXRSS;
+ int expand = 1; /* guarantee room for leading and trailing slashes */
+ unsigned short int trnlnm_iter_count;
+ int cmp_rslt;
+ if (utf8_fl != NULL)
+ *utf8_fl = 0;
- /* New VMS specific format needs translation
- * glob passes filenames with trailing '\n' and expects this preserved.
- */
- if (decc_posix_compliant_pathnames) {
- if (strncmp(spec, "\"^UP^", 5) == 0) {
- char * uspec;
- char *tunix;
- int tunix_len;
- int nl_flag;
-
- tunix = PerlMem_malloc(VMS_MAXRSS);
- if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
- strcpy(tunix, spec);
- tunix_len = strlen(tunix);
- nl_flag = 0;
- if (tunix[tunix_len - 1] == '\n') {
- tunix[tunix_len - 1] = '\"';
- tunix[tunix_len] = '\0';
- tunix_len--;
- nl_flag = 1;
- }
- uspec = decc$translate_vms(tunix);
- PerlMem_free(tunix);
- if ((int)uspec > 0) {
- strcpy(rslt,uspec);
- if (nl_flag) {
- strcat(rslt,"\n");
- }
- else {
- /* If we can not translate it, makemaker wants as-is */
- strcpy(rslt, spec);
- }
- return rslt;
- }
+ if (vms_debug_fileify) {
+ if (spec == NULL)
+ fprintf(stderr, "int_tounixspec: spec = NULL\n");
+ else
+ fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
+ }
+
+ if (spec == NULL) {
+ set_errno(EINVAL);
+ set_vaxc_errno(SS$_BADPARAM);
+ return NULL;
+ }
+ if (strlen(spec) > (VMS_MAXRSS-1)) {
+ set_errno(E2BIG);
+ set_vaxc_errno(SS$_BUFFEROVF);
+ return NULL;
}
- }
- cmp_rslt = 0; /* Presume VMS */
- cp1 = strchr(spec, '/');
- if (cp1 == NULL)
- cmp_rslt = 0;
+ /* New VMS specific format needs translation
+ * glob passes filenames with trailing '\n' and expects this preserved.
+ */
+ if (decc_posix_compliant_pathnames) {
+ if (strncmp(spec, "\"^UP^", 5) == 0) {
+ char * uspec;
+ char *tunix;
+ int tunix_len;
+ int nl_flag;
+
+ tunix = PerlMem_malloc(VMS_MAXRSS);
+ if (tunix == NULL)
+ _ckvmssts_noperl(SS$_INSFMEM);
+ strcpy(tunix, spec);
+ tunix_len = strlen(tunix);
+ nl_flag = 0;
+ if (tunix[tunix_len - 1] == '\n') {
+ tunix[tunix_len - 1] = '\"';
+ tunix[tunix_len] = '\0';
+ tunix_len--;
+ nl_flag = 1;
+ }
+ uspec = decc$translate_vms(tunix);
+ PerlMem_free(tunix);
+ if ((int)uspec > 0) {
+ strcpy(buf, uspec);
+ if (nl_flag) {
+ strcat(buf, "\n");
+ } else {
+ /* If we can not translate it, makemaker wants as-is */
+ strcpy(buf, spec);
+ }
+ if (vms_debug_fileify) {
+ fprintf(stderr, "int_tounixspec: buf = %s\n", buf);
+ }
+ return buf;
+ }
+ }
+ }
+
+ cmp_rslt = 0; /* Presume VMS */
+ cp1 = strchr(spec, '/');
+ if (cp1 == NULL)
+ cmp_rslt = 0;
/* Look for EFS ^/ */
if (decc_efs_charset) {
- while (cp1 != NULL) {
- cp2 = cp1 - 1;
- if (*cp2 != '^') {
- /* Found illegal VMS, assume UNIX */
- cmp_rslt = 1;
- break;
- }
- cp1++;
- cp1 = strchr(cp1, '/');
+ while (cp1 != NULL) {
+ cp2 = cp1 - 1;
+ if (*cp2 != '^') {
+ /* Found illegal VMS, assume UNIX */
+ cmp_rslt = 1;
+ break;
+ }
+ cp1++;
+ cp1 = strchr(cp1, '/');
+ }
}
- }
- /* Look for "." and ".." */
- if (decc_filename_unix_report) {
- if (spec[0] == '.') {
- if ((spec[1] == '\0') || (spec[1] == '\n')) {
- cmp_rslt = 1;
- }
- else {
- if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
- cmp_rslt = 1;
- }
- }
+ /* Look for "." and ".." */
+ if (decc_filename_unix_report) {
+ if (spec[0] == '.') {
+ if ((spec[1] == '\0') || (spec[1] == '\n')) {
+ cmp_rslt = 1;
+ } else {
+ if ((spec[1] == '.') &&
+ ((spec[2] == '\0') || (spec[2] == '\n'))) {
+ cmp_rslt = 1;
+ }
+ }
+ }
+ }
+ /* This is already UNIX or at least nothing VMS understands */
+ if (cmp_rslt) {
+ strcpy(buf, spec);
+ if (vms_debug_fileify) {
+ fprintf(stderr, "int_tounixspec: buf = %s\n", buf);
+ }
+ return buf;
}
- }
- /* This is already UNIX or at least nothing VMS understands */
- if (cmp_rslt) {
- strcpy(rslt,spec);
- 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);
- return rslt;
- }
+ cp1 = buf;
+ cp2 = spec;
+ dirend = strrchr(spec,']');
+ if (dirend == NULL)
+ dirend = strrchr(spec,'>');
+ if (dirend == NULL)
+ dirend = strchr(spec,':');
+ if (dirend == NULL) {
+ strcpy(buf,spec);
+ if (vms_debug_fileify) {
+ fprintf(stderr, "int_tounixspec: buf = %s\n", buf);
+ }
+ return buf;
+ }
- /* Special case 1 - sys$posix_root = / */
+ /* Special case 1 - sys$posix_root = / */
#if __CRTL_VER >= 70000000
- if (!decc_disable_posix_root) {
- if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
- *cp1 = '/';
- cp1++;
- cp2 = cp2 + 15;
- }
- }
+ if (!decc_disable_posix_root) {
+ if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
+ *cp1 = '/';
+ cp1++;
+ cp2 = cp2 + 15;
+ }
+ }
#endif
- /* Special case 2 - Convert NLA0: to /dev/null */
+ /* Special case 2 - Convert NLA0: to /dev/null */
#if __CRTL_VER < 70000000
- cmp_rslt = strncmp(spec,"NLA0:", 5);
- if (cmp_rslt != 0)
- cmp_rslt = strncmp(spec,"nla0:", 5);
+ cmp_rslt = strncmp(spec,"NLA0:", 5);
+ if (cmp_rslt != 0)
+ cmp_rslt = strncmp(spec,"nla0:", 5);
#else
- cmp_rslt = strncasecmp(spec,"NLA0:", 5);
+ cmp_rslt = strncasecmp(spec,"NLA0:", 5);
#endif
- if (cmp_rslt == 0) {
- strcpy(rslt, "/dev/null");
- cp1 = cp1 + 9;
- cp2 = cp2 + 5;
- if (spec[6] != '\0') {
- cp1[9] == '/';
- cp1++;
- cp2++;
+ if (cmp_rslt == 0) {
+ strcpy(buf, "/dev/null");
+ cp1 = cp1 + 9;
+ cp2 = cp2 + 5;
+ if (spec[6] != '\0') {
+ cp1[9] == '/';
+ cp1++;
+ cp2++;
+ }
}
- }
- /* Also handle special case "SYS$SCRATCH:" */
+ /* Also handle special case "SYS$SCRATCH:" */
#if __CRTL_VER < 70000000
- cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
- if (cmp_rslt != 0)
- cmp_rslt = strncmp(spec,"sys$scratch:", 12);
+ cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
+ if (cmp_rslt != 0)
+ cmp_rslt = strncmp(spec,"sys$scratch:", 12);
#else
- cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
+ cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
#endif
- tmp = PerlMem_malloc(VMS_MAXRSS);
- if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
- if (cmp_rslt == 0) {
- int islnm;
-
- islnm = my_trnlnm(tmp, "TMP", 0);
- if (!islnm) {
- strcpy(rslt, "/tmp");
- cp1 = cp1 + 4;
- cp2 = cp2 + 12;
- if (spec[12] != '\0') {
- cp1[4] == '/';
- cp1++;
- cp2++;
- }
+ tmp = PerlMem_malloc(VMS_MAXRSS);
+ if (tmp == NULL)
+ _ckvmssts_noperl(SS$_INSFMEM);
+ if (cmp_rslt == 0) {
+ int islnm;
+
+ islnm = simple_trnlnm(tmp, "TMP", VMS_MAXRSS);
+ if (!islnm) {
+ strcpy(buf, "/tmp");
+ cp1 = cp1 + 4;
+ cp2 = cp2 + 12;
+ if (spec[12] != '\0') {
+ cp1[4] == '/';
+ cp1++;
+ cp2++;
+ }
+ }
}
- }
- if (*cp2 != '[' && *cp2 != '<') {
- *(cp1++) = '/';
- }
- else { /* the VMS spec begins with directories */
- cp2++;
- if (*cp2 == ']' || *cp2 == '>') {
- *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
- PerlMem_free(tmp);
- return rslt;
- }
- else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied
device */
- if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
- if (ts) Safefree(rslt);
- PerlMem_free(tmp);
- return NULL;
- }
- trnlnm_iter_count = 0;
- do {
- cp3 = tmp;
- while (*cp3 != ':' && *cp3) cp3++;
- *(cp3++) = '\0';
- if (strchr(cp3,']') != NULL) break;
- trnlnm_iter_count++;
- if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
- } while (vmstrnenv(tmp,tmp,0,fildev,0));
- if (ts && !buf &&
- ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
- retlen = devlen + dirlen;
- Renew(rslt,retlen+1+2*expand,char);
- cp1 = rslt;
- }
- cp3 = tmp;
- *(cp1++) = '/';
- while (*cp3) {
- *(cp1++) = *(cp3++);
- if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
- PerlMem_free(tmp);
- return NULL; /* No room */
- }
- }
- *(cp1++) = '/';
- }
- if ((*cp2 == '^')) {
- /* EFS file escape, pass the next character as is */
- /* Fix me: HEX encoding for Unicode not implemented */
- cp2++;
- }
- else if ( *cp2 == '.') {
- if (*(cp2+1) == '.' && *(cp2+2) == '.') {
- *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
- cp2 += 3;
- }
- else cp2++;
+ if (*cp2 != '[' && *cp2 != '<') {
+ *(cp1++) = '/';
+ } else { /* the VMS spec begins with directories */
+ cp2++;
+ if (*cp2 == ']' || *cp2 == '>') {
+ *(cp1++) = '.';
+ } else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') {
+ /* add the implied device */
+ if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
+ PerlMem_free(tmp);
+ if (vms_debug_fileify) {
+ fprintf(stderr, "int_tounixspec: buf = NULL\n");
+ }
+ return NULL;
+ }
+ trnlnm_iter_count = 0;
+ do {
+ cp3 = tmp;
+ while (*cp3 != ':' && *cp3)
+ cp3++;
+ *(cp3++) = '\0';
+ if (strchr(cp3,']') != NULL)
+ break;
+ trnlnm_iter_count++;
+ if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1)
+ break;
+ } while (vmstrnenv(tmp,tmp,0,fildev,0));
+ cp1 = buf;
+ cp3 = tmp;
+ *(cp1++) = '/';
+ while (*cp3) {
+ *(cp1++) = *(cp3++);
+ if (cp1 - buf > (VMS_MAXRSS - 1)) {
+ PerlMem_free(tmp);
+ set_errno(ENAMETOOLONG);
+ set_vaxc_errno(SS$_BUFFEROVF);
+ if (vms_debug_fileify) {
+ fprintf(stderr, "int_tounixspec: buf = NULL\n");
+ }
+ return NULL; /* No room */
+ }
+ }
+ *(cp1++) = '/';
+ }
+ if ((*cp2 == '^')) {
+ /* EFS file escape, pass the next character as is */
+ /* Fix me: HEX encoding for Unicode not implemented */
+ cp2++;
+ } else if ( *cp2 == '.') {
+ if (*(cp2+1) == '.' && *(cp2+2) == '.') {
+ *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
+ cp2 += 3;
+ } else {
+ cp2++;
+ }
+ }
}
- }
- 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++;
- }
- if (*cp2 == ':') {
- *(cp1++) = '/';
- if (*(cp2+1) == '[') cp2++;
- }
- else if (*cp2 == ']' || *cp2 == '>') {
- if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
- }
- else if ((*cp2 == '.') && (*cp2-1 != '^')) {
- *(cp1++) = '/';
- if (*(cp2+1) == ']' || *(cp2+1) == '>') {
- while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
- *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
- if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
- *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
- }
- else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
- *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
- cp2 += 2;
- }
- }
- else if (*cp2 == '-') {
- if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
- while (*cp2 == '-') {
- cp2++;
- *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
- }
- if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
- if (ts) Safefree(rslt); /* filespecs like */
- set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
- return NULL;
+ 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++;
+ }
+ if (*cp2 == ':') {
+ *(cp1++) = '/';
+ if (*(cp2+1) == '[')
+ cp2++;
+ } else if (*cp2 == ']' || *cp2 == '>') {
+ if (*(cp1-1) != '/') {
+ /* Don't double after ellipsis */
+ *(cp1++) = '/';
+ }
+ } else if ((*cp2 == '.') && (*cp2-1 != '^')) {
+ *(cp1++) = '/';
+ if (*(cp2+1) == ']' || *(cp2+1) == '>') {
+ while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
+ *(cp2+1) == '[' || *(cp2+1) == '<')
+ cp2++;
+ if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
+ *(cp2+7) == '>' || *(cp2+7) == '.'))
+ cp2 += 7;
+ } else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
+ *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
+ cp2 += 2;
+ }
+ } else if (*cp2 == '-') {
+ if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
+ while (*cp2 == '-') {
+ cp2++;
+ *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
+ }
+ if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') {
+ /* we don't allow filespecs like [fred.--foo.bar] */
+ set_errno(EINVAL);
+ set_vaxc_errno(RMS$_SYN);
+ if (vms_debug_fileify) {
+ fprintf(stderr, "int_tounixspec: buf = NULL\n");
+ }
+ return NULL;
+ }
+ } else {
+ *(cp1++) = *cp2;
+ }
+ } else {
+ *(cp1++) = *cp2;
}
- }
- else *(cp1++) = *cp2;
}
- else *(cp1++) = *cp2;
- }
- while (*cp2) {
- if ((*cp2 == '^') && (*(cp2+1) == '.')) cp2++; /* '^.' --> '.' */
- *(cp1++) = *(cp2++);
- }
- *cp1 = '\0';
+ while (*cp2) {
+ if ((*cp2 == '^') && (*(cp2+1) == '.')) cp2++; /* '^.' --> '.' */
+ *(cp1++) = *(cp2++);
+ }
+ *cp1 = '\0';
- /* This still leaves /000000/ when working with a
- * VMS device root or concealed root.
- */
- {
- int ulen;
- char * zeros;
+ /* This still leaves /000000/ when working with a
+ * VMS device root or concealed root.
+ */
+ {
+ int ulen;
+ char * zeros;
- ulen = strlen(rslt);
+ ulen = strlen(buf);
- /* Get rid of "000000/ in rooted filespecs */
- if (ulen > 7) {
- zeros = strstr(rslt, "/000000/");
- if (zeros != NULL) {
- int mlen;
- mlen = ulen - (zeros - rslt) - 7;
- memmove(zeros, &zeros[7], mlen);
- ulen = ulen - 7;
- rslt[ulen] = '\0';
- }
- }
- }
+ /* Get rid of "000000/ in rooted filespecs */
+ if (ulen > 7) {
+ zeros = strstr(buf, "/000000/");
+ if (zeros != NULL) {
+ int mlen;
+ mlen = ulen - (zeros - buf) - 7;
+ memmove(zeros, &zeros[7], mlen);
+ ulen = ulen - 7;
+ buf[ulen] = '\0';
+ }
+ }
+ }
+
+ if (vms_debug_fileify) {
+ fprintf(stderr, "int_tounixspec: buf = %s\n", buf);
+ }
+ return buf;
+}
+
+
+/*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
+static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int *
utf8_fl)
+{
+ static char __tounixspec_retbuf[VMS_MAXRSS];
+ char * unixspec, *ret_spec, *ret_buf;
+
+ unixspec = NULL;
+ ret_buf = buf;
+ if (ret_buf == NULL) {
+ if (ts) {
+ Newx(unixspec, VMS_MAXRSS, char);
+ if (unixspec == NULL)
+ _ckvmssts(SS$_INSFMEM);
+ ret_buf = unixspec;
+ } else {
+ ret_buf = __tounixspec_retbuf;
+ }
+ }
+
+ ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
+
+ if (ret_spec == NULL) {
+ /* Cleanup on isle 5, if this is thread specific we need to deallocate
*/
+ if (unixspec)
+ Safefree(unixspec);
+ }
+
+ return ret_spec;
- return rslt;
} /* end of do_tounixspec() */
+
/*}}}*/
/* External entry points */
char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
