# define RTL_USES_UTC 1
#endif
+#if !defined(__VAX) && __CRTL_VER >= 80200000
+#ifdef lstat
+#undef lstat
+#endif
+#else
+#ifdef lstat
+#undef lstat
+#endif
+#define lstat(_x, _y) stat(_x, _y)
+#endif
+
/* Routine to create a decterm for use with the Perl debugger */
/* No headers, this information was found in the Programming Concepts Manual */
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);
+static char * int_tounixspec(const char *spec, char *buf, int * utf8_fl);
+static char * int_tovmspath(const char *path, char *buf, int * utf8_fl);
/* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
#define PERL_LNM_MAX_ALLOWED_INDEX 127
/* vmssetuserlnm
* sets a user-mode logical in the process logical name table
* used for redirection of sys$error
+ *
+ * Fix-me: The pTHX is not needed for this routine, however doio.c
+ * is calling it with one instead of using a macro.
+ * A macro needs to be added to vmsish.h and doio.c updated to use it.
+ *
*/
void
Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
- rslt = do_rmsexpand(name,
- vmsname,
- 0,
- NULL,
- PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
- NULL,
- NULL);
+ rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
if (rslt == NULL) {
PerlMem_free(vmsname);
return -1;
int retval;
Stat_t st;
- dirfile = PerlMem_malloc(VMS_MAXRSS + 1);
- if (dirfile == NULL)
- _ckvmssts(SS$_INSFMEM);
+ /* lstat returns a VMS fileified specification of the name */
+ /* that is looked up, and also lets verifies that this is a directory */
- /* Force to a directory specification */
- if (do_fileify_dirspec(name, dirfile, 0, NULL) == NULL) {
- PerlMem_free(dirfile);
- return -1;
+ retval = flex_lstat(name, &st);
+ if (retval != 0) {
+ char * ret_spec;
+
+ /* Due to a historical feature, flex_stat/lstat can not see some */
+ /* Unix format file names that the rest of the CRTL can see */
+ /* Fixing that feature will cause some perl tests to fail */
+ /* So try this one more time. */
+
+ retval = lstat(name, &st.crtl_stat);
+ if (retval != 0)
+ return -1;
+
+ /* force it to a file spec for the kill file to work. */
+ ret_spec = do_fileify_dirspec(name, st.st_devnam, 0, NULL);
+ if (ret_spec == NULL) {
+ errno = EIO;
+ return -1;
+ }
}
- if (Perl_flex_lstat(aTHX_ dirfile, &st) || !S_ISDIR(st.st_mode)) {
+
+ if (!S_ISDIR(st.st_mode)) {
errno = ENOTDIR;
retval = -1;
}
- else
+ else {
+ dirfile = st.st_devnam;
+
+ /* It may be possible for flex_stat to find a file and vmsify() to */
+ /* fail with ODS-2 specifications. mp_do_kill_file can not deal */
+ /* with that case, so fail it */
+ if (dirfile[0] == 0) {
+ errno = EIO;
+ return -1;
+ }
+
retval = mp_do_kill_file(aTHX_ dirfile, 1);
+ }
- PerlMem_free(dirfile);
return retval;
} /* end of do_rmdir */
int
Perl_kill_file(pTHX_ const char *name)
{
- char rspec[NAM$C_MAXRSS+1];
- char *tspec;
+ char * vmsfile;
Stat_t st;
int rmsts;
- /* Remove() is allowed to delete directories, according to the X/Open
- * specifications.
- * This may need special handling to work with the ACL hacks.
+ /* Convert the filename to VMS format and see if it is a directory */
+ /* flex_lstat returns a vmsified file specification */
+ rmsts = flex_lstat(name, &st);
+ if (rmsts != 0) {
+
+ /* Due to a historical feature, flex_stat/lstat can not see some */
+ /* Unix format file names that the rest of the CRTL can see when */
+ /* ODS-2 file specifications are in use. */
+ /* Fixing that feature will cause some perl tests to fail */
+ /* [.lib.ExtUtils.t]Manifest.t is one of them */
+ st.st_mode = 0;
+ vmsfile = (char *) name; /* cast ok */
+
+ } else {
+ vmsfile = st.st_devnam;
+ if (vmsfile[0] == 0) {
+ /* It may be possible for flex_stat to find a file and vmsify() */
+ /* to fail with ODS-2 specifications. mp_do_kill_file can not */
+ /* deal with that case, so fail it */
+ errno = EIO;
+ return -1;
+ }
+ }
+
+ /* Remove() is allowed to delete directories, according to the X/Open
+ * specifications.
+ * This may need special handling to work with the ACL hacks.
*/
- if ((flex_lstat(name, &st) == 0) && S_ISDIR(st.st_mode)) {
- rmsts = Perl_do_rmdir(aTHX_ name);
- return rmsts;
+ if (S_ISDIR(st.st_mode)) {
+ rmsts = mp_do_kill_file(aTHX_ vmsfile, 1);
+ return rmsts;
}
- rmsts = mp_do_kill_file(aTHX_ name, 0);
+ rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
+
+ /* Need to delete all versions ? */
+ if ((rmsts == 0) && (vms_unlink_all_versions == 1)) {
+ int i = 0;
+
+ /* Just use lstat() here as do not need st_dev */
+ /* and we know that the file is in VMS format or that */
+ /* because of a historical bug, flex_stat can not see the file */
+ while (lstat(vmsfile, (stat_t *)&st) == 0) {
+ rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
+ if (rmsts != 0)
+ break;
+ i++;
+
+ /* Make sure that we do not loop forever */
+ if (i > 32767) {
+ errno = EIO;
+ rmsts = -1;
+ break;
+ }
+ }
+ }
return rmsts;
* null file name/type. However, it's commonplace under Unix,
* so we'll allow it for a gain in portability.
*
- * - Preview- '/' will be valid soon on VMS
+ * '/' is valid when SYS$POSIX_ROOT or POSIX compliant pathnames are active.
*/
if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
- char *newdir = savepvn(dir1,dirlen-1);
- int ret = chdir(newdir);
- Safefree(newdir);
- return ret;
+ char *newdir;
+ int ret;
+ newdir = PerlMem_malloc(dirlen);
+ if (newdir ==NULL)
+ _ckvmssts_noperl(SS$_INSFMEM);
+ strncpy(newdir, dir1, dirlen-1);
+ newdir[dirlen-1] = '\0';
+ ret = chdir(newdir);
+ PerlMem_free(newdir);
+ return ret;
}
else return chdir(dir1);
} /* end of my_chdir */
int
Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
{
+ Stat_t st;
+ int ret = -1;
+ char * changefile;
STRLEN speclen = strlen(file_spec);
/* zero length string sometimes gives ACCVIO */
* Tests are showing that chmod() on VMS 8.3 is only accepting directories
* in VMS file.dir notation.
*/
- if ((speclen > 1) && (file_spec[speclen-1] == '/')) {
- char *vms_src, *vms_dir, *rslt;
- int ret = -1;
- errno = EIO;
-
- /* First convert this to a VMS format specification */
- vms_src = PerlMem_malloc(VMS_MAXRSS);
- if (vms_src == NULL)
- _ckvmssts_noperl(SS$_INSFMEM);
-
- rslt = do_tovmsspec(file_spec, vms_src, 0, NULL);
- if (rslt == NULL) {
- /* If we fail, then not a file specification */
- PerlMem_free(vms_src);
- errno = EIO;
- return -1;
- }
+ changefile = (char *) file_spec; /* cast ok */
+ ret = flex_lstat(file_spec, &st);
+ if (ret != 0) {
- /* Now make it a directory spec so chmod is happy */
- vms_dir = PerlMem_malloc(VMS_MAXRSS + 1);
- if (vms_dir == NULL)
- _ckvmssts_noperl(SS$_INSFMEM);
- rslt = do_fileify_dirspec(vms_src, vms_dir, 0, NULL);
- PerlMem_free(vms_src);
+ /* Due to a historical feature, flex_stat/lstat can not see some */
+ /* Unix format file names that the rest of the CRTL can see when */
+ /* ODS-2 file specifications are in use. */
+ /* Fixing that feature will cause some perl tests to fail */
+ /* [.lib.ExtUtils.t]Manifest.t is one of them */
+ st.st_mode = 0;
- /* Now do it */
- if (rslt != NULL) {
- ret = chmod(vms_dir, mode);
- } else {
- errno = EIO;
- }
- PerlMem_free(vms_dir);
- return ret;
+ } else {
+ /* It may be possible to get here with nothing in st_devname */
+ /* chmod still may work though */
+ if (st.st_devnam[0] != 0) {
+ changefile = st.st_devnam;
+ }
}
- else return chmod(file_spec, mode);
+ ret = chmod(changefile, mode);
+ return ret;
} /* end of my_chmod */
/*}}}*/
file[NAM$C_MAXRSS] = '\0';
p = p->next;
- exp_res = do_rmsexpand
- (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
+ exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
if (!exp_res) continue;
if (cando_by_name_int
fsync(fileno(fp));
fgetname(fp, file, 1);
- fstat(fileno(fp), (struct stat *)&s0);
+ fstat(fileno(fp), &s0.crtl_stat);
fclose(fp);
if (decc_filename_unix_only)
- do_tounixspec(file, file, 0, NULL);
+ int_tounixspec(file, file, NULL);
fp = fopen(file,"r","shr=get");
if (!fp) return 0;
- fstat(fileno(fp), (struct stat *)&s1);
+ fstat(fileno(fp), &s1.crtl_stat);
cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
if (*in_mode == 'r') {
PerlIO * xterm_fd;
+#if defined(PERL_IMPLICIT_CONTEXT)
+ /* Can not fork an xterm with a NULL context */
+ /* This probably could never happen */
+ xterm_fd = NULL;
+ if (aTHX != NULL)
+#endif
xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
if (xterm_fd != NULL)
return xterm_fd;
rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
rms_bind_fab_nam(myfab, mynam);
- /* Are we removing all versions? */
- if (vms_unlink_all_versions == 1) {
- const char * defspec = ";*";
- rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
- }
-
#ifdef NAML$M_OPEN_SPECIAL
rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
#endif
if (vmsname == NULL)
return SS$_INSFMEM;
- rslt = do_rmsexpand(vms_src_dsc->dsc$a_pointer,
+ rslt = int_rmsexpand_tovms(vms_src_dsc->dsc$a_pointer,
vmsname,
- 0,
- NULL,
- PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
- NULL,
- NULL);
+ PERL_RMSEXPAND_M_SYMLINK);
if (rslt == NULL) {
PerlMem_free(vmsname);
return SS$_INSFMEM;
/* No source file or other problem */
return src_sts;
}
+ if (src_st.st_devnam[0] == 0) {
+ /* This may be possible so fail if it is seen. */
+ errno = EIO;
+ return -1;
+ }
dst_sts = flex_lstat(dst, &dst_st);
if (dst_sts == 0) {
if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
int d_sts;
- d_sts = mp_do_kill_file(aTHX_ dst, S_ISDIR(dst_st.st_mode));
+ d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam,
+ S_ISDIR(dst_st.st_mode));
+
+ /* Need to delete all versions ? */
+ if ((d_sts == 0) && (vms_unlink_all_versions == 1)) {
+ int i = 0;
+
+ while (lstat(dst_st.st_devnam, &dst_st.crtl_stat) == 0) {
+ d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 0);
+ if (d_sts != 0)
+ break;
+ i++;
+
+ /* Make sure that we do not loop forever */
+ if (i > 32767) {
+ errno = EIO;
+ d_sts = -1;
+ break;
+ }
+ }
+ }
+
if (d_sts != 0)
return d_sts;
/* if the source is a directory, then need to fileify */
/* and dest must be a directory or non-existant. */
- char * vms_src;
char * vms_dst;
int sts;
char * ret_str;
* on if one or more of them are directories.
*/
- vms_src = PerlMem_malloc(VMS_MAXRSS);
- if (vms_src == NULL)
- _ckvmssts_noperl(SS$_INSFMEM);
-
- /* Source is always a VMS format file */
- ret_str = do_tovmsspec(src, vms_src, 0, NULL);
- if (ret_str == NULL) {
- PerlMem_free(vms_src);
- errno = EIO;
- return -1;
- }
-
vms_dst = PerlMem_malloc(VMS_MAXRSS);
if (vms_dst == NULL)
_ckvmssts_noperl(SS$_INSFMEM);
if (vms_dir_file == NULL)
_ckvmssts_noperl(SS$_INSFMEM);
- /* The source must be a file specification */
- ret_str = do_fileify_dirspec(vms_src, vms_dir_file, 0, NULL);
- if (ret_str == NULL) {
- PerlMem_free(vms_src);
- PerlMem_free(vms_dst);
- PerlMem_free(vms_dir_file);
- errno = EIO;
- return -1;
- }
- PerlMem_free(vms_src);
- vms_src = vms_dir_file;
-
/* If the dest is a directory, we must remove it
if (dst_sts == 0) {
int d_sts;
- d_sts = mp_do_kill_file(aTHX_ dst, 1);
+ d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 1);
if (d_sts != 0) {
- PerlMem_free(vms_src);
PerlMem_free(vms_dst);
errno = EIO;
return sts;
/* The dest must be a VMS file specification */
ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
if (ret_str == NULL) {
- PerlMem_free(vms_src);
PerlMem_free(vms_dst);
errno = EIO;
return -1;
ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
if (ret_str == NULL) {
- PerlMem_free(vms_src);
PerlMem_free(vms_dst);
PerlMem_free(vms_dir_file);
errno = EIO;
if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
/* VMS pathify a dir target */
- ret_str = do_tovmspath(dst, vms_dst, 0, NULL);
+ ret_str = int_tovmspath(dst, vms_dst, NULL);
if (ret_str == NULL) {
- PerlMem_free(vms_src);
PerlMem_free(vms_dst);
errno = EIO;
return -1;
}
} else {
+ char * v_spec, * r_spec, * d_spec, * n_spec;
+ char * e_spec, * vs_spec;
+ int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
/* fileify a target VMS file specification */
ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
if (ret_str == NULL) {
- PerlMem_free(vms_src);
PerlMem_free(vms_dst);
errno = EIO;
return -1;
}
+
+ sts = vms_split_path(vms_dst, &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) {
+ if (e_len == 0) {
+ /* Get rid of the version */
+ if (vs_len != 0) {
+ *vs_spec = '\0';
+ }
+ /* Need to specify a '.' so that the extension */
+ /* is not inherited */
+ strcat(vms_dst,".");
+ }
+ }
}
}
- old_file_dsc.dsc$a_pointer = vms_src;
- old_file_dsc.dsc$w_length = strlen(vms_src);
+ old_file_dsc.dsc$a_pointer = src_st.st_devnam;
+ old_file_dsc.dsc$w_length = strlen(src_st.st_devnam);
old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
}
- PerlMem_free(vms_src);
PerlMem_free(vms_dst);
if (!$VMS_STATUS_SUCCESS(sts)) {
errno = EIO;
/* Now get rid of any previous versions of the source file that
* might still exist
*/
- int save_errno;
- save_errno = errno;
- src_sts = mp_do_kill_file(aTHX_ src, S_ISDIR(src_st.st_mode));
- errno = save_errno;
+ int i = 0;
+ dSAVEDERRNO;
+ SAVE_ERRNO;
+ src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
+ S_ISDIR(src_st.st_mode));
+ while (lstat(src_st.st_devnam, &src_st.crtl_stat) == 0) {
+ src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
+ S_ISDIR(src_st.st_mode));
+ if (src_sts != 0)
+ break;
+ i++;
+
+ /* Make sure that we do not loop forever */
+ if (i > 32767) {
+ src_sts = -1;
+ break;
+ }
+ }
+ RESTORE_ERRNO;
}
/* We deleted the destination, so must force the error to be EIO */
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 * 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;
set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
return NULL;
}
- if (!outbuf) {
- if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
- else outbuf = __rmsexpand_retbuf;
- }
vmsfspec = NULL;
- tmpfspec = NULL;
+ vmsdefspec = NULL;
outbufl = NULL;
+ in_spec = filespec;
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_noperl(SS$_INSFMEM);
- if (int_tovmsspec(filespec, vmsfspec, 0, fs_utf8) == NULL) {
- PerlMem_free(vmsfspec);
- if (out)
- Safefree(out);
- return NULL;
- }
- filespec = vmsfspec;
+ 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 this is a UNIX file spec, convert it to VMS */
+ sts = vms_split_path(filespec, &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) {
+ isunix = 1;
+ char * ret_spec;
+
+ vmsfspec = PerlMem_malloc(VMS_MAXRSS);
+ if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
+ 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
- */
+ /* Unless we are forcing to VMS format, a UNIX input means
+ * UNIX output, and that requires long names to be used
+ */
+ if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
#if !defined(__VAX) && defined(NAML$C_MAXRSS)
- if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
- opts |= PERL_RMSEXPAND_M_LONG;
- else
+ opts |= PERL_RMSEXPAND_M_LONG;
+#else
+ NOOP;
#endif
- isunix = 0;
+ else
+ isunix = 0;
}
- }
- rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
+ }
+
+ rms_set_fna(myfab, mynam, (char *)in_spec, strlen(in_spec)); /* cast ok */
rms_bind_fab_nam(myfab, mynam);
+ /* 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) {
- tmpfspec = PerlMem_malloc(VMS_MAXRSS);
- if (tmpfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
- if (int_tovmsspec(defspec, tmpfspec, 0, dfs_utf8) == NULL) {
- PerlMem_free(tmpfspec);
- if (vmsfspec != NULL)
- PerlMem_free(vmsfspec);
- if (out)
- Safefree(out);
- return NULL;
+ 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;
}
- defspec = tmpfspec;
- }
- rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
+ rms_set_dna(myfab, mynam,
+ (char *)def_spec, strlen(def_spec)); /* cast ok */
}
+ /* 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)
/* 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) {
+ 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;
+ if (retsts & STS$K_SUCCESS) goto int_expanded;
}
/* 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 (vmsdefspec != NULL)
+ PerlMem_free(vmsdefspec);
if (vmsfspec != NULL)
PerlMem_free(vmsfspec);
if (outbufl != 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 (vmsdefspec != NULL)
+ PerlMem_free(vmsdefspec);
if (vmsfspec != NULL)
PerlMem_free(vmsfspec);
if (outbufl != NULL)
/* If the input filespec contained any lowercase characters,
* downcase the result for compatibility with Unix-minded code. */
- expanded:
+int_expanded:
if (!decc_efs_case_preserve) {
+ char * tbuf;
for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
if (islower(*tbuf)) { haslower = 1; break; }
}
/* Is a long or a short name expected */
/*------------------------------------*/
+ spec_buf = NULL;
+#if !defined(__VAX) && defined(NAML$C_MAXRSS)
if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
if (rms_nam_rsll(mynam)) {
- tbuf = outbufl;
+ spec_buf = outbufl;
speclen = rms_nam_rsll(mynam);
}
else {
- tbuf = esal; /* Not esa */
+ spec_buf = esal; /* Not esa */
speclen = rms_nam_esll(mynam);
}
}
else {
+#endif
if (rms_nam_rsl(mynam)) {
- tbuf = outbuf;
+ spec_buf = outbuf;
speclen = rms_nam_rsl(mynam);
}
else {
- tbuf = esa; /* Not esal */
+ spec_buf = esa; /* Not esal */
speclen = rms_nam_esl(mynam);
}
+#if !defined(__VAX) && defined(NAML$C_MAXRSS)
}
- tbuf[speclen] = '\0';
+#endif
+ spec_buf[speclen] = '\0';
/* Trim off null fields added by $PARSE
* If type > 1 char, must have been specified in original or default spec
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_noperl(SS$_INSFMEM);
#endif
- struct FAB deffab = cc$rms_fab;
rms_setup_nam(defnam);
rms_bind_fab_nam(deffab, defnam);
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) - tbuf;
+ speclen = rms_nam_verl(mynam) - spec_buf;
}
else {
if (*(rms_nam_ver(mynam)) != '\"')
- speclen = rms_nam_ver(mynam) - tbuf;
+ 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) - tbuf)
+ if (speclen > rms_nam_verl(mynam) - spec_buf)
memmove
(rms_nam_typel(mynam),
rms_nam_verl(mynam),
- speclen - (rms_nam_verl(mynam) - tbuf));
+ speclen - (rms_nam_verl(mynam) - spec_buf));
speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
}
else {
- if (speclen > rms_nam_ver(mynam) - tbuf)
+ if (speclen > rms_nam_ver(mynam) - spec_buf)
memmove
(rms_nam_type(mynam),
rms_nam_ver(mynam),
- speclen - (rms_nam_ver(mynam) - tbuf));
+ speclen - (rms_nam_ver(mynam) - spec_buf));
speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
}
}
/*-------------------------------------------*/
if (vmsfspec != NULL)
PerlMem_free(vmsfspec);
- if (tmpfspec != NULL)
- PerlMem_free(tmpfspec);
+ 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 (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;
+ 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;
+ 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] = '\"';
+ 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. */
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) {
- 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;
- }
+ 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 strcpy(outbuf, tbuf);
}
- else if (isunix) {
- tmpfspec = PerlMem_malloc(VMS_MAXRSS);
- if (tmpfspec == NULL) _ckvmssts_noperl(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;
+ 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;
}
- 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 */
- PerlMem_free(esa);
+
+ /* Clean up the extra buffers */
if (esal != NULL)
- PerlMem_free(esal);
+ PerlMem_free(esal);
+ PerlMem_free(esa);
if (outbufl != NULL)
PerlMem_free(outbufl);
- return outbuf;
+
+ /* 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;
+ }
+ }
+
+
+ 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 */
** found in the Perl standard distribution.
*/
-/*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
-static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
+/*{{{ char * int_fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
+static char *
+int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl)
{
- static char __fileify_retbuf[VMS_MAXRSS];
unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
- char *retspec, *cp1, *cp2, *lastdir;
+ char *cp1, *cp2, *lastdir;
char *trndir, *vmsdir;
unsigned short int trnlnm_iter_count;
int is_vms = 0;
vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
cp1 = strpbrk(trndir,"]:>");
- if (hasfilename || !cp1) { /* Unix-style path or filename */
+ if (hasfilename || !cp1) { /* filename present or not VMS */
+
+ if (decc_efs_charset && !cp1) {
+
+ /* EFS handling for UNIX mode */
+
+ /* Just remove the trailing '/' and we should be done */
+ STRLEN trndir_len;
+ trndir_len = strlen(trndir);
+
+ if (trndir_len > 1) {
+ trndir_len--;
+ if (trndir[trndir_len] == '/') {
+ trndir[trndir_len] = '\0';
+ }
+ }
+ strcpy(buf, trndir);
+ PerlMem_free(trndir);
+ PerlMem_free(vmsdir);
+ return buf;
+ }
+
+ /* For non-EFS mode, this is left for backwards compatibility */
+ /* For EFS mode, this is only done for VMS format filespecs as */
+ /* Perl programs generally have problems when a UNIX format spec */
+ /* returns a VMS format spec */
if (trndir[0] == '.') {
if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
PerlMem_free(trndir);
PerlMem_free(vmsdir);
- return do_fileify_dirspec("[]",buf,ts,NULL);
+ return int_fileify_dirspec("[]", buf, NULL);
}
else if (trndir[1] == '.' &&
(trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
PerlMem_free(trndir);
PerlMem_free(vmsdir);
- return do_fileify_dirspec("[-]",buf,ts,NULL);
+ return int_fileify_dirspec("[-]", buf, NULL);
}
}
if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);
return NULL;
}
- if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
+ if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
PerlMem_free(trndir);
PerlMem_free(vmsdir);
return NULL;
}
- ret_chr = do_tounixspec(trndir,buf,ts,NULL);
+ ret_chr = int_tounixspec(trndir, buf, utf8_fl);
PerlMem_free(trndir);
PerlMem_free(vmsdir);
return ret_chr;
PerlMem_free(vmsdir);
return NULL;
}
- if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
+ if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
PerlMem_free(trndir);
PerlMem_free(vmsdir);
return NULL;
}
- ret_chr = do_tounixspec(trndir,buf,ts,NULL);
+ ret_chr = int_tounixspec(trndir, buf, utf8_fl);
PerlMem_free(trndir);
PerlMem_free(vmsdir);
return ret_chr;
if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
!(lastdir = cp1 = strrchr(trndir,']')) &&
!(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
- if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
- int ver; char *cp3;
- /* For EFS or ODS-5 look for the last dot */
- if (decc_efs_charset) {
- cp2 = strrchr(cp1,'.');
- }
- if (vms_process_case_tolerant) {
- if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
- !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
- !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
- (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
- (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
- (ver || *cp3)))))) {
- PerlMem_free(trndir);
- PerlMem_free(vmsdir);
- set_errno(ENOTDIR);
- set_vaxc_errno(RMS$_DIR);
- return NULL;
- }
- }
- else {
- if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
- !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
- !*(cp2+3) || *(cp2+3) != 'R' ||
- (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
- (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
- (ver || *cp3)))))) {
- PerlMem_free(trndir);
- PerlMem_free(vmsdir);
- set_errno(ENOTDIR);
- set_vaxc_errno(RMS$_DIR);
- return NULL;
- }
- }
- dirlen = cp2 - trndir;
+ cp2 = strrchr(cp1,'.');
+ if (cp2) {
+ int e_len, vs_len = 0;
+ int is_dir = 0;
+ char * cp3;
+ cp3 = strchr(cp2,';');
+ e_len = strlen(cp2);
+ if (cp3) {
+ vs_len = strlen(cp3);
+ e_len = e_len - vs_len;
+ }
+ is_dir = is_dir_ext(cp2, e_len, cp3, vs_len);
+ if (!is_dir) {
+ if (!decc_efs_charset) {
+ /* If this is not EFS, then not a directory */
+ PerlMem_free(trndir);
+ PerlMem_free(vmsdir);
+ set_errno(ENOTDIR);
+ set_vaxc_errno(RMS$_DIR);
+ return NULL;
+ }
+ } else {
+ /* Ok, here we have an issue, technically if a .dir shows */
+ /* from inside a directory, then we should treat it as */
+ /* xxx^.dir.dir. But we do not have that context at this */
+ /* point unless this is totally restructured, so we remove */
+ /* The .dir for now, and fix this better later */
+ dirlen = cp2 - trndir;
+ }
}
+
}
retlen = dirlen + 6;
- if (buf) retspec = buf;
- else if (ts) Newx(retspec,retlen+1,char);
- else retspec = __fileify_retbuf;
- memcpy(retspec,trndir,dirlen);
- retspec[dirlen] = '\0';
+ memcpy(buf, trndir, dirlen);
+ buf[dirlen] = '\0';
/* We've picked up everything up to the directory file name.
Now just add the type and version, and we're set. */
if ((!decc_efs_case_preserve) && vms_process_case_tolerant) {
/* Traditionally Perl expects filenames in lower case */
- strcat(retspec, ".dir");
+ strcat(buf, ".dir");
} else {
/* VMS expects the .DIR to be in upper case */
- strcat(retspec, ".DIR");
+ strcat(buf, ".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");
+ strcat(buf, ";1");
}
PerlMem_free(trndir);
PerlMem_free(vmsdir);
- return retspec;
+ return buf;
}
else { /* VMS-style directory spec */
for (cp = trndir; *cp; cp++)
if (islower(*cp)) { haslower = 1; break; }
if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
- if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
- rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
- sts = sys$parse(&dirfab) & STS$K_SUCCESS;
+ if ((dirfab.fab$l_sts == RMS$_DIR) ||
+ (dirfab.fab$l_sts == RMS$_DNF) ||
+ (dirfab.fab$l_sts == RMS$_PRV)) {
+ rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
+ sts = sys$parse(&dirfab);
}
if (!sts) {
PerlMem_free(esa);
/* Does the file really exist? */
if (sys$search(&dirfab)& STS$K_SUCCESS) {
/* Yes; fake the fnb bits so we'll check type below */
- rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
+ rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
}
else { /* No; just work with potential name */
if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
}
/* Make sure we are using the right buffer */
+#if !defined(__VAX) && defined(NAML$C_MAXRSS)
if (esal != NULL) {
my_esa = esal;
my_esa_len = rms_nam_esll(dirnam);
} else {
+#endif
my_esa = esa;
my_esa_len = rms_nam_esl(dirnam);
+#if !defined(__VAX) && defined(NAML$C_MAXRSS)
}
+#endif
my_esa[my_esa_len] = '\0';
if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
cp1 = strchr(my_esa,']');
if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
/* They provided at least the name; we added the type, if necessary, */
- if (buf) retspec = buf; /* in sys$parse() */
- else if (ts) Newx(retspec, my_esa_len + 1, char);
- else retspec = __fileify_retbuf;
- strcpy(retspec,my_esa);
+ strcpy(buf, my_esa);
sts = rms_free_search_context(&dirfab);
PerlMem_free(trndir);
PerlMem_free(esa);
if (esal != NULL)
PerlMem_free(esal);
PerlMem_free(vmsdir);
- return retspec;
+ return buf;
}
if ((cp1 = strstr(esa,".][000000]")) != NULL) {
for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
if ((cp1) != NULL) {
/* There's more than one directory in the path. Just roll back. */
*cp1 = term;
- if (buf) retspec = buf;
- else if (ts) Newx(retspec,retlen+7,char);
- else retspec = __fileify_retbuf;
- strcpy(retspec,my_esa);
+ strcpy(buf, my_esa);
}
else {
if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
}
retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
- if (buf) retspec = buf;
- else if (ts) Newx(retspec,retlen+16,char);
- else retspec = __fileify_retbuf;
cp1 = strstr(my_esa,"][");
if (!cp1) cp1 = strstr(my_esa,"]<");
dirlen = cp1 - my_esa;
- memcpy(retspec,my_esa,dirlen);
+ memcpy(buf, my_esa, dirlen);
if (!strncmp(cp1+2,"000000]",7)) {
- retspec[dirlen-1] = '\0';
+ buf[dirlen-1] = '\0';
/* fix-me Not full ODS-5, just extra dots in directories for now */
- cp1 = retspec + dirlen - 1;
- while (cp1 > retspec)
+ cp1 = buf + dirlen - 1;
+ while (cp1 > buf)
{
if (*cp1 == '[')
break;
}
if (*cp1 == '.') *cp1 = ']';
else {
- memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
+ memmove(cp1+8, cp1+1, buf+dirlen-cp1);
memmove(cp1+1,"000000]",7);
}
}
else {
- memmove(retspec+dirlen,cp1+2,retlen-dirlen);
- retspec[retlen] = '\0';
+ memmove(buf+dirlen, cp1+2, retlen-dirlen);
+ buf[retlen] = '\0';
/* Convert last '.' to ']' */
- cp1 = retspec+retlen-1;
+ cp1 = buf+retlen-1;
while (*cp != '[') {
cp1--;
if (*cp1 == '.') {
/* Do not trip on extra dots in ODS-5 directories */
- if ((cp1 == retspec) || (*(cp1-1) != '^'))
+ if ((cp1 == buf) || (*(cp1-1) != '^'))
break;
}
}
if (*cp1 == '.') *cp1 = ']';
else {
- memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
+ memmove(cp1+8, cp1+1, buf+dirlen-cp1);
memmove(cp1+1,"000000]",7);
}
}
}
else { /* This is a top-level dir. Add the MFD to the path. */
- if (buf) retspec = buf;
- else if (ts) Newx(retspec,retlen+16,char);
- else retspec = __fileify_retbuf;
cp1 = my_esa;
- cp2 = retspec;
+ cp2 = buf;
while ((*cp1 != ':') && (*cp1 != '\0')) *(cp2++) = *(cp1++);
strcpy(cp2,":[000000]");
cp1 += 2;
sts = rms_free_search_context(&dirfab);
/* We've set up the string up through the filename. Add the
type and version, and we're done. */
- strcat(retspec,".DIR;1");
+ strcat(buf,".DIR;1");
/* $PARSE may have upcased filespec, so convert output to lower
* case if input contained any lowercase characters. */
- if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
+ if (haslower && !decc_efs_case_preserve) __mystrtolower(buf);
PerlMem_free(trndir);
PerlMem_free(esa);
if (esal != NULL)
PerlMem_free(esal);
PerlMem_free(vmsdir);
- return retspec;
+ return buf;
}
+} /* end of int_fileify_dirspec() */
+
+
+/*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
+static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
+{
+ static char __fileify_retbuf[VMS_MAXRSS];
+ char * fileified, *ret_spec, *ret_buf;
+
+ fileified = NULL;
+ ret_buf = buf;
+ if (ret_buf == NULL) {
+ if (ts) {
+ Newx(fileified, VMS_MAXRSS, char);
+ if (fileified == NULL)
+ _ckvmssts(SS$_INSFMEM);
+ ret_buf = fileified;
+ } else {
+ ret_buf = __fileify_retbuf;
+ }
+ }
+
+ ret_spec = int_fileify_dirspec(dir, ret_buf, utf8_fl);
+
+ if (ret_spec == NULL) {
+ /* Cleanup on isle 5, if this is thread specific we need to deallocate */
+ if (fileified)
+ Safefree(fileified);
+ }
+
+ return ret_spec;
} /* end of do_fileify_dirspec() */
/*}}}*/
+
/* External entry points */
char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
{ return do_fileify_dirspec(dir,buf,0,NULL); }
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);
- /* At this point we do not work with *dir, but the copy in
- * *trndir that is modifiable.
- */
+ /* Trap simple rooted lnms, and return lnm:[000000] */
+ if (!strcmp(trndir+trnlen-2,".]")) {
+ strcpy(buf, dir);
+ strcat(buf, ":[000000]");
+ PerlMem_free(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;
-
- /* 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;
+ if (vms_debug_fileify) {
+ fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf);
+ }
+ return buf;
}
- else { /* No file type present. Treat the filename as a directory. */
- retlen = strlen(trndir) + 1;
+ }
+
+ /* At this point we do not work with *dir, but the copy in *trndir */
+
+ if (need_to_lower && !decc_efs_case_preserve) {
+ /* Legacy mode, lower case the returned value */
+ __mystrtolower(trndir);
+ }
+
+
+ /* 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 (ret_spec != NULL) {
+ PerlMem_free(trndir);
+ if (vms_debug_fileify) {
+ fprintf(stderr,
+ "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
+ }
+ return ret_spec;
+ }
- /* 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;
- }
- }
+ /* 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;
+ }
}
- else { /* No file type, so just draw name into directory part */
- for (cp2 = cp1; *cp2; cp2++) ;
+ 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);
}
- *cp2 = *cp1;
- *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
- *cp1 = '.';
- /* We've now got a VMS 'path'; fall through */
- }
+ 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;
+
+ /* '.dir' is discarded, and any other '.' is invalid */
+ e_len = strlen(lastdot);
- 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;
+ 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);
+ }
+ return ret_spec;
+ }
+}
+
+/*{{{ 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;
}
- }
- /* 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);
- }
+ }
- /* Null terminate the buffer */
- my_esa[my_esa_len] = '\0';
+ ret_spec = int_pathify_dirspec(dir, ret_buf);
- /* 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);
+ 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); }
char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
{ return do_pathify_dirspec(dir,buf,1,utf8_fl); }
-/*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
-static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
+/* Internal tounixspec routine that does not use a thread context */
+/*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
+static char *int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
{
- static char __tounixspec_retbuf[VMS_MAXRSS];
- char *dirend, *rslt, *cp1, *cp3, *tmp;
+ char *dirend, *cp1, *cp3, *tmp;
const char *cp2;
int devlen, dirlen, retlen = VMS_MAXRSS;
int expand = 1; /* guarantee room for leading and trailing slashes */
if (utf8_fl != NULL)
*utf8_fl = 0;
- if (spec == NULL) return NULL;
- if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
- if (buf) rslt = buf;
- else if (ts) {
- Newx(rslt, VMS_MAXRSS, char);
+ if (vms_debug_fileify) {
+ if (spec == NULL)
+ fprintf(stderr, "int_tounixspec: spec = NULL\n");
+ else
+ fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
+ }
+
+
+ if (spec == NULL) {
+ set_errno(EINVAL);
+ set_vaxc_errno(SS$_BADPARAM);
+ return NULL;
+ }
+ if (strlen(spec) > (VMS_MAXRSS-1)) {
+ set_errno(E2BIG);
+ set_vaxc_errno(SS$_BUFFEROVF);
+ return NULL;
}
- else rslt = __tounixspec_retbuf;
/* New VMS specific format needs translation
* glob passes filenames with trailing '\n' and expects this preserved.
/* This is already UNIX or at least nothing VMS understands */
if (cmp_rslt) {
strcpy(rslt,spec);
+ if (vms_debug_fileify) {
+ fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
+ }
return rslt;
}
if (dirend == NULL) dirend = strchr(spec,':');
if (dirend == NULL) {
strcpy(rslt,spec);
+ if (vms_debug_fileify) {
+ fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
+ }
return rslt;
}
}
else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
- if (ts) Safefree(rslt);
PerlMem_free(tmp);
+ if (vms_debug_fileify) {
+ fprintf(stderr, "int_tounixspec: rslt = NULL\n");
+ }
return NULL;
}
trnlnm_iter_count = 0;
trnlnm_iter_count++;
if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
} while (vmstrnenv(tmp,tmp,0,fildev,0));
- if (ts && !buf &&
- ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
- retlen = devlen + dirlen;
- Renew(rslt,retlen+1+2*expand,char);
- cp1 = rslt;
- }
+ cp1 = rslt;
cp3 = tmp;
*(cp1++) = '/';
while (*cp3) {
*(cp1++) = *(cp3++);
- if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
+ if (cp1 - rslt > (VMS_MAXRSS - 1)) {
PerlMem_free(tmp);
+ set_errno(ENAMETOOLONG);
+ set_vaxc_errno(SS$_BUFFEROVF);
+ if (vms_debug_fileify) {
+ fprintf(stderr, "int_tounixspec: rslt = NULL\n");
+ }
return NULL; /* No room */
}
}
*(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
}
if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
- if (ts) Safefree(rslt); /* filespecs like */
+ /* filespecs like */
set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
+ if (vms_debug_fileify) {
+ fprintf(stderr, "int_tounixspec: rslt = NULL\n");
+ }
return NULL;
}
}
}
else *(cp1++) = *cp2;
}
+ /* Translate the rest of the filename. */
while (*cp2) {
- if ((*cp2 == '^') && (*(cp2+1) == '.')) cp2++; /* '^.' --> '.' */
- *(cp1++) = *(cp2++);
+ int dot_seen;
+ dot_seen = 0;
+ switch(*cp2) {
+ /* Fixme - for compatibility with the CRTL we should be removing */
+ /* spaces from the file specifications, but this may show that */
+ /* some tests that were appearing to pass are not really passing */
+ case '%':
+ cp2++;
+ *(cp1++) = '?';
+ break;
+ case '^':
+ /* Fix me hex expansions not implemented */
+ cp2++; /* '^.' --> '.' and other. */
+ if (*cp2) {
+ if (*cp2 == '_') {
+ cp2++;
+ *(cp1++) = ' ';
+ } else {
+ *(cp1++) = *(cp2++);
+ }
+ }
+ break;
+ case ';':
+ if (decc_filename_unix_no_version) {
+ /* Easy, drop the version */
+ while (*cp2)
+ cp2++;
+ break;
+ } else {
+ /* Punt - passing the version as a dot will probably */
+ /* break perl in weird ways, but so did passing */
+ /* through the ; as a version. Follow the CRTL and */
+ /* hope for the best. */
+ cp2++;
+ *(cp1++) = '.';
+ }
+ break;
+ case '.':
+ if (dot_seen) {
+ /* We will need to fix this properly later */
+ /* As Perl may be installed on an ODS-5 volume, but not */
+ /* have the EFS_CHARSET enabled, it still may encounter */
+ /* filenames with extra dots in them, and a precedent got */
+ /* set which allowed them to work, that we will uphold here */
+ /* If extra dots are present in a name and no ^ is on them */
+ /* VMS assumes that the first one is the extension delimiter */
+ /* the rest have an implied ^. */
+
+ /* this is also a conflict as the . is also a version */
+ /* delimiter in VMS, */
+
+ *(cp1++) = *(cp2++);
+ break;
+ }
+ dot_seen = 1;
+ /* This is an extension */
+ if (decc_readdir_dropdotnotype) {
+ cp2++;
+ if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
+ /* Drop the dot for the extension */
+ break;
+ } else {
+ *(cp1++) = '.';
+ }
+ break;
+ }
+ default:
+ *(cp1++) = *(cp2++);
+ }
}
*cp1 = '\0';
}
}
+ if (vms_debug_fileify) {
+ fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
+ }
return rslt;
+} /* end of int_tounixspec() */
+
+
+/*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
+static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
+{
+ static char __tounixspec_retbuf[VMS_MAXRSS];
+ char * unixspec, *ret_spec, *ret_buf;
+
+ unixspec = NULL;
+ ret_buf = buf;
+ if (ret_buf == NULL) {
+ if (ts) {
+ Newx(unixspec, VMS_MAXRSS, char);
+ if (unixspec == NULL)
+ _ckvmssts(SS$_INSFMEM);
+ ret_buf = unixspec;
+ } else {
+ ret_buf = __tounixspec_retbuf;
+ }
+ }
+
+ ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
+
+ if (ret_spec == NULL) {
+ /* Cleanup on isle 5, if this is thread specific we need to deallocate */
+ if (unixspec)
+ Safefree(unixspec);
+ }
+
+ return ret_spec;
+
} /* end of do_tounixspec() */
/*}}}*/
/* External entry points */
* special device files.
*/
- if ((add_6zero == 0) && (*nextslash == '/') &&
+ if (!islnm && (add_6zero == 0) && (*nextslash == '/') &&
(&nextslash[1] == unixend)) {
/* No real directory present */
add_6zero = 1;
vmsptr2 = vmsptr - 1;
if ((vmslen > 1) &&
(*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
- (*vmsptr2 != ')') && (*lastdot != '.')) {
+ (*vmsptr2 != ')') && (*lastdot != '.') && (*vmsptr2 != ':')) {
*vmsptr++ = '.';
vmslen++;
}
}
}
-/* If POSIX mode active, handle the conversion */
+/* If EFS charset 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);
char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
{ return do_tovmsspec(path,buf,1,utf8_fl); }
+/*{{{ char *int_tovmspath(char *path, char *buf, const int *)*/
+/* Internal routine for use with out an explict context present */
+static char * int_tovmspath(const char *path, char *buf, int * utf8_fl) {
+
+ char * ret_spec, *pathified;
+
+ if (path == NULL)
+ return NULL;
+
+ pathified = PerlMem_malloc(VMS_MAXRSS);
+ if (pathified == NULL)
+ _ckvmssts_noperl(SS$_INSFMEM);
+
+ ret_spec = int_pathify_dirspec(path, pathified);
+
+ if (ret_spec == NULL) {
+ PerlMem_free(pathified);
+ return NULL;
+ }
+
+ ret_spec = int_tovmsspec(pathified, buf, 0, utf8_fl);
+
+ PerlMem_free(pathified);
+ return ret_spec;
+
+}
+
/*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
static char __tovmspath_retbuf[VMS_MAXRSS];
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;
}
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;
}
/* Input from a pipe, reopen it in binary mode to disable */
/* carriage control processing. */
- fgetname(stdin, mbxname);
+ fgetname(stdin, mbxname, 1);
mbxnam.dsc$a_pointer = mbxname;
mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
vms_image_init(int *argcp, char ***argvp)
{
int status;
- char val_str[10];
char eqv[LNM$C_NAMLENGTH+1] = "";
unsigned int len, tabct = 8, tabidx = 0;
unsigned long int *mask, iosb[2], i, rlst[128], rsz;
Perl_csighandler_init();
#endif
+#if __CRTL_VER >= 70300000 && !defined(__VAX)
/* This was moved from the pre-image init handler because on threaded */
/* Perl it was always returning 0 for the default value. */
- status = simple_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
+ status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH);
if (status > 0) {
int s;
s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
if (s > 0) {
int initial;
initial = decc$feature_get_value(s, 4);
- if (initial >= 0) {
- /* initial is -1 if nothing has set the feature */
- /* initial is 1 if the logical name is present */
+ if (initial > 0) {
+ /* initial is: 0 if nothing has set the feature */
+ /* -1 if initialized to default */
+ /* 1 if set by logical name */
+ /* 2 if set by decc$feature_set_value */
decc_disable_posix_root = decc$feature_get_value(s, 1);
/* If the value is not valid, force the feature off */
}
}
else {
- /* Traditionally Perl assumes this is off */
+ /* Nothing has asked for it explicitly, so use our own default. */
decc_disable_posix_root = 1;
decc$feature_set_value(s, 1, 1);
}
}
}
-
+#endif
_ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
_ckvmssts_noperl(iosb[0]);
if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
template = unixwild;
if (strpbrk(wildspec,"]>:") != NULL) {
- if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
+ if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
PerlMem_free(unixwild);
return 0;
}
unixified = PerlMem_malloc(VMS_MAXRSS);
if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
if (strpbrk(fspec,"]>:") != NULL) {
- if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
+ if (int_tounixspec(fspec, unixified, NULL) == NULL) {
PerlMem_free(unixwild);
PerlMem_free(unixified);
return 0;
Stat_t sb;
Newx(dir, VMS_MAXRSS, char);
- if (do_tovmspath(name,dir,0,NULL) == NULL) {
+ if (int_tovmspath(name, dir, NULL) == NULL) {
Safefree(dir);
return NULL;
}
/* In Unix report mode, remove the ".dir;1" from the name */
/* if it is a real directory. */
if (decc_filename_unix_report || decc_efs_charset) {
- if ((e_len == 4) && (vs_len == 2) && (vs_spec[1] == '1')) {
- if ((toupper(e_spec[1]) == 'D') &&
- (toupper(e_spec[2]) == 'I') &&
- (toupper(e_spec[3]) == 'R')) {
- Stat_t statbuf;
- int ret_sts;
-
- ret_sts = stat(buff, (stat_t *)&statbuf);
- if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
- e_len = 0;
- e_spec[0] = 0;
- }
+ if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
+ Stat_t statbuf;
+ int ret_sts;
+
+ ret_sts = flex_lstat(buff, &statbuf);
+ if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
+ e_len = 0;
+ e_spec[0] = 0;
}
}
}
/* Try to find the exact program requested to be run */
/*---------------------------------------------------*/
- iname = do_rmsexpand
- (tmpspec, image_name, 0, ".exe",
+ iname = int_rmsexpand
+ (tmpspec, image_name, ".exe",
PERL_RMSEXPAND_M_VMS, NULL, NULL);
if (iname != NULL) {
if (cando_by_name_int
else {
/* Try again with a null type */
/*----------------------------*/
- iname = do_rmsexpand
- (tmpspec, image_name, 0, ".",
+ iname = int_rmsexpand
+ (tmpspec, image_name, ".",
PERL_RMSEXPAND_M_VMS, NULL, NULL);
if (iname != NULL) {
if (cando_by_name_int
memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
sockflagsize = fdoff + 2;
}
- if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
+ if (fstat(fd, &sbuf.crtl_stat) == 0 && S_ISSOCK(sbuf.st_mode))
sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
}
return fp;
}
/*}}}*/
+/* fgetname() is not returning the correct file specifications when
+ * decc_filename_unix_report mode is active. So we have to have it
+ * aways return filenames in VMS mode and convert it ourselves.
+ */
+
+/*{{{ char * my_fgetname(FILE *fp, buf)*/
+char *
+Perl_my_fgetname(FILE *fp, char * buf) {
+ char * retname;
+ char * vms_name;
+
+ retname = fgetname(fp, buf, 1);
+
+ /* If we are in VMS mode, then we are done */
+ if (!decc_filename_unix_report || (retname == NULL)) {
+ return retname;
+ }
+
+ /* Convert this to Unix format */
+ vms_name = PerlMem_malloc(VMS_MAXRSS + 1);
+ strcpy(vms_name, retname);
+ retname = int_tounixspec(vms_name, buf, NULL);
+ PerlMem_free(vms_name);
+
+ return retname;
+}
+/*}}}*/
+
/*
* Here are replacements for the following Unix routines in the VMS environment:
* getpwuid Get information for a particular UIC or UID
}
/* Convert to VMS format ensuring that it will fit in 255 characters */
- if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
+ if (int_rmsexpand_tovms(file, vmsspec, 0) == NULL) {
SETERRNO(ENOENT, LIB$_INVARG);
return -1;
}
return (*name++ == ':') && (*name != ':');
}
+static int
+Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag);
+
+#define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
static I32
Perl_cando_by_name_int
}
/* sys$check_access needs a file spec, not a directory spec.
- * Don't use flex_stat here, as that depends on thread context
- * having been initialized, and we may get here during startup.
+ * flex_stat now will handle a null thread context during startup.
*/
retlen = namdsc.dsc$w_length = strlen(vmsname);
if (vmsname[retlen-1] == ']'
|| vmsname[retlen-1] == '>'
|| vmsname[retlen-1] == ':'
- || (!stat(vmsname, (stat_t *)&st) && S_ISDIR(st.st_mode))) {
+ || (!flex_stat_int(vmsname, &st, 1) &&
+ S_ISDIR(st.st_mode))) {
- if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) {
+ if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
PerlMem_free(fileified);
PerlMem_free(vmsname);
return FALSE;
int
Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
{
- if (!fstat(fd,(stat_t *) statbufp)) {
+ if (!fstat(fd, &statbufp->crtl_stat)) {
char *cptr;
char *vms_filename;
vms_filename = PerlMem_malloc(VMS_MAXRSS);
}
else {
/* Make sure that the saved name fits in 255 characters */
- cptr = do_rmsexpand
+ cptr = int_rmsexpand_vms
(vms_filename,
statbufp->st_devnam,
- 0,
- NULL,
- PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
- NULL,
- NULL);
+ 0);
if (cptr == NULL)
statbufp->st_devnam[0] = 0;
}
} /* end of flex_fstat() */
/*}}}*/
-#if !defined(__VAX) && __CRTL_VER >= 80200000
-#ifdef lstat
-#undef lstat
-#endif
-#else
-#ifdef lstat
-#undef lstat
-#endif
-#define lstat(_x, _y) stat(_x, _y)
-#endif
-
-#define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
-
static int
Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
{
- char fileified[VMS_MAXRSS];
- char temp_fspec[VMS_MAXRSS];
- char *save_spec;
+ char *fileified;
+ char *temp_fspec;
+ const char *save_spec;
+ char *ret_spec;
int retval = -1;
+ int efs_hack = 0;
dSAVEDERRNO;
- if (!fspec) return retval;
- SAVE_ERRNO;
- strcpy(temp_fspec, fspec);
+ if (!fspec) {
+ errno = EINVAL;
+ return retval;
+ }
if (decc_bug_devnull != 0) {
- if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
+ if (is_null_device(fspec)) { /* Fake a stat() for the null device */
memset(statbufp,0,sizeof *statbufp);
VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
*/
-#if __CRTL_VER >= 70300000 && !defined(__VAX)
- /* The CRTL stat() falls down hard on multi-dot filenames in unix format unless
- * DECC$EFS_CHARSET is in effect, so temporarily enable it if it isn't already.
- */
- if (!decc_efs_charset)
- decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,1);
-#endif
+ fileified = PerlMem_malloc(VMS_MAXRSS);
+ if (fileified == NULL)
+ _ckvmssts_noperl(SS$_INSFMEM);
+
+ temp_fspec = PerlMem_malloc(VMS_MAXRSS);
+ if (temp_fspec == NULL)
+ _ckvmssts_noperl(SS$_INSFMEM);
+
+ strcpy(temp_fspec, fspec);
+
+ SAVE_ERRNO;
#if __CRTL_VER >= 80200000 && !defined(__VAX)
if (decc_posix_compliant_pathnames == 0) {
#endif
- if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
- if (lstat_flag == 0)
- retval = stat(fileified,(stat_t *) statbufp);
- else
- retval = lstat(fileified,(stat_t *) statbufp);
- save_spec = fileified;
+
+ /* We may be able to optimize this, but in order for fileify_dirspec to
+ * always return a usuable answer, we have to call vmspath first to
+ * make sure that it is in VMS directory format, as stat/lstat on 8.3
+ * can not handle directories in unix format that it does not have read
+ * access to. Vmspath handles the case where a bare name which could be
+ * a logical name gets passed.
+ */
+ ret_spec = int_tovmspath(fspec, temp_fspec, NULL);
+ if (ret_spec != NULL) {
+ ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
+ if (ret_spec != NULL) {
+ if (lstat_flag == 0)
+ retval = stat(fileified, &statbufp->crtl_stat);
+ else
+ retval = lstat(fileified, &statbufp->crtl_stat);
+ save_spec = fileified;
+ }
}
- if (retval) {
- if (lstat_flag == 0)
- retval = stat(temp_fspec,(stat_t *) statbufp);
- else
- retval = lstat(temp_fspec,(stat_t *) statbufp);
- save_spec = temp_fspec;
+
+ if (retval && vms_bug_stat_filename) {
+
+ /* We should try again as a vmsified file specification */
+ /* However Perl traditionally has not done this, which */
+ /* causes problems with existing tests */
+
+ ret_spec = int_tovmsspec(fspec, temp_fspec, 0, NULL);
+ if (ret_spec != NULL) {
+ if (lstat_flag == 0)
+ retval = stat(temp_fspec, &statbufp->crtl_stat);
+ else
+ retval = lstat(temp_fspec, &statbufp->crtl_stat);
+ save_spec = temp_fspec;
+ }
}
-/*
- * In debugging, on 8.3 Alpha, I found a case where stat was returning a
- * file not found error for a directory named foo:[bar.t] or /foo/bar/t
- * and lstat was working correctly for the same file.
- * The only syntax that was working for stat was "foo:[bar]t.dir".
- *
- * Other directories with the same syntax worked fine.
- * So work around the problem when it shows up here.
- */
+
if (retval) {
- int save_errno = errno;
- if (do_tovmsspec(fspec, temp_fspec, 0, NULL) != NULL) {
- if (do_fileify_dirspec(temp_fspec, fileified, 0, NULL) != NULL) {
- retval = stat(fileified, (stat_t *) statbufp);
- save_spec = fileified;
- }
- }
- /* Restore the errno value if third stat does not succeed */
- if (retval != 0)
- errno = save_errno;
+ /* Last chance - allow multiple dots with out EFS CHARSET */
+ /* The CRTL stat() falls down hard on multi-dot filenames in unix
+ * format unless * DECC$EFS_CHARSET is in effect, so temporarily
+ * enable it if it isn't already.
+ */
+#if __CRTL_VER >= 70300000 && !defined(__VAX)
+ if (!decc_efs_charset && (decc_efs_charset_index > 0))
+ decc$feature_set_value(decc_efs_charset_index, 1, 1);
+#endif
+ if (lstat_flag == 0)
+ retval = stat(fspec, &statbufp->crtl_stat);
+ else
+ retval = lstat(fspec, &statbufp->crtl_stat);
+ save_spec = fspec;
+#if __CRTL_VER >= 70300000 && !defined(__VAX)
+ if (!decc_efs_charset && (decc_efs_charset_index > 0)) {
+ decc$feature_set_value(decc_efs_charset_index, 1, 0);
+ efs_hack = 1;
+ }
+#endif
}
+
#if __CRTL_VER >= 80200000 && !defined(__VAX)
} else {
if (lstat_flag == 0)
- retval = stat(temp_fspec,(stat_t *) statbufp);
+ retval = stat(temp_fspec, &statbufp->crtl_stat);
else
- retval = lstat(temp_fspec,(stat_t *) statbufp);
+ retval = lstat(temp_fspec, &statbufp->crtl_stat);
save_spec = temp_fspec;
}
#endif
if (lstat_flag)
rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
- cptr = do_rmsexpand
- (save_spec, statbufp->st_devnam, 0, NULL, rmsex_flags, NULL, NULL);
+#if __CRTL_VER >= 70300000 && !defined(__VAX)
+ /* If we used the efs_hack above, we must also use it here for */
+ /* perl_cando to work */
+ if (efs_hack && (decc_efs_charset_index > 0)) {
+ decc$feature_set_value(decc_efs_charset_index, 1, 1);
+ }
+#endif
+ cptr = int_rmsexpand_tovms(save_spec, statbufp->st_devnam, rmsex_flags);
+#if __CRTL_VER >= 70300000 && !defined(__VAX)
+ if (efs_hack && (decc_efs_charset_index > 0)) {
+ decc$feature_set_value(decc_efs_charset, 1, 0);
+ }
+#endif
+
+ /* Fix me: If this is NULL then stat found a file, and we could */
+ /* not convert the specification to VMS - Should never happen */
if (cptr == NULL)
statbufp->st_devnam[0] = 0;
unsigned long hasver = 0, isunix = 0;
unsigned long int lff_flags = 0;
int rms_sts;
+ int vms_old_glob = 1;
if (!SvOK(tmpglob)) {
SETERRNO(ENOENT,RMS$_FNF);
return NULL;
}
+ vms_old_glob = !decc_filename_unix_report;
+
#ifdef VMS_LONGNAME_SUPPORT
lff_flags = LIB$M_FIL_LONG_NAMES;
#endif
break;
}
}
+
+ /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
+ if ((hasdir == 0) && decc_filename_unix_report) {
+ isunix = 1;
+ }
+
if ((tmpfp = PerlIO_tmpfile()) != NULL) {
+ char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
+ int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
+ int wildstar = 0;
+ int wildquery = 0;
int found = 0;
Stat_t st;
int stat_sts;
stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
if (!stat_sts && S_ISDIR(st.st_mode)) {
- wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
- ok = (wilddsc.dsc$a_pointer != NULL);
- /* maybe passed 'foo' rather than '[.foo]', thus not detected above */
- hasdir = 1;
+ char * vms_dir;
+ const char * fname;
+ STRLEN fname_len;
+
+ /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
+ /* path delimiter of ':>]', if so, then the old behavior has */
+ /* obviously been specificially requested */
+
+ fname = SvPVX_const(tmpglob);
+ fname_len = strlen(fname);
+ vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
+ if (vms_old_glob || (vms_dir != NULL)) {
+ wilddsc.dsc$a_pointer = tovmspath_utf8(
+ SvPVX(tmpglob),vmsspec,NULL);
+ ok = (wilddsc.dsc$a_pointer != NULL);
+ /* maybe passed 'foo' rather than '[.foo]', thus not
+ detected above */
+ hasdir = 1;
+ } else {
+ /* Operate just on the directory, the special stat/fstat for */
+ /* leaves the fileified specification in the st_devnam */
+ /* member. */
+ wilddsc.dsc$a_pointer = st.st_devnam;
+ ok = 1;
+ }
}
else {
wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
/* If not extended character set, replace ? with % */
/* With extended character set, ? is a wildcard single character */
- if (!decc_efs_case_preserve) {
- for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
- if (*cp == '?') *cp = '%';
+ for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
+ if (*cp == '?') {
+ wildquery = 1;
+ if (!decc_efs_case_preserve)
+ *cp = '%';
+ } else if (*cp == '%') {
+ wildquery = 1;
+ } else if (*cp == '*') {
+ wildstar = 1;
+ }
}
+
+ if (ok) {
+ wv_sts = vms_split_path(
+ wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
+ &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
+ &wvs_spec, &wvs_len);
+ } else {
+ wn_spec = NULL;
+ wn_len = 0;
+ we_spec = NULL;
+ we_len = 0;
+ }
+
sts = SS$_NORMAL;
while (ok && $VMS_STATUS_SUCCESS(sts)) {
char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
+ int valid_find;
+ valid_find = 0;
sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
&dfltdsc,NULL,&rms_sts,&lff_flags);
if (!$VMS_STATUS_SUCCESS(sts))
break;
- found++;
-
/* with varying string, 1st word of buffer contains result length */
rstr[rslt->length] = '\0';
if (!hasver && (vs_len > 0)) {
*vs_spec = '\0';
vs_len = 0;
+ }
+
+ if (isunix) {
+
+ /* In Unix report mode, remove the ".dir;1" from the name */
+ /* if it is a real directory */
+ if (decc_filename_unix_report || decc_efs_charset) {
+ if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
+ Stat_t statbuf;
+ int ret_sts;
+
+ ret_sts = flex_lstat(rstr, &statbuf);
+ if ((ret_sts == 0) &&
+ S_ISDIR(statbuf.st_mode)) {
+ e_len = 0;
+ e_spec[0] = 0;
+ }
+ }
+ }
/* No version & a null extension on UNIX handling */
- if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
+ if ((e_len == 1) && decc_readdir_dropdotnotype) {
e_len = 0;
*e_spec = '\0';
}
for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
}
- if (hasdir) {
- if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
- begin = rstr;
- }
- else {
- /* Start with the name */
- begin = n_spec;
- }
- strcat(begin,"\n");
- ok = (PerlIO_puts(tmpfp,begin) != EOF);
+ /* Find File treats a Null extension as return all extensions */
+ /* This is contrary to Perl expectations */
+
+ if (wildstar || wildquery || vms_old_glob) {
+ /* really need to see if the returned file name matched */
+ /* but for now will assume that it matches */
+ valid_find = 1;
+ } else {
+ /* Exact Match requested */
+ /* How are directories handled? - like a file */
+ if ((e_len == we_len) && (n_len == wn_len)) {
+ int t1;
+ t1 = e_len;
+ if (t1 > 0)
+ t1 = strncmp(e_spec, we_spec, e_len);
+ if (t1 == 0) {
+ t1 = n_len;
+ if (t1 > 0)
+ t1 = strncmp(n_spec, we_spec, n_len);
+ if (t1 == 0)
+ valid_find = 1;
+ }
+ }
+ }
+
+ if (valid_find) {
+ found++;
+
+ if (hasdir) {
+ if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
+ begin = rstr;
+ }
+ else {
+ /* Start with the name */
+ begin = n_spec;
+ }
+ strcat(begin,"\n");
+ ok = (PerlIO_puts(tmpfp,begin) != EOF);
+ }
}
if (cxt) (void)lib$find_file_end(&cxt);
/* As symbolic links can hold things other than files, we will only do */
/* the conversion in in ODS-2 mode */
- Newx(utarget, VMS_MAXRSS + 1, char);
- if (do_tounixspec(contents, utarget, 0, NULL) == NULL) {
+ utarget = PerlMem_malloc(VMS_MAXRSS + 1);
+ if (int_tounixspec(contents, utarget, NULL) == NULL) {
/* This should not fail, as an untranslatable filename */
/* should be passed through */
utarget = (char *)contents;
}
sts = symlink(utarget, link_name);
- Safefree(utarget);
+ PerlMem_free(utarget);
return sts;
}
/* Hack, use old stat() as fastest way of getting ino_t and device */
int decc$stat(const char *name, void * statbuf);
+#if !defined(__VAX) && __CRTL_VER >= 80200000
+int decc$lstat(const char *name, void * statbuf);
+#else
+#define decc$lstat decc$stat
+#endif
/* Realpath is fragile. In 8.3 it does not work if the feature
* fall back to looking up the filename by the device name and FID.
*/
-int vms_fid_to_name(char * outname, int outlen, const char * name)
+int vms_fid_to_name(char * outname, int outlen,
+ const char * name, int lstat_flag, mode_t * mode)
{
+#pragma message save
+#pragma message disable MISALGNDSTRCT
+#pragma message disable MISALGNDMEM
+#pragma member_alignment save
+#pragma nomember_alignment
struct statbuf_t {
char * st_dev;
unsigned short st_ino[3];
- unsigned short padw;
+ unsigned short old_st_mode;
unsigned long padl[30]; /* plenty of room */
} statbuf;
-int sts;
-struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
-struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
+#pragma message restore
+#pragma member_alignment restore
+
+ int sts;
+ struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
+ struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
+ char *fileified;
+ char *temp_fspec;
+ char *ret_spec;
+
+ /* Need to follow the mostly the same rules as flex_stat_int, or we may get
+ * unexpected answers
+ */
+
+ fileified = PerlMem_malloc(VMS_MAXRSS);
+ if (fileified == NULL)
+ _ckvmssts_noperl(SS$_INSFMEM);
+
+ temp_fspec = PerlMem_malloc(VMS_MAXRSS);
+ if (temp_fspec == NULL)
+ _ckvmssts_noperl(SS$_INSFMEM);
+
+ sts = -1;
+ /* First need to try as a directory */
+ ret_spec = int_tovmspath(name, temp_fspec, NULL);
+ if (ret_spec != NULL) {
+ ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
+ if (ret_spec != NULL) {
+ if (lstat_flag == 0)
+ sts = decc$stat(fileified, &statbuf);
+ else
+ sts = decc$lstat(fileified, &statbuf);
+ }
+ }
+
+ /* Then as a VMS file spec */
+ if (sts != 0) {
+ ret_spec = int_tovmsspec(name, temp_fspec, 0, NULL);
+ if (ret_spec != NULL) {
+ if (lstat_flag == 0) {
+ sts = decc$stat(temp_fspec, &statbuf);
+ } else {
+ sts = decc$lstat(temp_fspec, &statbuf);
+ }
+ }
+ }
+
+ if (sts) {
+ /* Next try - allow multiple dots with out EFS CHARSET */
+ /* The CRTL stat() falls down hard on multi-dot filenames in unix
+ * format unless * DECC$EFS_CHARSET is in effect, so temporarily
+ * enable it if it isn't already.
+ */
+#if __CRTL_VER >= 70300000 && !defined(__VAX)
+ if (!decc_efs_charset && (decc_efs_charset_index > 0))
+ decc$feature_set_value(decc_efs_charset_index, 1, 1);
+#endif
+ ret_spec = int_tovmspath(name, temp_fspec, NULL);
+ if (lstat_flag == 0) {
+ sts = decc$stat(name, &statbuf);
+ } else {
+ sts = decc$lstat(name, &statbuf);
+ }
+#if __CRTL_VER >= 70300000 && !defined(__VAX)
+ if (!decc_efs_charset && (decc_efs_charset_index > 0))
+ decc$feature_set_value(decc_efs_charset_index, 1, 0);
+#endif
+ }
+
+
+ /* and then because the Perl Unix to VMS conversion is not perfect */
+ /* Specifically the CRTL removes spaces and possibly other illegal ODS-2 */
+ /* characters from filenames so we need to try it as-is */
+ if (sts) {
+ if (lstat_flag == 0) {
+ sts = decc$stat(name, &statbuf);
+ } else {
+ sts = decc$lstat(name, &statbuf);
+ }
+ }
- sts = decc$stat(name, &statbuf);
if (sts == 0) {
+ int vms_sts;
dvidsc.dsc$a_pointer=statbuf.st_dev;
- dvidsc.dsc$w_length=strlen(statbuf.st_dev);
+ dvidsc.dsc$w_length=strlen(statbuf.st_dev);
specdsc.dsc$a_pointer = outname;
specdsc.dsc$w_length = outlen-1;
- sts = lib$fid_to_name
+ vms_sts = lib$fid_to_name
(&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
- if ($VMS_STATUS_SUCCESS(sts)) {
+ if ($VMS_STATUS_SUCCESS(vms_sts)) {
outname[specdsc.dsc$w_length] = 0;
+
+ /* Return the mode */
+ if (mode) {
+ *mode = statbuf.old_st_mode;
+ }
return 0;
}
}
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;
int file_len;
+ mode_t my_mode;
/* Fall back to fid_to_name */
Newx(vms_spec, VMS_MAXRSS + 1, char);
- sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec);
+ sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec, 0, &my_mode);
if (sts == 0) {
int file_len = v_len + r_len + d_len + n_len + e_len;
vms_spec[file_len] = 0;
+ /* Trim off the .DIR if this is a directory */
+ if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
+ if (S_ISDIR(my_mode)) {
+ e_len = 0;
+ e_spec[0] = 0;
+ }
+ }
+
+ /* Drop NULL extensions on UNIX file specification */
+ if ((e_len == 1) && decc_readdir_dropdotnotype) {
+ e_len = 0;
+ e_spec[0] = '\0';
+ }
+
/* The result is expected to be in UNIX format */
- rslt = do_tounixspec(vms_spec, outbuf, 0, utf8_fl);
+ rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
/* Downcase if input had any lower case letters and
* case preservation is not in effect.
if (!decc_efs_charset) {
/* 1. ODS-2 mode wants to do a syntax only translation */
- rslt = do_rmsexpand(filespec, outbuf,
- 0, NULL, 0, NULL, utf8_fl);
+ rslt = int_rmsexpand(filespec, outbuf,
+ NULL, 0, NULL, utf8_fl);
} else {
if (decc_filename_unix_report) {
/* Need realpath for the directory */
sts = vms_fid_to_name(vms_dir_name,
VMS_MAXRSS + 1,
- dir_name);
+ dir_name, 0, NULL);
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) {
/* Fall back to fid_to_name */
- sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec);
+ sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec, 0, NULL);
if (sts != 0) {
return NULL;
}
https://perl5.git.perl.org / perl5.git / blobdiff