From: John E. Malmberg Date: Mon, 30 Jul 2007 23:55:34 +0000 (-0500) Subject: [patch@31688] VMS symbolic links - part 1 of ? 2nd try. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e0e5e8d61e90273a3d6628eb9323f31e7d517c91;p=p5sagit%2Fp5-mst-13.2.git [patch@31688] VMS symbolic links - part 1 of ? 2nd try. From: "John E. Malmberg" Message-id: <46AEC0C6.5020702@qsl.net> Patch for VMS so that remove/delete/unlink/kill_file and rmdir will work on symbolic links where support is available in VMS 8.3. p4raw-id: //depot/perl@31670 --- diff --git a/vms/vms.c b/vms/vms.c index 026a47d..27a5531 100644 --- a/vms/vms.c +++ b/vms/vms.c @@ -287,6 +287,7 @@ int decc_readdir_dropdotnotype = 0; static int vms_process_case_tolerant = 1; int vms_vtf7_filenames = 0; int gnv_unix_shell = 0; +static int vms_unlink_all_versions = 0; /* bug workarounds if needed */ int decc_bug_readdir_efs1 = 0; @@ -1756,6 +1757,10 @@ static char * fixup_bare_dirnames(const char * name) return NULL; } +/* 8.3, remove() is now broken on symbolic links */ +static int rms_erase(const char * vmsname); + + /* mp_do_kill_file * A little hack to get around a bug in some implemenation of remove() * that do not know how to delete a directory @@ -1771,8 +1776,8 @@ static char * fixup_bare_dirnames(const char * name) static int mp_do_kill_file(pTHX_ const char *name, int dirflag) { - char *vmsname, *rspec; - char *remove_name; + char *vmsname; + char *rslt; unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE; unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1; struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; @@ -1799,59 +1804,31 @@ mp_do_kill_file(pTHX_ const char *name, int dirflag) vmsname = PerlMem_malloc(NAM$C_MAXRSS+1); if (vmsname == NULL) _ckvmssts(SS$_INSFMEM); - if (do_rmsexpand(name, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) { - PerlMem_free(vmsname); - return -1; - } - - if (decc_posix_compliant_pathnames) { - /* In POSIX mode, we prefer to remove the UNIX name */ - rspec = vmsname; - remove_name = (char *)name; - } - else { - rspec = PerlMem_malloc(NAM$C_MAXRSS+1); - if (rspec == NULL) _ckvmssts(SS$_INSFMEM); - if (do_rmsexpand(vmsname, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) { - PerlMem_free(rspec); + rslt = do_rmsexpand(name, + vmsname, + 0, + NULL, + PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK, + NULL, + NULL); + if (rslt == NULL) { PerlMem_free(vmsname); return -1; } - PerlMem_free(vmsname); - remove_name = rspec; - } - -#if defined(__CRTL_VER) && __CRTL_VER >= 70000000 - if (dirflag != 0) { - if (decc_dir_barename && decc_posix_compliant_pathnames) { - remove_name = PerlMem_malloc(NAM$C_MAXRSS+1); - if (remove_name == NULL) _ckvmssts(SS$_INSFMEM); - do_pathify_dirspec(name, remove_name, 0, NULL); - if (!rmdir(remove_name)) { + /* Erase the file */ + rmsts = rms_erase(vmsname); - PerlMem_free(remove_name); - PerlMem_free(rspec); - return 0; /* Can we just get rid of it? */ - } - } - else { - if (!rmdir(remove_name)) { - PerlMem_free(rspec); - return 0; /* Can we just get rid of it? */ - } - } - } - else -#endif - if (!remove(remove_name)) { - PerlMem_free(rspec); - return 0; /* Can we just get rid of it? */ + /* Did it succeed */ + if ($VMS_STATUS_SUCCESS(rmsts)) { + PerlMem_free(vmsname); + return 0; } /* If not, can changing protections help? */ - if (vaxc$errno != RMS$_PRV) { - PerlMem_free(rspec); + if (rmsts != RMS$_PRV) { + set_vaxc_errno(rmsts); + PerlMem_free(vmsname); return -1; } @@ -1860,10 +1837,11 @@ mp_do_kill_file(pTHX_ const char *name, int dirflag) * to delete the file. */ _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0)); - fildsc.dsc$w_length = strlen(rspec); - fildsc.dsc$a_pointer = rspec; + fildsc.dsc$w_length = strlen(vmsname); + fildsc.dsc$a_pointer = vmsname; cxt = 0; newace.myace$l_ident = oldace.myace$l_ident; + rmsts = -1; if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) { switch (aclsts) { case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT: @@ -1880,7 +1858,7 @@ mp_do_kill_file(pTHX_ const char *name, int dirflag) _ckvmssts(aclsts); } set_vaxc_errno(aclsts); - PerlMem_free(rspec); + PerlMem_free(vmsname); return -1; } /* Grab any existing ACEs with this identifier in case we fail */ @@ -1891,23 +1869,12 @@ mp_do_kill_file(pTHX_ const char *name, int dirflag) if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1)) goto yourroom; -#if defined(__CRTL_VER) && __CRTL_VER >= 70000000 - if (dirflag != 0) - if (decc_dir_barename && decc_posix_compliant_pathnames) { - remove_name = PerlMem_malloc(NAM$C_MAXRSS+1); - if (remove_name == NULL) _ckvmssts(SS$_INSFMEM); - - do_pathify_dirspec(name, remove_name, 0, NULL); - rmsts = rmdir(remove_name); - PerlMem_free(remove_name); + rmsts = rms_erase(vmsname); + if ($VMS_STATUS_SUCCESS(rmsts)) { + rmsts = 0; } else { - rmsts = rmdir(remove_name); - } - else -#endif - rmsts = remove(remove_name); - if (rmsts) { + rmsts = -1; /* We blew it - dir with files in it, no write priv for * parent directory, etc. Put things back the way they were. */ if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1)) @@ -1931,11 +1898,9 @@ mp_do_kill_file(pTHX_ const char *name, int dirflag) if (!(aclsts & 1)) { set_errno(EVMSERR); set_vaxc_errno(aclsts); - PerlMem_free(rspec); - return -1; } - PerlMem_free(rspec); + PerlMem_free(vmsname); return rmsts; } /* end of kill_file() */ @@ -1946,13 +1911,27 @@ mp_do_kill_file(pTHX_ const char *name, int dirflag) int Perl_do_rmdir(pTHX_ const char *name) { - char dirfile[NAM$C_MAXRSS+1]; + char * dirfile; int retval; Stat_t st; - if (do_fileify_dirspec(name,dirfile,0,NULL) == NULL) return -1; - if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1; - else retval = mp_do_kill_file(aTHX_ dirfile, 1); + dirfile = PerlMem_malloc(VMS_MAXRSS + 1); + if (dirfile == NULL) + _ckvmssts(SS$_INSFMEM); + + /* Force to a directory specification */ + if (do_fileify_dirspec(name, dirfile, 0, NULL) == NULL) { + PerlMem_free(dirfile); + return -1; + } + if (flex_lstat(dirfile, &st) || !S_ISDIR(st.st_mode)) { + errno = ENOTDIR; + retval = -1; + } + else + retval = mp_do_kill_file(aTHX_ dirfile, 1); + + PerlMem_free(dirfile); return retval; } /* end of do_rmdir */ @@ -1972,95 +1951,19 @@ Perl_kill_file(pTHX_ const char *name) { char rspec[NAM$C_MAXRSS+1]; char *tspec; - unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE; - unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1; - struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; - 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 itmlst_3 - findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0}, - {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}}, - addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}}, - dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}}, - lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}}, - ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}}; - - /* Expand the input spec using RMS, since the CRTL remove() and - * system services won't do this by themselves, so we may miss - * a file "hiding" behind a logical name or search list. */ - tspec = do_rmsexpand(name, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL); - if (tspec == NULL) return -1; - if (!remove(rspec)) return 0; /* Can we just get rid of it? */ - /* If not, can changing protections help? */ - if (vaxc$errno != RMS$_PRV) return -1; + Stat_t st; + int rmsts; - /* No, 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. + /* Remove() is allowed to delete directories, according to the X/Open + * specifications. + * This needs special handling to work with the ACL hacks. */ - _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0)); - fildsc.dsc$w_length = strlen(rspec); - fildsc.dsc$a_pointer = rspec; - cxt = 0; - newace.myace$l_ident = oldace.myace$l_ident; - if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) { - switch (aclsts) { - case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT: - set_errno(ENOENT); break; - case RMS$_DIR: - set_errno(ENOTDIR); break; - case RMS$_DEV: - set_errno(ENODEV); break; - case RMS$_SYN: case SS$_INVFILFOROP: - set_errno(EINVAL); break; - case RMS$_PRV: - set_errno(EACCES); break; - default: - _ckvmssts(aclsts); - } - set_vaxc_errno(aclsts); - return -1; - } - /* Grab any existing ACEs with this identifier in case we fail */ - aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt); - if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY - || fndsts == SS$_NOMOREACE ) { - /* Add the new ACE . . . */ - if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1)) - goto yourroom; - if ((rmsts = remove(name))) { - /* We blew it - dir with files in it, no write priv for - * parent directory, etc. Put things back the way they were. */ - if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1)) - goto yourroom; - if (fndsts & 1) { - addlst[0].bufadr = &oldace; - if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1)) - goto yourroom; - } - } + if (flex_stat(name, &st) && S_ISDIR(st.st_mode)) { + rmsts = Perl_do_rmdir(name); + return rmsts; } - yourroom: - fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0); - /* We just deleted it, so of course it's not there. Some versions of - * VMS seem to return success on the unlock operation anyhow (after all - * the unlock is successful), but others don't. - */ - if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL; - if (aclsts & 1) aclsts = fndsts; - if (!(aclsts & 1)) { - set_errno(EVMSERR); - set_vaxc_errno(aclsts); - return -1; - } + rmsts = mp_do_kill_file(aTHX_ name, 0); return rmsts; @@ -4801,6 +4704,38 @@ 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 + * 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) +{ + int status; + struct FAB myfab = cc$rms_fab; + rms_setup_nam(mynam); + + 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 + + status = SYS$ERASE(&myfab, 0, 0); + + return status; +} + /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/ /* Shortcut for common case of simple calls to $PARSE and $SEARCH @@ -4818,6 +4753,7 @@ struct NAML * nam; * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format. * PERL_RMSEXPAND_M_LONG - Want output in long formst * PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify + * PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target */ static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *); @@ -4933,6 +4869,12 @@ mp_do_rmsexpand rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE); #endif + /* We may not want to follow symbolic links */ +#ifdef NAML$M_OPEN_SPECIAL + if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0) + rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL); +#endif + /* First attempt to parse as an existing file */ retsts = sys$parse(&myfab,0,0); if (!(retsts & STS$K_SUCCESS)) { @@ -5050,6 +4992,10 @@ mp_do_rmsexpand if (decc_efs_case_preserve) rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE); #endif +#ifdef NAML$M_OPEN_SPECIAL + if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0) + rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL); +#endif if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) { if (trimver) { trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER); @@ -12460,6 +12406,18 @@ static int set_features vms_vtf7_filenames = 0; } + + /* unlink all versions on unlink() or rename() */ + vms_vtf7_filenames = 0; + status = sys_trnlnm + ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str)); + if ($VMS_STATUS_SUCCESS(status)) { + if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) + vms_unlink_all_versions = 1; + else + vms_unlink_all_versions = 0; + } + /* Dectect running under GNV Bash or other UNIX like shell */ #if __CRTL_VER >= 70300000 && !defined(__VAX) gnv_unix_shell = 0; @@ -12473,6 +12431,7 @@ static int set_features set_feature_default("DECC$FILENAME_UNIX_REPORT", 1); set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1); set_feature_default("DECC$DISABLE_POSIX_ROOT", 0); + vms_unlink_all_versions = 1; } else gnv_unix_shell = 0;