X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=vms%2Fvms.c;h=150747f52d29a624f51351ec8b876db0c184c08e;hb=7aa5c81fb93ce6741dd5751e93d46dc87d2c1c61;hp=10e2db45a913b5f3d2e3707462a7d80554c8a16d;hpb=c07a80fdfe3926b5eb0585b674aa5d1f57b32ade;p=p5sagit%2Fp5-mst-13.2.git diff --git a/vms/vms.c b/vms/vms.c index 10e2db4..150747f 100644 --- a/vms/vms.c +++ b/vms/vms.c @@ -2,8 +2,8 @@ * * VMS-specific routines for perl5 * - * Last revised: 18-Jan-1996 by Charles Bailey bailey@genetics.upenn.edu - * Version: 5.2.0 + * Last revised: 21-Jun-1996 by Charles Bailey bailey@genetics.upenn.edu + * Version: 5.2.2 */ #include @@ -11,6 +11,7 @@ #include #include #include +#include #include #include #include @@ -39,9 +40,9 @@ /* gcc's header files don't #define direct access macros * corresponding to VAXC's variant structs */ #ifdef __GNUC__ -# define uic$v_format uic$r_uic_form.uiv$v_format -# define uic$v_group uic$r_uic_form.uiv$v_group -# define uic$v_member uic$r_uic_form.uiv$v_member +# define uic$v_format uic$r_uic_form.uic$v_format +# define uic$v_group uic$r_uic_form.uic$v_group +# define uic$v_member uic$r_uic_form.uic$v_member # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall @@ -56,6 +57,12 @@ struct itmlst_3 { unsigned short int *retlen; }; +static char *__mystrtolower(char *str) +{ + if (str) for (; *str; ++str) *str= tolower(*str); + return str; +} + int my_trnlnm(char *lnm, char *eqv, unsigned long int idx) { @@ -478,7 +485,7 @@ int my_utime(char *file, struct utimbuf *utimes) for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i]; for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i]; /* This prevents the revision time of the file being reset to the current - * time as a reqult of our IO$_MODIFY $QIO. */ + * time as a result of our IO$_MODIFY $QIO. */ myfib.fib$l_acctl = FIB$M_NORECORD; #else for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i]; @@ -486,6 +493,7 @@ int my_utime(char *file, struct utimbuf *utimes) myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD; #endif retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0); + _ckvmssts(sys$dassgn(chan)); if (retsts & 1) retsts = iosb[0]; if (!(retsts & 1)) { set_vaxc_errno(retsts); @@ -591,6 +599,13 @@ my_popen(char *cmd, char *mode) DSC$K_CLASS_S, 0}; + cmddsc.dsc$w_length=strlen(cmd); + cmddsc.dsc$a_pointer=cmd; + if (cmddsc.dsc$w_length > 255) { + set_errno(E2BIG); set_vaxc_errno(CLI$_BUFOVF); + return Nullfp; + } + New(7001,info,1,struct pipe_details); /* create mailbox */ @@ -605,9 +620,6 @@ my_popen(char *cmd, char *mode) if (!info->fp) return Nullfp; - cmddsc.dsc$w_length=strlen(cmd); - cmddsc.dsc$a_pointer=cmd; - info->mode = *mode; info->done = FALSE; info->completion=0; @@ -761,12 +773,11 @@ my_gconvert(double val, int ndig, int trail, char *buf) ** tounixspec() - convert any file spec into a Unix-style file spec. ** tovmsspec() - convert any file spec into a VMS-style spec. ** -** Copyright 1995 by Charles Bailey -** Permission is given for non-commercial use of this code according -** to the terms of the GNU General Public License or the Perl -** Artistic License. Copies of each may be found in the Perl -** standard distribution. This software is supplied without any -** warranty whatsoever. +** Copyright 1996 by Charles Bailey +** Permission is given to distribute this code as part of the Perl +** standard distribution under the terms of the GNU General Public +** License or the Perl Artistic License. Copies of each may be +** found in the Perl standard distribution. */ static char *do_tounixspec(char *, char *, int); @@ -783,7 +794,7 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL; } dirlen = strlen(dir); - if (dir[dirlen-1] == '/') dir[--dirlen] = '\0'; + if (dir[dirlen-1] == '/') --dirlen; if (!dirlen) { set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR); @@ -795,6 +806,11 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) dir = trndir; dirlen = strlen(dir); } + else { + strncpy(trndir,dir,dirlen); + trndir[dirlen] = '\0'; + dir = trndir; + } /* If we were handed a rooted logical name or spec, treat it like a * simple directory, so that * $ Define myroot dev:[dir.] @@ -818,22 +834,19 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) dirlen -= 1; /* to last element */ lastdir = strrchr(dir,'/'); } - else if ((cp1 = strstr(trndir,"/.")) != NULL) { + else if ((cp1 = strstr(dir,"/.")) != NULL) { + /* If we have "/." or "/..", VMSify it and let the VMS code + * below expand it, rather than repeating the code to handle + * relative components of a filespec here */ do { if (*(cp1+2) == '.') cp1++; if (*(cp1+2) == '/' || *(cp1+2) == '\0') { - addmfd = 1; - break; + if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL; + if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL; + return do_tounixspec(trndir,buf,ts); } cp1++; } while ((cp1 = strstr(cp1,"/.")) != NULL); - /* If we have a relative path, VMSify it and let the VMS code - * below expand it, rather than repeating the code here */ - if (addmfd) { - if (do_tovmsspec(trndir,vmsdir,0) == NULL) return NULL; - if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL; - return do_tounixspec(trndir,buf,ts); - } } else { if (!(lastdir = cp1 = strrchr(dir,'/'))) cp1 = dir; @@ -850,8 +863,8 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) } dirlen = cp2 - dir; } - else { /* There's a type, and it's not .dir. Bzzt. */ - set_errno(ENOTDIR); + else { /* There's a type, and it's not .dir. Bzzt. */ + set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR); return NULL; } @@ -888,8 +901,8 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) return retspec; } else { /* VMS-style directory spec */ - char esa[NAM$C_MAXRSS+1], term; - unsigned long int sts, cmplen, hasdev, hasdir, hastype, hasver; + char esa[NAM$C_MAXRSS+1], term, *cp; + unsigned long int sts, cmplen, haslower = 0; struct FAB dirfab = cc$rms_fab; struct NAM savnam, dirnam = cc$rms_nam; @@ -900,6 +913,9 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) dirfab.fab$b_dns = 6; dirnam.nam$b_ess = NAM$C_MAXRSS; dirnam.nam$l_esa = esa; + + for (cp = dir; *cp; cp++) + if (islower(*cp)) { haslower = 1; break; } if (!((sts = sys$parse(&dirfab))&1)) { if (dirfab.fab$l_sts == RMS$_DIR) { dirnam.nam$b_nop |= NAM$M_SYNCHK; @@ -1023,6 +1039,10 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) /* We've set up the string up through the filename. Add the type and version, and we're done. */ strcat(retspec,".DIR;1"); + + /* $PARSE may have upcased filespec, so convert output to lower + * case if input contained any lowercase characters. */ + if (haslower) __mystrtolower(retspec); return retspec; } } /* end of do_fileify_dirspec() */ @@ -1068,7 +1088,7 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts) retlen = 2 + (*(dir+1) != '\0'); else { if (!(cp1 = strrchr(dir,'/'))) cp1 = dir; - if ((cp2 = strchr(cp1,'.')) && *(cp2+1) != '.') { + if ((cp2 = strchr(cp1,'.')) && (*(cp2+1) != '.' && *(cp2+1) != '\0')) { if (toupper(*(cp2+1)) == 'D' && /* They specified .dir. */ toupper(*(cp2+2)) == 'I' && /* Trim it off. */ toupper(*(cp2+3)) == 'R') { @@ -1095,8 +1115,8 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts) else retpath[retlen-1] = '\0'; } else { /* VMS-style directory spec */ - char esa[NAM$C_MAXRSS+1]; - unsigned long int sts, cmplen; + char esa[NAM$C_MAXRSS+1], *cp; + unsigned long int sts, cmplen, haslower; struct FAB dirfab = cc$rms_fab; struct NAM savnam, dirnam = cc$rms_nam; @@ -1116,7 +1136,11 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts) dirfab.fab$l_nam = &dirnam; dirnam.nam$b_ess = (unsigned char) sizeof esa - 1; dirnam.nam$l_esa = esa; - if (!((sts = sys$parse(&dirfab))&1)) { + + for (cp = dir; *cp; cp++) + if (islower(*cp)) { haslower = 1; break; } + + if (!(sts = (sys$parse(&dirfab)&1))) { if (dirfab.fab$l_sts == RMS$_DIR) { dirnam.nam$b_nop |= NAM$M_SYNCHK; sts = sys$parse(&dirfab) & 1; @@ -1162,6 +1186,9 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts) else if (ts) New(7014,retpath,retlen,char); else retpath = __pathify_retbuf; strcpy(retpath,esa); + /* $PARSE may have upcased filespec, so convert output to lower + * case if input contained any lowercase characters. */ + if (haslower) __mystrtolower(retpath); } return retpath; @@ -1190,7 +1217,7 @@ static char *do_tounixspec(char *spec, char *buf, int ts) if (cp1) { for (cp1++; *cp1 == '-'; cp1++) dashes++; /* VMS '-' ==> Unix '../' */ } - New(7015,rslt,retlen+1+2*dashes,char); + New(7015,rslt,retlen+2+2*dashes,char); } else rslt = __tounixspec_retbuf; if (strchr(spec,'/') != NULL) { @@ -1207,25 +1234,17 @@ static char *do_tounixspec(char *spec, char *buf, int ts) strcpy(rslt,spec); return rslt; } - if (*cp2 != '[') { + if (*cp2 != '[' && *cp2 != '<') { *(cp1++) = '/'; } else { /* the VMS spec begins with directories */ cp2++; - if (*cp2 == '-') { - while (*cp2 == '-') { - *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/'; - cp2++; - } - if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */ - if (ts) Safefree(rslt); /* filespecs like */ - set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [--foo.bar] */ - return NULL; - } - cp2++; + if (*cp2 == ']' || *cp2 == '>') { + strcpy(rslt,"./"); + return rslt; } - else if ( *(cp2) != '.') { /* add the implied device into the Unix spec */ - *(cp1++) = '/'; + else if ( *cp2 != '.' && *cp2 != '-') { + *(cp1++) = '/'; /* add the implied device into the Unix spec */ if (getcwd(tmp,sizeof tmp,1) == NULL) { if (ts) Safefree(rslt); return NULL; @@ -1248,7 +1267,7 @@ static char *do_tounixspec(char *spec, char *buf, int ts) cp1 = rslt + offset; } } - else cp2++; + else if (*cp2 == '.') cp2++; } for (; cp2 <= dirend; cp2++) { if (*cp2 == ':') { @@ -1273,10 +1292,9 @@ static char *do_tounixspec(char *spec, char *buf, int ts) } if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */ if (ts) Safefree(rslt); /* filespecs like */ - set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [--foo.bar] */ + set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */ return NULL; } - cp2++; } else *(cp1++) = *cp2; } @@ -1325,6 +1343,7 @@ static char *do_tovmsspec(char *path, char *buf, int ts) { int islnm, rooted; STRLEN trnend; + while (*(++cp2) == '/') ; /* Skip multiple /s */ while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2; *cp1 = '\0'; islnm = my_trnlnm(rslt,trndev,0); @@ -1370,12 +1389,13 @@ static char *do_tovmsspec(char *path, char *buf, int ts) { } for (; cp2 < dirend; cp2++) { if (*cp2 == '/') { + if (*(cp2-1) == '/') continue; if (*(cp1-1) != '.') *(cp1++) = '.'; infront = 0; } else if (!infront && *cp2 == '.') { - if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */ - else if (*(cp2+1) == '\0') { cp2++; break; } + if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; } + else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */ else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) { if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */ else if (*(cp1-2) == '[') *(cp1-1) = '-'; @@ -1388,17 +1408,13 @@ static char *do_tovmsspec(char *path, char *buf, int ts) { } } cp2 += 2; - if (cp2 == dirend) { - if (*(cp1-1) == '.') cp1--; - break; - } + if (cp2 == dirend) break; } else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */ } else { if (!infront && *(cp1-1) == '-') *(cp1++) = '.'; - if (*cp2 == '/') *(cp1++) = '.'; - else if (*cp2 == '.') *(cp1++) = '_'; + if (*cp2 == '.') *(cp1++) = '_'; else *(cp1++) = *cp2; infront = 1; } @@ -1693,7 +1709,7 @@ getredirection(int *ac, char ***av) /* Check for input from a pipe (mailbox) */ - if (1 == isapipe(0)) + if (in == NULL && 1 == isapipe(0)) { char mbxname[L_tmpnam]; long int bufsize; @@ -1704,11 +1720,6 @@ getredirection(int *ac, char ***av) /* Input from a pipe, reopen it in binary mode to disable */ /* carriage control processing. */ - if (in != NULL) - { - fprintf(stderr,"'|' and '<' may not both be specified on command line"); - exit(LIB$_INVARGORD); - } fgetname(stdin, mbxname,1); mbxnam.dsc$a_pointer = mbxname; mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer); @@ -1841,7 +1852,7 @@ unsigned long int zero = 0, sts; for (c = string; *c; ++c) if (isupper(*c)) *c = tolower(*c); - if (isunix) trim_unixpath(item,string); + if (isunix) trim_unixpath(string,item); add_item(head, tail, string, count); ++expcount; } @@ -1995,40 +2006,103 @@ unsigned long int flags = 17, one = 1, retsts; * full path). Note that returned filespec is Unix-style, regardless * of whether input filespec was VMS-style or Unix-style. * - * Returns !=0 on success, 0 on failure. + * fspec is filespec to be trimmed, and wildspec is wildcard spec used to + * determine prefix (both may be in VMS or Unix syntax). + * + * Returns !=0 on success, with trimmed filespec replacing contents of + * fspec, and 0 on failure, with contents of fpsec unchanged. */ -/*{{{int trim_unixpath(char *template, char *fspec)*/ +/*{{{int trim_unixpath(char *fspec, char *wildspec)*/ int -trim_unixpath(char *template, char *fspec) +trim_unixpath(char *fspec, char *wildspec) { - char unixified[NAM$C_MAXRSS+1], *base, *cp1, *cp2; - register int tmplen; + char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1], + *template, *base, *cp1, *cp2; + register int tmplen, reslen = 0; + if (!wildspec || !fspec) return 0; + if (strpbrk(wildspec,"]>:") != NULL) { + if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0; + else template = unixified; + } + else template = wildspec; if (strpbrk(fspec,"]>:") != NULL) { if (do_tounixspec(fspec,unixified,0) == NULL) return 0; else base = unixified; + /* reslen != 0 ==> we had to unixify resultant filespec, so we must + * check to see that final result fits into (isn't longer than) fspec */ + reslen = strlen(fspec); } else base = fspec; - for (cp2 = base; *cp2; cp2++) ; /* Find end of filespec */ + + /* No prefix or absolute path on wildcard, so nothing to remove */ + if (!*template || *template == '/') { + if (base == fspec) return 1; + tmplen = strlen(unixified); + if (tmplen > reslen) return 0; /* not enough space */ + /* Copy unixified resultant, including trailing NUL */ + memmove(fspec,unixified,tmplen+1); + return 1; + } /* Find prefix to template consisting of path elements without wildcards */ if ((cp1 = strpbrk(template,"*%?")) == NULL) for (cp1 = template; *cp1; cp1++) ; - else while (cp1 >= template && *cp1 != '/') cp1--; - if (cp1 == template) return 1; /* Wildcard was up front - no prefix to clip */ - tmplen = cp1 - template; - - /* Try to find template prefix on filespec */ - if (!memcmp(base,template,tmplen)) return 1; /* Nothing before prefix - we're done */ - for (; cp2 - base > tmplen; base++) { - if (*base != '/') continue; - if (!memcmp(base + 1,template,tmplen)) break; - } - if (cp2 - base == tmplen) return 0; /* Not there - not good */ - base++; /* Move past leading '/' */ - /* Copy down remaining portion of filespec, including trailing NUL */ - memmove(fspec,base,cp2 - base + 1); - return 1; + else while (cp1 > template && *cp1 != '/') cp1--; + for (cp2 = base; *cp2; cp2++) ; /* Find end of resultant filespec */ + + /* Wildcard was in first element, so we don't have a reliable string to + * match against. Guess where to trim resultant filespec by counting + * directory levels in the Unix template. (We could do this instead of + * string matching in all cases, since Unix doesn't have a ... wildcard + * that can expand into multiple levels of subdirectory, but we try for + * the string match so our caller can interpret foo/.../bar.* as + * [.foo...]bar.* if it wants, and only get burned if there was a + * wildcard in the first word (in which case, caveat caller). */ + if (cp1 == template) { + int subdirs = 0; + for ( ; *cp1; cp1++) if (*cp1 == '/') subdirs++; + /* need to back one more '/' than in template, to pick up leading dirname */ + subdirs++; + while (cp2 > base) { + if (*cp2 == '/') subdirs--; + if (!subdirs) break; /* quit without decrement when we hit last '/' */ + cp2--; + } + /* ran out of directories on resultant; allow for already trimmed + * resultant, which hits start of string looking for leading '/' */ + if (subdirs && (cp2 != base || subdirs != 1)) return 0; + /* Move past leading '/', if there is one */ + base = cp2 + (*cp2 == '/' ? 1 : 0); + tmplen = strlen(base); + if (reslen && tmplen > reslen) return 0; /* not enough space */ + memmove(fspec,base,tmplen+1); /* copy result to fspec, with trailing NUL */ + return 1; + } + /* We have a prefix string of complete directory names, so we + * try to find it on the resultant filespec */ + else { + tmplen = cp1 - template; + if (!memcmp(base,template,tmplen)) { /* Nothing before prefix; we're done */ + if (reslen) { /* we converted to Unix syntax; copy result over */ + tmplen = cp2 - base; + if (tmplen > reslen) return 0; /* not enough space */ + memmove(fspec,base,tmplen+1); /* Copy trimmed spec + trailing NUL */ + } + return 1; + } + for ( ; cp2 - base > tmplen; base++) { + if (*base != '/') continue; + if (!memcmp(base + 1,template,tmplen)) break; + } + + if (cp2 - base == tmplen) return 0; /* Not there - not good */ + base++; /* Move past leading '/' */ + if (reslen && cp2 - base > reslen) return 0; /* not enough space */ + /* Copy down remaining portion of filespec, including trailing NUL */ + memmove(fspec,base,cp2 - base + 1); + return 1; + } } /* end of trim_unixpath() */ /*}}}*/ @@ -2407,9 +2481,11 @@ setup_cmddsc(char *cmd, int check_img) } } - return SS$_NORMAL; + return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : SS$_NORMAL); + } /* end of setup_cmddsc() */ + /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */ bool vms_do_aexec(SV *really,SV **mark,SV **sp) @@ -2494,7 +2570,7 @@ do_spawn(char *cmd) set_errno(EVMSERR); set_vaxc_errno(substs); if (dowarn) - warn("Can't exec \"%s\": %s", + warn("Can't spawn \"%s\": %s", hadcmd ? VMScmd.dsc$a_pointer : "", Strerror(errno)); } vms_execfree(); @@ -2585,12 +2661,6 @@ static int contxt= 0; static struct passwd __pwdcache; static char __pw_namecache[UAI$S_IDENT+1]; -static char *_mystrtolower(char *str) -{ - if (str) for (; *str; ++str) *str= tolower(*str); - return str; -} - /* * This routine does most of the work extracting the user information. */ @@ -2667,7 +2737,7 @@ static int fillpasswd (const char *name, struct passwd *pwd) } else strcpy(pwd->pw_unixdir, pwd->pw_dir); - _mystrtolower(pwd->pw_unixdir); + __mystrtolower(pwd->pw_unixdir); return 1; } @@ -2747,7 +2817,7 @@ struct passwd *my_getpwuid(Uid_t uid) else { _ckvmssts(status); } } __pw_namecache[lname]= '\0'; - _mystrtolower(__pw_namecache); + __mystrtolower(__pw_namecache); __pwdcache = __passwd_empty; __pwdcache.pw_name = __pw_namecache; @@ -2986,7 +3056,7 @@ cando_by_name(I32 bit, I32 effective, char *fname) static char usrname[L_cuserid]; 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 short int retlen; struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; @@ -2997,12 +3067,27 @@ cando_by_name(I32 bit, I32 effective, char *fname) {0,0,0,0}}; if (!fname || !*fname) return FALSE; + /* Make sure we expand logical names, since sys$check_access doesn't */ + if (!strpbrk(fname,"/]>:")) { + strcpy(fileified,fname); + while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ; + fname = fileified; + } + 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] == ':') { + if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE; + namdsc.dsc$w_length = strlen(fileified); + namdsc.dsc$a_pointer = fileified; + } + if (!usrdsc.dsc$w_length) { cuserid(usrname); usrdsc.dsc$w_length = strlen(usrname); } - namdsc.dsc$w_length = strlen(fname); - namdsc.dsc$a_pointer = fname; + switch (bit) { case S_IXUSR: case S_IXGRP: @@ -3029,8 +3114,15 @@ cando_by_name(I32 bit, I32 effective, char *fname) } retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst); - if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJ || retsts == RMS$_FNF || - retsts == RMS$_DIR || retsts == RMS$_DEV) return FALSE; +#ifndef SS$_NOSUCHOBJECT /* Older versions of ssdef.h don't have this */ +# define SS$_NOSUCHOBJECT 2696 +#endif + if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT || + retsts == RMS$_FNF || retsts == RMS$_DIR || + retsts == RMS$_DEV) { + set_errno(retsts == SS$_NOPRIV ? EACCES : ENOENT); set_vaxc_errno(retsts); + return FALSE; + } if (retsts == SS$_NORMAL) { if (!privused) return TRUE; /* We can get access, but only by using privs. Do we have the @@ -3126,6 +3218,187 @@ my_getlogin() /*}}}*/ +/* rmscopy - copy a file using VMS RMS routines + * + * Copies contents and attributes of spec_in to spec_out, except owner + * and protection information. Name and type of spec_in are used as + * defaults for spec_out. The third parameter specifies whether rmscopy() + * should try to propagate timestamps from the input file to the output file. + * If it is less than 0, no timestamps are preserved. If it is 0, then + * rmscopy() will behave similarly to the DCL COPY command: timestamps are + * propagated to the output file at creation iff the output file specification + * did not contain an explicit name or type, and the revision date is always + * updated at the end of the copy operation. If it is greater than 0, then + * it is interpreted as a bitmask, in which bit 0 indicates that timestamps + * other than the revision date should be propagated, and bit 1 indicates + * that the revision date should be propagated. + * + * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure. + * + * Copyright 1996 by Charles Bailey . + * Incorporates, with permission, some code from EZCOPY by Tim Adye + * . Permission is given to distribute this code + * as part of the Perl standard distribution under the terms of the + * GNU General Public License or the Perl Artistic License. Copies + * of each may be found in the Perl standard distribution. + */ +/*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/ +int +rmscopy(char *spec_in, char *spec_out, int preserve_dates) +{ + char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS], + rsa[NAM$C_MAXRSS], ubf[32256]; + unsigned long int i, sts, sts2; + struct FAB fab_in, fab_out; + struct RAB rab_in, rab_out; + struct NAM nam; + struct XABDAT xabdat; + struct XABFHC xabfhc; + struct XABRDT xabrdt; + struct XABSUM xabsum; + + if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) || + !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) { + set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); + return 0; + } + + fab_in = cc$rms_fab; + fab_in.fab$l_fna = vmsin; + fab_in.fab$b_fns = strlen(vmsin); + fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI; + fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET; + fab_in.fab$l_fop = FAB$M_SQO; + fab_in.fab$l_nam = &nam; + fab_in.fab$l_xab = (void *) &xabdat; + + nam = cc$rms_nam; + nam.nam$l_rsa = rsa; + nam.nam$b_rss = sizeof(rsa); + nam.nam$l_esa = esa; + nam.nam$b_ess = sizeof (esa); + nam.nam$b_esl = nam.nam$b_rsl = 0; + + xabdat = cc$rms_xabdat; /* To get creation date */ + xabdat.xab$l_nxt = (void *) &xabfhc; + + xabfhc = cc$rms_xabfhc; /* To get record length */ + xabfhc.xab$l_nxt = (void *) &xabsum; + + xabsum = cc$rms_xabsum; /* To get key and area information */ + + if (!((sts = sys$open(&fab_in)) & 1)) { + set_vaxc_errno(sts); + switch (sts) { + case RMS$_FNF: + case RMS$_DIR: + set_errno(ENOENT); break; + case RMS$_DEV: + set_errno(ENODEV); break; + case RMS$_SYN: + set_errno(EINVAL); break; + case RMS$_PRV: + set_errno(EACCES); break; + default: + set_errno(EVMSERR); + } + return 0; + } + + fab_out = fab_in; + fab_out.fab$w_ifi = 0; + fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT; + fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI; + fab_out.fab$l_fop = FAB$M_SQO; + fab_out.fab$l_fna = vmsout; + fab_out.fab$b_fns = strlen(vmsout); + fab_out.fab$l_dna = nam.nam$l_name; + fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0; + + if (preserve_dates == 0) { /* Act like DCL COPY */ + nam.nam$b_nop = NAM$M_SYNCHK; + fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */ + if (!((sts = sys$parse(&fab_out)) & 1)) { + set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR); + set_vaxc_errno(sts); + return 0; + } + fab_out.fab$l_xab = (void *) &xabdat; + if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1; + } + fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */ + if (preserve_dates < 0) /* Clear all bits; we'll use it as a */ + preserve_dates =0; /* bitmask from this point forward */ + + if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc; + if (!((sts = sys$create(&fab_out)) & 1)) { + set_vaxc_errno(sts); + switch (sts) { + case RMS$_DIR: + set_errno(ENOENT); break; + case RMS$_DEV: + set_errno(ENODEV); break; + case RMS$_SYN: + set_errno(EINVAL); break; + case RMS$_PRV: + set_errno(EACCES); break; + default: + set_errno(EVMSERR); + } + return 0; + } + fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */ + if (preserve_dates & 2) { + /* sys$close() will process xabrdt, not xabdat */ + xabrdt = cc$rms_xabrdt; + xabrdt.xab$q_rdt = xabdat.xab$q_rdt; + fab_out.fab$l_xab = (void *) &xabrdt; + } + + rab_in = cc$rms_rab; + rab_in.rab$l_fab = &fab_in; + rab_in.rab$l_rop = RAB$M_BIO; + rab_in.rab$l_ubf = ubf; + rab_in.rab$w_usz = sizeof ubf; + if (!((sts = sys$connect(&rab_in)) & 1)) { + sys$close(&fab_in); sys$close(&fab_out); + set_errno(EVMSERR); set_vaxc_errno(sts); + return 0; + } + + rab_out = cc$rms_rab; + rab_out.rab$l_fab = &fab_out; + rab_out.rab$l_rbf = ubf; + if (!((sts = sys$connect(&rab_out)) & 1)) { + sys$close(&fab_in); sys$close(&fab_out); + set_errno(EVMSERR); set_vaxc_errno(sts); + return 0; + } + + while ((sts = sys$read(&rab_in))) { /* always true */ + if (sts == RMS$_EOF) break; + rab_out.rab$w_rsz = rab_in.rab$w_rsz; + if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) { + sys$close(&fab_in); sys$close(&fab_out); + set_errno(EVMSERR); set_vaxc_errno(sts); + return 0; + } + } + + fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */ + sys$close(&fab_in); sys$close(&fab_out); + sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts; + if (!(sts & 1)) { + set_errno(EVMSERR); set_vaxc_errno(sts); + return 0; + } + + return 1; + +} /* end of rmscopy() */ +/*}}}*/ + + /*** The following glue provides 'hooks' to make some of the routines * from this file available from Perl. These routines are sufficiently * basic, and are required sufficiently early in the build process, @@ -3136,6 +3409,55 @@ my_getlogin() */ void +rmsexpand_fromperl(CV *cv) +{ + dXSARGS; + char esa[NAM$C_MAXRSS], rsa[NAM$C_MAXRSS], *cp, *out; + struct FAB myfab = cc$rms_fab; + struct NAM mynam = cc$rms_nam; + STRLEN speclen; + unsigned long int retsts, haslower = 0; + + myfab.fab$l_fna = SvPV(ST(0),speclen); + myfab.fab$b_fns = speclen; + myfab.fab$l_nam = &mynam; + + mynam.nam$l_esa = esa; + mynam.nam$b_ess = sizeof esa; + mynam.nam$l_rsa = rsa; + mynam.nam$b_rss = sizeof rsa; + + retsts = sys$parse(&myfab,0,0); + if (!(retsts & 1)) { + set_vaxc_errno(retsts); + if (retsts == RMS$_PRV) set_errno(EACCES); + else if (retsts == RMS$_DEV) set_errno(ENODEV); + else if (retsts == RMS$_DIR) set_errno(ENOTDIR); + else set_errno(EVMSERR); + XSRETURN_UNDEF; + } + retsts = sys$search(&myfab,0,0); + if (!(retsts & 1) && retsts != RMS$_FNF) { + set_vaxc_errno(retsts); + if (retsts == RMS$_PRV) set_errno(EACCES); + else set_errno(EVMSERR); + XSRETURN_UNDEF; + } + /* If the input filespec contained any lowercase characters, + * downcase the result for compatibility with Unix-minded code. */ + for (out = myfab.fab$l_fna; *out; out++) + if (islower(*out)) { haslower = 1; break; } + if (mynam.nam$b_rsl) { out = rsa; speclen = mynam.nam$b_rsl; } + else { out = esa; speclen = mynam.nam$b_esl; } + if (!(mynam.nam$l_fnb & NAM$M_EXP_VER)) + speclen = mynam.nam$l_type - out; + out[speclen] = '\0'; + if (haslower) __mystrtolower(out); + + ST(0) = sv_2mortal(newSVpv(out, speclen)); +} + +void vmsify_fromperl(CV *cv) { dXSARGS; @@ -3217,12 +3539,83 @@ void candelete_fromperl(CV *cv) { dXSARGS; - char vmsspec[NAM$C_MAXRSS+1]; + char fspec[NAM$C_MAXRSS+1], *fsp; + SV *mysv; + IO *io; if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)"); - if (do_tovmsspec(SvPV(ST(0),na),buf,0) && cando_by_name(S_IDUSR,0,buf)) - ST(0) = &sv_yes; - else ST(0) = &sv_no; + + mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0); + if (SvTYPE(mysv) == SVt_PVGV) { + if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec)) { + set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); + ST(0) = &sv_no; + XSRETURN(1); + } + fsp = fspec; + } + else { + if (mysv != ST(0) || !(fsp = SvPV(mysv,na)) || !*fsp) { + set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); + ST(0) = &sv_no; + XSRETURN(1); + } + } + + ST(0) = cando_by_name(S_IDUSR,0,fsp) ? &sv_yes : &sv_no; + XSRETURN(1); +} + +void +rmscopy_fromperl(CV *cv) +{ + dXSARGS; + char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp; + int date_flag; + struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}, + outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; + unsigned long int sts; + SV *mysv; + IO *io; + + if (items < 2 || items > 3) + croak("Usage: File::Copy::rmscopy(from,to[,date_flag])"); + + mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0); + if (SvTYPE(mysv) == SVt_PVGV) { + if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec)) { + set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); + ST(0) = &sv_no; + XSRETURN(1); + } + inp = inspec; + } + else { + if (mysv != ST(0) || !(inp = SvPV(mysv,na)) || !*inp) { + set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); + ST(0) = &sv_no; + XSRETURN(1); + } + } + mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1); + if (SvTYPE(mysv) == SVt_PVGV) { + if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec)) { + set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); + ST(0) = &sv_no; + XSRETURN(1); + } + outp = outspec; + } + else { + if (mysv != ST(1) || !(outp = SvPV(mysv,na)) || !*outp) { + set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); + ST(0) = &sv_no; + XSRETURN(1); + } + } + date_flag = (items == 3) ? SvIV(ST(2)) : 0; + + ST(0) = rmscopy(inp,outp,date_flag) ? &sv_yes : &sv_no; XSRETURN(1); } @@ -3231,13 +3624,15 @@ init_os_extras() { char* file = __FILE__; - newXS("VMS::Filespec::vmsify",vmsify_fromperl,file); - newXS("VMS::Filespec::unixify",unixify_fromperl,file); - newXS("VMS::Filespec::pathify",pathify_fromperl,file); - newXS("VMS::Filespec::fileify",fileify_fromperl,file); - newXS("VMS::Filespec::vmspath",vmspath_fromperl,file); - newXS("VMS::Filespec::unixpath",unixpath_fromperl,file); - newXS("VMS::Filespec::candelete",candelete_fromperl,file); + newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$"); + newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$"); + newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$"); + newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$"); + newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$"); + newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$"); + newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$"); + newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$"); + newXS("File::Copy::rmscopy",rmscopy_fromperl,file); return; }