This patch makes a version of rmsexpand 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 sixth 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.
Hopefully this is the last big patch for a while.
-John
[EMAIL PROTECTED]
Personal Opinion Only
--- /ref7_root/perl/vms/vms.c Sun Dec 7 17:20:31 2008
+++ vms/vms.c Sun Dec 7 17:31:53 2008
@@ -296,6 +296,10 @@
static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts,
int *);
+static char * int_rmsexpand_vms(
+ const char * filespec, char * outbuf, unsigned opts);
+static char * int_rmsexpand_tovms(
+ const char * filespec, char * outbuf, unsigned opts);
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);
@@ -5364,384 +5368,478 @@
static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
static char *
-mp_do_rmsexpand
- (pTHX_ const char *filespec,
+int_rmsexpand
+ (const char *filespec,
char *outbuf,
- int ts,
const char *defspec,
unsigned opts,
int * fs_utf8,
int * dfs_utf8)
{
- static char __rmsexpand_retbuf[VMS_MAXRSS];
- char * vmsfspec, *tmpfspec;
- char * esa, *cp, *out = NULL;
- char * tbuf;
- char * esal = NULL;
- char * outbufl;
- struct FAB myfab = cc$rms_fab;
- rms_setup_nam(mynam);
- STRLEN speclen;
- unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
- int sts;
+ char * ret_spec;
+ const char * in_spec;
+ char * spec_buf;
+ const char * def_spec;
+ char * vmsfspec, *vmsdefspec;
+ char * esa;
+ char * esal = NULL;
+ char * outbufl;
+ struct FAB myfab = cc$rms_fab;
+ rms_setup_nam(mynam);
+ STRLEN speclen;
+ unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
+ int sts;
- /* temp hack until UTF8 is actually implemented */
- if (fs_utf8 != NULL)
- *fs_utf8 = 0;
+ /* temp hack until UTF8 is actually implemented */
+ if (fs_utf8 != NULL)
+ *fs_utf8 = 0;
- if (!filespec || !*filespec) {
- set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
- return NULL;
- }
- if (!outbuf) {
- if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
- else outbuf = __rmsexpand_retbuf;
- }
+ if (!filespec || !*filespec) {
+ set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
+ return NULL;
+ }
- vmsfspec = NULL;
- tmpfspec = NULL;
- outbufl = NULL;
-
- isunix = 0;
- if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
- isunix = is_unix_filespec(filespec);
- if (isunix) {
- vmsfspec = PerlMem_malloc(VMS_MAXRSS);
- if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
- if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
- PerlMem_free(vmsfspec);
- if (out)
- Safefree(out);
- return NULL;
- }
- filespec = vmsfspec;
+ vmsfspec = NULL;
+ vmsdefspec = NULL;
+ outbufl = NULL;
+
+ in_spec = filespec;
+ isunix = 0;
+ if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
+
+ /* If this is a UNIX file spec, convert it to VMS */
+ isunix = is_unix_filespec(filespec);
+ if (isunix) {
+ char * ret_spec;
+ vmsfspec = PerlMem_malloc(VMS_MAXRSS);
+ if (vmsfspec == NULL)
+ _ckvmssts_noperl(SS$_INSFMEM);
- /* Unless we are forcing to VMS format, a UNIX input means
- * UNIX output, and that requires long names to be used
- */
+ ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
+ if (ret_spec == NULL) {
+ PerlMem_free(vmsfspec);
+ return NULL;
+ }
+ in_spec = (const char *)vmsfspec;
+
+ /* Unless we are forcing to VMS format, a UNIX input means
+ * UNIX output, and that requires long names to be used
+ */
#if !defined(__VAX) && defined(NAML$C_MAXRSS)
- if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
- opts |= PERL_RMSEXPAND_M_LONG;
- else
+ if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
+ opts |= PERL_RMSEXPAND_M_LONG;
+ else
#endif
- isunix = 0;
- }
+ isunix = 0;
+ }
}
- rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
- rms_bind_fab_nam(myfab, mynam);
+ rms_set_fna(myfab, mynam, (char *)in_spec, strlen(in_spec)); /* cast ok */
+ rms_bind_fab_nam(myfab, mynam);
- if (defspec && *defspec) {
- int t_isunix;
- t_isunix = is_unix_filespec(defspec);
- if (t_isunix) {
- tmpfspec = PerlMem_malloc(VMS_MAXRSS);
- if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
- if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
- PerlMem_free(tmpfspec);
- if (vmsfspec != NULL)
- PerlMem_free(vmsfspec);
- if (out)
- Safefree(out);
- return NULL;
- }
- defspec = tmpfspec;
+ /* Process the default file specification if present */
+ def_spec = defspec;
+ if (defspec && *defspec) {
+ int t_isunix;
+ t_isunix = is_unix_filespec(defspec);
+ if (t_isunix) {
+ char * ret_spec;
+ vmsdefspec = PerlMem_malloc(VMS_MAXRSS);
+ if (vmsdefspec == NULL)
+ _ckvmssts_noperl(SS$_INSFMEM);
+ ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
+
+ if (ret_spec == NULL) {
+ /* Clean up and bail */
+ PerlMem_free(vmsdefspec);
+ if (vmsfspec != NULL)
+ PerlMem_free(vmsfspec);
+ return NULL;
+ }
+ def_spec = (const char *)vmsdefspec;
+ }
+ rms_set_dna(myfab, mynam,
+ (char *)def_spec, strlen(def_spec)); /* cast ok */
}
- rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
- }
- esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
- if (esa == NULL) _ckvmssts(SS$_INSFMEM);
+ /* Now we need the expansion buffers */
+ esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
+ if (esa == NULL)
+ _ckvmssts_noperl(SS$_INSFMEM);
#if !defined(__VAX) && defined(NAML$C_MAXRSS)
- esal = PerlMem_malloc(VMS_MAXRSS);
- if (esal == NULL) _ckvmssts(SS$_INSFMEM);
+ esal = PerlMem_malloc(VMS_MAXRSS);
+ if (esal == NULL)
+ _ckvmssts_noperl(SS$_INSFMEM);
#endif
- rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
+ rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
- /* If a NAML block is used RMS always writes to the long and short
- * addresses unless you suppress the short name.
- */
+ /* If a NAML block is used RMS always writes to the long and short
+ * addresses unless you suppress the short name.
+ */
#if !defined(__VAX) && defined(NAML$C_MAXRSS)
- outbufl = PerlMem_malloc(VMS_MAXRSS);
- if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
+ outbufl = PerlMem_malloc(VMS_MAXRSS);
+ if (outbufl == NULL)
+ _ckvmssts_noperl(SS$_INSFMEM);
#endif
- rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
+ rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
#ifdef NAM$M_NO_SHORT_UPCASE
- if (decc_efs_case_preserve)
- rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
+ if (decc_efs_case_preserve)
+ rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
#endif
- /* We may not want to follow symbolic links */
+ /* We may not want to follow symbolic links */
#ifdef NAML$M_OPEN_SPECIAL
- if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
- rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
+ if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
+ rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
#endif
- /* First attempt to parse as an existing file */
- retsts = sys$parse(&myfab,0,0);
- if (!(retsts & STS$K_SUCCESS)) {
-
- /* Could not find the file, try as syntax only if error is not fatal */
- rms_set_nam_nop(mynam, NAM$M_SYNCHK);
- if (retsts == RMS$_DNF ||
- retsts == RMS$_DIR ||
- retsts == RMS$_DEV ||
- retsts == RMS$_PRV) {
- retsts = sys$parse(&myfab,0,0);
- if (retsts & STS$K_SUCCESS) goto expanded;
+ /* First attempt to parse as an existing file */
+ retsts = sys$parse(&myfab, 0, 0);
+ if (!$VMS_STATUS_SUCCESS(retsts)) {
+
+ /* Could not find the file, try as syntax only if error is not fatal */
+ rms_set_nam_nop(mynam, NAM$M_SYNCHK);
+ if (retsts == RMS$_DNF ||
+ retsts == RMS$_DIR ||
+ retsts == RMS$_DEV ||
+ retsts == RMS$_PRV) {
+ retsts = sys$parse(&myfab, 0, 0);
+ if ($VMS_STATUS_SUCCESS(retsts))
+ goto int_expanded;
+ }
+
+ /* Still could not parse the file specification */
+ /*----------------------------------------------*/
+ sts = rms_free_search_context(&myfab); /* Free search context */
+ if (vmsdefspec != NULL)
+ PerlMem_free(vmsdefspec);
+ if (vmsfspec != NULL)
+ PerlMem_free(vmsfspec);
+ if (outbufl != NULL)
+ PerlMem_free(outbufl);
+ PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
+ set_vaxc_errno(retsts);
+ if (retsts == RMS$_PRV) set_errno(EACCES);
+ else if (retsts == RMS$_DEV) set_errno(ENODEV);
+ else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
+ else set_errno(EVMSERR);
+ return NULL;
}
- /* Still could not parse the file specification */
- /*----------------------------------------------*/
- sts = rms_free_search_context(&myfab); /* Free search context */
- if (out) Safefree(out);
- if (tmpfspec != NULL)
- PerlMem_free(tmpfspec);
- if (vmsfspec != NULL)
- PerlMem_free(vmsfspec);
- if (outbufl != NULL)
- PerlMem_free(outbufl);
- PerlMem_free(esa);
- if (esal != NULL)
- PerlMem_free(esal);
- set_vaxc_errno(retsts);
- if (retsts == RMS$_PRV) set_errno(EACCES);
- else if (retsts == RMS$_DEV) set_errno(ENODEV);
- else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
- else set_errno(EVMSERR);
- return NULL;
- }
- retsts = sys$search(&myfab,0,0);
- if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
- sts = rms_free_search_context(&myfab); /* Free search context */
- if (out) Safefree(out);
- if (tmpfspec != NULL)
- PerlMem_free(tmpfspec);
- if (vmsfspec != NULL)
- PerlMem_free(vmsfspec);
- if (outbufl != NULL)
- PerlMem_free(outbufl);
- PerlMem_free(esa);
- if (esal != NULL)
- PerlMem_free(esal);
- set_vaxc_errno(retsts);
- if (retsts == RMS$_PRV) set_errno(EACCES);
- else set_errno(EVMSERR);
- return NULL;
- }
-
- /* If the input filespec contained any lowercase characters,
- * downcase the result for compatibility with Unix-minded code. */
- expanded:
- if (!decc_efs_case_preserve) {
- for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
- if (islower(*tbuf)) { haslower = 1; break; }
- }
- /* Is a long or a short name expected */
- /*------------------------------------*/
- if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
- if (rms_nam_rsll(mynam)) {
- tbuf = outbufl;
- speclen = rms_nam_rsll(mynam);
- }
- else {
- tbuf = esal; /* Not esa */
- speclen = rms_nam_esll(mynam);
+ retsts = sys$search(&myfab,0,0);
+ if (!$VMS_STATUS_SUCCESS(retsts) && (retsts != RMS$_FNF)) {
+ sts = rms_free_search_context(&myfab); /* Free search context */
+ if (vmsdefspec != NULL)
+ PerlMem_free(vmsdefspec);
+ if (vmsfspec != NULL)
+ PerlMem_free(vmsfspec);
+ if (outbufl != NULL)
+ PerlMem_free(outbufl);
+ PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
+ set_vaxc_errno(retsts);
+ if (retsts == RMS$_PRV) set_errno(EACCES);
+ else set_errno(EVMSERR);
+ return NULL;
}
- }
- else {
- if (rms_nam_rsl(mynam)) {
- tbuf = outbuf;
- speclen = rms_nam_rsl(mynam);
+
+ /* If the input filespec contained any lowercase characters,
+ * downcase the result for compatibility with Unix-minded code. */
+int_expanded:
+ if (!decc_efs_case_preserve) {
+ char * tbuf;
+ for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
+ if (islower(*tbuf)) {
+ haslower = 1;
+ break;
+ }
}
- else {
- tbuf = esa; /* Not esal */
- speclen = rms_nam_esl(mynam);
+
+ /* Is a long or a short name expected */
+ /*------------------------------------*/
+ spec_buf = NULL;
+ if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
+ if (rms_nam_rsll(mynam)) {
+ spec_buf = outbufl;
+ speclen = rms_nam_rsll(mynam);
+ } else {
+ spec_buf = esal; /* Not esa */
+ speclen = rms_nam_esll(mynam);
+ }
+ } else {
+ if (rms_nam_rsl(mynam)) {
+ spec_buf = outbuf;
+ speclen = rms_nam_rsl(mynam);
+ } else {
+ spec_buf = esa; /* Not esal */
+ speclen = rms_nam_esl(mynam);
+ }
}
- }
- tbuf[speclen] = '\0';
+ spec_buf[speclen] = '\0';
- /* Trim off null fields added by $PARSE
- * If type > 1 char, must have been specified in original or default spec
- * (not true for version; $SEARCH may have added version of existing file).
- */
- trimver = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
- if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
- trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
- ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
- }
- else {
- trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
+ /* Trim off null fields added by $PARSE
+ * If type > 1 char, must have been specified in original or default spec
+ * (not true for version; $SEARCH may have added version of existing file).
+ */
+ trimver = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
+ if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
+ trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
+ ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
+ } else {
+ trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
- }
- if (trimver || trimtype) {
- if (defspec && *defspec) {
- char *defesal = NULL;
- char *defesa = NULL;
- defesa = PerlMem_malloc(VMS_MAXRSS + 1);
- if (defesa != NULL) {
+ }
+ if (trimver || trimtype) {
+ if (defspec && *defspec) {
+ char *defesal = NULL;
+ char *defesa = NULL;
+ defesa = PerlMem_malloc(VMS_MAXRSS + 1);
+ if (defesa != NULL) {
+ struct FAB deffab = cc$rms_fab;
#if !defined(__VAX) && defined(NAML$C_MAXRSS)
- defesal = PerlMem_malloc(VMS_MAXRSS + 1);
- if (defesal == NULL) _ckvmssts(SS$_INSFMEM);
+ defesal = PerlMem_malloc(VMS_MAXRSS + 1);
+ if (defesal == NULL)
+ _ckvmssts_noperl(SS$_INSFMEM);
#endif
- struct FAB deffab = cc$rms_fab;
- rms_setup_nam(defnam);
+ rms_setup_nam(defnam);
- rms_bind_fab_nam(deffab, defnam);
-
- /* Cast ok */
- rms_set_fna
- (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
+ rms_bind_fab_nam(deffab, defnam);
- /* RMS needs the esa/esal as a work area if wildcards are involved */
- rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
+ /* Cast ok */
+ rms_set_fna(deffab, defnam, (char *)defspec,
+ rms_nam_dns(myfab, mynam));
+
+ /* RMS needs the esa/esal as a work area if wildcards are */
+ /* involved */
+ rms_set_esal(defnam, defesa, NAM$C_MAXRSS,
+ defesal, VMS_MAXRSS - 1);
- rms_clear_nam_nop(defnam);
- rms_set_nam_nop(defnam, NAM$M_SYNCHK);
+ rms_clear_nam_nop(defnam);
+ rms_set_nam_nop(defnam, NAM$M_SYNCHK);
#ifdef NAM$M_NO_SHORT_UPCASE
- if (decc_efs_case_preserve)
- rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
+ if (decc_efs_case_preserve)
+ rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
#endif
#ifdef NAML$M_OPEN_SPECIAL
- if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
- rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
+ if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
+ rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
#endif
- if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
- if (trimver) {
- trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
- }
- if (trimtype) {
- trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
- }
- }
- if (defesal != NULL)
- PerlMem_free(defesal);
- PerlMem_free(defesa);
- }
- }
- if (trimver) {
- if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
- if (*(rms_nam_verl(mynam)) != '\"')
- speclen = rms_nam_verl(mynam) - tbuf;
- }
- else {
- if (*(rms_nam_ver(mynam)) != '\"')
- speclen = rms_nam_ver(mynam) - tbuf;
- }
- }
- if (trimtype) {
- /* If we didn't already trim version, copy down */
- if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
- if (speclen > rms_nam_verl(mynam) - tbuf)
- memmove
- (rms_nam_typel(mynam),
- rms_nam_verl(mynam),
- speclen - (rms_nam_verl(mynam) - tbuf));
- speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
- }
- else {
- if (speclen > rms_nam_ver(mynam) - tbuf)
- memmove
- (rms_nam_type(mynam),
- rms_nam_ver(mynam),
- speclen - (rms_nam_ver(mynam) - tbuf));
- speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
- }
+ retsts = sys$parse(&deffab,0,0);
+ if ($VMS_STATUS_SUCCESS(retsts)) {
+ if (trimver) {
+ trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
+ }
+ if (trimtype) {
+ trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
+ }
+ }
+ if (defesal != NULL)
+ PerlMem_free(defesal);
+ PerlMem_free(defesa);
+ } else {
+ _ckvmssts_noperl(SS$_INSFMEM);
+ }
+ }
+ if (trimver) {
+ if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
+ if (*(rms_nam_verl(mynam)) != '\"')
+ speclen = rms_nam_verl(mynam) - spec_buf;
+ } else {
+ if (*(rms_nam_ver(mynam)) != '\"')
+ speclen = rms_nam_ver(mynam) - spec_buf;
+ }
+ }
+ if (trimtype) {
+ /* If we didn't already trim version, copy down */
+ if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
+ if (speclen > rms_nam_verl(mynam) - spec_buf)
+ memmove(rms_nam_typel(mynam),
+ rms_nam_verl(mynam),
+ speclen - (rms_nam_verl(mynam) - spec_buf));
+ speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
+ } else {
+ if (speclen > rms_nam_ver(mynam) - spec_buf)
+ memmove(rms_nam_type(mynam),
+ rms_nam_ver(mynam),
+ speclen - (rms_nam_ver(mynam) - spec_buf));
+ speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
+ }
+ }
}
- }
- /* Done with these copies of the input files */
- /*-------------------------------------------*/
- if (vmsfspec != NULL)
- PerlMem_free(vmsfspec);
- if (tmpfspec != NULL)
- PerlMem_free(tmpfspec);
+ /* Done with these copies of the input files */
+ /*-------------------------------------------*/
+ if (vmsfspec != NULL)
+ PerlMem_free(vmsfspec);
+ if (vmsdefspec != NULL)
+ PerlMem_free(vmsdefspec);
- /* If we just had a directory spec on input, $PARSE "helpfully"
- * adds an empty name and type for us */
+ /* If we just had a directory spec on input, $PARSE "helpfully"
+ * adds an empty name and type for us */
#if !defined(__VAX) && defined(NAML$C_MAXRSS)
- if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
- if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
- rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
- !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
- speclen = rms_nam_namel(mynam) - tbuf;
- }
- else
+ if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
+ if ((rms_nam_namel(mynam) == rms_nam_typel(mynam)) &&
+ (rms_nam_verl(mynam) == (rms_nam_typel(mynam) + 1)) &&
+ !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
+ speclen = rms_nam_namel(mynam) - spec_buf;
+ } else
#endif
- {
- if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
- rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
- !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
- speclen = rms_nam_name(mynam) - tbuf;
- }
+ {
+ if ((rms_nam_name(mynam) == rms_nam_type(mynam)) &&
+ (rms_nam_ver(mynam) == (rms_nam_ver(mynam) + 1)) &&
+ !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
+ speclen = rms_nam_name(mynam) - spec_buf;
+ }
- /* Posix format specifications must have matching quotes */
- if (speclen < (VMS_MAXRSS - 1)) {
- if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
- if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
- tbuf[speclen] = '\"';
- speclen++;
- }
+ /* Posix format specifications must have matching quotes */
+ if (speclen < (VMS_MAXRSS - 1)) {
+ if (decc_posix_compliant_pathnames && (spec_buf[0] == '\"')) {
+ if ((speclen > 1) && (spec_buf[speclen-1] != '\"')) {
+ spec_buf[speclen] = '\"';
+ speclen++;
+ }
+ }
}
- }
- tbuf[speclen] = '\0';
- if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
+ spec_buf[speclen] = '\0';
+ if (haslower && !decc_efs_case_preserve)
+ __mystrtolower(spec_buf);
- /* Have we been working with an expanded, but not resultant, spec? */
- /* Also, convert back to Unix syntax if necessary. */
- {
- int rsl;
+ /* Have we been working with an expanded, but not resultant, spec? */
+ /* Also, convert back to Unix syntax if necessary. */
+ {
+ int rsl;
#if !defined(__VAX) && defined(NAML$C_MAXRSS)
- if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
- rsl = rms_nam_rsll(mynam);
- } else
-#endif
- {
- rsl = rms_nam_rsl(mynam);
+ if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
+ rsl = rms_nam_rsll(mynam);
+ } else
+#endif
+ {
+ rsl = rms_nam_rsl(mynam);
+ }
+ if (!rsl) {
+ /* rsl is not present, it means that spec_buf is either */
+ /* esa or esal, and needs to be copied to outbuf */
+ /* convert to Unix if desired */
+
+ if (isunix) {
+ /* Convert it */
+ ret_spec = int_tounixspec(spec_buf, outbuf, fs_utf8);
+ } else {
+ /* VMS file specs are not in UTF-8 */
+ if (fs_utf8 != NULL)
+ *fs_utf8 = 0;
+ strcpy(outbuf, spec_buf);
+ ret_spec = outbuf;
+ }
+ } else {
+ /* Now spec_buf is either outbuf or outbufl */
+ /* We need the result into outbuf */
+ if (isunix) {
+
+ /* If we need this in UNIX, then we need another buffer */
+ /* to keep things in order */
+ char * src;
+ char * new_src = NULL;
+ if (spec_buf == outbuf) {
+ new_src = PerlMem_malloc(VMS_MAXRSS);
+ strcpy(new_src, spec_buf);
+ } else {
+ src = spec_buf;
+ }
+ ret_spec = int_tounixspec(src, outbuf, fs_utf8);
+ if (new_src) {
+ PerlMem_free(new_src);
+ }
+ } else {
+ /* VMS file specs are not in UTF-8 */
+ if (fs_utf8 != NULL)
+ *fs_utf8 = 0;
+
+ /* Copy the buffer if needed */
+ if (outbuf != spec_buf)
+ strcpy(outbuf, spec_buf);
+ ret_spec = outbuf;
+ }
+ }
}
- if (!rsl) {
- if (isunix) {
- if (do_tounixspec(tbuf, outbuf ,0 , fs_utf8) == NULL) {
- if (out) Safefree(out);
- if (esal != NULL)
- PerlMem_free(esal);
- PerlMem_free(esa);
- if (outbufl != NULL)
- PerlMem_free(outbufl);
- return NULL;
- }
- }
- else strcpy(outbuf, tbuf);
- }
- else if (isunix) {
- tmpfspec = PerlMem_malloc(VMS_MAXRSS);
- if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
- if (do_tounixspec(tbuf,tmpfspec,0,fs_utf8) == NULL) {
- if (out) Safefree(out);
- PerlMem_free(esa);
- if (esal != NULL)
- PerlMem_free(esal);
- PerlMem_free(tmpfspec);
- if (outbufl != NULL)
- PerlMem_free(outbufl);
- return NULL;
- }
- strcpy(outbuf,tmpfspec);
- PerlMem_free(tmpfspec);
+
+ /* Need to clean up the search context */
+ rms_set_rsal(mynam, NULL, 0, NULL, 0);
+ sts = rms_free_search_context(&myfab); /* Free search context */
+
+ /* Clean up the extra buffers */
+ if (esal != NULL)
+ PerlMem_free(esal);
+ PerlMem_free(esa);
+ if (outbufl != NULL)
+ PerlMem_free(outbufl);
+
+ /* Return the result */
+ return ret_spec;
+}
+
+/* Common simple case - Expand an already VMS spec */
+static char *
+int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
+ opts |= PERL_RMSEXPAND_M_VMS_IN;
+ return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
+}
+
+/* Common simple case - Expand to a VMS spec */
+static char *
+int_rmsexpand_tovms(const char * filespec, char * outbuf, unsigned opts) {
+ opts |= PERL_RMSEXPAND_M_VMS;
+ return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
+}
+
+
+
+/* Entry point used by perl routines */
+static char *
+mp_do_rmsexpand
+ (pTHX_ const char *filespec,
+ char *outbuf,
+ int ts,
+ const char *defspec,
+ unsigned opts,
+ int * fs_utf8,
+ int * dfs_utf8)
+{
+ static char __rmsexpand_retbuf[VMS_MAXRSS];
+ char * expanded, *ret_spec, *ret_buf;
+
+ expanded = NULL;
+ ret_buf = outbuf;
+ if (ret_buf == NULL) {
+ if (ts) {
+ Newx(expanded, VMS_MAXRSS, char);
+ if (expanded == NULL)
+ _ckvmssts(SS$_INSFMEM);
+ ret_buf = expanded;
+ } else {
+ ret_buf = __rmsexpand_retbuf;
+ }
}
- }
- rms_set_rsal(mynam, NULL, 0, NULL, 0);
- sts = rms_free_search_context(&myfab); /* Free search context */
- PerlMem_free(esa);
- if (esal != NULL)
- PerlMem_free(esal);
- if (outbufl != NULL)
- PerlMem_free(outbufl);
- return outbuf;
+
+
+ ret_spec = int_rmsexpand(filespec, ret_buf, defspec,
+ opts, fs_utf8, dfs_utf8);
+
+ if (ret_spec == NULL) {
+ /* Cleanup on isle 5, if this is thread specific we need to deallocate
*/
+ if (expanded)
+ Safefree(expanded);
+ }
+
+ return ret_spec;
}
+
/*}}}*/
/* External entry points */
char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def,
unsigned opt)
@@ -6424,22 +6522,6 @@
set_errno(ENOTDIR);
return NULL;
}
-
-
-/* Common simple case - Expand an already VMS spec */
-static char *
-int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
-
- /* Temporary hack until routine is converted to not take a thread context */
-#if defined(PERL_IMPLICIT_CONTEXT)
- pTHX = NULL;
-#endif
-
- opts |= PERL_RMSEXPAND_M_VMS_IN;
- return do_rmsexpand(filespec, outbuf, 0, NULL, opts, NULL, NULL);
-}
-
-
/* Internal routine to make sure or convert a directory to be in a */
