X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=vms%2Fvms.c;h=40e80a2f7d2e313cdfc3d8714924933b054f8004;hb=53c40a8fd46e24a1d1e4bce188f973172eb1a279;hp=27a55316c3c94cbb5acd944131559ccb7daba6b7;hpb=e0e5e8d61e90273a3d6628eb9323f31e7d517c91;p=p5sagit%2Fp5-mst-13.2.git diff --git a/vms/vms.c b/vms/vms.c index 27a5531..40e80a2 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) @@ -1924,7 +1975,7 @@ Perl_do_rmdir(pTHX_ const char *name) PerlMem_free(dirfile); return -1; } - if (flex_lstat(dirfile, &st) || !S_ISDIR(st.st_mode)) { + if (Perl_flex_lstat(aTHX_ dirfile, &st) || !S_ISDIR(st.st_mode)) { errno = ENOTDIR; retval = -1; } @@ -1956,10 +2007,10 @@ 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)) { - rmsts = Perl_do_rmdir(name); + if ((flex_lstat(name, &st) == 0) && S_ISDIR(st.st_mode)) { + rmsts = Perl_do_rmdir(aTHX_ name); return rmsts; } @@ -2032,6 +2083,61 @@ Perl_my_chdir(pTHX_ const char *dir) /*}}}*/ +/*{{{int my_chmod(char *, mode_t)*/ +int +Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode) +{ + STRLEN speclen = strlen(file_spec); + + /* zero length string sometimes gives ACCVIO */ + if (speclen == 0) return -1; + + /* some versions of CRTL chmod() doesn't tolerate trailing /, since + * that implies null file name/type. However, it's commonplace under Unix, + * so we'll allow it for a gain in portability. + * + * 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(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; + } + + /* Now make it a directory spec so chmod is happy */ + vms_dir = PerlMem_malloc(VMS_MAXRSS + 1); + if (vms_dir == NULL) + _ckvmssts(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 return chmod(file_spec, mode); +} /* end of my_chmod */ +/*}}}*/ + + /*{{{FILE *my_tmpfile()*/ FILE * my_tmpfile(void) @@ -4704,13 +4810,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 +4824,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 +4841,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 @@ -5077,7 +5606,7 @@ mp_do_rmsexpand if (!rms_nam_rsll(mynam)) { if (isunix) { - if (do_tounixspec(esa,outbuf,0,fs_utf8) == NULL) { + if (do_tounixspec(tbuf, outbuf ,0 , fs_utf8) == NULL) { if (out) Safefree(out); if (esal != NULL) PerlMem_free(esal); @@ -5087,7 +5616,7 @@ mp_do_rmsexpand return NULL; } } - else strcpy(outbuf,esa); + else strcpy(outbuf, tbuf); } else if (isunix) { tmpfspec = PerlMem_malloc(VMS_MAXRSS); @@ -11272,6 +11801,27 @@ Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag) retval = lstat(temp_fspec,(stat_t *) statbufp); 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; + } #if __CRTL_VER >= 80200000 && !defined(__VAX) } else { if (lstat_flag == 0)