diff options
author | John Malmberg <wb8tyw@gmail.com> | 2009-01-18 13:12:18 -0600 |
---|---|---|
committer | Craig A. Berry <craigberry@mac.com> | 2009-01-19 20:50:21 -0600 |
commit | 1fe570cc5e24eecfb07059e53e95fa864bb44142 (patch) | |
tree | 5f7285af0f4c49a27b3aaa66c49e3b499985e6fa /vms | |
parent | 85a8a980a9693eec73613792ab6c1f1c4fdd098d (diff) | |
download | perl-1fe570cc5e24eecfb07059e53e95fa864bb44142.tar.gz |
Pathify_dirspec replacement
This replaces pathify_dirspec in vms.c with a new version that better
handles the extended character set.
The [.vms.ext]filespec.t has been adjusted for to support both the
default mode and the extended file spec mode.
This fixes an inconsistency where now vmsify and vmspath will return the
same result for similar input.
Message-ID: <49737F12.6010803@gmail.com>
Diffstat (limited to 'vms')
-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) { |