X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=vms%2Fvms.c;h=150747f52d29a624f51351ec8b876db0c184c08e;hb=7aa5c81fb93ce6741dd5751e93d46dc87d2c1c61;hp=9a079414afed2bd4733dcde9c4228c6ebdf43440;hpb=e518068a77032c4207f9b00e462857e158778ea4;p=p5sagit%2Fp5-mst-13.2.git diff --git a/vms/vms.c b/vms/vms.c index 9a07941..150747f 100644 --- a/vms/vms.c +++ b/vms/vms.c @@ -2,8 +2,8 @@ * * VMS-specific routines for perl5 * - * Last revised: 22-Nov-1995 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 @@ -36,6 +37,19 @@ #include "perl.h" #include "XSUB.h" +/* 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.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 +# define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv +#endif + + struct itmlst_3 { unsigned short int buflen; unsigned short int itmcode; @@ -43,30 +57,40 @@ struct itmlst_3 { unsigned short int *retlen; }; -static char * -my_trnlnm(char *lnm, char *eqv) +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) { static char __my_trnlnm_eqv[LNM$C_NAMLENGTH+1]; unsigned short int eqvlen; unsigned long int retsts, attr = LNM$M_CASE_BLIND; $DESCRIPTOR(tabdsc,"LNM$FILE_DEV"); struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0}; - struct itmlst_3 lnmlst[2] = {{LNM$C_NAMLENGTH, LNM$_STRING,0, &eqvlen}, + struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0}, + {LNM$C_NAMLENGTH, LNM$_STRING, 0, &eqvlen}, {0, 0, 0, 0}}; if (!eqv) eqv = __my_trnlnm_eqv; - lnmlst[0].bufadr = (void *)eqv; + lnmlst[1].bufadr = (void *)eqv; lnmdsc.dsc$a_pointer = lnm; lnmdsc.dsc$w_length = strlen(lnm); retsts = sys$trnlnm(&attr,&tabdsc,&lnmdsc,0,lnmlst); - if (retsts == SS$_NOLOGNAM || retsts == SS$_IVLOGNAM) return Nullch; + if (retsts == SS$_NOLOGNAM || retsts == SS$_IVLOGNAM) { + set_vaxc_errno(retsts); set_errno(EINVAL); return 0; + } else if (retsts & 1) { eqv[eqvlen] = '\0'; - return eqv; + return 1; } _ckvmssts(retsts); /* Must be an error */ - return Nullch; /* Not reached, assuming _ckvmssts() bails out */ -} + return 0; /* Not reached, assuming _ckvmssts() bails out */ + +} /* end of my_trnlnm */ /* my_getenv * Translate a logical name. Substitute for CRTL getenv() to avoid @@ -82,6 +106,7 @@ my_getenv(char *lnm) { static char __my_getenv_eqv[LNM$C_NAMLENGTH+1]; char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2; + unsigned long int idx = 0; for (cp1 = lnm, cp2= uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1); *cp2 = '\0'; @@ -89,24 +114,31 @@ my_getenv(char *lnm) getcwd(__my_getenv_eqv,sizeof __my_getenv_eqv); return __my_getenv_eqv; } - else if (my_trnlnm(uplnm,__my_getenv_eqv) != NULL) { - return __my_getenv_eqv; - } else { - unsigned long int retsts; - struct dsc$descriptor_s symdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0}, - valdsc = {sizeof __my_getenv_eqv,DSC$K_DTYPE_T, - DSC$K_CLASS_S, __my_getenv_eqv}; - symdsc.dsc$w_length = cp1 - lnm; - symdsc.dsc$a_pointer = uplnm; - retsts = lib$get_symbol(&symdsc,&valdsc,&(valdsc.dsc$w_length),0); - if (retsts == LIB$_INVSYMNAM) return Nullch; - if (retsts != LIB$_NOSUCHSYM) { - /* We want to return only logical names or CRTL Unix emulations */ - if (retsts & 1) return Nullch; - _ckvmssts(retsts); + if ((cp2 = strchr(uplnm,';')) != NULL) { + *cp2 = '\0'; + idx = strtoul(cp2+1,NULL,0); + } + if (my_trnlnm(uplnm,__my_getenv_eqv,idx)) { + return __my_getenv_eqv; + } + else { + unsigned long int retsts; + struct dsc$descriptor_s symdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0}, + valdsc = {sizeof __my_getenv_eqv,DSC$K_DTYPE_T, + DSC$K_CLASS_S, __my_getenv_eqv}; + symdsc.dsc$w_length = cp1 - lnm; + symdsc.dsc$a_pointer = uplnm; + retsts = lib$get_symbol(&symdsc,&valdsc,&(valdsc.dsc$w_length),0); + if (retsts == LIB$_INVSYMNAM) return Nullch; + if (retsts != LIB$_NOSUCHSYM) { + /* We want to return only logical names or CRTL Unix emulations */ + if (retsts & 1) return Nullch; + _ckvmssts(retsts); + } + /* Try for CRTL emulation of a Unix/POSIX name */ + else return getenv(lnm); } - else return getenv(lnm); /* Try for CRTL emulation of a Unix/POSIX name */ } return Nullch; @@ -149,6 +181,69 @@ my_setenv(char *lnm,char *eqv) } /* end of my_setenv() */ /*}}}*/ + +/*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/ +/* my_crypt - VMS password hashing + * my_crypt() provides an interface compatible with the Unix crypt() + * C library function, and uses sys$hash_password() to perform VMS + * password hashing. The quadword hashed password value is returned + * as a NUL-terminated 8 character string. my_crypt() does not change + * the case of its string arguments; in order to match the behavior + * of LOGINOUT et al., alphabetic characters in both arguments must + * be upcased by the caller. + */ +char * +my_crypt(const char *textpasswd, const char *usrname) +{ +# ifndef UAI$C_PREFERRED_ALGORITHM +# define UAI$C_PREFERRED_ALGORITHM 127 +# endif + unsigned char alg = UAI$C_PREFERRED_ALGORITHM; + unsigned short int salt = 0; + unsigned long int sts; + struct const_dsc { + unsigned short int dsc$w_length; + unsigned char dsc$b_type; + unsigned char dsc$b_class; + const char * dsc$a_pointer; + } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}, + txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; + struct itmlst_3 uailst[3] = { + { sizeof alg, UAI$_ENCRYPT, &alg, 0}, + { sizeof salt, UAI$_SALT, &salt, 0}, + { 0, 0, NULL, NULL}}; + static char hash[9]; + + usrdsc.dsc$w_length = strlen(usrname); + usrdsc.dsc$a_pointer = usrname; + if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) { + switch (sts) { + case SS$_NOGRPPRV: + case SS$_NOSYSPRV: + set_errno(EACCES); + break; + case RMS$_RNF: + set_errno(ESRCH); /* There isn't a Unix no-such-user error */ + break; + default: + set_errno(EVMSERR); + } + set_vaxc_errno(sts); + if (sts != RMS$_RNF) return NULL; + } + + txtdsc.dsc$w_length = strlen(textpasswd); + txtdsc.dsc$a_pointer = textpasswd; + if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) { + set_errno(EVMSERR); set_vaxc_errno(sts); return NULL; + } + + return (char *) hash; + +} /* end of my_crypt() */ +/*}}}*/ + + static char *do_fileify_dirspec(char *, char *, int); static char *do_tovmsspec(char *, char *, int); @@ -390,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]; @@ -398,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); @@ -503,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 */ @@ -517,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; @@ -560,11 +660,11 @@ I32 my_pclose(FILE *fp) /* get here => no such pipe open */ croak("No such pipe open"); + fclose(info->fp); + if (info->done) retsts = info->completion; else waitpid(info->pid,(int *) &retsts,0); - fclose(info->fp); - /* remove from list of open pipes */ if (last) last->next = info->next; else open_pipes = info->next; @@ -673,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); @@ -691,15 +790,37 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) char *retspec, *cp1, *cp2, *lastdir; char trndir[NAM$C_MAXRSS+1], vmsdir[NAM$C_MAXRSS+1]; - if (dir == NULL) return NULL; + if (!dir || !*dir) { + 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); + return NULL; + } if (!strpbrk(dir+1,"/]>:")) { strcpy(trndir,*dir == '/' ? dir + 1: dir); - while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir) != NULL) ; + while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ; 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.] + * ... do_fileify_dirspec("myroot",buf,1) ... + * does something useful. + */ + if (!strcmp(dir+dirlen-2,".]")) { + dir[--dirlen] = '\0'; + dir[dirlen-1] = ']'; + } if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain dir name */ if (dir[0] == '.') { @@ -713,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; @@ -745,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; } @@ -783,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; @@ -795,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; @@ -848,6 +969,11 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) strcpy(retspec,esa); return retspec; } + if ((cp1 = strstr(esa,".][000000]")) != NULL) { + for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2; + *cp1 = '\0'; + dirnam.nam$b_esl -= 9; + } if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>'); if (cp1 == NULL) return NULL; /* should never happen */ term = *cp1; @@ -913,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() */ @@ -930,10 +1060,26 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts) unsigned long int retlen; char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1]; - if (dir == NULL) return NULL; + if (!dir || !*dir) { + set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL; + } + + if (*dir) strcpy(trndir,dir); + else getcwd(trndir,sizeof trndir - 1); + + while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir,0)) { + STRLEN trnlen = strlen(trndir); - strcpy(trndir,dir); - while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir) != NULL) ; + /* Trap simple rooted lnms, and return lnm:[000000] */ + if (!strcmp(trndir+trnlen-2,".]")) { + if (buf) retpath = buf; + else if (ts) New(7018,retpath,strlen(dir)+10,char); + else retpath = __pathify_retbuf; + strcpy(retpath,dir); + strcat(retpath,":[000000]"); + return retpath; + } + } dir = trndir; if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain dir name */ @@ -942,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') { @@ -969,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; @@ -990,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; @@ -1036,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; @@ -1064,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) { @@ -1081,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; @@ -1122,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 == ':') { @@ -1147,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; } @@ -1199,9 +1343,10 @@ 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) != Nullch); + islnm = my_trnlnm(rslt,trndev,0); trnend = islnm ? strlen(trndev) - 1 : 0; islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0; rooted = islnm ? (trndev[trnend-1] == '.') : 0; @@ -1244,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) = '-'; @@ -1262,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; } @@ -1567,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; @@ -1578,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); @@ -1658,7 +1795,6 @@ static void expand_wild_cards(char *item, int expcount = 0; unsigned long int context = 0; int isunix = 0; -int status_value; char *had_version; char *had_device; int had_directory; @@ -1667,7 +1803,7 @@ char vmsspec[NAM$C_MAXRSS+1]; $DESCRIPTOR(filespec, ""); $DESCRIPTOR(defaultspec, "SYS$DISK:[]"); $DESCRIPTOR(resultspec, ""); -unsigned long int zero = 0; +unsigned long int zero = 0, sts; if (strcspn(item, "*%") == strlen(item)) { @@ -1692,8 +1828,8 @@ unsigned long int zero = 0; had_device = strchr(item, ':'); had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<')); - while (1 == (1&lib$find_file(&filespec, &resultspec, &context, - &defaultspec, 0, &status_value, &zero))) + while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context, + &defaultspec, 0, 0, &zero)))) { char *string; char *c; @@ -1716,14 +1852,32 @@ unsigned long int zero = 0; 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; } + if (sts != RMS$_NMF) + { + 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: + _ckvmssts(sts); + } + } if (expcount == 0) add_item(head, tail, item, count); - lib$sfree1_dd(&resultspec); - lib$find_file_end(&context); + _ckvmssts(lib$sfree1_dd(&resultspec)); + _ckvmssts(lib$find_file_end(&context)); } static int child_st[2];/* Event Flag set when child process completes */ @@ -1852,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() */ /*}}}*/ @@ -2035,17 +2252,12 @@ readdir(DIR *dd) set_vaxc_errno(tmpsts); switch (tmpsts) { case RMS$_PRV: - set_errno(EACCES); - break; + set_errno(EACCES); break; case RMS$_DEV: - set_errno(ENODEV); - break; + set_errno(ENODEV); break; case RMS$_DIR: - set_errno(ENOTDIR); - break; case RMS$_FNF: - set_errno(ENOENT); - break; + set_errno(ENOENT); break; default: set_errno(EVMSERR); } @@ -2269,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) @@ -2356,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(); @@ -2447,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. */ @@ -2479,7 +2687,7 @@ static int fillpasswd (const char *name, struct passwd *pwd) static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd; struct dsc$descriptor_s name_desc; - int status; + unsigned long int sts; static struct itmlst_3 itmlst[]= { {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner}, @@ -2496,8 +2704,12 @@ static int fillpasswd (const char *name, struct passwd *pwd) name_desc.dsc$a_pointer= (char *) name; /* Note that sys$getuai returns many fields as counted strings. */ - status= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0); - if (!(status&1)) return status; + sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0); + if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) { + set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES); + } + else { _ckvmssts(sts); } + if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */ if ((int) owner.length < lowner) lowner= (int) owner.length; if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length; @@ -2525,8 +2737,8 @@ static int fillpasswd (const char *name, struct passwd *pwd) } else strcpy(pwd->pw_unixdir, pwd->pw_dir); - _mystrtolower(pwd->pw_unixdir); - return status; + __mystrtolower(pwd->pw_unixdir); + return 1; } /* @@ -2540,8 +2752,7 @@ struct passwd *my_getpwnam(char *name) unsigned long int status, stat; __pwdcache = __passwd_empty; - if ((status = fillpasswd(name, &__pwdcache)) == SS$_NOSYSPRV - || status == SS$_NOGRPPRV || status == RMS$_RNF) { + if (!fillpasswd(name, &__pwdcache)) { /* We still may be able to determine pw_uid and pw_gid */ name_desc.dsc$w_length= strlen(name); name_desc.dsc$b_dtype= DSC$K_DTYPE_T; @@ -2551,10 +2762,15 @@ struct passwd *my_getpwnam(char *name) __pwdcache.pw_uid= uic.uic$l_uic; __pwdcache.pw_gid= uic.uic$v_group; } - else if (stat == SS$_NOSUCHID || stat == RMS$_PRV) return NULL; - else { _ckvmssts(stat); } + else { + if (stat == SS$_NOSUCHID || stat == SS$_IVIDENT || stat == RMS$_PRV) { + set_vaxc_errno(stat); + set_errno(stat == RMS$_PRV ? EACCES : EINVAL); + return NULL; + } + else { _ckvmssts(stat); } + } } - else { _ckvmssts(status); } strncpy(__pw_namecache, name, sizeof(__pw_namecache)); __pw_namecache[sizeof __pw_namecache - 1] = '\0'; __pwdcache.pw_name= __pw_namecache; @@ -2578,6 +2794,8 @@ struct passwd *my_getpwuid(Uid_t uid) do { status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt); if (status == SS$_NOSUCHID || status == RMS$_PRV) { + set_vaxc_errno(status); + set_errno(status == RMS$_PRV ? EACCES : EINVAL); my_endpwent(); return NULL; } @@ -2586,14 +2804,20 @@ struct passwd *my_getpwuid(Uid_t uid) } else { uic.uic$l_uic= uid; - if (!uic.uic$v_group) uic.uic$v_group= getgid(); + if (!uic.uic$v_group) + uic.uic$v_group= getgid(); if (valid_uic(uic)) status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0); else status = SS$_IVIDENT; - _ckvmssts(status); + if (status == SS$_IVIDENT || status == SS$_NOSUCHID || + status == RMS$_PRV) { + set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL); + return NULL; + } + else { _ckvmssts(status); } } __pw_namecache[lname]= '\0'; - _mystrtolower(__pw_namecache); + __mystrtolower(__pw_namecache); __pwdcache = __passwd_empty; __pwdcache.pw_name = __pw_namecache; @@ -2604,9 +2828,7 @@ struct passwd *my_getpwuid(Uid_t uid) __pwdcache.pw_uid = uic.uic$l_uic; __pwdcache.pw_gid = uic.uic$v_group; - status = fillpasswd(__pw_namecache, &__pwdcache); - if (status != SS$_NOSYSPRV && status != SS$_NOGRPPRV && - status != RMS$_RNF) { _ckvmssts(status); } + fillpasswd(__pw_namecache, &__pwdcache); return &__pwdcache; } /* end of my_getpwuid() */ @@ -2810,7 +3032,7 @@ cando(I32 bit, I32 effective, struct stat *statbufp) namdsc.dsc$a_pointer = fname; namdsc.dsc$w_length = sizeof fname - 1; - retsts = lib$fid_to_name(&devdsc,statbufp->st_inode_u.fid,&namdsc, + retsts = lib$fid_to_name(&devdsc,&(statbufp->st_ino),&namdsc, &namdsc.dsc$w_length,0,0); if (retsts & 1) { fname[namdsc.dsc$w_length] = '\0'; @@ -2826,6 +3048,7 @@ cando(I32 bit, I32 effective, struct stat *statbufp) } /* end of cando() */ /*}}}*/ + /*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/ I32 cando_by_name(I32 bit, I32 effective, char *fname) @@ -2833,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}; @@ -2844,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: @@ -2876,18 +3114,25 @@ 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 necessary privs currently enabled? */ _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0)); if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE; - if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv - && !curprv.prv$v_bypass) return FALSE; - if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv - && !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE; + if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv && + !curprv.prv$v_bypass) return FALSE; + if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv && + !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE; if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE; return TRUE; } @@ -2962,6 +3207,198 @@ flex_stat(char *fspec, struct mystat *statbufp) #define stat mystat /*}}}*/ +/*{{{char *my_getlogin()*/ +/* VMS cuserid == Unix getlogin, except calling sequence */ +char * +my_getlogin() +{ + static char user[L_cuserid]; + return cuserid(user); +} +/*}}}*/ + + +/* 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, @@ -2972,6 +3409,55 @@ flex_stat(char *fspec, struct mystat *statbufp) */ 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; @@ -3053,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); } @@ -3067,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; }