(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)
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;
+ changefile = (char *) file_spec; /* cast ok */
+ ret = flex_lstat(file_spec, &st);
+ if (ret != 0) {
- /* First convert this to a VMS format specification */
- vms_src = PerlMem_malloc(VMS_MAXRSS);
- if (vms_src == NULL)
- _ckvmssts_noperl(SS$_INSFMEM);
+ /* 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;
- 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;
- }
-
- /* 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);
-
- /* 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 */
/*}}}*/
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)
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
/* 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 = int_fileify_dirspec(vms_src, vms_dir_file, 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 */
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];
/* 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);
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;
}
Stat_t statbuf;
int ret_sts;
- ret_sts = stat(buff, (stat_t *)&statbuf);
+ ret_sts = stat(buff, &statbuf.crtl_stat);
if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
e_len = 0;
e_spec[0] = 0;
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
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 (!int_fileify_dirspec(vmsname, fileified, NULL)) {
PerlMem_free(fileified);
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);
#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;
+#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;
/* 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);
+ utarget = PerlMem_malloc(VMS_MAXRSS + 1);
if (int_tounixspec(contents, utarget, NULL) == NULL) {
/* This should not fail, as an untranslatable filename */
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) {
/* 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.
/* 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;
}
projects / p5sagit/p5-mst-13.2.git / blobdiff