diff options
| -rw-r--r-- | vms/ext/filespec.t | 181 | ||||
| -rw-r--r-- | vms/vms.c | 632 |
2 files changed, 494 insertions, 319 deletions
diff --git a/vms/ext/filespec.t b/vms/ext/filespec.t index 3415400b21..11b6698116 100644 --- a/vms/ext/filespec.t +++ b/vms/ext/filespec.t @@ -15,13 +15,46 @@ foreach (<DATA>) { require './test.pl'; plan(tests => scalar(2*@tests)+6); +my $vms_unix_rpt; +my $vms_efs; + +if ($^O eq 'VMS') { + if (eval 'require VMS::Feature') { + $vms_unix_rpt = VMS::Feature::current("filename_unix_report"); + $vms_efs = VMS::Feature::current("efs_charset"); + } else { + my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; + my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || ''; + $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i; + $vms_efs = $efs_charset =~ /^[ET1]/i; + } +} + + + foreach $test (@tests) { - ($arg,$func,$expect) = split(/\s+/,$test); + ($arg,$func,$expect2,$expect5) = split(/\s+/,$test); + + $expect2 = undef if $expect2 eq 'undef'; + $expect2 = undef if $expect2 eq '^'; + $expect5 = undef if $expect5 eq 'undef'; + $expect5 = $expect2 if $expect5 eq '^'; + + if ($vms_efs) { + $expect = $expect5; + } + else { + $expect = $expect2; + } - $expect = undef if $expect eq 'undef'; $rslt = eval "$func('$arg')"; is($@, '', "eval ${func}('$arg')"); - is(lc($rslt), lc($expect), "${func}('$arg'): '$rslt'"); + if ($expect ne '^*') { + is(lc($rslt), lc($expect), "${func}('$arg'): '$rslt'"); + } + else { + is(lc($rslt), lc($expect), "${func}('$arg'): '$rslt' # TODO fix ODS-5 test"); + } } $defwarn = <<'EOW'; @@ -49,84 +82,88 @@ __DATA__ # lots of underscores used to minimize collision with existing logical names # Basic VMS to Unix filespecs -__some_:[__where_.__over_]__the_.__rainbow_ unixify /__some_/__where_/__over_/__the_.__rainbow_ -[.__some_.__where_.__over_]__the_.__rainbow_ unixify __some_/__where_/__over_/__the_.__rainbow_ -[-.__some_.__where_.__over_]__the_.__rainbow_ unixify ../__some_/__where_/__over_/__the_.__rainbow_ -[.__some_.--.__where_.__over_]__the_.__rainbow_ unixify __some_/../../__where_/__over_/__the_.__rainbow_ -[.__some_...__where_.__over_]__the_.__rainbow_ unixify __some_/.../__where_/__over_/__the_.__rainbow_ -[...__some_.__where_.__over_]__the_.__rainbow_ unixify .../__some_/__where_/__over_/__the_.__rainbow_ -[.__some_.__where_.__over_...]__the_.__rainbow_ unixify __some_/__where_/__over_/.../__the_.__rainbow_ -[.__some_.__where_.__over_...] unixify __some_/__where_/__over_/.../ -[.__some_.__where_.__over_.-] unixify __some_/__where_/__over_/../ -[] unixify ./ -[-] unixify ../ -[--] unixify ../../ -[...] unixify .../ -__lyrics_:[__are_.__very_^.__sappy_]__but_^.__rhymes_^.__are_.__true_ unixify /__lyrics_/__are_/__very_.__sappy_/__but_.__rhymes_.__are_.__true_ +__some_:[__where_.__over_]__the_.__rainbow_ unixify /__some_/__where_/__over_/__the_.__rainbow_ ^ +[.__some_.__where_.__over_]__the_.__rainbow_ unixify __some_/__where_/__over_/__the_.__rainbow_ ^ +[-.__some_.__where_.__over_]__the_.__rainbow_ unixify ../__some_/__where_/__over_/__the_.__rainbow_ ^ +[.__some_.--.__where_.__over_]__the_.__rainbow_ unixify __some_/../../__where_/__over_/__the_.__rainbow_ ^ +[.__some_...__where_.__over_]__the_.__rainbow_ unixify __some_/.../__where_/__over_/__the_.__rainbow_ ^* +[...__some_.__where_.__over_]__the_.__rainbow_ unixify .../__some_/__where_/__over_/__the_.__rainbow_ ^* +[.__some_.__where_.__over_...]__the_.__rainbow_ unixify __some_/__where_/__over_/.../__the_.__rainbow_ ^* +[.__some_.__where_.__over_...] unixify __some_/__where_/__over_/.../ ^* +[.__some_.__where_.__over_.-] unixify __some_/__where_/__over_/../ ^ +[] unixify ./ ^ +[-] unixify ../ ^ +[--] unixify ../../ ^ +[...] unixify .../ ^* +[.$(macro)] unixify $(macro)/ ^ # and back again -/__some_/__where_/__over_/__the_.__rainbow_ vmsify __some_:[__where_.__over_]__the_.__rainbow_ -__some_/__where_/__over_/__the_.__rainbow_ vmsify [.__some_.__where_.__over_]__the_.__rainbow_ -../__some_/__where_/__over_/__the_.__rainbow_ vmsify [-.__some_.__where_.__over_]__the_.__rainbow_ -__some_/../../__where_/__over_/__the_.__rainbow_ vmsify [-.__where_.__over_]__the_.__rainbow_ -.../__some_/__where_/__over_/__the_.__rainbow_ vmsify [...__some_.__where_.__over_]__the_.__rainbow_ -__some_/.../__where_/__over_/__the_.__rainbow_ vmsify [.__some_...__where_.__over_]__the_.__rainbow_ -/__some_/.../__where_/__over_/__the_.__rainbow_ vmsify __some_:[...__where_.__over_]__the_.__rainbow_ -__some_/__where_/... vmsify [.__some_.__where_...] -/__where_/... vmsify __where_:[...] -. vmsify [] -.. vmsify [-] -../.. vmsify [--] -.../ vmsify [...] -/ vmsify sys$disk:[000000] +/__some_/__where_/__over_/__the_.__rainbow_ vmsify __some_:[__where_.__over_]__the_.__rainbow_ ^ +__some_/__where_/__over_/__the_.__rainbow_ vmsify [.__some_.__where_.__over_]__the_.__rainbow_ ^ +../__some_/__where_/__over_/__the_.__rainbow_ vmsify [-.__some_.__where_.__over_]__the_.__rainbow_ ^ +__some_/../../__where_/__over_/__the_.__rainbow_ vmsify [-.__where_.__over_]__the_.__rainbow_ [.__some_.--.__where_.__over_]__the_.__rainbow_ +.../__some_/__where_/__over_/__the_.__rainbow_ vmsify [...__some_.__where_.__over_]__the_.__rainbow_ [.^.^.^..__some_.__where_.__over_]__the_.__rainbow_ +__some_/.../__where_/__over_/__the_.__rainbow_ vmsify [.__some_...__where_.__over_]__the_.__rainbow_ [.__some_.^.^.^..__where_.__over_]__the_.__rainbow_ +/__some_/.../__where_/__over_/__the_.__rainbow_ vmsify __some_:[...__where_.__over_]__the_.__rainbow_ __some_:[^.^.^..__where_.__over_]__the_.__rainbow_ +__some_/__where_/... vmsify [.__some_.__where_...] [.__some_.__where_]^.^.^.. +/__where_/... vmsify __where_:[...] __where_:[]^.^.^.. +. vmsify [] ^ +.. vmsify [-] ^ +../.. vmsify [--] ^ +.../ vmsify [...] [.^.^.^.] +# Can not predict what / will translate to. +/ vmsify sys$disk:[000000] ^* +./$(macro)/ vmsify [.$(macro)] ^ +./$(macro) vmsify []$(macro) ^ +./$(m+ vmsify []$^(m^+ []$^(m^+. # Fileifying directory specs -__down_:[__the_.__garden_.__path_] fileify __down_:[__the_.__garden_]__path_.dir;1 -[.__down_.__the_.__garden_.__path_] fileify [.__down_.__the_.__garden_]__path_.dir;1 -/__down_/__the_/__garden_/__path_ fileify /__down_/__the_/__garden_/__path_.dir;1 -/__down_/__the_/__garden_/__path_/ fileify /__down_/__the_/__garden_/__path_.dir;1 -__down_/__the_/__garden_/__path_ fileify __down_/__the_/__garden_/__path_.dir;1 -__down_:[__the_.__garden_]__path_ fileify __down_:[__the_.__garden_]__path_.dir;1 -__down_:[__the_.__garden_]__path_. fileify # N.B. trailing . ==> null type -__down_:[__the_]__garden_.__path_ fileify undef -/__down_/__the_/__garden_/__path_. fileify # N.B. trailing . ==> null type -/__down_/__the_/__garden_.__path_ fileify undef +__down_:[__the_.__garden_.__path_] fileify __down_:[__the_.__garden_]__path_.dir;1 ^ +[.__down_.__the_.__garden_.__path_] fileify [.__down_.__the_.__garden_]__path_.dir;1 ^ +/__down_/__the_/__garden_/__path_ fileify /__down_/__the_/__garden_/__path_.dir;1 /__down_/__the_/__garden_/__path_ +/__down_/__the_/__garden_/__path_/ fileify /__down_/__the_/__garden_/__path_.dir;1 /__down_/__the_/__garden_/__path_ +__down_/__the_/__garden_/__path_ fileify __down_/__the_/__garden_/__path_.dir;1 __down_/__the_/__garden_/__path_ +__down_:[__the_.__garden_]__path_ fileify __down_:[__the_.__garden_]__path_.dir;1 ^ +__down_:[__the_.__garden_]__path_. fileify ^ __down_:[__the_.__garden_]__path_^..dir;1 # N.B. trailing . ==> null type +__down_:[__the_]__garden_.__path_ fileify ^ __down_:[__the_]__garden_^.__path_.dir;1 #undef +/__down_/__the_/__garden_/__path_. fileify ^ /__down_/__the_/__garden_/__path_. # N.B. trailing . ==> null type +/__down_/__the_/__garden_.__path_ fileify ^ /__down_/__the_/__garden_.__path_ # and pathifying them -__down_:[__the_.__garden_]__path_.dir;1 pathify __down_:[__the_.__garden_.__path_] -[.__down_.__the_.__garden_]__path_.dir pathify [.__down_.__the_.__garden_.__path_] -/__down_/__the_/__garden_/__path_.dir pathify /__down_/__the_/__garden_/__path_/ -__down_/__the_/__garden_/__path_.dir pathify __down_/__the_/__garden_/__path_/ -__down_:[__the_.__garden_]__path_ pathify __down_:[__the_.__garden_.__path_] -__down_:[__the_.__garden_]__path_. pathify # N.B. trailing . ==> null type -__down_:[__the_]__garden_.__path_ pathify undef -/__down_/__the_/__garden_/__path_. pathify # N.B. trailing . ==> null type -/__down_/__the_/__garden_.__path_ pathify undef -__down_:[__the_.__garden_]__path_.dir;2 pathify #N.B. ;2 -__path_ pathify __path_/ -/__down_/__the_/__garden_/. pathify /__down_/__the_/__garden_/./ -/__down_/__the_/__garden_/.. pathify /__down_/__the_/__garden_/../ -/__down_/__the_/__garden_/... pathify /__down_/__the_/__garden_/.../ -__path_.notdir pathify undef +__down_:[__the_.__garden_]__path_.dir;1 pathify __down_:[__the_.__garden_.__path_] ^ +[.__down_.__the_.__garden_]__path_.dir pathify [.__down_.__the_.__garden_.__path_] ^ +/__down_/__the_/__garden_/__path_.dir pathify /__down_/__the_/__garden_/__path_/ ^ +__down_/__the_/__garden_/__path_.dir pathify __down_/__the_/__garden_/__path_/ ^ +__down_:[__the_.__garden_]__path_ pathify __down_:[__the_.__garden_.__path_] ^ +__down_:[__the_.__garden_]__path_. pathify ^ __down_:[__the.__garden_.__path_^.] # N.B. trailing . ==> null type +__down_:[__the_]__garden_.__path_ pathify ^ __down_:[__the_.__garden_^.__path_] # undef +/__down_/__the_/__garden_/__path_. pathify /__down_/__the_/__garden_/__path__/ /__down_/__the_/__garden_/__path_./ # N.B. trailing . ==> null type +/__down_/__the_/__garden_.__path_ pathify /__down_/__the_/__garden____path_/ /__down_/__the_/__garden_.__path_/ +__down_:[__the_.__garden_]__path_.dir;2 pathify ^ #N.B. ;2 +__path_ pathify __path_/ ^ +/__down_/__the_/__garden_/. pathify /__down_/__the_/__garden_/./ ^ +/__down_/__the_/__garden_/.. pathify /__down_/__the_/__garden_/../ ^ +/__down_/__the_/__garden_/... pathify /__down_/__the_/__garden_/.../ ^ +__path_.notdir pathify __path__notdir/ __path_.notdir/ # Both VMS/Unix and file/path conversions -__down_:[__the_.__garden_]__path_.dir;1 unixpath /__down_/__the_/__garden_/__path_/ -/__down_/__the_/__garden_/__path_ vmspath __down_:[__the_.__garden_.__path_] -__down_:[__the_.__garden_.__path_] unixpath /__down_/__the_/__garden_/__path_/ -__down_:[__the_.__garden_.__path_...] unixpath /__down_/__the_/__garden_/__path_/.../ -/__down_/__the_/__garden_/__path_.dir vmspath __down_:[__the_.__garden_.__path_] -[.__down_.__the_.__garden_]__path_.dir unixpath __down_/__the_/__garden_/__path_/ -__down_/__the_/__garden_/__path_ vmspath [.__down_.__the_.__garden_.__path_] -__path_ vmspath [.__path_] -/ vmspath sys$disk:[000000] +__down_:[__the_.__garden_]__path_.dir;1 unixpath /__down_/__the_/__garden_/__path_/ ^ +/__down_/__the_/__garden_/__path_ vmspath __down_:[__the_.__garden_.__path_] ^ +__down_:[__the_.__garden_.__path_] unixpath /__down_/__the_/__garden_/__path_/ ^ +__down_:[__the_.__garden_.__path_...] unixpath /__down_/__the_/__garden_/__path_/.../ # Not translatable +/__down_/__the_/__garden_/__path_.dir vmspath __down_:[__the_.__garden_.__path_] ^ +[.__down_.__the_.__garden_]__path_.dir unixpath __down_/__the_/__garden_/__path_/ ^ +__down_/__the_/__garden_/__path_ vmspath [.__down_.__the_.__garden_.__path_] ^ +__path_ vmspath [.__path_] ^ +/ vmspath sys$disk:[000000] ^* # Redundant characters in Unix paths -//__some_/__where_//__over_/../__the_.__rainbow_ vmsify __some_:[__where_]__the_.__rainbow_ -/__some_/__where_//__over_/./__the_.__rainbow_ vmsify __some_:[__where_.__over_]__the_.__rainbow_ -..//../ vmspath [--] -./././ vmspath [] -./../. vmsify [-] +//__some_/__where_//__over_/../__the_.__rainbow_ vmsify __some_:[__where_]__the_.__rainbow_ __some_:[__where_.__over_.-]__the_.__rainbow_ +/__some_/__where_//__over_/./__the_.__rainbow_ vmsify __some_:[__where_.__over_]__the_.__rainbow_ ^ +..//../ vmspath [--] ^ +./././ vmspath [] ^ +./../. vmsify [-] ^ # Our override of File::Spec->canonpath can do some strange things -__dev:[__dir.000000]__foo File::Spec->canonpath __dev:[__dir.000000]__foo -__dev:[__dir.][000000]__foo File::Spec->canonpath __dev:[__dir]__foo +__dev:[__dir.000000]__foo File::Spec->canonpath __dev:[__dir.000000]__foo ^ +__dev:[__dir.][000000]__foo File::Spec->canonpath __dev:[__dir]__foo ^ @@ -6517,281 +6517,419 @@ char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl) char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl) { return do_fileify_dirspec(dir,buf,1,utf8_fl); } -/*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/ -static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl) +static char * int_pathify_dirspec_simple(const char * dir, char * buf, + char * v_spec, int v_len, char * r_spec, int r_len, + char * d_spec, int d_len, char * n_spec, int n_len, + char * e_spec, int e_len, char * vs_spec, int vs_len) { + + /* VMS specification - Try to do this the simple way */ + if ((v_len + r_len > 0) || (d_len > 0)) { + int is_dir; + + /* No name or extension component, already a directory */ + if ((n_len + e_len + vs_len) == 0) { + strcpy(buf, dir); + return buf; + } + + /* Special case, we may get [.foo]bar instead of [.foo]bar.dir */ + /* This results from catfile() being used instead of catdir() */ + /* So even though it should not work, we need to allow it */ + + /* If this is .DIR;1 then do a simple conversion */ + is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len); + if (is_dir || (e_len == 0) && (d_len > 0)) { + int len; + len = v_len + r_len + d_len - 1; + char dclose = d_spec[d_len - 1]; + strncpy(buf, dir, len); + buf[len] = '.'; + len++; + strncpy(&buf[len], n_spec, n_len); + len += n_len; + buf[len] = dclose; + buf[len + 1] = '\0'; + return buf; + } + +#ifdef HAS_SYMLINK + else if (d_len > 0) { + /* In the olden days, a directory needed to have a .DIR */ + /* extension to be a valid directory, but now it could */ + /* be a symbolic link */ + int len; + len = v_len + r_len + d_len - 1; + char dclose = d_spec[d_len - 1]; + strncpy(buf, dir, len); + buf[len] = '.'; + len++; + strncpy(&buf[len], n_spec, n_len); + len += n_len; + if (e_len > 0) { + if (decc_efs_charset) { + buf[len] = '^'; + len++; + strncpy(&buf[len], e_spec, e_len); + len += e_len; + } else { + set_vaxc_errno(RMS$_DIR); + set_errno(ENOTDIR); + return NULL; + } + } + buf[len] = dclose; + buf[len + 1] = '\0'; + return buf; + } +#else + else { + set_vaxc_errno(RMS$_DIR); + set_errno(ENOTDIR); + return NULL; + } +#endif + } + set_vaxc_errno(RMS$_DIR); + set_errno(ENOTDIR); + return NULL; +} + + +/* Internal routine to make sure or convert a directory to be in a */ +/* path specification. No utf8 flag because it is not changed or used */ +static char *int_pathify_dirspec(const char *dir, char *buf) { - static char __pathify_retbuf[VMS_MAXRSS]; - unsigned long int retlen; - char *retpath, *cp1, *cp2, *trndir; + 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; + char * exp_spec, *ret_spec; + char * trndir; unsigned short int trnlnm_iter_count; STRLEN trnlen; - int sts; - if (utf8_fl != NULL) - *utf8_fl = 0; + int need_to_lower; + + if (vms_debug_fileify) { + if (dir == NULL) + fprintf(stderr, "int_pathify_dirspec: dir = NULL\n"); + else + fprintf(stderr, "int_pathify_dirspec: dir = %s\n", dir); + } + + /* We may need to lower case the result if we translated */ + /* a logical name or got the current working directory */ + need_to_lower = 0; if (!dir || !*dir) { - set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL; + set_errno(EINVAL); + set_vaxc_errno(SS$_BADPARAM); + return NULL; } trndir = PerlMem_malloc(VMS_MAXRSS); - if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM); - if (*dir) strcpy(trndir,dir); - else getcwd(trndir,VMS_MAXRSS - 1); + if (trndir == NULL) + _ckvmssts_noperl(SS$_INSFMEM); + /* If no directory specified use the current default */ + if (*dir) + strcpy(trndir, dir); + else { + getcwd(trndir, VMS_MAXRSS - 1); + need_to_lower = 1; + } + + /* now deal with bare names that could be logical names */ trnlnm_iter_count = 0; while (!strpbrk(trndir,"/]:>") && !no_translate_barewords - && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) { - trnlnm_iter_count++; - if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break; - trnlen = strlen(trndir); - - /* Trap simple rooted lnms, and return lnm:[000000] */ - if (!strcmp(trndir+trnlen-2,".]")) { - if (buf) retpath = buf; - else if (ts) Newx(retpath,strlen(dir)+10,char); - else retpath = __pathify_retbuf; - strcpy(retpath,dir); - strcat(retpath,":[000000]"); - PerlMem_free(trndir); - return retpath; - } + && simple_trnlnm(trndir, trndir, VMS_MAXRSS)) { + trnlnm_iter_count++; + need_to_lower = 1; + if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) + break; + trnlen = strlen(trndir); + + /* Trap simple rooted lnms, and return lnm:[000000] */ + if (!strcmp(trndir+trnlen-2,".]")) { + strcpy(buf, dir); + strcat(buf, ":[000000]"); + PerlMem_free(trndir); + + if (vms_debug_fileify) { + fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf); + } + return buf; + } } - /* At this point we do not work with *dir, but the copy in - * *trndir that is modifiable. - */ + /* At this point we do not work with *dir, but the copy in *trndir */ - if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */ - if (*trndir == '.' && (*(trndir+1) == '\0' || - (*(trndir+1) == '.' && *(trndir+2) == '\0'))) - retlen = 2 + (*(trndir+1) != '\0'); - else { - if ( !(cp1 = strrchr(trndir,'/')) && - !(cp1 = strrchr(trndir,']')) && - !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir; - if ((cp2 = strchr(cp1,'.')) != NULL && - (*(cp2-1) != '/' || /* Trailing '.', '..', */ - !(*(cp2+1) == '\0' || /* or '...' are dirs. */ - (*(cp2+1) == '.' && *(cp2+2) == '\0') || - (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) { - int ver; char *cp3; + if (need_to_lower && !decc_efs_case_preserve) { + /* Legacy mode, lower case the returned value */ + __mystrtolower(trndir); + } - /* 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); - 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); - set_errno(ENOTDIR); - set_vaxc_errno(RMS$_DIR); - return NULL; - } - } - retlen = cp2 - trndir + 1; - } - else { /* No file type present. Treat the filename as a directory. */ - retlen = strlen(trndir) + 1; + + /* Some special cases, '..', '.' */ + sts = 0; + if ((trndir[0] == '.') && ((trndir[1] == '.') || (trndir[1] == '\0'))) { + /* Force UNIX filespec */ + sts = 1; + + } else { + /* Is this Unix or VMS format? */ + sts = vms_split_path(trndir, &v_spec, &v_len, &r_spec, &r_len, + &d_spec, &d_len, &n_spec, &n_len, &e_spec, + &e_len, &vs_spec, &vs_len); + if (sts == 0) { + + /* Just a filename? */ + if ((v_len + r_len + d_len) == 0) { + + /* Now we have a problem, this could be Unix or VMS */ + /* We have to guess. .DIR usually means VMS */ + + /* In UNIX report mode, the .DIR extension is removed */ + /* if one shows up, it is for a non-directory or a directory */ + /* in EFS charset mode */ + + /* So if we are in Unix report mode, assume that this */ + /* is a relative Unix directory specification */ + + sts = 1; + if (!decc_filename_unix_report && decc_efs_charset) { + int is_dir; + is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len); + + if (is_dir) { + /* Traditional mode, assume .DIR is directory */ + buf[0] = '['; + buf[1] = '.'; + strncpy(&buf[2], n_spec, n_len); + buf[n_len + 2] = ']'; + buf[n_len + 3] = '\0'; + PerlMem_free(trndir); + if (vms_debug_fileify) { + fprintf(stderr, + "int_pathify_dirspec: buf = %s\n", + buf); + } + return buf; + } + } + } } - } - if (buf) retpath = buf; - else if (ts) Newx(retpath,retlen+1,char); - else retpath = __pathify_retbuf; - strncpy(retpath, trndir, retlen-1); - if (retpath[retlen-2] != '/') { /* If the path doesn't already end */ - retpath[retlen-1] = '/'; /* with '/', add it. */ - retpath[retlen] = '\0'; - } - else retpath[retlen-1] = '\0'; } - else { /* VMS-style directory spec */ - char *esa, *esal, *cp; - char *my_esa; - int my_esa_len; - unsigned long int sts, cmplen, haslower; - struct FAB dirfab = cc$rms_fab; - int dirlen; - rms_setup_nam(savnam); - rms_setup_nam(dirnam); + if (sts == 0) { + ret_spec = int_pathify_dirspec_simple(trndir, buf, + v_spec, v_len, r_spec, r_len, + d_spec, d_len, n_spec, n_len, + e_spec, e_len, vs_spec, vs_len); - /* If we've got an explicit filename, we can just shuffle the string. */ - if ( ( (cp1 = strrchr(trndir,']')) != NULL || - (cp1 = strrchr(trndir,'>')) != NULL ) && *(cp1+1)) { - if ((cp2 = strchr(cp1,'.')) != NULL) { - int ver; char *cp3; - 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); - 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); - set_errno(ENOTDIR); - set_vaxc_errno(RMS$_DIR); - return NULL; - } - } + if (ret_spec != NULL) { + PerlMem_free(trndir); + if (vms_debug_fileify) { + fprintf(stderr, + "int_pathify_dirspec: ret_spec = %s\n", ret_spec); + } + return ret_spec; } - else { /* No file type, so just draw name into directory part */ - for (cp2 = cp1; *cp2; cp2++) ; + + /* Simple way did not work, which means that a logical name */ + /* was present for the directory specification. */ + /* Need to use an rmsexpand variant to decode it completely */ + exp_spec = PerlMem_malloc(VMS_MAXRSS); + if (exp_spec == NULL) + _ckvmssts_noperl(SS$_INSFMEM); + + ret_spec = int_rmsexpand_vms(trndir, exp_spec, PERL_RMSEXPAND_M_LONG); + if (ret_spec != NULL) { + sts = vms_split_path(exp_spec, &v_spec, &v_len, + &r_spec, &r_len, &d_spec, &d_len, + &n_spec, &n_len, &e_spec, + &e_len, &vs_spec, &vs_len); + if (sts == 0) { + ret_spec = int_pathify_dirspec_simple( + exp_spec, buf, v_spec, v_len, r_spec, r_len, + d_spec, d_len, n_spec, n_len, + e_spec, e_len, vs_spec, vs_len); + + if ((ret_spec != NULL) && (!decc_efs_case_preserve)) { + /* Legacy mode, lower case the returned value */ + __mystrtolower(ret_spec); + } + } else { + set_vaxc_errno(RMS$_DIR); + set_errno(ENOTDIR); + ret_spec = NULL; + } } - *cp2 = *cp1; - *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */ - *cp1 = '.'; - /* We've now got a VMS 'path'; fall through */ - } + PerlMem_free(exp_spec); + PerlMem_free(trndir); + if (vms_debug_fileify) { + if (ret_spec == NULL) + fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n"); + else + fprintf(stderr, + "int_pathify_dirspec: ret_spec = %s\n", ret_spec); + } + return ret_spec; - dirlen = strlen(trndir); - if (trndir[dirlen-1] == ']' || - trndir[dirlen-1] == '>' || - trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */ - if (buf) retpath = buf; - else if (ts) Newx(retpath,strlen(trndir)+1,char); - else retpath = __pathify_retbuf; - strcpy(retpath,trndir); - PerlMem_free(trndir); - return retpath; - } - rms_set_fna(dirfab, dirnam, trndir, dirlen); - esa = PerlMem_malloc(VMS_MAXRSS); - 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_noperl(SS$_INSFMEM); -#endif - rms_set_dna(dirfab, dirnam, ".DIR;1", 6); - rms_bind_fab_nam(dirfab, dirnam); - 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); -#endif + } else { + /* Unix specification, Could be trivial conversion */ + STRLEN dir_len; + dir_len = strlen(trndir); + + /* If the extended file character set is in effect */ + /* then pathify is simple */ + + if (!decc_efs_charset) { + /* Have to deal with traiing '.dir' or extra '.' */ + /* that should not be there in legacy mode, but is */ + + char * lastdot; + char * lastslash; + int is_dir; + + lastslash = strrchr(trndir, '/'); + if (lastslash == NULL) + lastslash = trndir; + else + lastslash++; + + lastdot = NULL; + + /* '..' or '.' are valid directory components */ + is_dir = 0; + if (lastslash[0] == '.') { + if (lastslash[1] == '\0') { + is_dir = 1; + } else if (lastslash[1] == '.') { + if (lastslash[2] == '\0') { + is_dir = 1; + } else { + /* And finally allow '...' */ + if ((lastslash[2] == '.') && (lastslash[3] == '\0')) { + is_dir = 1; + } + } + } + } - for (cp = trndir; *cp; cp++) - if (islower(*cp)) { haslower = 1; break; } + if (!is_dir) { + lastdot = strrchr(lastslash, '.'); + } + if (lastdot != NULL) { + STRLEN e_len; - if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) { - if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) { - rms_set_nam_nop(dirnam, NAM$M_SYNCHK); - sts = sys$parse(&dirfab) & STS$K_SUCCESS; + /* '.dir' is discarded, and any other '.' is invalid */ + e_len = strlen(lastdot); + + is_dir = is_dir_ext(lastdot, e_len, NULL, 0); + + if (is_dir) { + dir_len = dir_len - 4; + + } + } } - if (!sts) { - PerlMem_free(trndir); - PerlMem_free(esa); - if (esal != NULL) - PerlMem_free(esal); - set_errno(EVMSERR); - set_vaxc_errno(dirfab.fab$l_sts); - return NULL; + + strcpy(buf, trndir); + if (buf[dir_len - 1] != '/') { + buf[dir_len] = '/'; + buf[dir_len + 1] = '\0'; } - } - else { - savnam = dirnam; - /* Does the file really exist? */ - if (!(sys$search(&dirfab)&STS$K_SUCCESS)) { - if (dirfab.fab$l_sts != RMS$_FNF) { - int sts1; - sts1 = rms_free_search_context(&dirfab); - PerlMem_free(trndir); - PerlMem_free(esa); - if (esal != NULL) - PerlMem_free(esal); - set_errno(EVMSERR); - set_vaxc_errno(dirfab.fab$l_sts); - return NULL; - } - dirnam = savnam; /* No; just work with potential name */ + + /* Under ODS-2 rules, '.' becomes '_', so fix it up */ + if (!decc_efs_charset) { + int dir_start = 0; + char * str = buf; + if (str[0] == '.') { + char * dots = str; + int cnt = 1; + while ((dots[cnt] == '.') && (cnt < 3)) + cnt++; + if (cnt <= 3) { + if ((dots[cnt] == '\0') || (dots[cnt] == '/')) { + dir_start = 1; + str += cnt; + } + } + } + for (; *str; ++str) { + while (*str == '/') { + dir_start = 1; + *str++; + } + if (dir_start) { + + /* Have to skip up to three dots which could be */ + /* directories, 3 dots being a VMS extension for Perl */ + char * dots = str; + int cnt = 0; + while ((dots[cnt] == '.') && (cnt < 3)) { + cnt++; + } + if (dots[cnt] == '\0') + break; + if ((cnt > 1) && (dots[cnt] != '/')) { + dir_start = 0; + } else { + str += cnt; + } + + /* too many dots? */ + if ((cnt == 0) || (cnt > 3)) { + dir_start = 0; + } + } + if (!dir_start && (*str == '.')) { + *str = '_'; + } + } } - } - 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)) { - int sts2; - /* Something other than .DIR[;1]. Bzzt. */ - sts2 = rms_free_search_context(&dirfab); - PerlMem_free(trndir); - PerlMem_free(esa); - if (esal != NULL) - PerlMem_free(esal); - set_errno(ENOTDIR); - set_vaxc_errno(RMS$_DIR); - return NULL; + PerlMem_free(trndir); + ret_spec = buf; + if (vms_debug_fileify) { + if (ret_spec == NULL) + fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n"); + else + fprintf(stderr, + "int_pathify_dirspec: ret_spec = %s\n", ret_spec); } - } - /* Make sure we are using the right buffer */ - if (esal != NULL) { - /* We only need one, clean up the other */ - my_esa = esal; - my_esa_len = rms_nam_esll(dirnam); - } else { - my_esa = esa; - my_esa_len = rms_nam_esl(dirnam); - } + return ret_spec; + } +} - /* Null terminate the buffer */ - my_esa[my_esa_len] = '\0'; +/*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/ +static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl) +{ + static char __pathify_retbuf[VMS_MAXRSS]; + char * pathified, *ret_spec, *ret_buf; + + pathified = NULL; + ret_buf = buf; + if (ret_buf == NULL) { + if (ts) { + Newx(pathified, VMS_MAXRSS, char); + if (pathified == NULL) + _ckvmssts(SS$_INSFMEM); + ret_buf = pathified; + } else { + ret_buf = __pathify_retbuf; + } + } - /* OK, the type was fine. Now pull any file name into the - directory path. */ - if ((cp1 = strrchr(my_esa,']'))) *(rms_nam_typel(dirnam)) = ']'; - else { - cp1 = strrchr(my_esa,'>'); - *(rms_nam_typel(dirnam)) = '>'; - } - *cp1 = '.'; - *(rms_nam_typel(dirnam) + 1) = '\0'; - retlen = (rms_nam_typel(dirnam)) - my_esa + 2; - if (buf) retpath = buf; - else if (ts) Newx(retpath,retlen,char); - else retpath = __pathify_retbuf; - strcpy(retpath,my_esa); - PerlMem_free(esa); - if (esal != NULL) - PerlMem_free(esal); - sts = rms_free_search_context(&dirfab); - /* $PARSE may have upcased filespec, so convert output to lower - * case if input contained any lowercase characters. */ - if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath); + ret_spec = int_pathify_dirspec(dir, ret_buf); + + if (ret_spec == NULL) { + /* Cleanup on isle 5, if this is thread specific we need to deallocate */ + if (pathified) + Safefree(pathified); } - PerlMem_free(trndir); - return retpath; + return ret_spec; + } /* end of do_pathify_dirspec() */ -/*}}}*/ + + /* External entry points */ char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf) { return do_pathify_dirspec(dir,buf,0,NULL); } @@ -8766,7 +8904,7 @@ static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * ut 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) { + if (int_pathify_dirspec(path, pathified) == NULL) { PerlMem_free(pathified); return NULL; } @@ -8819,7 +8957,7 @@ static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * u 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) { + if (int_pathify_dirspec(path, pathified) == NULL) { PerlMem_free(pathified); return NULL; } @@ -13878,8 +14016,8 @@ mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf, if (sts == 0) { /* Now need to pathify it. - char *tdir = do_pathify_dirspec(vms_dir_name, - outbuf, utf8_fl); + char *tdir = int_pathify_dirspec(vms_dir_name, + outbuf); /* And now add the original filespec to it */ if (file_name != NULL) { |