#include <lib$routines.h>
#include <lnmdef.h>
#include <msgdef.h>
+#if __CRTL_VER >= 70301000 && !defined(__VAX)
+#include <ppropdef.h>
+#endif
#include <prvdef.h>
#include <psldef.h>
#include <rms.h>
#include <stsdef.h>
#include <rmsdef.h>
+/* 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 <unixlib.h>
+#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
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
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;
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)
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;
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);
}
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; }
memcpy(eqv,eqv+4,eqvlen-4);
eqvlen -= 4;
}
- cp1 += eqvlen;
- *cp1 = '\0';
+ cp2 += eqvlen;
+ *cp2 = '\0';
}
if ((retsts == SS$_IVLOGNAM) ||
(retsts == SS$_NOLOGNAM)) { continue; }
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
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;
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
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 {
*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. */
}
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++) {
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;
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);
#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)) {
/* 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);
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;
/*
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() */
{
pInfo i = open_pipes;
int iss;
+ int sts;
pXpipe x;
info->completion &= 0x0FFFFFFF; /* strip off "control" field */
pCBuf b = p->curr;
int iss = p->iosb.status;
int eof = (iss == SS$_ENDOFFILE);
+ int sts;
#ifdef PERL_IMPLICIT_CONTEXT
pTHX = p->thx;
#endif
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));
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);
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);
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);
/* 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
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);
!(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. */
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;
}
/*}}}*/
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;
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)) {
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);
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 */
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;
}
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;
}
}
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;
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) {
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;
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;
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);
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);
}
}
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() */
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;
(*(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. */
(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++) ;
}
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;
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;
}
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;
/* 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;
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;
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;
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;
}
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++) = '/';
}
*(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;
}
*(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++) = '/';
}
}
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++;
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) == '>' ||
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() */
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;
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;
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;
}
}
else {
- *(cp1++) = ':';
- hasdir = 0;
+ if (decc_disable_posix_root) {
+ *(cp1++) = ':';
+ hasdir = 0;
+ }
}
}
}
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++) = '.';
}
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;
}
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;
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, ']')))
* 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;
{ 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));
}
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.
#if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
{
# include <reentrancy.h>
- (void) decc$set_reentrancy(C$C_MULTITHREAD);
+ decc$set_reentrancy(C$C_MULTITHREAD);
}
#endif
return;
* 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) {
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 */
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 */
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 == '/') {
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;
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);
}
/*}}}*/
/* 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;
}
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';
/* The increment is in readdir(). */
for (dd->count = 0; dd->count < count; )
- (void)readdir(dd);
+ readdir(dd);
dd->vms_wantversions = vms_wantversions;
/*{{{ 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);
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);
}
else
strcpy(pwd->pw_unixdir, pwd->pw_dir);
- __mystrtolower(pwd->pw_unixdir);
+ if (!decc_efs_case_preserve)
+ __mystrtolower(pwd->pw_unixdir);
return 1;
}
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;
}
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
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;
*/
# 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};
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)
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
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);
}
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);
#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)) {
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);
}
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;
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);
}
void
-init_os_extras()
+init_os_extras(void)
{
dTHX;
char* file = __FILE__;
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 */
projects / platform / upstream / perl.git / commitdiff