/* 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)
/* lstat returns a VMS fileified specification of the name */
/* that is looked up, and also lets verifies that this is a directory */
- retval = Perl_flex_lstat(NULL, name, &st);
+ retval = flex_lstat(name, &st);
if (retval != 0) {
char * ret_spec;
/* Convert the filename to VMS format and see if it is a directory */
/* flex_lstat returns a vmsified file specification */
- rmsts = Perl_flex_lstat(NULL, name, &st);
+ rmsts = flex_lstat(name, &st);
if (rmsts != 0) {
/* Due to a historical feature, flex_stat/lstat can not see some */
* 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 */
/*}}}*/
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
Stat_t dst_st;
/* Validate the source file */
- src_sts = Perl_flex_lstat(NULL, src, &src_st);
+ src_sts = flex_lstat(src, &src_st);
if (src_sts != 0) {
/* No source file or other problem */
return -1;
}
- dst_sts = Perl_flex_lstat(NULL, dst, &dst_st);
+ dst_sts = flex_lstat(dst, &dst_st);
if (dst_sts == 0) {
if (dst_st.st_dev != src_st.st_dev) {
if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
int d_sts;
- d_sts = mp_do_kill_file(NULL, dst_st.st_devnam,
+ d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam,
S_ISDIR(dst_st.st_mode));
/* Need to delete all versions ? */
int i = 0;
while (lstat(dst_st.st_devnam, &dst_st.crtl_stat) == 0) {
- d_sts = mp_do_kill_file(NULL, dst_st.st_devnam, 0);
+ d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 0);
if (d_sts != 0)
break;
i++;
/* If the dest is a directory, we must remove it
if (dst_sts == 0) {
int d_sts;
- d_sts = mp_do_kill_file(NULL dst_st.st_devnam, 1);
+ d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 1);
if (d_sts != 0) {
PerlMem_free(vms_dst);
errno = EIO;
int i = 0;
dSAVEDERRNO;
SAVE_ERRNO;
- src_sts = mp_do_kill_file(NULL, src_st.st_devnam,
+ 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(NULL, src_st.st_devnam,
+ src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
S_ISDIR(src_st.st_mode));
if (src_sts != 0)
break;
/* 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);
}
/*}}}*/
+/* 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
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
(pTHX_ I32 bit, bool effective, const char *fname, int opts)
if (vmsname[retlen-1] == ']'
|| vmsname[retlen-1] == '>'
|| vmsname[retlen-1] == ':'
- || (!Perl_flex_stat_int(NULL, vmsname, &st, 1) &&
+ || (!flex_stat_int(vmsname, &st, 1) &&
S_ISDIR(st.st_mode))) {
if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
#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)
{
/* 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;
}
https://perl5.git.perl.org / perl5.git / blobdiff