This patch makes a version of vmsify and vmspath available for calling
with out an implicit context, which is needed for threaded perl as
several routines do not have or need an implicit context.
This is the fourth 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.
-John
[EMAIL PROTECTED]
Personal Opinion Only
--- /ref5_root/perl/vms/vms.c Sun Dec 7 14:10:15 2008
+++ vms/vms.c Sun Dec 7 15:56:16 2008
@@ -296,7 +296,10 @@
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_tovmsspec
+ (const char *path, char *buf, int dir_flag, int * utf8_flag);
static char * int_tounixspec(const char *spec, char *buf, int * utf8_fl);
+static char * int_tovmspath(const char *path, 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
@@ -8107,58 +8110,65 @@
}
+
/*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
-static char *mp_do_tovmsspec
- (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
- static char __tovmsspec_retbuf[VMS_MAXRSS];
- char *rslt, *dirend;
- char *lastdot;
- char *vms_delim;
- register char *cp1;
- const char *cp2;
- unsigned long int infront = 0, hasdir = 1;
- int rslt_len;
- int no_type_seen;
- char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
- int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
-
- if (path == NULL) return NULL;
- rslt_len = VMS_MAXRSS-1;
- if (buf) rslt = buf;
- else if (ts) Newx(rslt, VMS_MAXRSS, char);
- else rslt = __tovmsspec_retbuf;
-
- /* '.' and '..' are "[]" and "[-]" for a quick check */
- if (path[0] == '.') {
- if (path[1] == '\0') {
- strcpy(rslt,"[]");
- if (utf8_flag != NULL)
- *utf8_flag = 0;
- return rslt;
+static char *int_tovmsspec
+ (const char *path, char *buf, int dir_flag, int * utf8_flag) {
+ char *dirend;
+ char *lastdot;
+ char *vms_delim;
+ register char *cp1;
+ const char *cp2;
+ unsigned long int infront = 0, hasdir = 1;
+ int rslt_len;
+ int no_type_seen;
+ char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
+ int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
+
+ if (vms_debug_fileify) {
+ if (path == NULL)
+ fprintf(stderr, "int_tovmsspec: path = NULL\n");
+ else
+ fprintf(stderr, "int_tovmsspec: path = %s\n", path);
}
- else {
- if (path[1] == '.' && path[2] == '\0') {
- strcpy(rslt,"[-]");
- if (utf8_flag != NULL)
- *utf8_flag = 0;
- return rslt;
- }
+
+ if (path == NULL) {
+ set_errno(EINVAL);
+ set_vaxc_errno(SS$_BADPARAM);
+ return NULL;
}
- }
+ rslt_len = VMS_MAXRSS-1;
- /* Posix specifications are now a native VMS format */
- /*--------------------------------------------------*/
+ /* '.' and '..' are "[]" and "[-]" for a quick check */
+ if (path[0] == '.') {
+ if (path[1] == '\0') {
+ strcpy(buf, "[]");
+ if (utf8_flag != NULL)
+ *utf8_flag = 0;
+ return buf;
+ } else {
+ if (path[1] == '.' && path[2] == '\0') {
+ strcpy(buf, "[-]");
+ if (utf8_flag != NULL)
+ *utf8_flag = 0;
+ return buf;
+ }
+ }
+ }
+
+ /* Posix specifications are now a native VMS format */
+ /*--------------------------------------------------*/
#if __CRTL_VER >= 80200000 && !defined(__VAX)
- if (decc_posix_compliant_pathnames) {
- if (strncmp(path,"\"^UP^",5) == 0) {
- posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
- return rslt;
+ if (decc_posix_compliant_pathnames) {
+ if (strncmp(path,"\"^UP^",5) == 0) {
+ posix_to_vmsspec_hardway(buf, rslt_len, path, dir_flag, utf8_flag);
+ return buf;
+ }
}
- }
#endif
- /* This is really the only way to see if this is already in VMS format */
- sts = vms_split_path
+ /* This is really the only way to see if this is already in VMS format */
+ sts = vms_split_path
(path,
&v_spec,
&v_len,
@@ -8172,7 +8182,7 @@
&e_len,
&vs_spec,
&vs_len);
- if (sts == 0) {
+ if (sts == 0) {
/* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
replacement, because the above parse just took care of most of
what is needed to do vmspath when the specification is already
@@ -8183,13 +8193,17 @@
the result.
*/
- /* If VMS punctuation was found, it is already VMS format */
- if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
- if (utf8_flag != NULL)
- *utf8_flag = 0;
- strcpy(rslt, path);
- return rslt;
- }
+ /* If VMS punctuation was found, it is already VMS format */
+ if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
+ if (utf8_flag != NULL)
+ *utf8_flag = 0;
+ strcpy(buf, path);
+
+ if (vms_debug_fileify) {
+ fprintf(stderr, "int_tovmsspec: buf = %s\n", buf);
+ }
+ return buf;
+ }
/* Now, what to do with trailing "." cases where there is no
extension? If this is a UNIX specification, and EFS characters
are enabled, then the trailing "." should be converted to a "^.".
@@ -8200,353 +8214,425 @@
*/
- /* If there is a possibility of UTF8, then if any UTF8 characters
- are present, then they must be converted to VTF-7
- */
- if (utf8_flag != NULL)
- *utf8_flag = 0;
- strcpy(rslt, path);
- return rslt;
- }
-
- dirend = strrchr(path,'/');
+ /* If there is a possibility of UTF8, then if any UTF8 characters
+ are present, then they must be converted to VTF-7
+ */
+ if (utf8_flag != NULL)
+ *utf8_flag = 0;
+ strcpy(buf, path);
+ if (vms_debug_fileify) {
+ fprintf(stderr, "int_tovmsspec: buf = %s\n", buf);
+ }
+ return buf;
+ }
- if (dirend == NULL) {
- /* 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 these passed through AS-IS,
- so apparently other programs expect this also.
+ dirend = strrchr(path,'/');
- utf8 flag setting needs to be preserved.
- */
- strcpy(rslt, path);
- return rslt;
- }
+ if (dirend == NULL) {
+ /* 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 these passed through AS-IS,
+ so apparently other programs expect this also.
+
+ utf8 flag setting needs to be preserved.
+ */
+ strcpy(buf, path);
+ if (vms_debug_fileify) {
+ fprintf(stderr, "int_tovmsspec: buf = %s\n", buf);
+ }
+ return buf;
+ }
/* If POSIX mode active, handle the conversion */
#if __CRTL_VER >= 80200000 && !defined(__VAX)
- if (decc_efs_charset) {
- posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
- return rslt;
- }
+ if (decc_efs_charset) {
+ posix_to_vmsspec_hardway(buf, rslt_len, path, dir_flag, utf8_flag);
+ if (vms_debug_fileify) {
+ fprintf(stderr, "int_tovmsspec: buf = %s\n", buf);
+ }
+ return buf;
+ }
#endif
- 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+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;
+ }
}
- }
- cp1 = rslt;
- cp2 = path;
- lastdot = strrchr(cp2,'.');
- if (*cp2 == '/') {
- char *trndev;
- int islnm, rooted;
- STRLEN trnend;
+ cp1 = buf;
+ cp2 = path;
+ lastdot = strrchr(cp2,'.');
+ if (*cp2 == '/') {
+ char *trndev;
+ int islnm, rooted;
+ STRLEN trnend;
+
+ while (*(cp2+1) == '/')
+ cp2++; /* Skip multiple /s */
+ if (!*(cp2+1)) {
+ if (decc_disable_posix_root) {
+ strcpy(buf, "sys$disk:[000000]");
+ } else {
+ strcpy(buf, "sys$posix_root:[000000]");
+ }
+ if (utf8_flag != NULL)
+ *utf8_flag = 0;
+ if (vms_debug_fileify) {
+ fprintf(stderr, "int_tovmsspec: buf = %s\n", buf);
+ }
+ return buf;
+ }
+ while (*(++cp2) != '/' && *cp2)
+ *(cp1++) = *cp2;
+ *cp1 = '\0';
+ trndev = PerlMem_malloc(VMS_MAXRSS);
+ if (trndev == NULL)
+ _ckvmssts_noperl(SS$_INSFMEM);
+ islnm = simple_trnlnm(buf, trndev, VMS_MAXRSS);
- while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
- if (!*(cp2+1)) {
- if (decc_disable_posix_root) {
- strcpy(rslt,"sys$disk:[000000]");
- }
- else {
- strcpy(rslt,"sys$posix_root:[000000]");
- }
- if (utf8_flag != NULL)
- *utf8_flag = 0;
- return rslt;
- }
- while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
- *cp1 = '\0';
- trndev = PerlMem_malloc(VMS_MAXRSS);
- if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
- islnm = my_trnlnm(rslt,trndev,0);
-
- /* DECC special handling */
- if (!islnm) {
- if (strcmp(rslt,"bin") == 0) {
- strcpy(rslt,"sys$system");
- cp1 = rslt + 10;
- *cp1 = 0;
- islnm = my_trnlnm(rslt,trndev,0);
- }
- else if (strcmp(rslt,"tmp") == 0) {
- strcpy(rslt,"sys$scratch");
- cp1 = rslt + 11;
- *cp1 = 0;
- islnm = my_trnlnm(rslt,trndev,0);
- }
- else if (!decc_disable_posix_root) {
- strcpy(rslt, "sys$posix_root");
- cp1 = rslt + 13;
- *cp1 = 0;
- cp2 = path;
- while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
- islnm = my_trnlnm(rslt,trndev,0);
- }
- else if (strcmp(rslt,"dev") == 0) {
- if (strncmp(cp2,"/null", 5) == 0) {
- if ((cp2[5] == 0) || (cp2[5] == '/')) {
- strcpy(rslt,"NLA0");
- cp1 = rslt + 4;
- *cp1 = 0;
- cp2 = cp2 + 5;
- islnm = my_trnlnm(rslt,trndev,0);
- }
- }
- }
- }
+ /* DECC special handling */
+ if (!islnm) {
+ if (strcmp(buf, "bin") == 0) {
+ strcpy(buf, "sys$system");
+ cp1 = buf + 10;
+ *cp1 = 0;
+ islnm = simple_trnlnm(buf, trndev, VMS_MAXRSS);
+ } else if (strcmp(buf, "tmp") == 0) {
+ strcpy(buf, "sys$scratch");
+ cp1 = buf + 11;
+ *cp1 = 0;
+ islnm = simple_trnlnm(buf, trndev, VMS_MAXRSS);
+ } else if (!decc_disable_posix_root) {
+ strcpy(buf, "sys$posix_root");
+ cp1 = buf + 13;
+ *cp1 = 0;
+ cp2 = path;
+ while (*(cp2+1) == '/')
+ cp2++; /* Skip multiple /s */
+ islnm = simple_trnlnm(buf, trndev, 0);
+ } else if (strcmp(buf, "dev") == 0) {
+ if (strncmp(cp2,"/null", 5) == 0) {
+ if ((cp2[5] == 0) || (cp2[5] == '/')) {
+ strcpy(buf, "NLA0");
+ cp1 = buf + 4;
+ *cp1 = 0;
+ cp2 = cp2 + 5;
+ islnm = simple_trnlnm(buf, trndev, VMS_MAXRSS);
+ }
+ }
+ }
+ }
- trnend = islnm ? strlen(trndev) - 1 : 0;
- islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
- rooted = islnm ? (trndev[trnend-1] == '.') : 0;
- /* If the first element of the path is a logical name, determine
- * whether it has to be translated so we can add more directories. */
- if (!islnm || rooted) {
- *(cp1++) = ':';
- *(cp1++) = '[';
- if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
- else cp2++;
- }
- else {
- if (cp2 != dirend) {
- strcpy(rslt,trndev);
- cp1 = rslt + trnend;
- if (*cp2 != 0) {
- *(cp1++) = '.';
- cp2++;
+ trnend = islnm ? strlen(trndev) - 1 : 0;
+ islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
+ rooted = islnm ? (trndev[trnend-1] == '.') : 0;
+ /* If the first element of the path is a logical name, determine
+ * whether it has to be translated so we can add more directories. */
+ if (!islnm || rooted) {
+ *(cp1++) = ':';
+ *(cp1++) = '[';
+ if (cp2 == dirend) {
+ while (infront++ < 6)
+ *(cp1++) = '0';
+ } else {
+ cp2++;
+ }
+ } else {
+ if (cp2 != dirend) {
+ strcpy(buf, trndev);
+ cp1 = buf + trnend;
+ if (*cp2 != 0) {
+ *(cp1++) = '.';
+ cp2++;
+ }
+ } else {
+ if (decc_disable_posix_root) {
+ *(cp1++) = ':';
+ hasdir = 0;
+ }
+ }
}
- }
- else {
- if (decc_disable_posix_root) {
- *(cp1++) = ':';
- hasdir = 0;
- }
- }
- }
- PerlMem_free(trndev);
- }
- else {
- *(cp1++) = '[';
- if (*cp2 == '.') {
- if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
- cp2 += 2; /* skip over "./" - it's redundant */
- *(cp1++) = '.'; /* but it does indicate a relative dirspec */
- }
- else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
- *(cp1++) = '-'; /* "../" --> "-" */
- cp2 += 3;
- }
- else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
- (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
- *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
- if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
- cp2 += 4;
- }
- else if ((cp2 != lastdot) || (lastdot < dirend)) {
- /* Escape the extra dots in EFS file specifications */
- *(cp1++) = '^';
- }
- if (cp2 > dirend) cp2 = dirend;
+ PerlMem_free(trndev);
+ } else {
+ *(cp1++) = '[';
+ if (*cp2 == '.') {
+ if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
+ cp2 += 2; /* skip over "./" - it's redundant */
+ *(cp1++) = '.'; /* but it does indicate a relative dirspec */
+ } else if ((*(cp2+1) == '.') &&
+ (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
+ *(cp1++) = '-'; /* "../" --> "-" */
+ cp2 += 3;
+ } else if (*(cp2+1) == '.' &&
+ *(cp2+2) == '.' &&
+ ( *(cp2+3) == '/' || *(cp2+3) == '\0')) {
+ *(cp1++) = '.';
+ *(cp1++) = '.';
+ *(cp1++) = '.'; /* ".../" --> "..." */
+ if (!*(cp2+4))
+ *(cp1++) = '.'; /* Simulate trailing '/' for later */
+ cp2 += 4;
+ } else if ((cp2 != lastdot) || (lastdot < dirend)) {
+ /* Escape the extra dots in EFS file specifications */
+ *(cp1++) = '^';
+ }
+ if (cp2 > dirend)
+ cp2 = dirend;
+ }
+ else
+ *(cp1++) = '.';
}
- else *(cp1++) = '.';
- }
- for (; cp2 < dirend; cp2++) {
- if (*cp2 == '/') {
- if (*(cp2-1) == '/') continue;
- if (*(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) = '-';
- else { /* back up over previous directory name */
- cp1--;
- while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
- if (*(cp1-1) == '[') {
- memcpy(cp1,"000000.",7);
- cp1 += 7;
- }
+ for (; cp2 < dirend; cp2++) {
+ if (*cp2 == '/') {
+ if (*(cp2-1) == '/')
+ continue;
+ if (*(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) = '-';
+ else { /* back up over previous directory name */
+ cp1--;
+ while (*(cp1-1) != '.' && *(cp1-1) != '[')
+ cp1--;
+ if (*(cp1-1) == '[') {
+ memcpy(cp1,"000000.",7);
+ cp1 += 7;
+ }
+ }
+ cp2 += 2;
+ if (cp2 == dirend)
+ break;
+ } else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
+ (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
+ if (*(cp1-1) != '.')
+ *(cp1++) = '.'; /* May already have 1 from '/' */
+ *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
+ if (!*(cp2+3)) {
+ *(cp1++) = '.'; /* Simulate trailing '/' */
+ cp2 += 2; /* for loop will incr this to == dirend */
+ } else
+ cp2 += 3; /* Trailing '/' was there, so skip it, too */
+ } else {
+ if (decc_efs_charset == 0) {
+ /* fix up syntax - '.' in name not allowed */
+ *(cp1++) = '_';
+ } else {
+ /* fix up syntax - '.' in name is allowed */
+ *(cp1++) = '^';
+ *(cp1++) = '.';
+ }
+ }
+ } else {
+ if (!infront && *(cp1-1) == '-')
+ *(cp1++) = '.';
+ if (*cp2 == '.') {
+ if (decc_efs_charset == 0)
+ *(cp1++) = '_';
+ else {
+ *(cp1++) = '^';
+ *(cp1++) = '.';
+ }
+ } else {
+ *(cp1++) = *cp2;
+ }
+ infront = 1;
}
- cp2 += 2;
- if (cp2 == dirend) break;
- }
- else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
- (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
- if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
- *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
- if (!*(cp2+3)) {
- *(cp1++) = '.'; /* Simulate trailing '/' */
- cp2 += 2; /* for loop will incr this to == dirend */
+ }
+ if (*(cp1-1) == '.')
+ cp1--; /* Unix spec ending in '/' ==> trailing '.' */
+ if (hasdir)
+ *(cp1++) = ']';
+ if (*cp2)
+ cp2++; /* check in case we ended with trailing '..' */
+ /* fixme for ODS5 */
+ no_type_seen = 0;
+ if (cp2 > lastdot)
+ no_type_seen = 1;
+ while (*cp2) {
+ switch(*cp2) {
+ case '?':
+ if (decc_efs_charset == 0)
+ *(cp1++) = '%';
+ else
+ *(cp1++) = '?';
+ cp2++;
+ break;
+ case ' ':
+ *(cp1)++ = '^';
+ *(cp1)++ = '_';
+ cp2++;
+ break;
+ case '.':
+ if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
+ decc_readdir_dropdotnotype) {
+ *(cp1)++ = '^';
+ *(cp1)++ = '.';
+ cp2++;
+
+ /* trailing dot ==> '^..' on VMS */
+ if (*cp2 == '\0') {
+ *(cp1++) = '.';
+ no_type_seen = 0;
+ }
+ } else {
+ *(cp1++) = *(cp2++);
+ no_type_seen = 0;
+ }
+ break;
+ case '$':
+ /* This could be a macro to be passed through */
+ *(cp1++) = *(cp2++);
+ if (*cp2 == '(') {
+ const char * save_cp2;
+ char * save_cp1;
+ int is_macro;
+
+ /* paranoid check */
+ save_cp2 = cp2;
+ save_cp1 = cp1;
+ is_macro = 0;
+
+ /* Test through */
+ *(cp1++) = *(cp2++);
+ if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
+ *(cp1++) = *(cp2++);
+ while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
+ *(cp1++) = *(cp2++);
+ }
+ if (*cp2 == ')') {
+ *(cp1++) = *(cp2++);
+ is_macro = 1;
+ }
+ }
+ if (is_macro == 0) {
+ /* Not really a macro - never mind */
+ cp2 = save_cp2;
+ cp1 = save_cp1;
+ }
+ }
+ break;
+ case '\"':
+ case '~':
+ case '`':
+ case '!':
+ case '#':
+ case '%':
+ case '^':
+ /* Don't escape again if following character is
+ * already something we escape.
+ */
+ if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
+ *(cp1++) = *(cp2++);
+ break;
+ }
+ /* But otherwise fall through and escape it. */
+ case '&':
+ case '(':
+ case ')':
+ case '=':
+ case '+':
+ case '\'':
+ case '@':
+ case '[':
+ case ']':
+ case '{':
+ case '}':
+ case ':':
+ case '\\':
+ case '|':
+ case '<':
+ case '>':
+ *(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) {
+ *(cp1++) = '^';
+ }
+ *(cp1++) = *(cp2++);
+ break;
+ default:
+ *(cp1++) = *(cp2++);
}
- else cp2 += 3; /* Trailing '/' was there, so skip it, too */
- }
- else {
- if (decc_efs_charset == 0)
- *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
- else {
- *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
- *(cp1++) = '.';
- }
- }
}
- else {
- if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
- if (*cp2 == '.') {
- if (decc_efs_charset == 0)
- *(cp1++) = '_';
- else {
- *(cp1++) = '^';
- *(cp1++) = '.';
- }
- }
- else *(cp1++) = *cp2;
- infront = 1;
+ if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
+ char *lcp1;
+ lcp1 = cp1;
+ lcp1--;
+ /* Fix me for "^]", but that requires making sure that you do
+ * not back up past the start of the filename
+ */
+ if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
+ *cp1++ = '.';
}
- }
- if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
- if (hasdir) *(cp1++) = ']';
- if (*cp2) cp2++; /* check in case we ended with trailing '..' */
- /* fixme for ODS5 */
- no_type_seen = 0;
- if (cp2 > lastdot)
- no_type_seen = 1;
- while (*cp2) {
- switch(*cp2) {
- case '?':
- if (decc_efs_charset == 0)
- *(cp1++) = '%';
- else
- *(cp1++) = '?';
- cp2++;
- case ' ':
- *(cp1)++ = '^';
- *(cp1)++ = '_';
- cp2++;
- break;
- case '.':
- if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
- decc_readdir_dropdotnotype) {
- *(cp1)++ = '^';
- *(cp1)++ = '.';
- cp2++;
+ *cp1 = '\0';
- /* trailing dot ==> '^..' on VMS */
- if (*cp2 == '\0') {
- *(cp1++) = '.';
- no_type_seen = 0;
- }
- }
- else {
- *(cp1++) = *(cp2++);
- no_type_seen = 0;
- }
- break;
- case '$':
- /* This could be a macro to be passed through */
- *(cp1++) = *(cp2++);
- if (*cp2 == '(') {
- const char * save_cp2;
- char * save_cp1;
- int is_macro;
-
- /* paranoid check */
- save_cp2 = cp2;
- save_cp1 = cp1;
- is_macro = 0;
-
- /* Test through */
- *(cp1++) = *(cp2++);
- if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
- *(cp1++) = *(cp2++);
- while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
- *(cp1++) = *(cp2++);
- }
- if (*cp2 == ')') {
- *(cp1++) = *(cp2++);
- is_macro = 1;
- }
- }
- if (is_macro == 0) {
- /* Not really a macro - never mind */
- cp2 = save_cp2;
- cp1 = save_cp1;
- }
- }
- break;
- case '\"':
- case '~':
- case '`':
- case '!':
- case '#':
- case '%':
- case '^':
- /* Don't escape again if following character is
- * already something we escape.
- */
- if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
- *(cp1++) = *(cp2++);
- break;
+ if (utf8_flag != NULL)
+ *utf8_flag = 0;
+
+ if (vms_debug_fileify) {
+ fprintf(stderr, "int_tovmsspec: buf = %s\n", buf);
+ }
+ return buf;
+
+}
+
+
+/*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
+static char *mp_do_tovmsspec
+ (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
+
+ static char __tovmsspec_retbuf[VMS_MAXRSS];
+ char * vmsspec, *ret_spec, *ret_buf;
+
+ vmsspec = NULL;
+ ret_buf = buf;
+ if (ret_buf == NULL) {
+ if (ts) {
+ Newx(vmsspec, VMS_MAXRSS, char);
+ if (vmsspec == NULL)
+ _ckvmssts(SS$_INSFMEM);
+ ret_buf = vmsspec;
+ } else {
+ ret_buf = __tovmsspec_retbuf;
}
- /* But otherwise fall through and escape it. */
- case '&':
- case '(':
- case ')':
- case '=':
- case '+':
- case '\'':
- case '@':
- case '[':
- case ']':
- case '{':
- case '}':
- case ':':
- case '\\':
- case '|':
- case '<':
- case '>':
- *(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) {
- *(cp1++) = '^';
- }
- *(cp1++) = *(cp2++);
- break;
- default:
- *(cp1++) = *(cp2++);
}
- }
- if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
- char *lcp1;
- lcp1 = cp1;
- lcp1--;
- /* Fix me for "^]", but that requires making sure that you do
- * not back up past the start of the filename
- */
- if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
- *cp1++ = '.';
- }
- *cp1 = '\0';
- if (utf8_flag != NULL)
- *utf8_flag = 0;
- return rslt;
+ ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
+
+ if (ret_spec == NULL) {
+ /* Cleanup on isle 5, if this is thread specific we need to deallocate
*/
+ if (vmsspec)
+ Safefree(vmsspec);
+ }
+
+ return ret_spec;
} /* end of do_tovmsspec() */
/*}}}*/
@@ -8561,43 +8647,71 @@
{ return do_tovmsspec(path,buf,1,utf8_fl); }
/*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
-static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *
utf8_fl) {
- static char __tovmspath_retbuf[VMS_MAXRSS];
- int vmslen;
- char *pathified, *vmsified, *cp;
-
- if (path == NULL) return NULL;
- pathified = PerlMem_malloc(VMS_MAXRSS);
- if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
- if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
- PerlMem_free(pathified);
- return NULL;
- }
+/* Internal routine for use with out an explict context present */
+static char * int_tovmspath(const char *path, char *buf, int * utf8_fl) {
+
+ char * ret_spec, *pathified;
+
+ if (path == NULL)
+ return NULL;
+
+ pathified = PerlMem_malloc(VMS_MAXRSS);
+ if (pathified == NULL)
+ _ckvmssts_noperl(SS$_INSFMEM);
+
+ ret_spec = int_pathify_dirspec(path, pathified);
+
+ if (ret_spec == NULL) {
+ PerlMem_free(pathified);
+ return NULL;
+ }
- vmsified = NULL;
- if (buf == NULL)
- Newx(vmsified, VMS_MAXRSS, char);
- if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
+ ret_spec = int_tovmsspec(pathified, buf, 0, utf8_fl);
+
PerlMem_free(pathified);
- if (vmsified) Safefree(vmsified);
- return NULL;
- }
- PerlMem_free(pathified);
- if (buf) {
- return buf;
- }
- else if (ts) {
- vmslen = strlen(vmsified);
- Newx(cp,vmslen+1,char);
- memcpy(cp,vmsified,vmslen);
- cp[vmslen] = '\0';
- Safefree(vmsified);
- return cp;
- }
- else {
- strcpy(__tovmspath_retbuf,vmsified);
- Safefree(vmsified);
- return __tovmspath_retbuf;
+ return ret_spec;
+
+}
+
+/*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
+static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *
utf8_fl) {
+ static char __tovmspath_retbuf[VMS_MAXRSS];
+ int vmslen;
+ char *pathified, *vmsified, *cp;
+ char *ret_buf, *ret_spec;
+
+ if (path == NULL)
+ return NULL;
+ Newx(pathified, VMS_MAXRSS, char);
+ if (pathified == NULL)
+ _ckvmssts(SS$_INSFMEM);
+ if (int_pathify_dirspec(path, pathified) == NULL) {
+ Safefree(pathified);
+ return NULL;
+ }
+
+ vmsified = NULL;
+ ret_buf = buf;
+ if (ret_buf == NULL) {
+ if (ts) {
+ Newx(vmsified, VMS_MAXRSS, char);
+ if (vmsified == NULL)
+ _ckvmssts(SS$_INSFMEM);
+ ret_buf = vmsified;
+ } else {
+ ret_buf = __tovmspath_retbuf;
+ }
+ }
+
+ ret_spec = int_tovmsspec(pathified, ret_buf, 0, utf8_fl);
+
+ if (ret_spec == NULL) {
+ if (vmsified) {
+ Safefree(vmsified);
+ }
+ Safefree(pathified);
+
+ return ret_spec;
}
} /* end of do_tovmspath() */
