X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=vms%2Fvms.c;h=073bf564703a8a64b7a4303a9f6d5ffe67037f18;hb=d896966de2ebabc4abc3d080ae3c7ee77c51781e;hp=fef054ae4c36e17bc07dbe36fd82b5ebf7b7551d;hpb=4633a7c4bad06b471d9310620b7fe8ddd158cccd;p=p5sagit%2Fp5-mst-13.2.git diff --git a/vms/vms.c b/vms/vms.c index fef054a..073bf56 100644 --- a/vms/vms.c +++ b/vms/vms.c @@ -2,8 +2,8 @@ * * VMS-specific routines for perl5 * - * Last revised: 5-Jun-1995 by Charles Bailey bailey@genetics.upenn.edu - * Version: 5.1.5 + * Last revised: 18-Jan-1996 by Charles Bailey bailey@genetics.upenn.edu + * Version: 5.2.0 */ #include @@ -36,6 +36,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 +56,34 @@ struct itmlst_3 { unsigned short int *retlen; }; -static char * -my_trnlnm(char *lnm, char *eqv) +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 +99,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 +107,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 +174,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); @@ -220,7 +308,8 @@ kill_file(char *name) } /* 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) { + 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; @@ -304,7 +393,7 @@ int my_utime(char *file, struct utimbuf *utimes) set_vaxc_errno(LIB$_INVARG); return -1; } - if (tovmsspec(file,vmsspec) == NULL) return -1; + if (do_tovmsspec(file,vmsspec,0) == NULL) return -1; if (utimes != NULL) { /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00) @@ -541,6 +630,7 @@ my_popen(char *cmd, char *mode) info->next=open_pipes; /* prepend to list */ open_pipes=info; + forkprocess = info->pid; return info->fp; } /*}}}*/ @@ -558,11 +648,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; @@ -670,6 +760,13 @@ my_gconvert(double val, int ndig, int trail, char *buf) ** tovmspath() - convert a directory spec into a VMS-style path. ** 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. */ static char *do_tounixspec(char *, char *, int); @@ -682,12 +779,33 @@ 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; - strcpy(trndir,dir); - while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir) != NULL) ; - dir = trndir; - + if (!dir || !*dir) { + set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL; + } dirlen = strlen(dir); + if (dir[dirlen-1] == '/') dir[--dirlen] = '\0'; + 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,0)) ; + dir = trndir; + dirlen = strlen(dir); + } + /* 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] == '.') { if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0')) @@ -752,7 +870,7 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) } retlen = dirlen + (addmfd ? 13 : 6); if (buf) retspec = buf; - else if (ts) New(7009,retspec,retlen+6,char); + else if (ts) New(7009,retspec,retlen+1,char); else retspec = __fileify_retbuf; if (addmfd) { dirlen = lastdir - dir; @@ -771,7 +889,7 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) } else { /* VMS-style directory spec */ char esa[NAM$C_MAXRSS+1], term; - unsigned long int cmplen, hasdev, hasdir, hastype, hasver; + unsigned long int sts, cmplen, hasdev, hasdir, hastype, hasver; struct FAB dirfab = cc$rms_fab; struct NAM savnam, dirnam = cc$rms_nam; @@ -782,23 +900,31 @@ 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; - if (!(sys$parse(&dirfab)&1)) { - set_errno(EVMSERR); - set_vaxc_errno(dirfab.fab$l_sts); - return NULL; - } - savnam = dirnam; - if (sys$search(&dirfab)&1) { /* Does the file really exist? */ - /* Yes; fake the fnb bits so we'll check type below */ - dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER; - } - else { - if (dirfab.fab$l_sts != RMS$_FNF) { + 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; + } + if (!sts) { set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts); return NULL; } - dirnam = savnam; /* No; just work with potential name */ + } + else { + savnam = dirnam; + if (sys$search(&dirfab)&1) { /* Does the file really exist? */ + /* Yes; fake the fnb bits so we'll check type below */ + dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER; + } + else { + if (dirfab.fab$l_sts != RMS$_FNF) { + set_errno(EVMSERR); + set_vaxc_errno(dirfab.fab$l_sts); + return NULL; + } + dirnam = savnam; /* No; just work with potential name */ + } } if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) { cp1 = strchr(esa,']'); @@ -822,11 +948,16 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) { /* They provided at least the name; we added the type, if necessary, */ if (buf) retspec = buf; /* in sys$parse() */ - else if (ts) New(7011,retspec,dirnam.nam$b_esl,char); + else if (ts) New(7011,retspec,dirnam.nam$b_esl+1,char); else retspec = __fileify_retbuf; 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; @@ -836,7 +967,7 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) /* There's more than one directory in the path. Just roll back. */ *cp1 = term; if (buf) retspec = buf; - else if (ts) New(7011,retspec,retlen+6,char); + else if (ts) New(7011,retspec,retlen+7,char); else retspec = __fileify_retbuf; strcpy(retspec,esa); } @@ -851,7 +982,7 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) } retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */ if (buf) retspec = buf; - else if (ts) New(7012,retspec,retlen+14,char); + else if (ts) New(7012,retspec,retlen+16,char); else retspec = __fileify_retbuf; cp1 = strstr(esa,"]["); dirlen = cp1 - esa; @@ -879,7 +1010,7 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) } else { /* This is a top-level dir. Add the MFD to the path. */ if (buf) retspec = buf; - else if (ts) New(7012,retspec,retlen+14,char); + else if (ts) New(7012,retspec,retlen+16,char); else retspec = __fileify_retbuf; cp1 = esa; cp2 = retspec; @@ -909,10 +1040,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 */ @@ -938,7 +1085,7 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts) } } if (buf) retpath = buf; - else if (ts) New(7013,retpath,retlen,char); + else if (ts) New(7013,retpath,retlen+1,char); else retpath = __pathify_retbuf; strncpy(retpath,dir,retlen-1); if (retpath[retlen-2] != '/') { /* If the path doesn't already end */ @@ -949,7 +1096,7 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts) } else { /* VMS-style directory spec */ char esa[NAM$C_MAXRSS+1]; - unsigned long int cmplen; + unsigned long int sts, cmplen; struct FAB dirfab = cc$rms_fab; struct NAM savnam, dirnam = cc$rms_nam; @@ -959,7 +1106,7 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts) dir[dirfab.fab$b_fns-1] == '>' || dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */ if (buf) retpath = buf; - else if (ts) New(7014,retpath,strlen(dir),char); + else if (ts) New(7014,retpath,strlen(dir)+1,char); else retpath = __pathify_retbuf; strcpy(retpath,dir); return retpath; @@ -967,23 +1114,30 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts) dirfab.fab$l_dna = ".DIR;1"; dirfab.fab$b_dns = 6; dirfab.fab$l_nam = &dirnam; - dirnam.nam$b_ess = (unsigned char) sizeof esa; + dirnam.nam$b_ess = (unsigned char) sizeof esa - 1; dirnam.nam$l_esa = esa; - if (!(sys$parse(&dirfab)&1)) { - set_errno(EVMSERR); - set_vaxc_errno(dirfab.fab$l_sts); - return NULL; - } - savnam = dirnam; - if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */ - if (dirfab.fab$l_sts != RMS$_FNF) { + 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; + } + if (!sts) { set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts); return NULL; } - dirnam = savnam; /* No; just work with potential name */ } - + else { + savnam = dirnam; + if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */ + if (dirfab.fab$l_sts != RMS$_FNF) { + set_errno(EVMSERR); + set_vaxc_errno(dirfab.fab$l_sts); + return NULL; + } + dirnam = savnam; /* No; just work with potential name */ + } + } if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */ /* Yep; check version while we're at it, if it's there. */ cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4; @@ -1024,11 +1178,20 @@ static char *do_tounixspec(char *spec, char *buf, int ts) { static char __tounixspec_retbuf[NAM$C_MAXRSS+1]; char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1]; - int devlen, dirlen; + int devlen, dirlen, retlen = NAM$C_MAXRSS+1, dashes = 0; if (spec == NULL) return NULL; + if (strlen(spec) > NAM$C_MAXRSS) return NULL; if (buf) rslt = buf; - else if (ts) New(7015,rslt,NAM$C_MAXRSS+1,char); + else if (ts) { + retlen = strlen(spec); + cp1 = strchr(spec,'['); + if (!cp1) cp1 = strchr(spec,'<'); + if (cp1) { + for (cp1++; *cp1 == '-'; cp1++) dashes++; /* VMS '-' ==> Unix '../' */ + } + New(7015,rslt,retlen+2+2*dashes,char); + } else rslt = __tounixspec_retbuf; if (strchr(spec,'/') != NULL) { strcpy(rslt,spec); @@ -1044,12 +1207,16 @@ 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 == '-') { + if (*cp2 == ']' || *cp2 == '>') { + strcpy(rslt,"./"); + return rslt; + } + else if (*cp2 == '-') { while (*cp2 == '-') { *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/'; cp2++; @@ -1072,15 +1239,17 @@ static char *do_tounixspec(char *spec, char *buf, int ts) while (*cp3 != ':' && *cp3) cp3++; *(cp3++) = '\0'; if (strchr(cp3,']') != NULL) break; - } while (((cp3 = getenv(tmp)) != NULL) && strcpy(tmp,cp3)); + } while (((cp3 = my_getenv(tmp)) != NULL) && strcpy(tmp,cp3)); cp3 = tmp; while (*cp3) *(cp1++) = *(cp3++); *(cp1++) = '/'; - if ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > NAM$C_MAXRSS) { - if (ts) Safefree(rslt); - set_errno(ERANGE); - set_errno(RMS$_SYN); - return NULL; + if (ts && + ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) { + int offset = cp1 - rslt; + + retlen = devlen + dirlen; + Renew(rslt,retlen+1+2*dashes,char); + cp1 = rslt + offset; } } else cp2++; @@ -1093,8 +1262,12 @@ static char *do_tounixspec(char *spec, char *buf, int ts) else if (*cp2 == ']' || *cp2 == '>') *(cp1++) = '/'; else if (*cp2 == '.') { *(cp1++) = '/'; - while (*(cp2+1) == ']' || *(cp2+1) == '>' || - *(cp2+1) == '[' || *(cp2+1) == '<') cp2++; + if (*(cp2+1) == ']' || *(cp2+1) == '>') { + while (*(cp2+1) == ']' || *(cp2+1) == '>' || + *(cp2+1) == '[' || *(cp2+1) == '<') cp2++; + if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' || + *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7; + } } else if (*cp2 == '-') { if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') { @@ -1127,12 +1300,13 @@ char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); } /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/ static char *do_tovmsspec(char *path, char *buf, int ts) { static char __tovmsspec_retbuf[NAM$C_MAXRSS+1]; - register char *rslt, *dirend, *cp1, *cp2; - register unsigned long int infront = 0; + char *rslt, *dirend; + register char *cp1, *cp2; + unsigned long int infront = 0, hasdir = 1; if (path == NULL) return NULL; if (buf) rslt = buf; - else if (ts) New(7016,rslt,strlen(path)+3,char); + else if (ts) New(7016,rslt,strlen(path)+9,char); else rslt = __tovmsspec_retbuf; if (strpbrk(path,"]:>") || (dirend = strrchr(path,'/')) == NULL) { @@ -1151,11 +1325,37 @@ static char *do_tovmsspec(char *path, char *buf, int ts) { cp1 = rslt; cp2 = path; if (*cp2 == '/') { + char trndev[NAM$C_MAXRSS+1]; + int islnm, rooted; + STRLEN trnend; + while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2; - *(cp1++) = ':'; - *(cp1++) = '['; - if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0'; - else cp2++; + *cp1 = '\0'; + 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; + /* If the first element of the path is a logical name, determine + * whether it has to be translated so we can add more directories. */ + if (!islnm || rooted) { + *(cp1++) = ':'; + *(cp1++) = '['; + if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0'; + else cp2++; + } + else { + if (cp2 != dirend) { + if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char); + strcpy(rslt,trndev); + cp1 = rslt + trnend; + *(cp1++) = '.'; + cp2++; + } + else { + *(cp1++) = ':'; + hasdir = 0; + } + } } else { *(cp1++) = '['; @@ -1200,7 +1400,7 @@ static char *do_tovmsspec(char *path, char *buf, int ts) { else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */ } else { - if (*(cp1-1) == '-') *(cp1++) = '.'; + if (!infront && *(cp1-1) == '-') *(cp1++) = '.'; if (*cp2 == '/') *(cp1++) = '.'; else if (*cp2 == '.') *(cp1++) = '_'; else *(cp1++) = *cp2; @@ -1208,7 +1408,7 @@ static char *do_tovmsspec(char *path, char *buf, int ts) { } } if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */ - *(cp1++) = ']'; + if (hasdir) *(cp1++) = ']'; if (*cp2) cp2++; /* check in case we ended with trailing '..' */ while (*cp2) *(cp1++) = *(cp2++); *cp1 = '\0'; @@ -1233,7 +1433,7 @@ static char *do_tovmspath(char *path, char *buf, int ts) { if (buf) return buf; else if (ts) { vmslen = strlen(vmsified); - New(7017,cp,vmslen,char); + New(7017,cp,vmslen+1,char); memcpy(cp,vmsified,vmslen); cp[vmslen] = '\0'; return cp; @@ -1262,7 +1462,7 @@ static char *do_tounixpath(char *path, char *buf, int ts) { if (buf) return buf; else if (ts) { unixlen = strlen(unixified); - New(7017,cp,unixlen,char); + New(7017,cp,unixlen+1,char); memcpy(cp,unixified,unixlen); cp[unixlen] = '\0'; return cp; @@ -1377,7 +1577,7 @@ getredirection(int *ac, char ***av) ap = argv[argc-1]; if (0 == strcmp("&", ap)) exit(background_process(--argc, argv)); - if ('&' == ap[strlen(ap)-1]) + if (*ap && '&' == ap[strlen(ap)-1]) { ap[strlen(ap)-1] = '\0'; exit(background_process(argc, argv)); @@ -1497,7 +1697,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; @@ -1508,11 +1708,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); @@ -1588,7 +1783,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; @@ -1597,7 +1791,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)) { @@ -1622,8 +1816,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; @@ -1650,10 +1844,28 @@ unsigned long int zero = 0; 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 */ @@ -1965,17 +2177,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); } @@ -2088,7 +2295,7 @@ static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch}; static void vms_execfree() { if (Cmd) { - safefree(Cmd); + Safefree(Cmd); Cmd = Nullch; } if (VMScmd.dsc$a_pointer) { @@ -2121,7 +2328,7 @@ setup_argstr(SV *really, SV **mark, SV **sp) cmdlen += rlen ? rlen + 1 : 0; } } - New(401,Cmd,cmdlen,char); + New(401,Cmd,cmdlen+1,char); if (tmps && *tmps) { strcpy(Cmd,tmps); @@ -2165,9 +2372,12 @@ setup_cmddsc(char *cmd, int check_img) } else isdcl = 1; if (isdcl) { /* It's a DCL command, just do it. */ - VMScmd.dsc$a_pointer = cmd; VMScmd.dsc$w_length = strlen(cmd); - if (cmd == Cmd) Cmd = Nullch; /* clear Cmd so vms_execfree isok */ + if (cmd == Cmd) { + VMScmd.dsc$a_pointer = Cmd; + Cmd = Nullch; /* Don't try to free twice in vms_execfree() */ + } + else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length); } else { /* assume first token is an image spec */ cmd = s; @@ -2188,7 +2398,7 @@ setup_cmddsc(char *cmd, int check_img) s = resspec; while (*s && !isspace(*s)) s++; *s = '\0'; - New(402,VMScmd.dsc$a_pointer,6 + s - resspec + (rest ? strlen(rest) : 0),char); + New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char); strcpy(VMScmd.dsc$a_pointer,"$ MCR "); strcat(VMScmd.dsc$a_pointer,resspec); if (rest) strcat(VMScmd.dsc$a_pointer,rest); @@ -2406,7 +2616,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}, @@ -2423,8 +2633,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; @@ -2453,7 +2667,7 @@ static int fillpasswd (const char *name, struct passwd *pwd) else strcpy(pwd->pw_unixdir, pwd->pw_dir); _mystrtolower(pwd->pw_unixdir); - return status; + return 1; } /* @@ -2467,8 +2681,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; @@ -2478,10 +2691,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; @@ -2505,6 +2723,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; } @@ -2513,11 +2733,17 @@ 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); @@ -2531,9 +2757,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() */ @@ -2562,6 +2786,57 @@ void my_endpwent() } /*}}}*/ + +/* my_gmtime + * If the CRTL has a real gmtime(), use it, else look for the logical + * name SYS$TIMEZONE_DIFFERENTIAL used by the native UTC routines on + * VMS >= 6.0. Can be manually defined under earlier versions of VMS + * to translate to the number of seconds which must be added to UTC + * to get to the local time of the system. + * Contributed by Chuck Lane + */ + +/*{{{struct tm *my_gmtime(const time_t *time)*/ +/* We #defined 'gmtime' as 'my_gmtime' in vmsish.h. #undef it here + * so we can call the CRTL's routine to see if it works. + */ +#undef gmtime +struct tm * +my_gmtime(const time_t *time) +{ + static int gmtime_emulation_type; + static time_t utc_offset_secs; + char *p; + time_t when; + + if (gmtime_emulation_type == 0) { + gmtime_emulation_type++; + when = 300000000; + if (gmtime(&when) == NULL) { /* CRTL gmtime() is just a stub */ + gmtime_emulation_type++; + if ((p = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL) + gmtime_emulation_type++; + else + utc_offset_secs = (time_t) atol(p); + } + } + + switch (gmtime_emulation_type) { + case 1: + return gmtime(time); + case 2: + when = *time - utc_offset_secs; + return localtime(&when); + default: + warn("gmtime not supported on this system"); + return NULL; + } +} /* end of my_gmtime() */ +/* Reset definition for later calls */ +#define gmtime(t) my_gmtime(t) +/*}}}*/ + + /* * flex_stat, flex_fstat * basic stat, but gets it right when asked to stat @@ -2584,7 +2859,7 @@ void my_endpwent() * available, do we try to pack the device name into an integer (flagged by * the sign bit (LOCKID_MASK) being set). * - * Note that encode_dev cann guarantee an 1-to-1 correspondence twixt device + * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device * name and its encoded form, but it seems very unlikely that we will find * two files on different disks that share the same encoded device names, * and even more remote that they will share the same file id (if the test @@ -2686,7 +2961,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'; @@ -2699,9 +2974,10 @@ cando(I32 bit, I32 effective, struct stat *statbufp) _ckvmssts(retsts); return FALSE; /* Should never get to here */ } -} +} /* end of cando() */ /*}}}*/ + /*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/ I32 cando_by_name(I32 bit, I32 effective, char *fname) @@ -2709,7 +2985,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}; @@ -2720,12 +2996,21 @@ cando_by_name(I32 bit, I32 effective, char *fname) {0,0,0,0}}; if (!fname || !*fname) return FALSE; + 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: @@ -2752,7 +3037,7 @@ cando_by_name(I32 bit, I32 effective, char *fname) } retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst); - if (retsts == SS$_NOPRIV || retsts == RMS$_FNF || + if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJ || retsts == RMS$_FNF || retsts == RMS$_DIR || retsts == RMS$_DEV) return FALSE; if (retsts == SS$_NORMAL) { if (!privused) return TRUE; @@ -2760,10 +3045,10 @@ cando_by_name(I32 bit, I32 effective, char *fname) 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; } @@ -2788,12 +3073,18 @@ flex_fstat(int fd, struct stat *statbuf) /*}}}*/ /*{{{ int flex_stat(char *fspec, struct stat *statbufp)*/ +/* We defined 'stat' as 'mystat' in vmsish.h so that declarations of + * 'struct stat' elsewhere in Perl would use our struct. We go back + * to the system version here, since we're actually calling their + * stat(). + */ +#undef stat int -flex_stat(char *fspec, struct stat *statbufp) +flex_stat(char *fspec, struct mystat *statbufp) { char fileified[NAM$C_MAXRSS+1]; int retval,myretval; - struct stat tmpbuf; + struct mystat tmpbuf; if (statbufp == &statcache) do_tovmsspec(fspec,namecache,0); @@ -2808,13 +3099,6 @@ flex_stat(char *fspec, struct stat *statbufp) return 0; } -/* We defined 'stat' as 'mystat' in vmsish.h so that declarations of - * 'struct stat' elsewhere in Perl would use our struct. We go back - * to the system version here, since we're actually calling their - * stat(). - */ -#undef stat - if (do_fileify_dirspec(fspec,fileified,0) == NULL) myretval = -1; else { myretval = stat(fileified,(stat_t *) &tmpbuf); @@ -2835,8 +3119,173 @@ flex_stat(char *fspec, struct stat *statbufp) return retval; } /* end of flex_stat() */ +/* Reset definition for later calls */ +#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. 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 use and distribute this + * code under the same terms as Perl itself. (See the GNU General Public + * License or the Perl Artistic License supplied as part of the Perl + * distribution.) + */ +/*{{{int rmscopy(char *src, char *dst)*/ +int +rmscopy(char *spec_in, char *spec_out) +{ + 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 (!((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 */ + /* sys$close() will process xabrdt, not xabdat */ + xabrdt = cc$rms_xabrdt; + xabrdt.xab$q_rdt = xabdat.xab$q_rdt; + fab_out.fab$l_xab = &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, @@ -2928,12 +3377,80 @@ 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; + 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) croak("Usage: File::Copy::rmscopy(from,to)"); + + 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); + } + } + + ST(0) = rmscopy(inp,outp) ? &sv_yes : &sv_no; XSRETURN(1); } @@ -2942,13 +3459,14 @@ 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::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; }