Re: [blead-498-gb94a8c4] vms chdir/chmod/mkdir... thread context dependency removal

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
> [email protected]
> 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:[email protected]

"... getting out of a sonnet is much more
  difficult than getting in."
                  Brad Leithauser