*
* VMS-specific routines for perl5
*
- * Last revised: 24-Apr-1999 by Charles Bailey bailey@newman.upenn.edu
- * Version: 5.5.58
+ * Last revised: 20-Aug-1999 by Charles Bailey bailey@newman.upenn.edu
+ * Version: 5.5.60
*/
#include <acedef.h>
# define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
#endif
+#if defined(NEED_AN_H_ERRNO)
+dEXT int h_errno;
+#endif
struct itmlst_3 {
unsigned short int buflen;
static struct dsc$descriptor_s **env_tables = defenv;
static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
+/* True if we shouldn't treat barewords as logicals during directory */
+/* munching */
+static int no_translate_barewords;
+
+/* Temp for subprocess commands */
+static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
+
/*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
int
vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
struct dsc$descriptor_s **tabvec, unsigned long int flags)
{
- char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
+ char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
unsigned long int retsts, attr = LNM$M_CASE_BLIND;
unsigned char acmode;
}
lnmdsc.dsc$w_length = cp1 - lnm;
lnmdsc.dsc$a_pointer = uplnm;
+ uplnm[lnmdsc.dsc$w_length] = '\0';
secure = flags & PERL__TRNENV_SECURE;
acmode = secure ? PSL$C_EXEC : PSL$C_USER;
if (!tabvec || !*tabvec) tabvec = env_tables;
retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
if (retsts == SS$_NOLOGNAM) continue;
+ /* PPFs have a prefix */
+ if (
+#if INTSIZE == 4
+ *((int *)uplnm) == *((int *)"SYS$") &&
+#endif
+ eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
+ ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
+ (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
+ (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
+ (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
+ memcpy(eqv,eqv+4,eqvlen-4);
+ eqvlen -= 4;
+ }
break;
}
}
idx = strtoul(cp2+1,NULL,0);
lnm = uplnm;
}
+ /* Impose security constraints only if tainting */
+ if (sys) sys = PL_curinterp ? PL_tainting : will_taint;
if (vmstrnenv(lnm,eqv,idx,
sys ? fildev : NULL,
#ifdef SECURE_INTERNAL_GETENV
idx = strtoul(cp2+1,NULL,0);
lnm = buf;
}
+ /* Impose security constraints only if tainting */
+ if (sys) sys = PL_curinterp ? PL_tainting : will_taint;
if ((*len = vmstrnenv(lnm,buf,idx,
sys ? fildev : NULL,
#ifdef SECURE_INTERNAL_GETENV
}
else {
if (!*eqv) eqvdsc.dsc$w_length = 1;
+ if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
+ eqvdsc.dsc$w_length = LNM$C_NAMLENGTH;
+ if (ckWARN(WARN_MISC)) {
+ Perl_warner(aTHX_ WARN_MISC,"Value of logical \"%s\" too long. Truncating to %i bytes",lnm, LNM$C_NAMLENGTH);
+ }
+ }
retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
}
}
info = open_pipes;
while (info) {
- if (info->mode != 'r' && !info->done) {
+ int need_eof;
+ _ckvmssts(sys$setast(0));
+ need_eof = info->mode != 'r' && !info->done;
+ _ckvmssts(sys$setast(1));
+ if (need_eof) {
if (pipe_eof(info->fp, 1) & 1) did_stuff = 1;
}
info = info->next;
did_stuff = 0;
info = open_pipes;
while (info) {
+ _ckvmssts(sys$setast(0));
if (!info->done) { /* Tap them gently on the shoulder . . .*/
sts = sys$forcex(&info->pid,0,&abort);
if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
did_stuff = 1;
}
+ _ckvmssts(sys$setast(1));
info = info->next;
}
if (did_stuff) sleep(1); /* wait for them to respond */
info = open_pipes;
while (info) {
+ _ckvmssts(sys$setast(0));
if (!info->done) { /* We tried to be nice . . . */
sts = sys$delprc(&info->pid,0);
if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
info->done = 1; /* so my_pclose doesn't try to write EOF */
}
+ _ckvmssts(sys$setast(1));
info = info->next;
}
}
}
+static unsigned long int setup_cmddsc(char *cmd, int check_img);
+static void vms_execfree();
+
static PerlIO *
safe_popen(char *cmd, char *mode)
{
static int handler_set_up = FALSE;
char mbxname[64];
unsigned short int chan;
- unsigned long int flags=1; /* nowait - gnu c doesn't allow &1 */
+ unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */
dTHX;
struct pipe_details *info;
struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
DSC$K_CLASS_S, 0};
- cmddsc.dsc$w_length=strlen(cmd);
- cmddsc.dsc$a_pointer=cmd;
- if (cmddsc.dsc$w_length > 255) {
- set_errno(E2BIG); set_vaxc_errno(CLI$_BUFOVF);
- return Nullfp;
- }
-
+ if (!(setup_cmddsc(cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; }
New(1301,info,1,struct pipe_details);
/* create mailbox */
info->completion=0;
if (*mode == 'r') {
- _ckvmssts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
+ _ckvmssts(lib$spawn(&VMScmd, &nl_desc, &namdsc, &flags,
0 /* name */, &info->pid, &info->completion,
0, popen_completion_ast,info,0,0,0));
}
else {
- _ckvmssts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags,
+ _ckvmssts(lib$spawn(&VMScmd, &namdsc, 0 /* sys$output */, &flags,
0 /* name */, &info->pid, &info->completion,
0, popen_completion_ast,info,0,0,0));
}
+ vms_execfree();
if (!handler_set_up) {
_ckvmssts(sys$dclexh(&pipe_exitblock));
handler_set_up = TRUE;
{
struct pipe_details *info, *last = NULL;
unsigned long int retsts;
+ int need_eof;
for (info = open_pipes; info != NULL; last = info, info = info->next)
if (info->fp == fp) break;
/* If we were writing to a subprocess, insure that someone reading from
* the mailbox gets an EOF. It looks like a simple fclose() doesn't
* produce an EOF record in the mailbox. */
- if (info->mode != 'r' && !info->done) pipe_eof(info->fp,0);
+ _ckvmssts(sys$setast(0));
+ need_eof = info->mode != 'r' && !info->done;
+ _ckvmssts(sys$setast(1));
+ if (need_eof) pipe_eof(info->fp,0);
PerlIO_close(info->fp);
if (info->done) retsts = info->completion;
else waitpid(info->pid,(int *) &retsts,0);
/* remove from list of open pipes */
+ _ckvmssts(sys$setast(0));
if (last) last->next = info->next;
else open_pipes = info->next;
+ _ckvmssts(sys$setast(1));
Safefree(info);
return retsts;
/* Yes; fake the fnb bits so we'll check type below */
dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
}
- else {
- if (dirfab.fab$l_sts != RMS$_FNF) {
- set_errno(EVMSERR);
- set_vaxc_errno(dirfab.fab$l_sts);
+ else { /* No; just work with potential name */
+ if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
+ 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);
return NULL;
}
- dirnam = savnam; /* No; just work with potential name */
}
}
if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
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);
set_errno(ENOTDIR);
set_vaxc_errno(RMS$_DIR);
return NULL;
else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
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);
return retspec;
}
if ((cp1 = strstr(esa,".][000000]")) != NULL) {
dirnam.nam$b_esl -= 9;
}
if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
- if (cp1 == NULL) return NULL; /* should never happen */
+ 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);
+ return NULL;
+ }
term = *cp1;
*cp1 = '\0';
retlen = strlen(esa);
/* Go back and expand rooted logical name */
dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
if (!(sys$parse(&dirfab) & 1)) {
+ dirnam.nam$l_rlf = NULL;
+ dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
set_errno(EVMSERR);
set_vaxc_errno(dirfab.fab$l_sts);
return NULL;
strcpy(cp2+9,cp1);
}
}
+ dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
+ dirfab.fab$b_dns = 0; (void) 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");
if (*dir) strcpy(trndir,dir);
else getcwd(trndir,sizeof trndir - 1);
- while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir,0)) {
+ while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
+ && my_trnlnm(trndir,trndir,0)) {
STRLEN trnlen = strlen(trndir);
/* Trap simple rooted lnms, and return lnm:[000000] */
savnam = dirnam;
if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
if (dirfab.fab$l_sts != RMS$_FNF) {
+ dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
+ dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
set_errno(EVMSERR);
set_vaxc_errno(dirfab.fab$l_sts);
return NULL;
cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
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);
set_errno(ENOTDIR);
set_vaxc_errno(RMS$_DIR);
return NULL;
else if (ts) New(1314,retpath,retlen,char);
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);
/* $PARSE may have upcased filespec, so convert output to lower
* case if input contained any lowercase characters. */
if (haslower) __mystrtolower(retpath);
exit(vaxc$errno);
}
if (err != NULL) {
+ if (strcmp(err,"&1") == 0) {
+ dup2(fileno(stdout), fileno(Perl_debug_log));
+ } else {
FILE *tmperr;
if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
{
exit(vaxc$errno);
}
}
+ }
#ifdef ARGPROC_DEBUG
PerlIO_printf(Perl_debug_log, "Arglist:\n");
for (j = 0; j < *ac; ++j)
/*}}}*/
-static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
-
static void
vms_execfree() {
if (PL_Cmd) {
- Safefree(PL_Cmd);
+ if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd);
PL_Cmd = Nullch;
}
if (VMScmd.dsc$a_pointer) {
static unsigned long int
setup_cmddsc(char *cmd, int check_img)
{
- char resspec[NAM$C_MAXRSS+1];
+ char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
$DESCRIPTOR(defdsc,".EXE");
+ $DESCRIPTOR(defdsc2,".");
$DESCRIPTOR(resdsc,resspec);
struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
- register char *s, *rest, *cp;
- register int isdcl = 0;
+ register char *s, *rest, *cp, *wordbreak;
+ register int isdcl;
dTHX;
+ if (strlen(cmd) >
+ (sizeof(vmsspec) > sizeof(resspec) ? sizeof(resspec) : sizeof(vmsspec)))
+ return LIB$_INVARG;
s = cmd;
while (*s && isspace(*s)) s++;
- if (check_img) {
- if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
- isdcl = 1; /* no dev/dir separators (i.e. not a foreign command) */
- for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
- if (*cp == ':' || *cp == '[' || *cp == '<') {
- isdcl = 0;
- break;
- }
+
+ if (*s == '@' || *s == '$') {
+ vmsspec[0] = *s; rest = s + 1;
+ for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
+ }
+ else { cp = vmsspec; rest = s; }
+ if (*rest == '.' || *rest == '/') {
+ char *cp2;
+ for (cp2 = resspec;
+ *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
+ rest++, cp2++) *cp2 = *rest;
+ *cp2 = '\0';
+ if (do_tovmsspec(resspec,cp,0)) {
+ s = vmsspec;
+ if (*rest) {
+ for (cp2 = vmsspec + strlen(vmsspec);
+ *rest && cp2 - vmsspec < sizeof vmsspec;
+ rest++, cp2++) *cp2 = *rest;
+ *cp2 = '\0';
}
}
}
- else isdcl = 1;
+ /* Intuit whether verb (first word of cmd) is a DCL command:
+ * - if first nonspace char is '@', it's a DCL indirection
+ * otherwise
+ * - if verb contains a filespec separator, it's not a DCL command
+ * - if it doesn't, caller tells us whether to default to a DCL
+ * command, or to a local image unless told it's DCL (by leading '$')
+ */
+ if (*s == '@') isdcl = 1;
+ else {
+ register char *filespec = strpbrk(s,":<[.;");
+ rest = wordbreak = strpbrk(s," \"\t/");
+ if (!wordbreak) wordbreak = s + strlen(s);
+ if (*s == '$') check_img = 0;
+ if (filespec && (filespec < wordbreak)) isdcl = 0;
+ else isdcl = !check_img;
+ }
+
if (!isdcl) {
- cmd = s;
- while (*s && !isspace(*s)) s++;
- rest = *s ? s : 0;
- imgdsc.dsc$a_pointer = cmd;
- imgdsc.dsc$w_length = s - cmd;
+ imgdsc.dsc$a_pointer = s;
+ imgdsc.dsc$w_length = wordbreak - s;
retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
- if (retsts & 1) {
+ if (!(retsts&1)) {
+ _ckvmssts(lib$find_file_end(&cxt));
+ retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
+ if (!(retsts & 1) && *s == '$') {
+ _ckvmssts(lib$find_file_end(&cxt));
+ imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
+ retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
+ if (!(retsts&1)) {
_ckvmssts(lib$find_file_end(&cxt));
+ retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
+ }
+ }
+ }
+ _ckvmssts(lib$find_file_end(&cxt));
+
+ if (retsts & 1) {
+ FILE *fp;
s = resspec;
while (*s && !isspace(*s)) s++;
*s = '\0';
+
+ /* check that it's really not DCL with no file extension */
+ fp = fopen(resspec,"r","ctx=bin,shr=get");
+ if (fp) {
+ char b[4] = {0,0,0,0};
+ read(fileno(fp),b,4);
+ isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
+ fclose(fp);
+ }
+ if (check_img && isdcl) return RMS$_FNF;
+
if (cando_by_name(S_IXUSR,0,resspec)) {
New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
+ if (!isdcl) {
strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
+ } else {
+ strcpy(VMScmd.dsc$a_pointer,"@");
+ }
strcat(VMScmd.dsc$a_pointer,resspec);
if (rest) strcat(VMScmd.dsc$a_pointer,rest);
VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
}
/* It's either a DCL command or we couldn't find a suitable image */
VMScmd.dsc$w_length = strlen(cmd);
- if (cmd == PL_Cmd) {
- VMScmd.dsc$a_pointer = PL_Cmd;
- PL_Cmd = Nullch; /* Don't try to free twice in vms_execfree() */
- }
+ if (cmd == PL_Cmd) VMScmd.dsc$a_pointer = PL_Cmd;
else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
if (!(retsts & 1)) {
/* just hand off status values likely to be due to user error */
# define RTL_USES_UTC 1
#endif
+/*
+ * DEC C previous to 6.0 corrupts the behavior of the /prefix
+ * qualifier with the extern prefix pragma. This provisional
+ * hack circumvents this prefix pragma problem in previous
+ * precompilers.
+ */
+#if defined(__VMS_VER) && __VMS_VER >= 70000000
+# if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
+# pragma __extern_prefix save
+# pragma __extern_prefix "" /* set to empty to prevent prefixing */
+# define gmtime decc$__utctz_gmtime
+# define localtime decc$__utctz_localtime
+# define time decc$__utc_time
+# pragma __extern_prefix restore
+
+ struct tm *gmtime(), *localtime();
+
+# endif
+#endif
+
+
static time_t toutc_dst(time_t loc) {
struct tm *rsltmp;
if (rsltmp->tm_isdst) loc -= 3600;
return loc;
}
-#define _toutc(secs) ((secs) == -1 ? -1 : \
+#define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
((gmtime_emulation_type || my_time(NULL)), \
(gmtime_emulation_type == 1 ? toutc_dst(secs) : \
((secs) - utc_offset_secs))))
if (rsltmp->tm_isdst) utc += 3600;
return utc;
}
-#define _toloc(secs) ((secs) == -1 ? -1 : \
+#define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
((gmtime_emulation_type || my_time(NULL)), \
(gmtime_emulation_type == 1 ? toloc_dst(secs) : \
((secs) + utc_offset_secs))))
/* If input was UTC; convert to local for sys svc */
if (!VMSISH_TIME) unixtime = _toloc(unixtime);
# endif
- unixtime >> 1; secscale << 1;
+ unixtime >>= 1; secscale <<= 1;
retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
if (!(retsts & 1)) {
set_errno(EVMSERR);
}
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);
set_vaxc_errno(retsts);
if (retsts == RMS$_PRV) set_errno(EACCES);
else if (retsts == RMS$_FNF) set_errno(ENOENT);
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);
set_vaxc_errno(retsts);
if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
else if (retsts == SS$_NOPRIV) set_errno(EACCES);
myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
#endif
retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
+ mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
+ myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
_ckvmssts(sys$dassgn(chan));
if (retsts & 1) retsts = iosb[0];
if (!(retsts & 1)) {
/* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
* subset of the applicable information.
*/
-/*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
-I32
-Perl_cando(pTHX_ I32 bit, I32 effective, Stat_t *statbufp)
+bool
+Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
{
if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
else {
/*}}}*/
-/*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
+/*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
I32
-cando_by_name(I32 bit, I32 effective, char *fname)
+cando_by_name(I32 bit, Uid_t effective, char *fname)
{
static char usrname[L_cuserid];
static struct dsc$descriptor_s usrdsc =
{
char* file = __FILE__;
dTHX;
+ char temp_buff[512];
+ if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
+ no_translate_barewords = TRUE;
+ } else {
+ no_translate_barewords = FALSE;
+ }
newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
https://perl5.git.perl.org / perl5.git / blobdiff