This patch makes a version of fileify 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 fifth 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
--- /ref6_root/perl/vms/vms.c Sun Dec 7 16:34:04 2008
+++ vms/vms.c Sun Dec 7 16:43:36 2008
@@ -298,6 +298,7 @@
static char *int_tovmsspec
(const char *path, char *buf, int dir_flag, int * utf8_flag);
+static char * int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl);
static char * int_tounixspec(const char *spec, char *buf, int * utf8_fl);
static char * int_tovmspath(const char *path, char *buf, int * utf8_fl);
@@ -5792,50 +5793,55 @@
** found in the Perl standard distribution.
*/
-/*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
-static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int
*utf8_fl)
-{
- static char __fileify_retbuf[VMS_MAXRSS];
+static char *
+int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl) {
+
unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
- char *retspec, *cp1, *cp2, *lastdir;
+ char *cp1, *cp2, *lastdir;
char *trndir, *vmsdir;
unsigned short int trnlnm_iter_count;
int sts;
if (utf8_fl != NULL)
- *utf8_fl = 0;
+ *utf8_fl = 0;
if (!dir || !*dir) {
- set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
+ set_errno(EINVAL);
+ set_vaxc_errno(SS$_BADPARAM);
+ return NULL;
}
dirlen = strlen(dir);
- while (dirlen && dir[dirlen-1] == '/') --dirlen;
+ while (dirlen && dir[dirlen-1] == '/')
+ --dirlen;
if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
- if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
- dir = "/sys$disk";
- dirlen = 9;
- }
- else
- dirlen = 1;
+ if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
+ dir = "/sys$disk";
+ dirlen = 9;
+ } else {
+ dirlen = 1;
+ }
}
if (dirlen > (VMS_MAXRSS - 1)) {
- set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
- return NULL;
+ set_errno(ENAMETOOLONG);
+ set_vaxc_errno(SS$_BUFFEROVF);
+ return NULL;
}
trndir = PerlMem_malloc(VMS_MAXRSS + 1);
- if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
+ if (trndir == NULL)
+ _ckvmssts_noperl(SS$_INSFMEM);
if (!strpbrk(dir+1,"/]>:") &&
- (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
- strcpy(trndir,*dir == '/' ? dir + 1: dir);
- trnlnm_iter_count = 0;
- while (!strpbrk(trndir,"/]>:") && my_trnlnm(trndir,trndir,0)) {
- trnlnm_iter_count++;
- if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
- }
- dirlen = strlen(trndir);
- }
- else {
- strncpy(trndir,dir,dirlen);
- trndir[dirlen] = '\0';
+ (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
+ strcpy(trndir,*dir == '/' ? dir + 1: dir);
+ trnlnm_iter_count = 0;
+ while (!strpbrk(trndir,"/]>:") &&
+ simple_trnlnm(trndir, trndir, VMS_MAXRSS)) {
+ trnlnm_iter_count++;
+ if (trnlnm_iter_count >= PERL_LNM_MAX_ITER)
+ break;
+ }
+ dirlen = strlen(trndir);
+ } else {
+ strncpy(trndir,dir,dirlen);
+ trndir[dirlen] = '\0';
}
/* At this point we are done with *dir and use *trndir which is a
@@ -5849,444 +5855,487 @@
* does something useful.
*/
if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
- trndir[--dirlen] = '\0';
- trndir[dirlen-1] = ']';
+ trndir[--dirlen] = '\0';
+ trndir[dirlen-1] = ']';
}
if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
- trndir[--dirlen] = '\0';
- trndir[dirlen-1] = '>';
+ trndir[--dirlen] = '\0';
+ trndir[dirlen-1] = '>';
}
- if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) !=
NULL) {
- /* If we've got an explicit filename, we can just shuffle the string. */
- if (*(cp1+1)) hasfilename = 1;
- /* Similarly, we can just back up a level if we've got multiple levels
- of explicit directories in a VMS spec which ends with directories. */
- else {
- for (cp2 = cp1; cp2 > trndir; cp2--) {
- if (*cp2 == '.') {
- if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
-/* fix-me, can not scan EFS file specs backward like this */
- *cp2 = *cp1; *cp1 = '\0';
- hasfilename = 1;
- break;
- }
- }
- if (*cp2 == '[' || *cp2 == '<') break;
+ if (((cp1 = strrchr(trndir,']')) != NULL) ||
+ ((cp1 = strrchr(trndir,'>')) != NULL)) {
+ /* If we've got an explicit filename, we can just shuffle the string.
*/
+ if (*(cp1+1)) {
+ hasfilename = 1;
+ } else {
+ /* Similarly, we can just back up a level if we've got multiple
+ * levels of explicit directories in a VMS spec which ends with
+ * directories. */
+ for (cp2 = cp1; cp2 > trndir; cp2--) {
+ if (*cp2 == '.') {
+ if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
+ /* fix-me, can not scan EFS file specs backward like
+ * this */
+ *cp2 = *cp1; *cp1 = '\0';
+ hasfilename = 1;
+ break;
+ }
+ }
+ if ((*cp2 == '[') || (*cp2 == '<'))
+ break;
+ }
}
- }
}
vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
- if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
+ if (vmsdir == NULL)
+ _ckvmssts_noperl(SS$_INSFMEM);
cp1 = strpbrk(trndir,"]:>");
if (hasfilename || !cp1) { /* Unix-style path or filename */
- if (trndir[0] == '.') {
- if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
- PerlMem_free(trndir);
- PerlMem_free(vmsdir);
- return do_fileify_dirspec("[]",buf,ts,NULL);
- }
- else if (trndir[1] == '.' &&
- (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0')))
{
- PerlMem_free(trndir);
- PerlMem_free(vmsdir);
- return do_fileify_dirspec("[-]",buf,ts,NULL);
- }
- }
- if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just
add .dir;1 */
- dirlen -= 1; /* to last element */
- lastdir = strrchr(trndir,'/');
- }
- else if ((cp1 = strstr(trndir,"/.")) != NULL) {
- /* If we have "/." or "/..", VMSify it and let the VMS code
- * below expand it, rather than repeating the code to handle
- * relative components of a filespec here */
- do {
- if (*(cp1+2) == '.') cp1++;
- if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
- char * ret_chr;
- if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
- PerlMem_free(trndir);
- PerlMem_free(vmsdir);
- return NULL;
- }
- if (strchr(vmsdir,'/') != NULL) {
- /* If do_tovmsspec() returned it, it must have VMS syntax
- * delimiters in it, so it's a mixed VMS/Unix spec. We take
- * the time to check this here only so we avoid a recursion
- * loop; otherwise, gigo.
- */
- PerlMem_free(trndir);
- PerlMem_free(vmsdir);
- set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);
- return NULL;
+ /* Fix-me: this is changing a UNIX spec to a VMS spec */
+ /* That should break something somewhere */
+ if (trndir[0] == '.') {
+ if ((trndir[1] == '\0') ||
+ ((trndir[1] == '/') && (trndir[2] == '\0'))) {
+ PerlMem_free(trndir);
+ PerlMem_free(vmsdir);
+ return int_fileify_dirspec("[]", buf, NULL);
+ } else if ((trndir[1] == '.') &&
+ ((trndir[2] == '\0') ||
+ ((trndir[2] == '/') && (trndir[3] == '\0')))) {
+ PerlMem_free(trndir);
+ PerlMem_free(vmsdir);
+ return int_fileify_dirspec("[-]", buf, NULL);
}
- if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
- PerlMem_free(trndir);
- PerlMem_free(vmsdir);
- return NULL;
- }
- ret_chr = do_tounixspec(trndir,buf,ts,NULL);
- PerlMem_free(trndir);
- PerlMem_free(vmsdir);
+ }
+ if (dirlen && trndir[dirlen-1] == '/') {
+ /* path ends with '/'; just add .dir;1 */
+ dirlen -= 1; /* to last element */
+ lastdir = strrchr(trndir,'/');
+ } else if ((cp1 = strstr(trndir,"/.")) != NULL) {
+ /* If we have "/." or "/..", VMSify it and let the VMS code
+ * below expand it, rather than repeating the code to handle
+ * relative components of a filespec here */
+ do {
+ if (*(cp1+2) == '.')
+ cp1++;
+ if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
+ char * ret_chr;
+ if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
+ PerlMem_free(trndir);
+ PerlMem_free(vmsdir);
+ return NULL;
+ }
+ if (strchr(vmsdir,'/') != NULL) {
+ /* If do_tovmsspec() returned it, it must have VMS
+ * syntax delimiters in it, so it's a mixed VMS/Unix
+ * spec. We take the time to check this here only
+ * so we avoid a recursion loop; otherwise, gigo.
+ */
+ PerlMem_free(trndir);
+ PerlMem_free(vmsdir);
+ set_errno(EINVAL);
+ set_vaxc_errno(RMS$_SYN);
+ return NULL;
+ }
+ if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
+ PerlMem_free(trndir);
+ PerlMem_free(vmsdir);
+ return NULL;
+ }
+ ret_chr = int_tounixspec(trndir, buf, utf8_fl);
+ PerlMem_free(trndir);
+ PerlMem_free(vmsdir);
+ return ret_chr;
+ }
+ cp1++;
+ } while ((cp1 = strstr(cp1,"/.")) != NULL);
+ lastdir = strrchr(trndir,'/');
+ } else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
+ char * ret_chr;
+ /* Ditto for specs that end in an MFD -- let the VMS code
+ * figure out whether it's a real device or a rooted logical. */
+
+ /* This should not happen any more. Allowing the fake /000000
+ * in a UNIX pathname causes all sorts of problems when trying
+ * to run in UNIX emulation. So the VMS to UNIX conversions
+ * now remove the fake /000000 directories.
+ */
+
+ trndir[dirlen] = '/';
+ trndir[dirlen+1] = '\0';
+ if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
+ PerlMem_free(trndir);
+ PerlMem_free(vmsdir);
+ return NULL;
+ }
+ if (int_fileify_dirspec(vmsdir, trndir, utf8_fl) == NULL) {
+ PerlMem_free(trndir);
+ PerlMem_free(vmsdir);
+ return NULL;
+ }
+ ret_chr = int_tounixspec(trndir, buf, utf8_fl);
+ PerlMem_free(trndir);
+ PerlMem_free(vmsdir);
return ret_chr;
- }
- cp1++;
- } while ((cp1 = strstr(cp1,"/.")) != NULL);
- lastdir = strrchr(trndir,'/');
- }
- else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
- char * ret_chr;
- /* Ditto for specs that end in an MFD -- let the VMS code
- * figure out whether it's a real device or a rooted logical. */
-
- /* This should not happen any more. Allowing the fake /000000
- * in a UNIX pathname causes all sorts of problems when trying
- * to run in UNIX emulation. So the VMS to UNIX conversions
- * now remove the fake /000000 directories.
- */
-
- trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
- if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
- PerlMem_free(trndir);
- PerlMem_free(vmsdir);
- return NULL;
- }
- if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
- PerlMem_free(trndir);
- PerlMem_free(vmsdir);
- return NULL;
- }
- ret_chr = do_tounixspec(trndir,buf,ts,NULL);
- PerlMem_free(trndir);
- PerlMem_free(vmsdir);
- return ret_chr;
- }
- else {
+ } else {
- if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
- !(lastdir = cp1 = strrchr(trndir,']')) &&
- !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
- if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
- int ver; char *cp3;
-
- /* For EFS or ODS-5 look for the last dot */
- if (decc_efs_charset) {
- cp2 = strrchr(cp1,'.');
- }
- if (vms_process_case_tolerant) {
- if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
- !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
- !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
- (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
- (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
- (ver || *cp3)))))) {
- PerlMem_free(trndir);
- PerlMem_free(vmsdir);
- set_errno(ENOTDIR);
- set_vaxc_errno(RMS$_DIR);
- return NULL;
- }
- }
- else {
- if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
- !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
- !*(cp2+3) || *(cp2+3) != 'R' ||
- (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
- (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
+ if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
+ !(lastdir = cp1 = strrchr(trndir,']')) &&
+ !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
+ if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
+ int ver; char *cp3;
+
+ /* For EFS or ODS-5 look for the last dot */
+ if (decc_efs_charset) {
+ cp2 = strrchr(cp1,'.');
+ }
+ if (vms_process_case_tolerant) {
+ /* Wrong type? */
+ if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||
+ !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
+ !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
+ (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
+ (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
(ver || *cp3)))))) {
- PerlMem_free(trndir);
- PerlMem_free(vmsdir);
- set_errno(ENOTDIR);
- set_vaxc_errno(RMS$_DIR);
- return NULL;
- }
- }
- dirlen = cp2 - trndir;
+ PerlMem_free(trndir);
+ PerlMem_free(vmsdir);
+ set_errno(ENOTDIR);
+ set_vaxc_errno(RMS$_DIR);
+ return NULL;
+ }
+ } else {
+ if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
+ !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
+ !*(cp2+3) || *(cp2+3) != 'R' ||
+ (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
+ (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
+ (ver || *cp3)))))) {
+ PerlMem_free(trndir);
+ PerlMem_free(vmsdir);
+ set_errno(ENOTDIR);
+ set_vaxc_errno(RMS$_DIR);
+ return NULL;
+ }
+ }
+ dirlen = cp2 - trndir;
+ }
}
- }
-
- retlen = dirlen + 6;
- if (buf) retspec = buf;
- else if (ts) Newx(retspec,retlen+1,char);
- else retspec = __fileify_retbuf;
- memcpy(retspec,trndir,dirlen);
- retspec[dirlen] = '\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(retspec,".dir;1");
- else
- strcat(retspec,".DIR;1");
- PerlMem_free(trndir);
- PerlMem_free(vmsdir);
- return retspec;
- }
- else { /* VMS-style directory spec */
-
- char *esa, *esal, term, *cp;
- char *my_esa;
- int my_esa_len;
- unsigned long int sts, cmplen, haslower = 0;
- unsigned int nam_fnb;
- char * nam_type;
- struct FAB dirfab = cc$rms_fab;
- rms_setup_nam(savnam);
- rms_setup_nam(dirnam);
-
- esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
- if (esa == NULL) _ckvmssts(SS$_INSFMEM);
- esal = NULL;
+ retlen = dirlen + 6;
+ memcpy(buf, trndir, dirlen);
+ buf[dirlen] = '\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");
+ else
+ strcat(buf,".DIR;1");
+ PerlMem_free(trndir);
+ PerlMem_free(vmsdir);
+ return buf;
+ } else { /* VMS-style directory spec */
+
+ char *esa, *esal, term, *cp;
+ char *my_esa;
+ int my_esa_len;
+ unsigned long int sts, cmplen, haslower = 0;
+ unsigned int nam_fnb;
+ char * nam_type;
+ struct FAB dirfab = cc$rms_fab;
+ rms_setup_nam(savnam);
+ rms_setup_nam(dirnam);
+
+ esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
+ if (esa == NULL)
+ _ckvmssts_noperl(SS$_INSFMEM);
+ esal = NULL;
#if !defined(__VAX) && defined(NAML$C_MAXRSS)
- esal = PerlMem_malloc(VMS_MAXRSS);
- if (esal == NULL) _ckvmssts(SS$_INSFMEM);
-#endif
- rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
- rms_bind_fab_nam(dirfab, dirnam);
- rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
- rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
+ esal = PerlMem_malloc(VMS_MAXRSS);
+ if (esal == NULL)
+ _ckvmssts_noperl(SS$_INSFMEM);
+#endif
+ rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
+ rms_bind_fab_nam(dirfab, dirnam);
+ rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
+ rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
#ifdef NAM$M_NO_SHORT_UPCASE
- if (decc_efs_case_preserve)
- rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
+ if (decc_efs_case_preserve)
+ rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
#endif
- for (cp = trndir; *cp; cp++)
- if (islower(*cp)) { haslower = 1; break; }
- if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
- if ((dirfab.fab$l_sts == RMS$_DIR) ||
- (dirfab.fab$l_sts == RMS$_DNF) ||
- (dirfab.fab$l_sts == RMS$_PRV)) {
- rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
- sts = sys$parse(&dirfab) & STS$K_SUCCESS;
+ for (cp = trndir; *cp; cp++)
+ if (islower(*cp)) {
+ haslower = 1;
+ break;
+ }
+ sts = sys$parse(&dirfab);
+ if (!$VMS_STATUS_SUCCESS(sts)) {
+ if ((dirfab.fab$l_sts == RMS$_DIR) ||
+ (dirfab.fab$l_sts == RMS$_DNF) ||
+ (dirfab.fab$l_sts == RMS$_PRV)) {
+ rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
+ sts = sys$parse(&dirfab);
+ }
+ if (!$VMS_STATUS_SUCCESS(sts)) {
+ PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
+ PerlMem_free(trndir);
+ PerlMem_free(vmsdir);
+ set_errno(EVMSERR);
+ set_vaxc_errno(dirfab.fab$l_sts);
+ return NULL;
+ }
+ } else {
+ savnam = dirnam;
+ /* Does the file really exist? */
+ sts = sys$search(&dirfab);
+ if ($VMS_STATUS_SUCCESS(sts)) {
+ /* Yes; fake the fnb bits so we'll check type below */
+ 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;
+ } else {
+ int fab_sts;
+ fab_sts = dirfab.fab$l_sts;
+ sts = rms_free_search_context(&dirfab);
+ PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
+ PerlMem_free(trndir);
+ PerlMem_free(vmsdir);
+ set_errno(EVMSERR);
+ set_vaxc_errno(fab_sts);
+ return NULL;
+ }
+ }
}
- if (!sts) {
- PerlMem_free(esa);
- if (esal != NULL)
- PerlMem_free(esal);
- PerlMem_free(trndir);
- PerlMem_free(vmsdir);
- set_errno(EVMSERR);
- set_vaxc_errno(dirfab.fab$l_sts);
- return NULL;
+
+ /* Make sure we are using the right buffer */
+ if (esal != NULL) {
+ my_esa = esal;
+ my_esa_len = rms_nam_esll(dirnam);
+ } else {
+ my_esa = esa;
+ my_esa_len = rms_nam_esl(dirnam);
}
- }
- else {
- savnam = dirnam;
- /* Does the file really exist? */
- if (sys$search(&dirfab)& STS$K_SUCCESS) {
- /* Yes; fake the fnb bits so we'll check type below */
- 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;
- else {
- int fab_sts;
- fab_sts = dirfab.fab$l_sts;
- sts = rms_free_search_context(&dirfab);
- PerlMem_free(esa);
- if (esal != NULL)
- PerlMem_free(esal);
- PerlMem_free(trndir);
- PerlMem_free(vmsdir);
- set_errno(EVMSERR); set_vaxc_errno(fab_sts);
- return NULL;
- }
+ my_esa[my_esa_len] = '\0';
+ if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
+ cp1 = strchr(my_esa,']');
+ if (!cp1)
+ cp1 = strchr(my_esa,'>');
+ if (cp1) { /* Should always be true */
+ my_esa_len -= cp1 - my_esa - 1;
+ memmove(my_esa, cp1 + 1, my_esa_len);
+ }
}
- }
-
- /* Make sure we are using the right buffer */
- if (esal != NULL) {
- my_esa = esal;
- my_esa_len = rms_nam_esll(dirnam);
- } else {
- my_esa = esa;
- my_esa_len = rms_nam_esl(dirnam);
- }
- my_esa[my_esa_len] = '\0';
- if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
- cp1 = strchr(my_esa,']');
- if (!cp1) cp1 = strchr(my_esa,'>');
- if (cp1) { /* Should always be true */
- my_esa_len -= cp1 - my_esa - 1;
- memmove(my_esa, cp1 + 1, my_esa_len);
- }
- }
- if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
- /* Yep; check version while we're at it, if it's there. */
- cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
- if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
- /* Something other than .DIR[;1]. Bzzt. */
- sts = rms_free_search_context(&dirfab);
- PerlMem_free(esa);
- if (esal != NULL)
- PerlMem_free(esal);
- PerlMem_free(trndir);
- PerlMem_free(vmsdir);
- set_errno(ENOTDIR);
- set_vaxc_errno(RMS$_DIR);
- return NULL;
+ if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {
+ /* Was type specified? */
+ /* Yep; check version while we're at it, if it's there. */
+ cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
+ if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
+ /* Something other than .DIR[;1]. Bzzt. */
+ sts = rms_free_search_context(&dirfab);
+ PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
+ PerlMem_free(trndir);
+ PerlMem_free(vmsdir);
+ set_errno(ENOTDIR);
+ set_vaxc_errno(RMS$_DIR);
+ return NULL;
+ }
}
- }
- if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
- /* They provided at least the name; we added the type, if necessary, */
- if (buf) retspec = buf; /* in sys$parse() */
- else if (ts) Newx(retspec, my_esa_len + 1, char);
- else retspec = __fileify_retbuf;
- strcpy(retspec,my_esa);
- sts = rms_free_search_context(&dirfab);
- PerlMem_free(trndir);
- PerlMem_free(esa);
- if (esal != NULL)
- PerlMem_free(esal);
- PerlMem_free(vmsdir);
- return retspec;
- }
- if ((cp1 = strstr(esa,".][000000]")) != NULL) {
- for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
+ if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
+ /* They provided at least the name; we added the type,
+ * if necessary, in sys$parse() */
+ strcpy(buf, my_esa);
+ sts = rms_free_search_context(&dirfab);
+ PerlMem_free(trndir);
+ PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
+ PerlMem_free(vmsdir);
+ return buf;
+ }
+ if ((cp1 = strstr(esa,".][000000]")) != NULL) {
+ for (cp2 = cp1 + 9; *cp2; cp1++,cp2++)
+ *cp1 = *cp2;
+ *cp1 = '\0';
+ my_esa_len -= 9;
+ }
+ if ((cp1 = strrchr(my_esa,']')) == NULL)
+ cp1 = strrchr(my_esa,'>');
+ if (cp1 == NULL) { /* should never happen */
+ sts = rms_free_search_context(&dirfab);
+ PerlMem_free(trndir);
+ PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
+ PerlMem_free(vmsdir);
+ return NULL;
+ }
+ term = *cp1;
*cp1 = '\0';
- my_esa_len -= 9;
- }
- if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
- if (cp1 == NULL) { /* should never happen */
- sts = rms_free_search_context(&dirfab);
- PerlMem_free(trndir);
- PerlMem_free(esa);
- if (esal != NULL)
- PerlMem_free(esal);
- PerlMem_free(vmsdir);
- return NULL;
- }
- term = *cp1;
- *cp1 = '\0';
- retlen = strlen(my_esa);
- cp1 = strrchr(my_esa,'.');
- /* ODS-5 directory specifications can have extra "." in them. */
- /* Fix-me, can not scan EFS file specifications backwards */
- while (cp1 != NULL) {
- if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
- break;
- else {
- cp1--;
- while ((cp1 > my_esa) && (*cp1 != '.'))
- cp1--;
- }
- if (cp1 == my_esa)
- cp1 = NULL;
- }
+ retlen = strlen(my_esa);
+ cp1 = strrchr(my_esa,'.');
+ /* ODS-5 directory specifications can have extra "." in them. */
+ /* Fix-me, can not scan EFS file specifications backwards */
+ while (cp1 != NULL) {
+ if ((cp1-1 == my_esa) || (*(cp1-1) != '^')) {
+ break;
+ } else {
+ cp1--;
+ while ((cp1 > my_esa) && (*cp1 != '.'))
+ cp1--;
+ }
+ if (cp1 == my_esa)
+ cp1 = NULL;
+ }
- if ((cp1) != NULL) {
- /* There's more than one directory in the path. Just roll back. */
- *cp1 = term;
- if (buf) retspec = buf;
- else if (ts) Newx(retspec,retlen+7,char);
- else retspec = __fileify_retbuf;
- strcpy(retspec,my_esa);
- }
- else {
- if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
- /* Go back and expand rooted logical name */
- rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
+ if ((cp1) != NULL) {
+ /* There's more than one directory in the path.
+ * Just roll back. */
+ *cp1 = term;
+ strcpy(buf, my_esa);
+ } else {
+ if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
+ /* Go back and expand rooted logical name */
+ rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
#ifdef NAM$M_NO_SHORT_UPCASE
- if (decc_efs_case_preserve)
- rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
+ if (decc_efs_case_preserve)
+ rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
#endif
- if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
- sts = rms_free_search_context(&dirfab);
- PerlMem_free(esa);
- if (esal != NULL)
- PerlMem_free(esal);
- PerlMem_free(trndir);
- PerlMem_free(vmsdir);
- set_errno(EVMSERR);
- set_vaxc_errno(dirfab.fab$l_sts);
- return NULL;
- }
+ sts = sys$parse(&dirfab);
+ if (!$VMS_STATUS_SUCCESS(sts)) {
+ sts = rms_free_search_context(&dirfab);
+ PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
+ PerlMem_free(trndir);
+ PerlMem_free(vmsdir);
+ set_errno(EVMSERR);
+ set_vaxc_errno(dirfab.fab$l_sts);
+ return NULL;
+ }
- /* This changes the length of the string of course */
- if (esal != NULL) {
- my_esa_len = rms_nam_esll(dirnam);
- } else {
- my_esa_len = rms_nam_esl(dirnam);
- }
+ /* This changes the length of the string of course */
+ if (esal != NULL) {
+ my_esa_len = rms_nam_esll(dirnam);
+ } else {
+ my_esa_len = rms_nam_esl(dirnam);
+ }
- retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
- if (buf) retspec = buf;
- else if (ts) Newx(retspec,retlen+16,char);
- else retspec = __fileify_retbuf;
- cp1 = strstr(my_esa,"][");
- if (!cp1) cp1 = strstr(my_esa,"]<");
- dirlen = cp1 - my_esa;
- memcpy(retspec,my_esa,dirlen);
- if (!strncmp(cp1+2,"000000]",7)) {
- retspec[dirlen-1] = '\0';
- /* fix-me Not full ODS-5, just extra dots in directories for now */
- cp1 = retspec + dirlen - 1;
- while (cp1 > retspec)
- {
- if (*cp1 == '[')
- break;
- if (*cp1 == '.') {
- if (*(cp1-1) != '^')
- break;
- }
- cp1--;
- }
- if (*cp1 == '.') *cp1 = ']';
- else {
- memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
- memmove(cp1+1,"000000]",7);
- }
- }
- else {
- memmove(retspec+dirlen,cp1+2,retlen-dirlen);
- retspec[retlen] = '\0';
- /* Convert last '.' to ']' */
- cp1 = retspec+retlen-1;
- while (*cp != '[') {
- cp1--;
- if (*cp1 == '.') {
- /* Do not trip on extra dots in ODS-5 directories */
- if ((cp1 == retspec) || (*(cp1-1) != '^'))
- break;
- }
- }
- if (*cp1 == '.') *cp1 = ']';
- else {
- memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
- memmove(cp1+1,"000000]",7);
+ retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
+ cp1 = strstr(my_esa,"][");
+ if (!cp1)
+ cp1 = strstr(my_esa,"]<");
+ dirlen = cp1 - my_esa;
+ memcpy(buf, my_esa, dirlen);
+ if (!strncmp(cp1+2,"000000]",7)) {
+ buf[dirlen-1] = '\0';
+ /* fix-me Not full ODS-5, just extra dots in directories
+ * for now */
+ cp1 = buf + dirlen - 1;
+ while (cp1 > buf) {
+ if (*cp1 == '[')
+ break;
+ if (*cp1 == '.') {
+ if (*(cp1-1) != '^')
+ break;
+ }
+ cp1--;
+ }
+ if (*cp1 == '.') {
+ *cp1 = ']';
+ } else {
+ memmove(cp1+8,cp1+1, buf+dirlen-cp1);
+ memmove(cp1+1,"000000]",7);
+ }
+ } else {
+ memmove(buf+dirlen,cp1+2,retlen-dirlen);
+ buf[retlen] = '\0';
+ /* Convert last '.' to ']' */
+ cp1 = buf+retlen-1;
+ while (*cp != '[') {
+ cp1--;
+ if (*cp1 == '.') {
+ /* Do not trip on extra dots in ODS-5 directories
*/
+ if ((cp1 == buf) || (*(cp1-1) != '^'))
+ break;
+ }
+ }
+ if (*cp1 == '.') {
+ *cp1 = ']';
+ } else {
+ memmove(cp1+8,cp1+1, buf+dirlen-cp1);
+ memmove(cp1+1,"000000]",7);
+ }
+ }
+ } 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);
}
- }
}
- else { /* This is a top-level dir. Add the MFD to the path. */
- if (buf) retspec = buf;
- else if (ts) Newx(retspec,retlen+16,char);
- else retspec = __fileify_retbuf;
- cp1 = my_esa;
- cp2 = retspec;
- while ((*cp1 != ':') && (*cp1 != '\0')) *(cp2++) = *(cp1++);
- strcpy(cp2,":[000000]");
- cp1 += 2;
- strcpy(cp2+9,cp1);
- }
- }
- sts = rms_free_search_context(&dirfab);
- /* We've set up the string up through the filename. Add the
- type and version, and we're done. */
- strcat(retspec,".DIR;1");
-
- /* $PARSE may have upcased filespec, so convert output to lower
- * case if input contained any lowercase characters. */
- if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
- PerlMem_free(trndir);
- PerlMem_free(esa);
- if (esal != NULL)
- PerlMem_free(esal);
- PerlMem_free(vmsdir);
- return retspec;
+ sts = rms_free_search_context(&dirfab);
+ /* We've set up the string up through the filename. Add the
+ * type and version, and we're done. */
+ strcat(buf, ".DIR;1");
+
+ /* $PARSE may have upcased filespec, so convert output to lower
+ * case if input contained any lowercase characters. */
+ if (haslower && !decc_efs_case_preserve)
+ __mystrtolower(buf);
+ PerlMem_free(trndir);
+ PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
+ PerlMem_free(vmsdir);
+ return buf;
}
+}
+
+
+/*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
+static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int
*utf8_fl)
+{
+ static char __fileify_retbuf[VMS_MAXRSS];
+ char * fileified, *ret_spec, *ret_buf;
+
+ fileified = NULL;
+ ret_buf = buf;
+ if (ret_buf == NULL) {
+ if (ts) {
+ Newx(fileified, VMS_MAXRSS, char);
+ if (fileified == NULL)
+ _ckvmssts(SS$_INSFMEM);
+ ret_buf = fileified;
+ } else {
+ ret_buf = __fileify_retbuf;
+ }
+ }
+
+ ret_spec = int_fileify_dirspec(dir, ret_buf, utf8_fl);
+
+ if (ret_spec == NULL) {
+ /* Cleanup on isle 5, if this is thread specific we need to deallocate
*/
+ if (fileified)
+ Safefree(fileified);
+ }
+
+ return ret_spec;
+
} /* end of do_fileify_dirspec() */
/*}}}*/
/* External entry points */
