At 11:57 AM +0100 5/24/01, BAZLEY, Sebastian wrote:
>
>-e "NL:" and -z "NL:" are true, however
>
>-r "NL:" is false, as is -w "NL:"
>
>though NL: is both writable and readable ...
It turns out there were two problems with checking access on a bare
device name. One, as Richard Brodie pointed out, is that we were
telling sys$check_access that such gadgets are files when in fact
they are not. But upstream from there I found another problem. We
were calling do_filefy_dirspec() on these things (the routine that
translates [.foo] into sys$disk:[]foo.dir) which in turn calls
sys$search, but sys$search blows up when passed a bare device name,
so we were saying access of any kind was impossible without even
checking.
The patch below seems to bring Perl_cando_by_name() up to snuff. For
example, these writability tests returned false before the patch:
$ mcr []miniperl -e "print -w 'nl:';"
1
$ mcr []miniperl -e "print -w 'tt:';"
1
$ mcr []miniperl -e "print -w 'wsa1:';"
1
This is some rather twisty business in a section of code that is
quite heavily used, so I think I'll bang on it some more before
officially submitting it and I invite others to do so as well.
Thanks to Sebastian for flagging the problem and to Richard for the
insight that got me on my way.
--- vms.c_old Mon May 21 22:48:08 2001
+++ vms.c Fri May 25 17:04:09 2001
@@ -6079,7 +6079,7 @@
static struct dsc$descriptor_s usrdsc =
{0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
- unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
+ unsigned long int objtyp, access, retsts, privused, iosb[2];
unsigned short int retlen;
struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
union prvdef curprv;
@@ -6087,6 +6087,7 @@
{sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
{0,0,0,0}};
+ unsigned long int dviitm = DVI$_DEVCHAR, devchar_mask = 0;
if (!fname || !*fname) return FALSE;
/* Make sure we expand logical names, since sys$check_access doesn't */
@@ -6098,8 +6099,21 @@
if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
retlen = namdsc.dsc$w_length = strlen(vmsname);
namdsc.dsc$a_pointer = vmsname;
- if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
- vmsname[retlen-1] == ':') {
+
+ /* See whether this is a file-oriented device or not. */
+
+ retsts = lib$getdvi(&dviitm, 0, &namdsc, &devchar_mask, 0, 0);
+
+ if ( (devchar_mask & DEV$M_FOD) || retsts == SS$_IVDEVNAM ||
+ retsts == SS$_IVLOGNAM || retsts == SS$_NOSUCHDEV ) {
+ objtyp = ACL$C_FILE; /* assume file */
+ retsts = SS$_NORMAL;
+ } else {
+ objtyp = ACL$C_DEVICE;
+ }
+
+ if ( (objtyp == ACL$C_FILE) && (vmsname[retlen-1] == ']'
+ || vmsname[retlen-1] == '>' || vmsname[retlen-1] == ':') ) {
if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
namdsc.dsc$w_length = strlen(fileified);
namdsc.dsc$a_pointer = fileified;
@@ -6123,7 +6137,9 @@
return FALSE;
}
- retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
+ if (retsts & 1) {
+ retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
+ }
if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
[end of patch]
--
____________________________________________
Craig A. Berry
mailto:[EMAIL PROTECTED]
"Literary critics usually know what they're
talking about. Even if they're wrong."
-- Perl creator Larry Wall
