From f7ddb74ae664d8225514d5dfa61fca99e012630d Mon Sep 17 00:00:00 2001 From: "John E. Malmberg" Date: Thu, 18 Aug 2005 17:18:27 -0400 Subject: [PATCH] [patch@25305] fixes to const fixes + Case Preserved start From: "John E. Malmberg" Message-ID: <43053363.8090809@qsl.net> p4raw-id: //depot/perl@25306 --- vms/vms.c | 1273 +++++++++++++++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 1123 insertions(+), 150 deletions(-) diff --git a/vms/vms.c b/vms/vms.c index 3124c8b..7d04fc9 100644 --- a/vms/vms.c +++ b/vms/vms.c @@ -31,6 +31,9 @@ #include #include #include +#if __CRTL_VER >= 70301000 && !defined(__VAX) +#include +#endif #include #include #include @@ -45,6 +48,59 @@ #include #include +/* Set the maximum filespec size here as it is larger for EFS file + * specifications. + * Not fully implemented at this time because the larger size + * will likely impact the stack local storage requirements of + * threaded code, and probably cause hard to diagnose failures. + * To implement the larger sizes, all places where filename + * storage is put on the stack need to be changed to use + * New()/SafeFree() instead. + */ +#define VMS_MAXRSS NAM$C_MAXRSS +#ifndef __VAX +#if 0 +#ifdef NAML$C_MAXRSS +#undef VMS_MAXRSS +#define VMS_MAXRSS NAML$C_MAXRSS +#endif +#endif +#endif + +#if __CRTL_VER < 70301000 && __CRTL_VER >= 70300000 +int decc$feature_get_index(const char *name); +char* decc$feature_get_name(int index); +int decc$feature_get_value(int index, int mode); +int decc$feature_set_value(int index, int mode, int value); +#else +#include +#endif + +#ifndef __VAX +#if __CRTL_VER >= 70300000 + +static int set_feature_default(const char *name, int value) +{ + int status; + int index; + + index = decc$feature_get_index(name); + + status = decc$feature_set_value(index, 1, value); + if (index == -1 || (status == -1)) { + return -1; + } + + status = decc$feature_get_value(index, 1); + if (status != value) { + return -1; + } + +return 0; +} +#endif +#endif + /* Older versions of ssdef.h don't have these */ #ifndef SS$_INVFILFOROP # define SS$_INVFILFOROP 3930 @@ -88,23 +144,41 @@ dEXT int h_errno; #endif +#ifdef __DECC +#pragma message disable pragma +#pragma member_alignment save +#pragma nomember_alignment longword +#pragma message save +#pragma message disable misalgndmem +#endif struct itmlst_3 { unsigned short int buflen; unsigned short int itmcode; void *bufadr; unsigned short int *retlen; }; +#ifdef __DECC +#pragma message restore +#pragma member_alignment restore +#endif #define do_fileify_dirspec(a,b,c) mp_do_fileify_dirspec(aTHX_ a,b,c) #define do_pathify_dirspec(a,b,c) mp_do_pathify_dirspec(aTHX_ a,b,c) #define do_tovmsspec(a,b,c) mp_do_tovmsspec(aTHX_ a,b,c) #define do_tovmspath(a,b,c) mp_do_tovmspath(aTHX_ a,b,c) #define do_rmsexpand(a,b,c,d,e) mp_do_rmsexpand(aTHX_ a,b,c,d,e) +#define do_vms_realpath(a,b) mp_do_vms_realpath(aTHX_ a,b) #define do_tounixspec(a,b,c) mp_do_tounixspec(aTHX_ a,b,c) #define do_tounixpath(a,b,c) mp_do_tounixpath(aTHX_ a,b,c) +#define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a) #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d) #define getredirection(a,b) mp_getredirection(aTHX_ a,b) +static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts); +static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts); +static char *mp_do_tounixspec(pTHX_ const char *, char *, int); +static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts); + /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */ #define PERL_LNM_MAX_ALLOWED_INDEX 127 @@ -140,15 +214,60 @@ static int no_translate_barewords; static int tz_updated = 1; #endif +/* DECC Features that may need to affect how Perl interprets + * displays filename information + */ +static int decc_disable_to_vms_logname_translation = 1; +static int decc_disable_posix_root = 1; +int decc_efs_case_preserve = 0; +static int decc_efs_charset = 0; +static int decc_filename_unix_no_version = 0; +static int decc_filename_unix_only = 0; +int decc_filename_unix_report = 0; +int decc_posix_compliant_pathnames = 0; +int decc_readdir_dropdotnotype = 0; +static int vms_process_case_tolerant = 1; + +/* Is this a UNIX file specification? + * No longer a simple check with EFS file specs + * For now, not a full check, but need to + * handle POSIX ^UP^ specifications + * Fixing to handle ^/ cases would require + * changes to many other conversion routines. + */ + +static is_unix_filespec(const char *path) +{ +int ret_val; +const char * pch1; + + ret_val = 0; + if (strncmp(path,"\"^UP^",5) != 0) { + pch1 = strchr(path, '/'); + if (pch1 != NULL) + ret_val = 1; + else { + + /* If the user wants UNIX files, "." needs to be treated as in UNIX */ + if (decc_filename_unix_report || decc_filename_unix_only) { + if (strcmp(path,".") == 0) + ret_val = 1; + } + } + } + return ret_val; +} + + /* my_maxidx * Routine to retrieve the maximum equivalence index for an input * logical name. Some calls to this routine have no knowledge if * the variable is a logical or not. So on error we return a max * index of zero. */ -/*{{{int my_maxidx(char *lnm) */ +/*{{{int my_maxidx(const char *lnm) */ static int -my_maxidx(char *lnm) +my_maxidx(const char *lnm) { int status; int midx; @@ -160,7 +279,7 @@ my_maxidx(char *lnm) lnmdsc.dsc$w_length = strlen(lnm); lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T; lnmdsc.dsc$b_class = DSC$K_CLASS_S; - lnmdsc.dsc$a_pointer = lnm; + lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */ status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst); if ((status & 1) == 0) @@ -175,7 +294,8 @@ int Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) { - char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2; + const char *cp1; + char uplnm[LNM$C_NAMLENGTH+1], *cp2; unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure; unsigned long int retsts, attr = LNM$M_CASE_BLIND; int midx; @@ -198,7 +318,7 @@ Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) { set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0; } - for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) { + for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) { *cp2 = _toupper(*cp1); if (cp1 - lnm > LNM$C_NAMLENGTH) { set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM); @@ -267,9 +387,9 @@ Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, } else if (!ivlnm) { if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) { - midx = my_maxidx((char *) lnm); - for (idx = 0, cp1 = eqv; idx <= midx; idx++) { - lnmlst[1].bufadr = cp1; + midx = my_maxidx(lnm); + for (idx = 0, cp2 = eqv; idx <= midx; idx++) { + lnmlst[1].bufadr = cp2; eqvlen = 0; retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst); if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; } @@ -287,8 +407,8 @@ Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, memcpy(eqv,eqv+4,eqvlen-4); eqvlen -= 4; } - cp1 += eqvlen; - *cp1 = '\0'; + cp2 += eqvlen; + *cp2 = '\0'; } if ((retsts == SS$_IVLOGNAM) || (retsts == SS$_NOLOGNAM)) { continue; } @@ -340,14 +460,15 @@ int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx) char * Perl_my_getenv(pTHX_ const char *lnm, bool sys) { + const char *cp1; static char *__my_getenv_eqv = NULL; - char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv; + char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv; unsigned long int idx = 0; int trnsuccess, success, secure, saverr, savvmserr; int midx, flags; SV *tmpsv; - midx = my_maxidx((char *) lnm) + 1; + midx = my_maxidx(lnm) + 1; if (PL_curinterp) { /* Perl interpreter running -- may be threaded */ /* Set up a temporary buffer for the return value; Perl will @@ -367,7 +488,7 @@ Perl_my_getenv(pTHX_ const char *lnm, bool sys) eqv = __my_getenv_eqv; } - for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1); + for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1); if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) { getcwd(eqv,LNM$C_NAMLENGTH); return eqv; @@ -425,14 +546,15 @@ Perl_my_getenv(pTHX_ const char *lnm, bool sys) char * Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys) { - char *buf, *cp1, *cp2; + const char *cp1; + char *buf, *cp2; unsigned long idx = 0; int midx, flags; static char *__my_getenv_len_eqv = NULL; int secure, saverr, savvmserr; SV *tmpsv; - midx = my_maxidx((char *) lnm) + 1; + midx = my_maxidx(lnm) + 1; if (PL_curinterp) { /* Perl interpreter running -- may be threaded */ /* Set up a temporary buffer for the return value; Perl will @@ -452,10 +574,24 @@ Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys) buf = __my_getenv_len_eqv; } - for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1); + for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1); if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) { + char * zeros; + getcwd(buf,LNM$C_NAMLENGTH); *len = strlen(buf); + + /* Get rid of "000000/ in rooted filespecs */ + if (*len > 7) { + zeros = strstr(buf, "/000000/"); + if (zeros != NULL) { + int mlen; + mlen = *len - (zeros - buf) - 7; + memmove(zeros, &zeros[7], mlen); + *len = *len - 7; + buf[*len] = '\0'; + } + } return buf; } else { @@ -488,6 +624,19 @@ Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys) *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags); + /* Get rid of "000000/ in rooted filespecs */ + if (*len > 7) { + char * zeros; + zeros = strstr(buf, "/000000/"); + if (zeros != NULL) { + int mlen; + mlen = *len - (zeros - buf) - 7; + memmove(zeros, &zeros[7], mlen); + *len = *len - 7; + buf[*len] = '\0'; + } + } + /* Discard NOLOGNAM on internal calls since we're often looking * for an optional name, and this "error" often shows up as the * (bogus) exit status for a die() call later on. */ @@ -689,7 +838,7 @@ prime_env_iter(void) } if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */ /* get the PPFs for this process, not the subprocess */ - char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL}; + const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL}; char eqv[LNM$C_NAMLENGTH+1]; int trnlen, i; for (i = 0; ppfs[i]; i++) { @@ -721,7 +870,8 @@ prime_env_iter(void) int Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec) { - char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2, *c; + const char *cp1; + char uplnm[LNM$C_NAMLENGTH], *cp2, *c; unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0; int nseg = 0, j; unsigned long int retsts, usermode = PSL$C_USER; @@ -737,7 +887,7 @@ Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s * return SS$_IVLOGNAM; } - for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) { + for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) { *cp2 = _toupper(*cp1); if (cp1 - lnm > LNM$C_NAMLENGTH) { set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM); @@ -802,7 +952,7 @@ Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s * #endif } else { - eqvdsc.dsc$a_pointer = (char *)eqv; + eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */ eqvdsc.dsc$w_length = strlen(eqv); if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) && !str$case_blind_compare(&tmpdsc,&clisym)) { @@ -1167,13 +1317,26 @@ Perl_my_chdir(pTHX_ const char *dir) /* zero length string sometimes gives ACCVIO */ if (dirlen == 0) return -1; + const char *dir1; + + /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces. + * This does not work if DECC$EFS_CHARSET is active. Hack it here + * so that existing scripts do not need to be changed. + */ + dir1 = dir; + while ((dirlen > 0) && (*dir1 == ' ')) { + dir1++; + dirlen--; + } /* some versions of CRTL chdir() doesn't tolerate trailing /, since * that implies * null file name/type. However, it's commonplace under Unix, * so we'll allow it for a gain in portability. + * + * - Preview- '/' will be valid soon on VMS */ - if (dir[dirlen-1] == '/') { + if ((dirlen > 1) && (dir1[dirlen-1] == '/')) { char *newdir = savepvn(dir,dirlen-1); int ret = chdir(newdir); Safefree(newdir); @@ -1508,7 +1671,8 @@ create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc) static unsigned long int syssize = 0; unsigned long int dviitm = DVI$_DEVNAM; char csize[LNM$C_NAMLENGTH+1]; - + int sts; + if (!syssize) { unsigned long syiitm = SYI$_MAXBUF; /* @@ -1530,9 +1694,9 @@ create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc) if (mbxbufsiz < 128) mbxbufsiz = 128; if (mbxbufsiz > syssize) mbxbufsiz = syssize; - _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0)); + _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0)); - _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length)); + _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length)); namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0'; } /* end of create_mbx() */ @@ -1773,6 +1937,7 @@ popen_completion_ast(pInfo info) { pInfo i = open_pipes; int iss; + int sts; pXpipe x; info->completion &= 0x0FFFFFFF; /* strip off "control" field */ @@ -1959,6 +2124,7 @@ pipe_tochild1_ast(pPipe p) pCBuf b = p->curr; int iss = p->iosb.status; int eof = (iss == SS$_ENDOFFILE); + int sts; #ifdef PERL_IMPLICIT_CONTEXT pTHX = p->thx; #endif @@ -1974,7 +2140,7 @@ pipe_tochild1_ast(pPipe p) b->eof = eof; b->size = p->iosb.count; - _ckvmssts(lib$insqhi(b, &p->wait)); + _ckvmssts(sts = lib$insqhi(b, &p->wait)); if (p->need_wake) { p->need_wake = FALSE; _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0)); @@ -3118,6 +3284,7 @@ mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *de struct NAM mynam = cc$rms_nam; STRLEN speclen; unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0; + int sts; if (!filespec || !*filespec) { set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL); @@ -3153,12 +3320,16 @@ mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *de retsts = sys$parse(&myfab,0,0); if (!(retsts & 1)) { mynam.nam$b_nop |= NAM$M_SYNCHK; +#ifdef NAM$M_NO_SHORT_UPCASE + if (decc_efs_case_preserve) + mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE; +#endif if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) { retsts = sys$parse(&myfab,0,0); if (retsts & 1) goto expanded; } mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0; - (void) sys$parse(&myfab,0,0); /* Free search context */ + sts = sys$parse(&myfab,0,0); /* Free search context */ if (out) Safefree(out); set_vaxc_errno(retsts); if (retsts == RMS$_PRV) set_errno(EACCES); @@ -3170,7 +3341,11 @@ mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *de retsts = sys$search(&myfab,0,0); if (!(retsts & 1) && retsts != RMS$_FNF) { mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL; - myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */ +#ifdef NAM$M_NO_SHORT_UPCASE + if (decc_efs_case_preserve) + mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE; +#endif + myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0); /* Free search context */ if (out) Safefree(out); set_vaxc_errno(retsts); if (retsts == RMS$_PRV) set_errno(EACCES); @@ -3181,8 +3356,10 @@ mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *de /* If the input filespec contained any lowercase characters, * downcase the result for compatibility with Unix-minded code. */ expanded: - for (out = myfab.fab$l_fna; *out; out++) - if (islower(*out)) { haslower = 1; break; } + if (!decc_efs_case_preserve) { + for (out = myfab.fab$l_fna; *out; out++) + if (islower(*out)) { haslower = 1; break; } + } if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; } else { out = esa; speclen = mynam.nam$b_esl; } /* Trim off null fields added by $PARSE @@ -3199,9 +3376,14 @@ mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *de struct NAM defnam = cc$rms_nam; deffab.fab$l_nam = &defnam; + /* cast below ok for read only pointer */ deffab.fab$l_fna = (char *)defspec; deffab.fab$b_fns = myfab.fab$b_dns; defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa; defnam.nam$b_nop = NAM$M_SYNCHK; +#ifdef NAM$M_NO_SHORT_UPCASE + if (decc_efs_case_preserve) + defnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE; +#endif if (sys$parse(&deffab,0,0) & 1) { if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER); if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE); @@ -3223,7 +3405,7 @@ mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *de !(mynam.nam$l_fnb & NAM$M_EXP_NAME)) speclen = mynam.nam$l_name - out; out[speclen] = '\0'; - if (haslower) __mystrtolower(out); + if (haslower && !decc_efs_case_preserve) __mystrtolower(out); /* Have we been working with an expanded, but not resultant, spec? */ /* Also, convert back to Unix syntax if necessary. */ @@ -3238,8 +3420,12 @@ mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *de strcpy(outbuf,tmpfspec); } mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL; +#ifdef NAM$M_NO_SHORT_UPCASE + if (decc_efs_case_preserve) + mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE; +#endif mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0; - myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */ + myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0); /* Free search context */ return outbuf; } /*}}}*/ @@ -3292,6 +3478,7 @@ static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts) char *retspec, *cp1, *cp2, *lastdir; char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1]; unsigned short int trnlnm_iter_count; + int sts; if (!dir || !*dir) { set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL; @@ -3299,13 +3486,18 @@ static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts) dirlen = strlen(dir); while (dirlen && dir[dirlen-1] == '/') --dirlen; if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */ - dir = "/sys$disk"; - dirlen = 9; + if (!decc_posix_compliant_pathnames && decc_disable_posix_root) { + dir = "/sys$disk"; + dirlen = 9; + } + else + dirlen = 1; } if (dirlen > NAM$C_MAXRSS) { set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL; } - if (!strpbrk(dir+1,"/]>:")) { + if (!strpbrk(dir+1,"/]>:") && + (!decc_posix_compliant_pathnames && decc_disable_posix_root)) { strcpy(trndir,*dir == '/' ? dir + 1: dir); trnlnm_iter_count = 0; while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) { @@ -3345,17 +3537,20 @@ static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts) of explicit directories in a VMS spec which ends with directories. */ else { for (cp2 = cp1; cp2 > trndir; cp2--) { - if (*cp2 == '.') { - *cp2 = *cp1; *cp1 = '\0'; - hasfilename = 1; - break; + if (*cp2 == '.') { + if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) { + *cp2 = *cp1; *cp1 = '\0'; + hasfilename = 1; + break; + } } if (*cp2 == '[' || *cp2 == '<') break; } } } - if (hasfilename || !strpbrk(trndir,"]:>")) { /* Unix-style path or filename */ + cp1 = strpbrk(trndir,"]:>"); /* Prepare for future change */ + if (hasfilename || !cp1) { /* Unix-style path or filename */ if (trndir[0] == '.') { if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) return do_fileify_dirspec("[]",buf,ts); @@ -3393,58 +3588,71 @@ static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts) else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) { /* Ditto for specs that end in an MFD -- let the VMS code * figure out whether it's a real device or a rooted logical. */ + + /* This should not happen any more. Allowing the fake /000000 + * in a UNIX pathname causes all sorts of problems when trying + * to run in UNIX emulation. So the VMS to UNIX conversions + * now remove the fake /000000 directories. + */ + trndir[dirlen] = '/'; trndir[dirlen+1] = '\0'; 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(trndir,'/')) && !(lastdir = cp1 = strrchr(trndir,']')) && !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir; if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */ int ver; char *cp3; - if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */ - !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */ - !*(cp2+3) || toupper(*(cp2+3)) != 'R' || - (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') || - (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 && + + /* For EFS or ODS-5 look for the last dot */ + if (decc_efs_charset) { + cp2 = strrchr(cp1,'.'); + } + if (vms_process_case_tolerant) { + if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */ + !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */ + !*(cp2+3) || toupper(*(cp2+3)) != 'R' || + (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') || + (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 && (ver || *cp3)))))) { - set_errno(ENOTDIR); - set_vaxc_errno(RMS$_DIR); - return NULL; + set_errno(ENOTDIR); + set_vaxc_errno(RMS$_DIR); + return NULL; + } + } + else { + if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */ + !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */ + !*(cp2+3) || *(cp2+3) != 'R' || + (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') || + (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 && + (ver || *cp3)))))) { + set_errno(ENOTDIR); + set_vaxc_errno(RMS$_DIR); + return NULL; + } } dirlen = cp2 - trndir; } } - /* If we lead off with a device or rooted logical, add the MFD - if we're specifying a top-level directory. */ - if (lastdir && *trndir == '/') { - addmfd = 1; - for (cp1 = lastdir - 1; cp1 > trndir; cp1--) { - if (*cp1 == '/') { - addmfd = 0; - break; - } - } - } - retlen = dirlen + (addmfd ? 13 : 6); + + retlen = dirlen + 6; if (buf) retspec = buf; else if (ts) Newx(retspec,retlen+1,char); else retspec = __fileify_retbuf; - if (addmfd) { - dirlen = lastdir - trndir; - memcpy(retspec,trndir,dirlen); - strcpy(&retspec[dirlen],"/000000"); - strcpy(&retspec[dirlen+7],lastdir); - } - else { - memcpy(retspec,trndir,dirlen); - retspec[dirlen] = '\0'; - } + memcpy(retspec,trndir,dirlen); + retspec[dirlen] = '\0'; + /* We've picked up everything up to the directory file name. Now just add the type and version, and we're set. */ - strcat(retspec,".dir;1"); + if ((!decc_efs_case_preserve) && vms_process_case_tolerant) + strcat(retspec,".dir;1"); + else + strcat(retspec,".DIR;1"); return retspec; } else { /* VMS-style directory spec */ @@ -3453,18 +3661,22 @@ static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts) struct FAB dirfab = cc$rms_fab; struct NAM savnam, dirnam = cc$rms_nam; - dirfab.fab$b_fns = strlen(dir); + dirfab.fab$b_fns = strlen(trndir); dirfab.fab$l_fna = trndir; dirfab.fab$l_nam = &dirnam; dirfab.fab$l_dna = ".DIR;1"; dirfab.fab$b_dns = 6; dirnam.nam$b_ess = NAM$C_MAXRSS; dirnam.nam$l_esa = esa; +#ifdef NAM$M_NO_SHORT_UPCASE + if (decc_efs_case_preserve) + dirnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE; +#endif for (cp = trndir; *cp; cp++) if (islower(*cp)) { haslower = 1; break; } if (!((sts = sys$parse(&dirfab))&1)) { - if (dirfab.fab$l_sts == RMS$_DIR) { + if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) { dirnam.nam$b_nop |= NAM$M_SYNCHK; sts = sys$parse(&dirfab) & 1; } @@ -3485,7 +3697,7 @@ static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts) else { set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts); dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL; - dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0); + dirfab.fab$b_dns = 0; sts = sys$parse(&dirfab,0,0); return NULL; } } @@ -3504,7 +3716,7 @@ static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts) if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) { /* Something other than .DIR[;1]. Bzzt. */ dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL; - dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0); + dirfab.fab$b_dns = 0; sts = sys$parse(&dirfab,0,0); set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR); return NULL; @@ -3518,7 +3730,7 @@ static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts) else retspec = __fileify_retbuf; strcpy(retspec,esa); dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL; - dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0); + dirfab.fab$b_dns = 0; sts = sys$parse(&dirfab,0,0); return retspec; } if ((cp1 = strstr(esa,".][000000]")) != NULL) { @@ -3529,13 +3741,27 @@ static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts) if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>'); if (cp1 == NULL) { /* should never happen */ dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL; - dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0); + dirfab.fab$b_dns = 0; sts = sys$parse(&dirfab,0,0); return NULL; } term = *cp1; *cp1 = '\0'; retlen = strlen(esa); - if ((cp1 = strrchr(esa,'.')) != NULL) { + cp1 = strrchr(esa,'.'); + /* ODS-5 directory specifications can have extra "." in them. */ + while (cp1 != NULL) { + if ((cp1-1 == esa) || (*(cp1-1) != '^')) + break; + else { + cp1--; + while ((cp1 > esa) && (*cp1 != '.')) + cp1--; + } + if (cp1 == esa) + cp1 = NULL; + } + + if ((cp1) != NULL) { /* There's more than one directory in the path. Just roll back. */ *cp1 = term; if (buf) retspec = buf; @@ -3547,9 +3773,13 @@ static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts) if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) { /* Go back and expand rooted logical name */ dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL; +#ifdef NAM$M_NO_SHORT_UPCASE + if (decc_efs_case_preserve) + dirnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE; +#endif if (!(sys$parse(&dirfab) & 1)) { dirnam.nam$l_rlf = NULL; - dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0); + dirfab.fab$b_dns = 0; sts = sys$parse(&dirfab,0,0); set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts); return NULL; @@ -3564,7 +3794,18 @@ static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts) memcpy(retspec,esa,dirlen); if (!strncmp(cp1+2,"000000]",7)) { retspec[dirlen-1] = '\0'; - for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ; + /* Not full ODS-5, just extra dots in directories for now */ + cp1 = retspec + dirlen - 1; + while (cp1 > retspec) + { + if (*cp1 == '[') + break; + if (*cp1 == '.') { + if (*(cp1-1) != '^') + break; + } + cp1--; + } if (*cp1 == '.') *cp1 = ']'; else { memmove(cp1+8,cp1+1,retspec+dirlen-cp1); @@ -3575,7 +3816,15 @@ static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts) memcpy(retspec+dirlen,cp1+2,retlen-dirlen); retspec[retlen] = '\0'; /* Convert last '.' to ']' */ - for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ; + cp1 = retspec+retlen-1; + while (*cp != '[') { + cp1--; + if (*cp1 == '.') { + /* Do not trip on extra dots in ODS-5 directories */ + if ((cp1 == retspec) || (*(cp1-1) != '^')) + break; + } + } if (*cp1 == '.') *cp1 = ']'; else { memmove(cp1+8,cp1+1,retspec+dirlen-cp1); @@ -3596,14 +3845,14 @@ static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts) } } dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL; - dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0); + dirfab.fab$b_dns = 0; sts = sys$parse(&dirfab,0,0); /* 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); + if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec); return retspec; } } /* end of do_fileify_dirspec() */ @@ -3622,6 +3871,7 @@ static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts) char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1]; unsigned short int trnlnm_iter_count; STRLEN trnlen; + int sts; if (!dir || !*dir) { set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL; @@ -3666,16 +3916,35 @@ static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts) (*(cp2+1) == '.' && *(cp2+2) == '\0') || (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) { int ver; char *cp3; - if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */ - !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */ - !*(cp2+3) || toupper(*(cp2+3)) != 'R' || - (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') || - (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 && + + /* For EFS or ODS-5 look for the last dot */ + if (decc_efs_charset) { + cp2 = strrchr(cp1,'.'); + } + if (vms_process_case_tolerant) { + if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */ + !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */ + !*(cp2+3) || toupper(*(cp2+3)) != 'R' || + (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') || + (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 && (ver || *cp3)))))) { - set_errno(ENOTDIR); - set_vaxc_errno(RMS$_DIR); - return NULL; - } + set_errno(ENOTDIR); + set_vaxc_errno(RMS$_DIR); + return NULL; + } + } + else { + if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */ + !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */ + !*(cp2+3) || *(cp2+3) != 'R' || + (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') || + (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 && + (ver || *cp3)))))) { + set_errno(ENOTDIR); + set_vaxc_errno(RMS$_DIR); + return NULL; + } + } retlen = cp2 - trndir + 1; } else { /* No file type present. Treat the filename as a directory. */ @@ -3703,16 +3972,30 @@ static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts) (cp1 = strrchr(trndir,'>')) != NULL ) && *(cp1+1)) { if ((cp2 = strchr(cp1,'.')) != NULL) { int ver; char *cp3; - if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */ - !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */ - !*(cp2+3) || toupper(*(cp2+3)) != 'R' || - (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') || - (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 && + if (vms_process_case_tolerant) { + if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */ + !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */ + !*(cp2+3) || toupper(*(cp2+3)) != 'R' || + (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') || + (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 && (ver || *cp3)))))) { - set_errno(ENOTDIR); - set_vaxc_errno(RMS$_DIR); - return NULL; - } + set_errno(ENOTDIR); + set_vaxc_errno(RMS$_DIR); + return NULL; + } + } + else { + if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */ + !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */ + !*(cp2+3) || *(cp2+3) != 'R' || + (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') || + (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 && + (ver || *cp3)))))) { + set_errno(ENOTDIR); + set_vaxc_errno(RMS$_DIR); + return NULL; + } + } } else { /* No file type, so just draw name into directory part */ for (cp2 = cp1; *cp2; cp2++) ; @@ -3724,11 +4007,11 @@ static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts) } dirfab.fab$b_fns = strlen(trndir); dirfab.fab$l_fna = trndir; - if (dir[dirfab.fab$b_fns-1] == ']' || - dir[dirfab.fab$b_fns-1] == '>' || - dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */ + if (trndir[dirfab.fab$b_fns-1] == ']' || + trndir[dirfab.fab$b_fns-1] == '>' || + trndir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */ if (buf) retpath = buf; - else if (ts) Newx(retpath,strlen(dir)+1,char); + else if (ts) Newx(retpath,strlen(trndir)+1,char); else retpath = __pathify_retbuf; strcpy(retpath,trndir); return retpath; @@ -3738,12 +4021,16 @@ static char *mp_do_pathify_dirspec(pTHX_ const 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; +#ifdef NAM$M_NO_SHORT_UPCASE + if (decc_efs_case_preserve) + dirnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE; +#endif for (cp = trndir; *cp; cp++) if (islower(*cp)) { haslower = 1; break; } if (!(sts = (sys$parse(&dirfab)&1))) { - if (dirfab.fab$l_sts == RMS$_DIR) { + if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) { dirnam.nam$b_nop |= NAM$M_SYNCHK; sts = sys$parse(&dirfab) & 1; } @@ -3757,8 +4044,10 @@ static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts) savnam = dirnam; if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */ if (dirfab.fab$l_sts != RMS$_FNF) { + int sts1; dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL; - dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0); + dirfab.fab$b_dns = 0; + sts1 = sys$parse(&dirfab,0,0); set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts); return NULL; @@ -3770,9 +4059,11 @@ static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts) /* Yep; check version while we're at it, if it's there. */ cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4; if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) { + int sts2; /* Something other than .DIR[;1]. Bzzt. */ dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL; - dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0); + dirfab.fab$b_dns = 0; + sts2 = sys$parse(&dirfab,0,0); set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR); return NULL; @@ -3793,10 +4084,10 @@ static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts) else retpath = __pathify_retbuf; strcpy(retpath,esa); dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL; - dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0); + dirfab.fab$b_dns = 0; sts = sys$parse(&dirfab,0,0); /* $PARSE may have upcased filespec, so convert output to lower * case if input contained any lowercase characters. */ - if (haslower) __mystrtolower(retpath); + if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath); } return retpath; @@ -3817,6 +4108,7 @@ static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts) int devlen, dirlen, retlen = NAM$C_MAXRSS+1; int expand = 1; /* guarantee room for leading and trailing slashes */ unsigned short int trnlnm_iter_count; + int cmp_rslt; if (spec == NULL) return NULL; if (strlen(spec) > NAM$C_MAXRSS) return NULL; @@ -3835,7 +4127,41 @@ static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts) Newx(rslt,retlen+2+2*expand,char); } else rslt = __tounixspec_retbuf; - if (strchr(spec,'/') != NULL) { + + cmp_rslt = 0; /* Presume VMS */ + cp1 = strchr(spec, '/'); + if (cp1 == NULL) + cmp_rslt = 0; + + /* Look for EFS ^/ */ + if (decc_efs_charset) { + while (cp1 != NULL) { + cp2 = cp1 - 1; + if (*cp2 != '^') { + /* Found illegal VMS, assume UNIX */ + cmp_rslt = 1; + break; + } + cp1++; + cp1 = strchr(cp1, '/'); + } + } + + /* Look for "." and ".." */ + if (decc_filename_unix_report) { + if (spec[0] == '.') { + if ((spec[1] == '\0') || (spec[1] == '\n')) { + cmp_rslt = 1; + } + else { + if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) { + cmp_rslt = 1; + } + } + } + } + /* This is already UNIX or at least nothing VMS understands */ + if (cmp_rslt) { strcpy(rslt,spec); return rslt; } @@ -3849,6 +4175,61 @@ static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts) strcpy(rslt,spec); return rslt; } + + /* Special case 1 - sys$posix_root = / */ +#if __CRTL_VER >= 70000000 + if (!decc_disable_posix_root) { + if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) { + *cp1 = '/'; + cp1++; + cp2 = cp2 + 15; + } + } +#endif + + /* Special case 2 - Convert NLA0: to /dev/null */ +#if __CRTL_VER < 70000000 + cmp_rslt = strncmp(spec,"NLA0:", 5); + if (cmp_rslt != 0) + cmp_rslt = strncmp(spec,"nla0:", 5); +#else + cmp_rslt = strncasecmp(spec,"NLA0:", 5); +#endif + if (cmp_rslt == 0) { + strcpy(rslt, "/dev/null"); + cp1 = cp1 + 9; + cp2 = cp2 + 5; + if (spec[6] != '\0') { + cp1[9] == '/'; + cp1++; + cp2++; + } + } + + /* Also handle special case "SYS$SCRATCH:" */ +#if __CRTL_VER < 70000000 + cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12); + if (cmp_rslt != 0) + cmp_rslt = strncmp(spec,"sys$scratch:", 12); +#else + cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12); +#endif + if (cmp_rslt == 0) { + int islnm; + + islnm = my_trnlnm(tmp, "TMP", 0); + if (!islnm) { + strcpy(rslt, "/tmp"); + cp1 = cp1 + 4; + cp2 = cp2 + 12; + if (spec[12] != '\0') { + cp1[4] == '/'; + cp1++; + cp2++; + } + } + } + if (*cp2 != '[' && *cp2 != '<') { *(cp1++) = '/'; } @@ -3858,7 +4239,7 @@ static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts) *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0'; return rslt; } - else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */ + else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */ if (getcwd(tmp,sizeof tmp,1) == NULL) { if (ts) Safefree(rslt); return NULL; @@ -3886,6 +4267,11 @@ static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts) } *(cp1++) = '/'; } + if ((*cp2 == '^')) { + /* EFS file escape, pass the next character as is */ + /* Fix me: HEX encoding for UNICODE not implemented */ + cp2++; + } else if ( *cp2 == '.') { if (*(cp2+1) == '.' && *(cp2+2) == '.') { *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/'; @@ -3895,6 +4281,12 @@ static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts) } } for (; cp2 <= dirend; cp2++) { + if ((*cp2 == '^')) { + /* EFS file escape, pass the next character as is */ + /* Fix me: HEX encoding for UNICODE not implemented */ + cp2++; + *(cp1++) = *cp2; + } if (*cp2 == ':') { *(cp1++) = '/'; if (*(cp2+1) == '[') cp2++; @@ -3902,7 +4294,7 @@ static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts) else if (*cp2 == ']' || *cp2 == '>') { if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */ } - else if (*cp2 == '.') { + else if ((*cp2 == '.') && (*cp2-1 != '^')) { *(cp1++) = '/'; if (*(cp2+1) == ']' || *(cp2+1) == '>') { while (*(cp2+1) == ']' || *(cp2+1) == '>' || @@ -3934,6 +4326,28 @@ static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts) while (*cp2) *(cp1++) = *(cp2++); *cp1 = '\0'; + /* This still leaves /000000/ when working with a + * VMS device root or concealed root. + */ + { + int ulen; + char * zeros; + + ulen = strlen(rslt); + + /* Get rid of "000000/ in rooted filespecs */ + if (ulen > 7) { + zeros = strstr(rslt, "/000000/"); + if (zeros != NULL) { + int mlen; + mlen = ulen - (zeros - rslt) - 7; + memmove(zeros, &zeros[7], mlen); + ulen = ulen - 7; + rslt[ulen] = '\0'; + } + } + } + return rslt; } /* end of do_tounixspec() */ @@ -3946,9 +4360,13 @@ char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf) { return do_tounixsp static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) { static char __tovmsspec_retbuf[NAM$C_MAXRSS+1]; char *rslt, *dirend; + char *lastdot; + char *vms_delim; register char *cp1; const char *cp2; unsigned long int infront = 0, hasdir = 1; + int rslt_len; + int no_type_seen; if (path == NULL) return NULL; if (buf) rslt = buf; @@ -3964,13 +4382,19 @@ static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) { else strcpy(rslt,path); return rslt; } + + vms_delim = strpbrk(path,"]:>"); + + if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */ if (!*(dirend+2)) dirend +=2; if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3; if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4; } + cp1 = rslt; cp2 = path; + lastdot = strrchr(cp2,'.'); if (*cp2 == '/') { char trndev[NAM$C_MAXRSS+1]; int islnm, rooted; @@ -3979,12 +4403,53 @@ static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) { while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */ if (!*(cp2+1)) { if (!buf & ts) Renew(rslt,18,char); - strcpy(rslt,"sys$disk:[000000]"); + if (decc_disable_posix_root) { + strcpy(rslt,"sys$disk:[000000]"); + } + else { + strcpy(rslt,"sys$posix_root:[000000]"); + } return rslt; } while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2; *cp1 = '\0'; islnm = my_trnlnm(rslt,trndev,0); + + /* DECC special handling */ + if (!islnm) { + if (strcmp(rslt,"bin") == 0) { + strcpy(rslt,"sys$system"); + cp1 = rslt + 10; + *cp1 = 0; + islnm = my_trnlnm(rslt,trndev,0); + } + else if (strcmp(rslt,"tmp") == 0) { + strcpy(rslt,"sys$scratch"); + cp1 = rslt + 11; + *cp1 = 0; + islnm = my_trnlnm(rslt,trndev,0); + } + else if (!decc_disable_posix_root) { + strcpy(rslt, "sys$posix_root"); + cp1 = rslt + 13; + *cp1 = 0; + cp2 = path; + while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */ + islnm = my_trnlnm(rslt,trndev,0); + } + else if (strcmp(rslt,"dev") == 0) { + if (strncmp(cp2,"/null", 5) == 0) { + if ((cp2[5] == 0) || (cp2[5] == '/')) { + strcpy(rslt,"NLA0"); + cp1 = rslt + 4; + *cp1 = 0; + cp2 = cp2 + 5; + 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; @@ -4007,8 +4472,10 @@ static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) { } } else { - *(cp1++) = ':'; - hasdir = 0; + if (decc_disable_posix_root) { + *(cp1++) = ':'; + hasdir = 0; + } } } } @@ -4029,6 +4496,10 @@ static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) { if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */ cp2 += 4; } + else if ((cp2 != lastdot) || (lastdot < dirend)) { + /* Escape the extra dots in EFS file specifications */ + *(cp1++) = '^'; + } if (cp2 > dirend) cp2 = dirend; } else *(cp1++) = '.'; @@ -4066,11 +4537,25 @@ static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) { } else cp2 += 3; /* Trailing '/' was there, so skip it, too */ } - else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */ + else { + if (decc_efs_charset == 0) + *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */ + else { + *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */ + *(cp1++) = '.'; + } + } } else { if (!infront && *(cp1-1) == '-') *(cp1++) = '.'; - if (*cp2 == '.') *(cp1++) = '_'; + if (*cp2 == '.') { + if (decc_efs_charset == 0) + *(cp1++) = '_'; + else { + *(cp1++) = '^'; + *(cp1++) = '.'; + } + } else *(cp1++) = *cp2; infront = 1; } @@ -4078,7 +4563,89 @@ static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) { if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */ if (hasdir) *(cp1++) = ']'; if (*cp2) cp2++; /* check in case we ended with trailing '..' */ - while (*cp2) *(cp1++) = *(cp2++); + /* fixme for ODS5 */ + no_type_seen = 0; + if (cp2 > lastdot) + no_type_seen = 1; + while (*cp2) { + switch(*cp2) { + case '?': + *(cp1++) = '%'; + cp2++; + case ' ': + *(cp1)++ = '^'; + *(cp1)++ = '_'; + cp2++; + break; + case '.': + if (((cp2 < lastdot) || (cp2[1] == '\0')) && + decc_readdir_dropdotnotype) { + *(cp1)++ = '^'; + *(cp1)++ = '.'; + cp2++; + + /* trailing dot ==> '^..' on VMS */ + if (*cp2 == '\0') { + *(cp1++) = '.'; + no_type_seen = 0; + } + } + else { + *(cp1++) = *(cp2++); + no_type_seen = 0; + } + break; + case '\"': + case '~': + case '`': + case '!': + case '#': + case '%': + case '^': + case '&': + case '(': + case ')': + case '=': + case '+': + case '\'': + case '@': + case '[': + case ']': + case '{': + case '}': + case ':': + case '\\': + case '|': + case '<': + case '>': + *(cp1++) = '^'; + *(cp1++) = *(cp2++); + break; + case ';': + /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs + * which is wrong. UNIX notation should be ".dir. unless + * the DECC$FILENAME_UNIX_NO_VERSION is enabled. + * changing this behavior could break more things at this time. + */ + if (decc_filename_unix_report != 0) { + *(cp1++) = '^'; + } + *(cp1++) = *(cp2++); + break; + default: + *(cp1++) = *(cp2++); + } + } + if ((no_type_seen == 1) && decc_readdir_dropdotnotype) { + char *lcp1; + lcp1 = cp1; + lcp1--; + /* Fix me for "^]", but that requires making sure that you do + * not back up past the start of the filename + */ + if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%')) + *cp1++ = '.'; + } *cp1 = '\0'; return rslt; @@ -4524,7 +5091,7 @@ unsigned long int zero = 0, sts; strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length); string[resultspec.dsc$w_length] = '\0'; if (NULL == had_version) - *((char *)strrchr(string, ';')) = '\0'; + *(strrchr(string, ';')) = '\0'; if ((!had_directory) && (had_device == NULL)) { if (NULL == (devdir = strrchr(string, ']'))) @@ -4535,9 +5102,11 @@ unsigned long int zero = 0, sts; * Be consistent with what the C RTL has already done to the rest of * the argv items and lowercase all of these names. */ - for (c = string; *c; ++c) + if (!decc_efs_case_preserve) { + for (c = string; *c; ++c) if (isupper(*c)) *c = tolower(*c); + } if (isunix) trim_unixpath(string,item,1); add_item(head, tail, string, count); ++expcount; @@ -4730,7 +5299,7 @@ vms_image_init(int *argcp, char ***argvp) { 0, 0, 0, 0} }; #ifdef KILL_BY_SIGPRC - (void) Perl_csighandler_init(); + Perl_csighandler_init(); #endif _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL)); @@ -4777,6 +5346,33 @@ vms_image_init(int *argcp, char ***argvp) } if (mask != rlst) Safefree(mask); } + + /* When Perl is in decc_filename_unix_report mode and is run from a concealed + * logical, some versions of the CRTL will add a phanthom /000000/ + * directory. This needs to be removed. + */ + if (decc_filename_unix_report) { + char * zeros; + int ulen; + ulen = strlen(argvp[0][0]); + if (ulen > 7) { + zeros = strstr(argvp[0][0], "/000000/"); + if (zeros != NULL) { + int mlen; + mlen = ulen - (zeros - argvp[0][0]) - 7; + memmove(zeros, &zeros[7], mlen); + ulen = ulen - 7; + argvp[0][0][ulen] = '\0'; + } + } + /* It also may have a trailing dot that needs to be removed otherwise + * it will be converted to VMS mode incorrectly. + */ + ulen--; + if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype)) + argvp[0][0][ulen] = '\0'; + } + /* We need to use this hack to tell Perl it should run with tainting, * since its tainting flag may be part of the PL_curinterp struct, which * hasn't been allocated when vms_image_init() is called. @@ -4831,7 +5427,7 @@ vms_image_init(int *argcp, char ***argvp) #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) ) { # include - (void) decc$set_reentrancy(C$C_MULTITHREAD); + decc$set_reentrancy(C$C_MULTITHREAD); } #endif return; @@ -4919,8 +5515,10 @@ Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts) * could match template). */ if (getcwd(tpl, sizeof tpl,0) == NULL) return 0; - for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++) - if (_tolower(*cp1) != _tolower(*cp2)) break; + if (!decc_efs_case_preserve) { + for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++) + if (_tolower(*cp1) != _tolower(*cp2)) break; + } segdirs = dirs - totells; /* Min # of dirs we must have left */ for (front = cp2+1; *front; front++) if (*front == '/') segdirs--; if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) { @@ -4933,8 +5531,10 @@ Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts) for (front = end ; front >= base; front--) if (*front == '/' && !dirs--) { front++; break; } } - for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres; + if (!decc_efs_case_preserve) { + for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres; cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */ + } if (cp1 != '\0') return 0; /* Path too long. */ lcend = cp2; *cp2 = '\0'; /* Pick up with memcpy later */ @@ -4954,7 +5554,14 @@ Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts) cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl; cp1++, cp2++) { if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */ - else *cp2 = _tolower(*cp1); /* else lowercase for match */ + else { + if (!decc_efs_case_preserve) { + *cp2 = _tolower(*cp1); /* else lowercase for match */ + } + else { + *cp2 = *cp1; /* else preserve case for match */ + } + } if (*cp2 == '/') segdirs++; } if (cp1 != ellipsis - 1) return 0; /* Path too long */ @@ -4982,8 +5589,10 @@ Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts) char def[NAM$C_MAXRSS+1], *st; if (getcwd(def, sizeof def,0) == NULL) return 0; - for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++) - if (_tolower(*cp1) != _tolower(*cp2)) break; + if (!decc_efs_case_preserve) { + for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++) + if (_tolower(*cp1) != _tolower(*cp2)) break; + } segdirs = dirs - totells; /* Min # of dirs we must have left */ for (st = cp2+1; *st; st++) if (*st == '/') segdirs--; if (*cp1 == '\0' && *cp2 == '/') { @@ -5056,7 +5665,7 @@ Perl_opendir(pTHX_ const char *name) Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char); /* Fill in the fields; mainly playing with the descriptor. */ - (void)sprintf(dd->pattern, "%s*.*",dir); + sprintf(dd->pattern, "%s*.*",dir); dd->context = 0; dd->count = 0; dd->vms_wantversions = 0; @@ -5093,13 +5702,15 @@ vmsreaddirversions(DIR *dd, int flag) void closedir(DIR *dd) { - (void)lib$find_file_end(&dd->context); + int sts; + + sts = lib$find_file_end(&dd->context); Safefree(dd->pattern); #if defined(USE_ITHREADS) MUTEX_DESTROY( (perl_mutex *) dd->mutex ); Safefree(dd->mutex); #endif - Safefree((char *)dd); + Safefree(dd); } /*}}}*/ @@ -5122,8 +5733,8 @@ collectversions(pTHX_ DIR *dd) /* Add the version wildcard, ignoring the "*.*" put on before */ i = strlen(dd->pattern); Newx(text,i + e->d_namlen + 3,char); - (void)strcpy(text, dd->pattern); - (void)sprintf(&text[i - 3], "%s;*", e->d_name); + strcpy(text, dd->pattern); + sprintf(&text[i - 3], "%s;*", e->d_name); /* Set up the pattern descriptor. */ pat.dsc$a_pointer = text; @@ -5192,14 +5803,23 @@ Perl_readdir(pTHX_ DIR *dd) } dd->count++; /* Force the buffer to end with a NUL, and downcase name to match C convention. */ - buff[sizeof buff - 1] = '\0'; + if (!decc_efs_case_preserve) { + buff[sizeof buff - 1] = '\0'; + for (p = buff; *p; p++) *p = _tolower(*p); + while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */ + *p = '\0'; + } + else { + /* we don't want to force to lowercase, just null terminate */ + buff[res.dsc$w_length] = '\0'; + } for (p = buff; *p; p++) *p = _tolower(*p); while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */ *p = '\0'; /* Skip any directory component and just copy the name. */ - if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1); - else (void)strcpy(dd->entry.d_name, buff); + if ((p = strchr(buff, ']'))) strcpy(dd->entry.d_name, p + 1); + else strcpy(dd->entry.d_name, buff); /* Clobber the version. */ if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0'; @@ -5266,7 +5886,7 @@ Perl_seekdir(pTHX_ DIR *dd, long count) /* The increment is in readdir(). */ for (dd->count = 0; dd->count < count; ) - (void)readdir(dd); + readdir(dd); dd->vms_wantversions = vms_wantversions; @@ -5685,7 +6305,7 @@ static unsigned int *sockflags, sockflagsize; /*{{{ FILE *my_fdopen(int fd, const char *mode)*/ FILE *my_fdopen(int fd, const char *mode) { - FILE *fp = fdopen(fd, (char *) mode); + FILE *fp = fdopen(fd, mode); if (fp) { unsigned int fdoff = fd / sizeof(unsigned int); @@ -5890,7 +6510,7 @@ static int fillpasswd (pTHX_ const char *name, struct passwd *pwd) name_desc.dsc$w_length= strlen(name); name_desc.dsc$b_dtype= DSC$K_DTYPE_T; name_desc.dsc$b_class= DSC$K_CLASS_S; - name_desc.dsc$a_pointer= (char *) name; + name_desc.dsc$a_pointer= (char *) name; /* read only pointer */ /* Note that sys$getuai returns many fields as counted strings. */ sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0); @@ -5926,7 +6546,8 @@ static int fillpasswd (pTHX_ const char *name, struct passwd *pwd) } else strcpy(pwd->pw_unixdir, pwd->pw_dir); - __mystrtolower(pwd->pw_unixdir); + if (!decc_efs_case_preserve) + __mystrtolower(pwd->pw_unixdir); return 1; } @@ -6471,8 +7092,8 @@ tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff) for (j = 0; j < 12; j++) { w2 =localtime(&when); - (void) tz_parse_startend(s_start,w2,&ds); - (void) tz_parse_startend(s_end,w2,&de); + tz_parse_startend(s_start,w2,&ds); + tz_parse_startend(s_end,w2,&de); if (ds != de) break; when += 30*86400; } @@ -6601,7 +7222,7 @@ Perl_my_localtime(pTHX_ const time_t *timep) return NULL; } if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */ - if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */ + if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */ when = *timep; # ifdef RTL_USES_UTC @@ -6659,6 +7280,7 @@ static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 }; int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes) { register int i; + int sts; long int bintime[2], len = 2, lowbit, unixtime, secscale = 10000000; /* seconds --> 100 ns intervals */ unsigned long int chan, iosb[2], retsts; @@ -6680,6 +7302,7 @@ int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes) */ # pragma message restore #endif + /* cast ok for read only parameter */ struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib}, devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0}, fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0}; @@ -6689,7 +7312,7 @@ int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes) set_vaxc_errno(LIB$_INVARG); return -1; } - if (do_tovmsspec((char *)file,vmsspec,0) == 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) @@ -6735,6 +7358,8 @@ int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes) mynam.nam$b_ess = (unsigned char) sizeof esa; mynam.nam$l_rsa = rsa; mynam.nam$b_rss = (unsigned char) sizeof rsa; + if (decc_efs_case_preserve) + mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE; /* Look for the file to be affected, letting RMS parse the file * specification for us as well. I have set errno using only @@ -6751,7 +7376,7 @@ int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes) retsts = sys$search(&myfab,0,0); if (!(retsts & 1)) { mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL; - myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); + myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0); set_vaxc_errno(retsts); if (retsts == RMS$_PRV) set_errno(EACCES); else if (retsts == RMS$_FNF) set_errno(ENOENT); @@ -6760,12 +7385,13 @@ int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes) } devdsc.dsc$w_length = mynam.nam$b_dev; + /* cast ok for read only parameter */ devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev; retsts = sys$assign(&devdsc,&chan,0,0); if (!(retsts & 1)) { mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL; - myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); + myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0); set_vaxc_errno(retsts); if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR); else if (retsts == SS$_NOPRIV) set_errno(EACCES); @@ -6791,7 +7417,7 @@ int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes) #endif retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0); mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL; - myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); + myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0); _ckvmssts(sys$dassgn(chan)); if (retsts & 1) retsts = iosb[0]; if (!(retsts & 1)) { @@ -6860,7 +7486,7 @@ static mydev_t encode_dev (pTHX_ const char *dev) dev_desc.dsc$w_length = strlen (dev); dev_desc.dsc$b_dtype = DSC$K_DTYPE_T; dev_desc.dsc$b_class = DSC$K_CLASS_S; - dev_desc.dsc$a_pointer = (char *) dev; + dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */ _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0)); if (lockid) return (lockid & ~LOCKID_MASK); } @@ -7234,6 +7860,10 @@ Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates nam.nam$l_esa = esa; nam.nam$b_ess = sizeof (esa); nam.nam$b_esl = nam.nam$b_rsl = 0; +#ifdef NAM$M_NO_SHORT_UPCASE + if (decc_efs_case_preserve) + nam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE; +#endif xabdat = cc$rms_xabdat; /* To get creation date */ xabdat.xab$l_nxt = (void *) &xabfhc; @@ -7273,7 +7903,7 @@ Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates 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; + 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); @@ -7675,7 +8305,7 @@ Perl_sys_intern_init(pTHX) } void -init_os_extras() +init_os_extras(void) { dTHX; char* file = __FILE__; @@ -7697,10 +8327,353 @@ init_os_extras() newXSproto("DynaLoader::mod2fname", mod2fname, file, "$"); newXS("File::Copy::rmscopy",rmscopy_fromperl,file); newXSproto("vmsish::hushed",hushexit_fromperl,file,";$"); +#ifdef HAS_SYMLINK + newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$"); +#endif +#if 0 /* future */ +#if __CRTL_VER >= 70301000 && !defined(__VAX) + newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$"); +#endif +#endif store_pipelocs(aTHX); /* will redo any earlier attempts */ return; } +#ifdef HAS_SYMLINK + +#if __CRTL_VER == 80200000 +/* This missed getting in to the DECC SDK for 8.2 */ +char *realpath(const char *file_name, char * resolved_name, ...); +#endif + +/*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/ +/* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK. + * The perl fallback routine to provide realpath() is not as efficient + * on OpenVMS. + */ +static char * +mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf) +{ + return realpath(filespec, outbuf); +} + +/*}}}*/ +/* External entry points */ +char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf) +{ return do_vms_realpath(filespec, outbuf); } +#else +char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf) +{ return NULL; } +#endif + + +#if __CRTL_VER >= 70301000 && !defined(__VAX) +/* case_tolerant */ + +/*{{{int do_vms_case_tolerant(void)*/ +/* OpenVMS provides a case sensitive implementation of ODS-5 and this is + * controlled by a process setting. + */ +int do_vms_case_tolerant(void) +{ + return vms_process_case_tolerant; +} +/*}}}*/ +/* External entry points */ +int Perl_vms_case_tolerant(void) +{ return do_vms_case_tolerant(); } +#else +int Perl_vms_case_tolerant(void) +{ return vms_process_case_tolerant; } +#endif + + + /* Start of DECC RTL Feature handling */ + +static int sys_trnlnm + (const char * logname, + char * value, + int value_len) +{ + const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV"); + const unsigned long attr = LNM$M_CASE_BLIND; + struct dsc$descriptor_s name_dsc; + int status; + unsigned short result; + struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result}, + {0, 0, 0, 0}}; + + name_dsc.dsc$w_length = strlen(logname); + name_dsc.dsc$a_pointer = (char *)logname; + name_dsc.dsc$b_dtype = DSC$K_DTYPE_T; + name_dsc.dsc$b_class = DSC$K_CLASS_S; + + status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst); + + if ($VMS_STATUS_SUCCESS(status)) { + + /* Null terminate and return the string */ + /*--------------------------------------*/ + value[result] = 0; + } + + return status; +} + +static int sys_crelnm + (const char * logname, + const char * value) +{ + int ret_val; + const char * proc_table = "LNM$PROCESS_TABLE"; + struct dsc$descriptor_s proc_table_dsc; + struct dsc$descriptor_s logname_dsc; + struct itmlst_3 item_list[2]; + + proc_table_dsc.dsc$a_pointer = (char *) proc_table; + proc_table_dsc.dsc$w_length = strlen(proc_table); + proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T; + proc_table_dsc.dsc$b_class = DSC$K_CLASS_S; + + logname_dsc.dsc$a_pointer = (char *) logname; + logname_dsc.dsc$w_length = strlen(logname); + logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T; + logname_dsc.dsc$b_class = DSC$K_CLASS_S; + + item_list[0].buflen = strlen(value); + item_list[0].itmcode = LNM$_STRING; + item_list[0].bufadr = (char *)value; + item_list[0].retlen = NULL; + + item_list[1].buflen = 0; + item_list[1].itmcode = 0; + + ret_val = sys$crelnm + (NULL, + (const struct dsc$descriptor_s *)&proc_table_dsc, + (const struct dsc$descriptor_s *)&logname_dsc, + NULL, + (const struct item_list_3 *) item_list); + + return ret_val; +} + + +/* C RTL Feature settings */ + +static int set_features + (int (* init_coroutine)(int *, int *, void *), /* Needs casts if used */ + int (* cli_routine)(void), /* Not documented */ + void *image_info) /* Not documented */ +{ + int status; + int s; + int dflt; + char* str; + char val_str[10]; + const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM; + const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE; + unsigned long case_perm; + unsigned long case_image; + +#if __CRTL_VER >= 70300000 && !defined(__VAX) + s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION"); + if (s >= 0) { + decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1); + if (decc_disable_to_vms_logname_translation < 0) + decc_disable_to_vms_logname_translation = 0; + } + + s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE"); + if (s >= 0) { + decc_efs_case_preserve = decc$feature_get_value(s, 1); + if (decc_efs_case_preserve < 0) + decc_efs_case_preserve = 0; + } + + s = decc$feature_get_index("DECC$EFS_CHARSET"); + if (s >= 0) { + decc_efs_charset = decc$feature_get_value(s, 1); + if (decc_efs_charset < 0) + decc_efs_charset = 0; + } + + s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT"); + if (s >= 0) { + decc_filename_unix_report = decc$feature_get_value(s, 1); + if (decc_filename_unix_report > 0) + decc_filename_unix_report = 1; + else + decc_filename_unix_report = 0; + } + + s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY"); + if (s >= 0) { + decc_filename_unix_only = decc$feature_get_value(s, 1); + if (decc_filename_unix_only > 0) { + decc_filename_unix_only = 1; + } + else { + decc_filename_unix_only = 0; + } + } + + s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION"); + if (s >= 0) { + decc_filename_unix_no_version = decc$feature_get_value(s, 1); + if (decc_filename_unix_no_version < 0) + decc_filename_unix_no_version = 0; + } + + s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE"); + if (s >= 0) { + decc_readdir_dropdotnotype = decc$feature_get_value(s, 1); + if (decc_readdir_dropdotnotype < 0) + decc_readdir_dropdotnotype = 0; + } + + status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str)); + if ($VMS_STATUS_SUCCESS(status)) { + s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT"); + if (s >= 0) { + dflt = decc$feature_get_value(s, 4); + if (dflt > 0) { + decc_disable_posix_root = decc$feature_get_value(s, 1); + if (decc_disable_posix_root <= 0) { + decc$feature_set_value(s, 1, 1); + decc_disable_posix_root = 1; + } + } + else { + /* Traditionally Perl assumes this is off */ + decc_disable_posix_root = 1; + decc$feature_set_value(s, 1, 1); + } + } + } + +#if __CRTL_VER >= 80200000 + s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES"); + if (s >= 0) { + decc_posix_compliant_pathnames = decc$feature_get_value(s, 1); + if (decc_posix_compliant_pathnames < 0) + decc_posix_compliant_pathnames = 0; + if (decc_posix_compliant_pathnames > 4) + decc_posix_compliant_pathnames = 0; + } + +#endif +#else + status = sys_trnlnm + ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str)); + if ($VMS_STATUS_SUCCESS(status)) { + val_str[0] = _toupper(val_str[0]); + if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) { + decc_disable_to_vms_logname_translation = 1; + } + } + +#ifndef __VAX + status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str)); + if ($VMS_STATUS_SUCCESS(status)) { + val_str[0] = _toupper(val_str[0]); + if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) { + decc_efs_case_preserve = 1; + } + } +#endif + + status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str)); + if ($VMS_STATUS_SUCCESS(status)) { + val_str[0] = _toupper(val_str[0]); + if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) { + decc_filename_unix_report = 1; + } + } + status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str)); + if ($VMS_STATUS_SUCCESS(status)) { + val_str[0] = _toupper(val_str[0]); + if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) { + decc_filename_unix_only = 1; + decc_filename_unix_report = 1; + } + } + status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str)); + if ($VMS_STATUS_SUCCESS(status)) { + val_str[0] = _toupper(val_str[0]); + if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) { + decc_filename_unix_no_version = 1; + } + } + status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str)); + if ($VMS_STATUS_SUCCESS(status)) { + val_str[0] = _toupper(val_str[0]); + if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) { + decc_readdir_dropdotnotype = 1; + } + } +#endif + +#ifndef __VAX + + /* Report true case tolerance */ + /*----------------------------*/ + status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0); + if (!$VMS_STATUS_SUCCESS(status)) + case_perm = PPROP$K_CASE_BLIND; + status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0); + if (!$VMS_STATUS_SUCCESS(status)) + case_image = PPROP$K_CASE_BLIND; + if ((case_perm == PPROP$K_CASE_SENSITIVE) || + (case_image == PPROP$K_CASE_SENSITIVE)) + vms_process_case_tolerant = 0; + +#endif + + + /* CRTL can be initialized past this point, but not before. */ +/* DECC$CRTL_INIT(); */ + + return SS$_NORMAL; +} + +#ifdef __DECC +/* DECC dependent attributes */ +#if __DECC_VER < 60560002 +#define relative +#define not_executable +#else +#define relative ,rel +#define not_executable ,noexe +#endif +#pragma nostandard +#pragma extern_model save +#pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt +#endif + const __align (LONGWORD) int spare[8] = {0}; +/* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */ +/* NOWRT, LONG */ +#ifdef __DECC +#pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \ + nowrt,noshr relative not_executable +#endif +const long vms_cc_features = (const long)set_features; + +/* +** Force a reference to LIB$INITIALIZE to ensure it +** exists in the image. +*/ +int lib$initialize(void); +#ifdef __DECC +#pragma extern_model strict_refdef +#endif + int lib_init_ref = (int) lib$initialize; + +#ifdef __DECC +#pragma extern_model restore +#pragma standard +#endif + /* End of vms.c */ -- 2.7.4