From: John Malmberg Date: Mon, 12 Jan 2009 04:15:28 +0000 (-0600) Subject: vms - vmsspec refactor X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=df27866545771c254ff7fc71eb20ecc427c341bd;p=p5sagit%2Fp5-mst-13.2.git vms - vmsspec refactor Message-id: <496AC3E0.2090207@gmail.com> Refactor of vmsspec() to not use a thread context for internal routines. --- diff --git a/vms/vms.c b/vms/vms.c index 920db99..9ccd7d5 100644 --- a/vms/vms.c +++ b/vms/vms.c @@ -296,6 +296,9 @@ static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *); static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *); static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *); +static char *int_tovmsspec + (const char *path, char *buf, int dir_flag, int * utf8_flag); + /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */ #define PERL_LNM_MAX_ALLOWED_INDEX 127 @@ -922,6 +925,37 @@ const int verspec = 7; return ret_stat; } +/* Routine to determine if the file specification ends with .dir */ +static int is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len) { + + /* e_len must be 4, and version must be <= 2 characters */ + if (e_len != 4 || vs_len > 2) + return 0; + + /* If a version number is present, it needs to be one */ + if ((vs_len == 2) && (vs_spec[1] != '1')) + return 0; + + /* Look for the DIR on the extension */ + if (vms_process_case_tolerant) { + if ((toupper(e_spec[1]) == 'D') && + (toupper(e_spec[2]) == 'I') && + (toupper(e_spec[3]) == 'R')) { + return 1; + } + } else { + /* Directory extensions are supposed to be in upper case only */ + /* I would not be surprised if this rule can not be enforced */ + /* if and when someone fully debugs the case sensitive mode */ + if ((e_spec[1] == 'D') && + (e_spec[2] == 'I') && + (e_spec[3] == 'R')) { + return 1; + } + } + return 0; +} + /* my_maxidx * Routine to retrieve the maximum equivalence index for an input @@ -5296,7 +5330,7 @@ Stat_t dst_st; } /* The dest must be a VMS file specification */ - ret_str = do_tovmsspec(dst, vms_dst, 0, NULL); + ret_str = int_tovmsspec(dst, vms_dst, 0, NULL); if (ret_str == NULL) { PerlMem_free(vms_src); PerlMem_free(vms_dst); @@ -5335,7 +5369,7 @@ Stat_t dst_st; } else { /* fileify a target VMS file specification */ - ret_str = do_tovmsspec(dst, vms_dst, 0, NULL); + ret_str = int_tovmsspec(dst, vms_dst, 0, NULL); if (ret_str == NULL) { PerlMem_free(vms_src); PerlMem_free(vms_dst); @@ -5467,7 +5501,7 @@ mp_do_rmsexpand if (isunix) { vmsfspec = PerlMem_malloc(VMS_MAXRSS); if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM); - if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) { + if (int_tovmsspec(filespec, vmsfspec, 0, fs_utf8) == NULL) { PerlMem_free(vmsfspec); if (out) Safefree(out); @@ -5496,7 +5530,7 @@ mp_do_rmsexpand if (t_isunix) { tmpfspec = PerlMem_malloc(VMS_MAXRSS); if (tmpfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM); - if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) { + if (int_tovmsspec(defspec, tmpfspec, 0, dfs_utf8) == NULL) { PerlMem_free(tmpfspec); if (vmsfspec != NULL) PerlMem_free(vmsfspec); @@ -5857,6 +5891,8 @@ static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int * char *retspec, *cp1, *cp2, *lastdir; char *trndir, *vmsdir; unsigned short int trnlnm_iter_count; + int is_vms = 0; + int is_unix = 0; int sts; if (utf8_fl != NULL) *utf8_fl = 0; @@ -5963,13 +5999,13 @@ static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int * if (*(cp1+2) == '.') cp1++; if (*(cp1+2) == '/' || *(cp1+2) == '\0') { char * ret_chr; - if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) { + if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) { PerlMem_free(trndir); PerlMem_free(vmsdir); return NULL; } if (strchr(vmsdir,'/') != NULL) { - /* If do_tovmsspec() returned it, it must have VMS syntax + /* If int_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. @@ -6005,7 +6041,7 @@ static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int * */ trndir[dirlen] = '/'; trndir[dirlen+1] = '\0'; - if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) { + if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) { PerlMem_free(trndir); PerlMem_free(vmsdir); return NULL; @@ -6058,8 +6094,8 @@ static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int * set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR); return NULL; - } - } + } + } dirlen = cp2 - trndir; } } @@ -6073,10 +6109,52 @@ static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int * /* 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"); + + /* We should only add type for VMS syntax, but historically Perl + has added it for UNIX style also */ + + /* Fix me - we should not be using the same routine for VMS and + UNIX format files. Things are too tangled so we need to lookup + what syntax the output is */ + + is_unix = 0; + is_vms = 0; + lastdir = strrchr(trndir,'/'); + if (lastdir) { + is_unix = 1; + } else { + lastdir = strpbrk(trndir,"]:>"); + if (lastdir) { + is_vms = 1; + } + } + + if ((is_vms == 0) && (is_unix == 0)) { + /* We still do not know? */ + is_unix = decc_filename_unix_report; + if (is_unix == 0) + is_vms = 1; + } + + if ((is_unix && !decc_efs_charset) || is_vms) { + + /* It is a bug to add a .dir to a UNIX format directory spec */ + /* However Perl on VMS may have programs that expect this so */ + /* If not using EFS character specifications allow it. */ + + if ((!decc_efs_case_preserve) && vms_process_case_tolerant) { + /* Traditionally Perl expects filenames in lower case */ + strcat(retspec, ".dir"); + } else { + /* VMS expects the .DIR to be in upper case */ + strcat(retspec, ".DIR"); + } + + /* It is also a bug to put a VMS format version on a UNIX file */ + /* specification. Perl self tests are looking for this */ + if (is_vms || !(decc_efs_charset || decc_filename_unix_report)) + strcat(retspec, ";1"); + } PerlMem_free(trndir); PerlMem_free(vmsdir); return retspec; @@ -7943,11 +8021,11 @@ int utf8_flag; } + /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/ -static char *mp_do_tovmsspec - (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) { - static char __tovmsspec_retbuf[VMS_MAXRSS]; - char *rslt, *dirend; +static char *int_tovmsspec + (const char *path, char *rslt, int dir_flag, int * utf8_flag) { + char *dirend; char *lastdot; char *vms_delim; register char *cp1; @@ -7958,11 +8036,20 @@ static char *mp_do_tovmsspec char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec; int sts, v_len, r_len, d_len, n_len, e_len, vs_len; - if (path == NULL) return NULL; + if (vms_debug_fileify) { + if (path == NULL) + fprintf(stderr, "int_tovmsspec: path = NULL\n"); + else + fprintf(stderr, "int_tovmsspec: path = %s\n", path); + } + + if (path == NULL) { + /* If we fail, we should be setting errno */ + set_errno(EINVAL); + set_vaxc_errno(SS$_BADPARAM); + return NULL; + } rslt_len = VMS_MAXRSS-1; - if (buf) rslt = buf; - else if (ts) Newx(rslt, VMS_MAXRSS, char); - else rslt = __tovmsspec_retbuf; /* '.' and '..' are "[]" and "[-]" for a quick check */ if (path[0] == '.') { @@ -8024,6 +8111,9 @@ static char *mp_do_tovmsspec if (utf8_flag != NULL) *utf8_flag = 0; strcpy(rslt, path); + if (vms_debug_fileify) { + fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt); + } return rslt; } /* Now, what to do with trailing "." cases where there is no @@ -8042,28 +8132,51 @@ static char *mp_do_tovmsspec if (utf8_flag != NULL) *utf8_flag = 0; strcpy(rslt, path); + if (vms_debug_fileify) { + fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt); + } return rslt; } dirend = strrchr(path,'/'); if (dirend == NULL) { + char *macro_start; + int has_macro; + /* If we get here with no UNIX directory delimiters, then this is not a complete file specification, either garbage a UNIX glob specification that can not be converted to a VMS wildcard, or - it a UNIX shell macro. MakeMaker wants these passed through AS-IS, - so apparently other programs expect this also. + it a UNIX shell macro. MakeMaker wants shell macros passed + through AS-IS, utf8 flag setting needs to be preserved. */ - strcpy(rslt, path); - return rslt; + hasdir = 0; + + has_macro = 0; + macro_start = strchr(path,'$'); + if (macro_start != NULL) { + if (macro_start[1] == '(') { + has_macro = 1; + } + } + if ((decc_efs_charset == 0) || (has_macro)) { + strcpy(rslt, path); + if (vms_debug_fileify) { + fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt); + } + return rslt; + } } /* If POSIX mode active, handle the conversion */ #if __CRTL_VER >= 80200000 && !defined(__VAX) if (decc_efs_charset) { posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag); + if (vms_debug_fileify) { + fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt); + } return rslt; } #endif @@ -8094,6 +8207,9 @@ static char *mp_do_tovmsspec } if (utf8_flag != NULL) *utf8_flag = 0; + if (vms_debug_fileify) { + fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt); + } return rslt; } while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2; @@ -8382,9 +8498,44 @@ static char *mp_do_tovmsspec if (utf8_flag != NULL) *utf8_flag = 0; + if (vms_debug_fileify) { + fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt); + } return rslt; -} /* end of do_tovmsspec() */ +} /* end of int_tovmsspec() */ + + +/*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/ +static char *mp_do_tovmsspec + (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) { + static char __tovmsspec_retbuf[VMS_MAXRSS]; + char * vmsspec, *ret_spec, *ret_buf; + + vmsspec = NULL; + ret_buf = buf; + if (ret_buf == NULL) { + if (ts) { + Newx(vmsspec, VMS_MAXRSS, char); + if (vmsspec == NULL) + _ckvmssts(SS$_INSFMEM); + ret_buf = vmsspec; + } else { + ret_buf = __tovmsspec_retbuf; + } + } + + ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag); + + if (ret_spec == NULL) { + /* Cleanup on isle 5, if this is thread specific we need to deallocate */ + if (vmsspec) + Safefree(vmsspec); + } + + return ret_spec; + +} /* end of mp_do_tovmsspec() */ /*}}}*/ /* External entry points */ char *Perl_tovmsspec(pTHX_ const char *path, char *buf) @@ -8867,7 +9018,7 @@ int rms_sts; vmsspec = PerlMem_malloc(VMS_MAXRSS); if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM); if ((isunix = (int) strchr(item,'/')) != (int) NULL) - filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL); + filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL); if (!isunix || !filespec.dsc$a_pointer) filespec.dsc$a_pointer = item; filespec.dsc$w_length = strlen(filespec.dsc$a_pointer); @@ -10080,7 +10231,7 @@ setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote, *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1); rest++, cp2++) *cp2 = *rest; *cp2 = '\0'; - if (do_tovmsspec(resspec,cp,0,NULL)) { + if (int_tovmsspec(resspec, cp, 0, NULL)) { s = vmsspec; /* When a UNIX spec with no file type is translated to VMS, */ @@ -12318,8 +12469,8 @@ Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM); vmsout = PerlMem_malloc(VMS_MAXRSS); if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM); - if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1,NULL) || - !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) { + if (!spec_in || !*spec_in || !int_tovmsspec(spec_in, vmsin, 1, NULL) || + !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) { PerlMem_free(vmsin); PerlMem_free(vmsout); set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);