From: John E. Malmberg Date: Thu, 30 Aug 2007 22:59:50 +0000 (-0500) Subject: [patch@31750] rename directories on VMS like on UNIX X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4fdf8f88a748ed01c597aa0c5a9e5dcdd59adab6;p=p5sagit%2Fp5-mst-13.2.git [patch@31750] rename directories on VMS like on UNIX From: "John E. Malmberg" Message-id: <46D79236.4070207@qsl.net> More aggressive UNIX-like renaming of directories on VMS by analogy with unlink() and rmdir(). Patch modified to compile under threads. p4raw-id: //depot/perl@31777 --- diff --git a/vms/vms.c b/vms/vms.c index 38029d7..de9c5c4 100644 --- a/vms/vms.c +++ b/vms/vms.c @@ -32,6 +32,7 @@ #include #include #include +#include #if __CRTL_VER >= 70301000 && !defined(__VAX) #include #endif @@ -91,6 +92,30 @@ int sys$getdviw void * nullarg); #endif +#ifdef sys$get_security +#undef sys$get_security +int sys$get_security + (const struct dsc$descriptor_s * clsnam, + const struct dsc$descriptor_s * objnam, + const unsigned int *objhan, + unsigned int flags, + const struct item_list_3 * itmlst, + unsigned int * contxt, + const unsigned int * acmode); +#endif + +#ifdef sys$set_security +#undef sys$set_security +int sys$set_security + (const struct dsc$descriptor_s * clsnam, + const struct dsc$descriptor_s * objnam, + const unsigned int *objhan, + unsigned int flags, + const struct item_list_3 * itmlst, + unsigned int * contxt, + const unsigned int * acmode); +#endif + #ifdef lib$find_image_symbol #undef lib$find_image_symbol int lib$find_image_symbol @@ -99,7 +124,33 @@ int lib$find_image_symbol void * symval, const struct dsc$descriptor_s * defspec, unsigned long flag); +#endif +#ifdef lib$rename_file +#undef lib$rename_file +int lib$rename_file + (const struct dsc$descriptor_s * old_file_dsc, + const struct dsc$descriptor_s * new_file_dsc, + const struct dsc$descriptor_s * default_file_dsc, + const struct dsc$descriptor_s * related_file_dsc, + const unsigned long * flags, + void * (success)(const struct dsc$descriptor_s * old_dsc, + const struct dsc$descriptor_s * new_dsc, + const void *), + void * (error)(const struct dsc$descriptor_s * old_dsc, + const struct dsc$descriptor_s * new_dsc, + const int * rms_sts, + const int * rms_stv, + const int * error_src, + const void * usr_arg), + int (confirm)(const struct dsc$descriptor_s * old_dsc, + const struct dsc$descriptor_s * new_dsc, + const void * old_fab, + const void * usr_arg), + void * user_arg, + struct dsc$descriptor_s * old_result_name_dsc, + struct dsc$descriptor_s * new_result_name_dsc, + unsigned long * file_scan_context); #endif #if __CRTL_VER >= 70300000 && !defined(__VAX) @@ -1956,9 +2007,9 @@ Perl_kill_file(pTHX_ const char *name) /* Remove() is allowed to delete directories, according to the X/Open * specifications. - * This needs special handling to work with the ACL hacks. + * This may need special handling to work with the ACL hacks. */ - if (flex_stat(name, &st) && S_ISDIR(st.st_mode)) { + if ((flex_lstat(name, &st) == 0) && S_ISDIR(st.st_mode)) { rmsts = Perl_do_rmdir(aTHX_ name); return rmsts; } @@ -4704,13 +4755,11 @@ struct NAML * nam; (nam.naml$l_long_name_size + nam.naml$l_long_type_size) #endif + /* rms_erase * The CRTL for 8.3 and later can create symbolic links in any mode, - * however the unlink/remove/delete routines will only properly handle + * however in 8.3 the unlink/remove/delete routines will only properly handle * them if one of the PCP modes is active. - * - * Future: rename() routine will also need this when the unlink_all_versions - * option is set. */ static int rms_erase(const char * vmsname) { @@ -4720,7 +4769,7 @@ static int rms_erase(const char * vmsname) 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 = ";*"; @@ -4737,6 +4786,431 @@ static int rms_erase(const char * vmsname) } +static int +vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc, + const struct dsc$descriptor_s * vms_dst_dsc, + unsigned long flags) +{ + /* VMS and UNIX handle file permissions differently and the + * the same ACL trick may be needed for renaming files, + * especially if they are directories. + */ + + /* todo: get kill_file and rename to share common code */ + /* I can not find online documentation for $change_acl + * it appears to be replaced by $set_security some time ago */ + +const unsigned int access_mode = 0; +$DESCRIPTOR(obj_file_dsc,"FILE"); +char *vmsname; +char *rslt; +unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE; +int aclsts, fndsts, rnsts = -1; +unsigned int ctx = 0; +struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; +struct dsc$descriptor_s * clean_dsc; + +struct myacedef { + unsigned char myace$b_length; + unsigned char myace$b_type; + unsigned short int myace$w_flags; + unsigned long int myace$l_access; + unsigned long int myace$l_ident; +} newace = { sizeof(struct myacedef), ACE$C_KEYID, 0, + ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, + 0}, + oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0}; + +struct item_list_3 + findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0}, + {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0}, + {0,0,0,0}}, + addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}}, + dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0}, + {0,0,0,0}}; + + + /* Expand the input spec using RMS, since we do not want to put + * ACLs on the target of a symbolic link */ + vmsname = PerlMem_malloc(NAM$C_MAXRSS+1); + if (vmsname == NULL) + return SS$_INSFMEM; + + rslt = do_rmsexpand(vms_src_dsc->dsc$a_pointer, + vmsname, + 0, + NULL, + PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK, + NULL, + NULL); + if (rslt == NULL) { + PerlMem_free(vmsname); + return SS$_INSFMEM; + } + + /* So we get our own UIC to use as a rights identifier, + * and the insert an ACE at the head of the ACL which allows us + * to delete the file. + */ + _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0)); + + fildsc.dsc$w_length = strlen(vmsname); + fildsc.dsc$a_pointer = vmsname; + ctx = 0; + newace.myace$l_ident = oldace.myace$l_ident; + rnsts = SS$_ABORT; + + /* Grab any existing ACEs with this identifier in case we fail */ + clean_dsc = &fildsc; + aclsts = fndsts = sys$get_security(&obj_file_dsc, + &fildsc, + NULL, + OSS$M_WLOCK, + findlst, + &ctx, + &access_mode); + + if ($VMS_STATUS_SUCCESS(fndsts) || (fndsts == SS$_ACLEMPTY)) { + /* Add the new ACE . . . */ + + /* if the sys$get_security succeeded, then ctx is valid, and the + * object/file descriptors will be ignored. But otherwise they + * are needed + */ + aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL, + OSS$M_RELCTX, addlst, &ctx, &access_mode); + if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) { + set_errno(EVMSERR); + set_vaxc_errno(aclsts); + PerlMem_free(vmsname); + return aclsts; + } + + rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc, + NULL, NULL, + &flags, + NULL, NULL, NULL, NULL, NULL, NULL, NULL); + + if ($VMS_STATUS_SUCCESS(rnsts)) { + clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc; + } + + /* Put things back the way they were. */ + ctx = 0; + aclsts = sys$get_security(&obj_file_dsc, + clean_dsc, + NULL, + OSS$M_WLOCK, + findlst, + &ctx, + &access_mode); + + if ($VMS_STATUS_SUCCESS(aclsts)) { + int sec_flags; + + sec_flags = 0; + if (!$VMS_STATUS_SUCCESS(fndsts)) + sec_flags = OSS$M_RELCTX; + + /* Get rid of the new ACE */ + aclsts = sys$set_security(NULL, NULL, NULL, + sec_flags, dellst, &ctx, &access_mode); + + /* If there was an old ACE, put it back */ + if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) { + addlst[0].bufadr = &oldace; + aclsts = sys$set_security(NULL, NULL, NULL, + OSS$M_RELCTX, addlst, &ctx, &access_mode); + if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) { + set_errno(EVMSERR); + set_vaxc_errno(aclsts); + rnsts = aclsts; + } + } else { + int aclsts2; + + /* Try to clear the lock on the ACL list */ + aclsts2 = sys$set_security(NULL, NULL, NULL, + OSS$M_RELCTX, NULL, &ctx, &access_mode); + + /* Rename errors are most important */ + if (!$VMS_STATUS_SUCCESS(rnsts)) + aclsts = rnsts; + set_errno(EVMSERR); + set_vaxc_errno(aclsts); + rnsts = aclsts; + } + } + else { + if (aclsts != SS$_ACLEMPTY) + rnsts = aclsts; + } + } + else + rnsts = fndsts; + + PerlMem_free(vmsname); + return rnsts; +} + + +/*{{{int rename(const char *, const char * */ +/* Not exactly what X/Open says to do, but doing it absolutely right + * and efficiently would require a lot more work. This should be close + * enough to pass all but the most strict X/Open compliance test. + */ +int +Perl_rename(pTHX_ const char *src, const char * dst) +{ +int retval; +int pre_delete = 0; +int src_sts; +int dst_sts; +Stat_t src_st; +Stat_t dst_st; + + /* Validate the source file */ + src_sts = flex_lstat(src, &src_st); + if (src_sts != 0) { + + /* No source file or other problem */ + return src_sts; + } + + dst_sts = flex_lstat(dst, &dst_st); + if (dst_sts == 0) { + + if (dst_st.st_dev != src_st.st_dev) { + /* Must be on the same device */ + errno = EXDEV; + return -1; + } + + /* VMS_INO_T_COMPARE is true if the inodes are different + * to match the output of memcmp + */ + + if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) { + /* That was easy, the files are the same! */ + return 0; + } + + if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) { + /* If source is a directory, so must be dest */ + errno = EISDIR; + return -1; + } + + } + + + if ((dst_sts == 0) && + (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) { + + /* We have issues here if vms_unlink_all_versions is set + * If the destination exists, and is not a directory, then + * we must delete in advance. + * + * If the src is a directory, then we must always pre-delete + * the destination. + * + * If we successfully delete the dst in advance, and the rename fails + * X/Open requires that errno be EIO. + * + */ + + 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)); + if (d_sts != 0) + return d_sts; + + /* We killed the destination, so only errno now is EIO */ + pre_delete = 1; + } + } + + /* Originally the idea was to call the CRTL rename() and only + * try the lib$rename_file if it failed. + * It turns out that there are too many variants in what the + * the CRTL rename might do, so only use lib$rename_file + */ + retval = -1; + + { + /* Is the source and dest both in VMS format */ + /* 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; + unsigned long flags; + struct dsc$descriptor_s old_file_dsc; + struct dsc$descriptor_s new_file_dsc; + + /* We need to modify the src and dst depending + * on if one or more of them are directories. + */ + + vms_src = PerlMem_malloc(VMS_MAXRSS); + if (vms_src == NULL) + _ckvmssts(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(SS$_INSFMEM); + + if (S_ISDIR(src_st.st_mode)) { + char * ret_str; + char * vms_dir_file; + + vms_dir_file = PerlMem_malloc(VMS_MAXRSS); + if (vms_dir_file == NULL) + _ckvmssts(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); + if (d_sts != 0) { + PerlMem_free(vms_src); + PerlMem_free(vms_dst); + errno = EIO; + return sts; + } + + pre_delete = 1; + } + + /* The dest must be a VMS file specification */ + ret_str = do_tovmsspec(dst, vms_dst, 0, NULL); + if (ret_str == NULL) { + PerlMem_free(vms_src); + PerlMem_free(vms_dst); + errno = EIO; + return -1; + } + + /* The source must be a file specification */ + vms_dir_file = PerlMem_malloc(VMS_MAXRSS); + if (vms_dir_file == NULL) + _ckvmssts(SS$_INSFMEM); + + 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; + return -1; + } + PerlMem_free(vms_dst); + vms_dst = vms_dir_file; + + } else { + /* File to file or file to new dir */ + + if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) { + /* VMS pathify a dir target */ + ret_str = do_tovmspath(dst, vms_dst, 0, NULL); + if (ret_str == NULL) { + PerlMem_free(vms_src); + PerlMem_free(vms_dst); + errno = EIO; + return -1; + } + } else { + + /* fileify a target VMS file specification */ + ret_str = do_tovmsspec(dst, vms_dst, 0, NULL); + if (ret_str == NULL) { + PerlMem_free(vms_src); + PerlMem_free(vms_dst); + errno = EIO; + return -1; + } + } + } + + old_file_dsc.dsc$a_pointer = vms_src; + old_file_dsc.dsc$w_length = strlen(vms_src); + old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T; + old_file_dsc.dsc$b_class = DSC$K_CLASS_S; + + new_file_dsc.dsc$a_pointer = vms_dst; + new_file_dsc.dsc$w_length = strlen(vms_dst); + new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T; + new_file_dsc.dsc$b_class = DSC$K_CLASS_S; + + flags = 0; +#if !defined(__VAX) && defined(NAML$C_MAXRSS) + flags |= 2; /* LIB$M_FIL_LONG_NAMES */ +#endif + + sts = lib$rename_file(&old_file_dsc, + &new_file_dsc, + NULL, NULL, + &flags, + NULL, NULL, NULL, NULL, NULL, NULL, NULL); + if (!$VMS_STATUS_SUCCESS(sts)) { + + /* We could have failed because VMS style permissions do not + * permit renames that UNIX will allow. Just like the hack + * in for kill_file. + */ + 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; + return -1; + } + retval = 0; + } + + if (vms_unlink_all_versions) { + /* 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; + } + + /* We deleted the destination, so must force the error to be EIO */ + if ((retval != 0) && (pre_delete != 0)) + errno = EIO; + + return retval; +} +/*}}}*/ + + /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/ /* Shortcut for common case of simple calls to $PARSE and $SEARCH * to expand file specification. Allows for a single default file diff --git a/vms/vmsish.h b/vms/vmsish.h index 328da31..05d4922 100644 --- a/vms/vmsish.h +++ b/vms/vmsish.h @@ -165,6 +165,7 @@ #define pathify_dirspec_utf8_ts Perl_pathify_dirspec_utf8_ts #define trim_unixpath Perl_trim_unixpath #define opendir Perl_opendir +#define rename Perl_rename #define rmscopy Perl_rmscopy #define my_mkdir Perl_my_mkdir #define vms_do_aexec Perl_vms_do_aexec @@ -228,6 +229,7 @@ #define rmsexpand_utf8_ts(a,b,c,d,e,f) Perl_rmsexpand_utf8_ts(aTHX_ a,b,c,d,e,f) #define trim_unixpath(a,b,c) Perl_trim_unixpath(aTHX_ a,b,c) #define opendir(a) Perl_opendir(aTHX_ a) +#define rename(a,b) Perl_rename(aTHX_ a,b) #define rmscopy(a,b,c) Perl_rmscopy(aTHX_ a,b,c) #define my_mkdir(a,b) Perl_my_mkdir(aTHX_ a,b) #define vms_do_aexec(a,b,c) Perl_vms_do_aexec(aTHX_ a,b,c) @@ -246,6 +248,7 @@ #define flex_fstat(a,b) Perl_flex_fstat(aTHX_ a,b) #define cando_by_name(a,b,c) Perl_cando_by_name(aTHX_ a,b,c) #define flex_stat(a,b) Perl_flex_stat(aTHX_ a,b) +#define flex_lstat(a,b) Perl_flex_lstat(aTHX_ a,b) #define my_getpwnam(a) Perl_my_getpwnam(aTHX_ a) #define my_getpwuid(a) Perl_my_getpwuid(aTHX_ a) #define my_flush(a) Perl_my_flush(aTHX_ a) @@ -859,6 +862,7 @@ char * Perl_rmsexpand_utf8 (const char *, char *, const char *, unsigned, int *, char * Perl_rmsexpand_utf8_ts (const char *, char *, const char *, unsigned, int *, int *); int Perl_trim_unixpath (char *, const char*, int); DIR * Perl_opendir (const char *); +int Perl_rename(const char *, const char *); int Perl_rmscopy (const char *, const char *, int); int Perl_my_mkdir (const char *, Mode_t); bool Perl_vms_do_aexec (SV *, SV **, SV **); @@ -896,6 +900,7 @@ char * Perl_rmsexpand_utf8 (pTHX_ const char *, char *, const char *, unsigned, char * Perl_rmsexpand_utf8_ts (pTHX_ const char *, char *, const char *, unsigned, int *, int *); int Perl_trim_unixpath (pTHX_ char *, const char*, int); DIR * Perl_opendir (pTHX_ const char *); +int Perl_rename (pTHX_ const char *, const char *); int Perl_rmscopy (pTHX_ const char *, const char *, int); int Perl_my_mkdir (pTHX_ const char *, Mode_t); bool Perl_vms_do_aexec (pTHX_ SV *, SV **, SV **);