On Feb 4, 2009, at 8:43 AM, John Malmberg wrote:
Getting close to the end of the list of patches to vms.c/vmsish.h
for thread context and Unix / Extended file specification support.
This removes the dependencies on the thread context from the mkdir,
chdir, chmod, and symlink wrappers.
It also adds a wrapper for fgetname() which will be exposed on the
next patch.
The next patch will be to remove the thread context from the
parameters of the wrapper routines and the internal routines where
it is no longer needed.
-John
wb8...@gmail.com
Personal Opinion Only
--- /ref1_root/perl/vms/vms.c Sun Feb 1 23:43:05 2009
+++ vms/vms.c Tue Feb 3 22:52:07 2009
patch is not happy with this patch:
$ gpatch --dry-run -p0 -l --fuzz 10 -i chdir_chmod_mkdir.eml
patching file vms/vms.c
Hunk #10 FAILED at 5271.
Hunk #11 FAILED at 5327.
Hunk #12 FAILED at 5369.
Hunk #13 FAILED at 5380.
Hunk #14 FAILED at 5392.
Hunk #15 FAILED at 5408.
Hunk #16 FAILED at 5420.
Hunk #17 FAILED at 5435.
Hunk #18 FAILED at 5498.
Hunk #19 FAILED at 5510.
Hunk #20 succeeded at 9436 (offset 28 lines).
Hunk #22 succeeded at 12993 (offset 229 lines).
Hunk #23 succeeded at 12965 with fuzz 3.
Hunk #24 succeeded at 14020 (offset 28 lines).
Hunk #26 succeeded at 14100 (offset 28 lines).
Hunk #28 succeeded at 14341 (offset 28 lines).
10 out of 29 hunks FAILED -- saving rejects to file vms/vms.c.rej
@@ -283,8 +283,6 @@
#define do_tovmsspec(a,b,c,d) mp_do_tovmsspec(aTHX_ a,b,c,0,d)
#define do_tovmspath(a,b,c,d) mp_do_tovmspath(aTHX_ a,b,c,d)
#define do_rmsexpand(a,b,c,d,e,f,g) mp_do_rmsexpand(aTHX_
a,b,c,d,e,f,g)
-#define do_vms_realpath(a,b,c) mp_do_vms_realpath(aTHX_ a,b,c)
-#define do_vms_realname(a,b,c) mp_do_vms_realname(aTHX_ a,b,c)
#define do_tounixspec(a,b,c,d) mp_do_tounixspec(aTHX_ a,b,c,d)
#define do_tounixpath(a,b,c,d) mp_do_tounixpath(aTHX_ a,b,c,d)
#define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a)
@@ -2213,10 +2211,16 @@
* so we'll allow it for a gain in portability.
*/
if (dir[dirlen-1] == '/') {
- char *newdir = savepvn(dir,dirlen-1);
- int ret = mkdir(newdir,mode);
- Safefree(newdir);
- return ret;
+ char *newdir;
+ int ret;
+ newdir = PerlMem_malloc(dirlen);
+ if (newdir ==NULL)
+ _ckvmssts_noperl(SS$_INSFMEM);
+ strncpy(newdir, dir, dirlen - 1);
+ newdir[dirlen-1] = '\0';
+ ret = mkdir(newdir, mode);
+ PerlMem_free(newdir);
+ return ret;
}
else return mkdir(dir,mode);
} /* end of my_mkdir */
@@ -2250,10 +2254,16 @@
* - Preview- '/' will be valid soon on VMS
*/
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 */
@@ -2264,6 +2274,9 @@
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 */
@@ -2276,41 +2289,26 @@
* 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);
+ changefile = (char *) file_spec; /* cast ok */
+ ret = Perl_flex_lstat(NULL, file_spec, &st);
You're explicitly passing a null thread context? That won't work.
The function prototype is
int Perl_flex_lstat (pTHX_ const char *, Stat_t *);
and pTHX_ will not expand to anything in the case of a Perl built
without thread support. So in a non-threaded Perl you'll be passing
three arguments to a function that expects two. What problem are you
trying to solve by ignoring whatever actual thread context there may
be and saying that it's always null?
+ if (ret != 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;
- }
+ /* 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 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 */
/*}}}*/
@@ -4290,6 +4288,12 @@
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;
@@ -4332,9 +4336,15 @@
} else { /* uh, oh...we're in tempfile hell */
tpipe = vmspipe_tempfile(aTHX);
if (!tpipe) { /* a fish popular in Boston */
- if (ckWARN(WARN_PIPE)) {
+#if defined(PERL_IMPLICIT_CONTEXT)
+ if (aTHX == NULL) {
+ fprintf(stderr,
+ "%%Perl-W-VMS_Init, unable to find VMSPIPE.COM for
i/o piping");
+ } else
+#endif
+ if (ckWARN(WARN_PIPE)) {
Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to
find VMSPIPE.COM for i/o piping");
- }
+ }
return NULL;
}
fgetname(tpipe,tfilebuf+1,1);
@@ -4364,6 +4374,12 @@
}
set_vaxc_errno(sts);
if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
+#if defined(PERL_IMPLICIT_CONTEXT)
+ if (aTHX == NULL) {
+ fprintf(stderr, "%%Perl-W-VMS_Init, Can't pipe \"%*s\":
%s",
+ strlen(cmd), cmd, Strerror(errno));
+ } else
+#endif
Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\":
%s", strlen(cmd), cmd, Strerror(errno));
}
*psts = sts;
@@ -5065,12 +5081,6 @@
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
@@ -5261,14 +5271,19 @@
Stat_t dst_st;
/* Validate the source file */
- src_sts = flex_lstat(src, &src_st);
+ src_sts = Perl_flex_lstat(NULL, src, &src_st);
Ditto.
if (src_sts != 0) {
/* 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);
+ dst_sts = Perl_flex_lstat(NULL, dst, &dst_st);
Ditto.
if (dst_sts == 0) {
if (dst_st.st_dev != src_st.st_dev) {
@@ -5312,7 +5327,28 @@
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(NULL, dst_st.st_devnam,
+ S_ISDIR(dst_st.st_mode));
Ditto.
+
+ /* 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(NULL, 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;
@@ -5333,7 +5369,6 @@
/* 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;
@@ -5345,18 +5380,6 @@
* 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);
@@ -5369,24 +5392,11 @@
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(NULL dst_st.st_devnam, 1);
Ditto.
if (d_sts != 0) {
- PerlMem_free(vms_src);
PerlMem_free(vms_dst);
errno = EIO;
return sts;
@@ -5398,7 +5408,6 @@
/* 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;
@@ -5411,7 +5420,6 @@
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;
@@ -5427,26 +5435,42 @@
/* VMS pathify a dir target */
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;
@@ -5474,7 +5498,6 @@
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;
@@ -5487,10 +5510,25 @@
/* 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(NULL, 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,
+ S_ISDIR(src_st.st_mode));
Ditto.
+ 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
*/
@@ -9370,7 +9408,7 @@
/* 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);
@@ -11301,6 +11339,34 @@
}
/*}}}*/
+/* 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
@@ -12698,6 +12764,7 @@
VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
VMS_DEVICE_ENCODE
(statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
+
# ifdef RTL_USES_UTC
# ifdef VMSISH_TIME
if (VMSISH_TIME) {
@@ -12898,7 +12965,6 @@
VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
VMS_DEVICE_ENCODE
(statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
-
# ifdef RTL_USES_UTC
# ifdef VMSISH_TIME
if (VMSISH_TIME) {
@@ -13926,8 +13992,7 @@
static char *
-mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
- int *utf8_fl);
+do_vms_realpath(const char *filespec, char * rslt_spec, int
*utf8_fl);
void
unixrealpath_fromperl(pTHX_ CV *cv)
@@ -13954,8 +14019,7 @@
}
static char *
-mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
- int *utf8_fl);
+do_vms_realname(const char *filespec, char * rslt_spec, int
*utf8_fl);
void
vmsrealpath_fromperl(pTHX_ CV *cv)
@@ -14008,7 +14072,7 @@
/* 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 */
@@ -14016,7 +14080,7 @@
utarget = (char *)contents;
}
sts = symlink(utarget, link_name);
- Safefree(utarget);
+ PerlMem_free(utarget);
return sts;
}
@@ -14249,8 +14313,7 @@
static char *
-mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
- int *utf8_fl)
+do_vms_realpath(const char *filespec, char *outbuf, int *utf8_fl)
{
char * rslt = NULL;
@@ -14418,8 +14481,7 @@
}
static char *
-mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
- int *utf8_fl)
+do_vms_realname(const char *filespec, char *outbuf, int *utf8_fl)
{
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;
________________________________________
Craig A. Berry
mailto:craigbe...@mac.com
"... getting out of a sonnet is much more
difficult than getting in."
Brad Leithauser
