-/* vms.c
+/* vms.c
*
- * VMS-specific routines for perl5
- * Version: 5.7.0
+ * VMS-specific routines for perl5
*
- * August 2005 Convert VMS status code to UNIX status codes
- * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name,
- * and Perl_cando by Craig Berry
- * 29-Aug-2000 Charles Lane's piping improvements rolled in
- * 20-Aug-1999 revisions by Charles Bailey bailey@newman.upenn.edu
+ * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
+ * 2002, 2003, 2004, 2005, 2006, 2007 by Charles Bailey and others.
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * Please see Changes*.* or the Perl Repository Browser for revision history.
*/
+/*
+ * Yet small as was their hunted band
+ * still fell and fearless was each hand,
+ * and strong deeds they wrought yet oft,
+ * and loved the woods, whose ways more soft
+ * them seemed than thralls of that black throne
+ * to live and languish in halls of stone.
+ * "The Lay of Leithian", Canto II, lines 135-40
+ *
+ * [p.162 of _The Lays of Beleriand_]
+ */
+
#include <acedef.h>
#include <acldef.h>
#include <armdef.h>
#define do_tovmspath(a,b,c,d) mp_do_tovmspath(aTHX_ a,b,c,d)
#define do_rmsexpand(a,b,c,d,e,f,g) mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
#define do_vms_realpath(a,b,c) mp_do_vms_realpath(aTHX_ a,b,c)
+#define do_vms_realname(a,b,c) mp_do_vms_realname(aTHX_ a,b,c)
#define do_tounixspec(a,b,c,d) mp_do_tounixspec(aTHX_ a,b,c,d)
#define do_tounixpath(a,b,c,d) mp_do_tounixpath(aTHX_ a,b,c,d)
#define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a)
static int decc_disable_posix_root = 1;
int decc_efs_case_preserve = 0;
static int decc_efs_charset = 0;
+static int decc_efs_charset_index = -1;
static int decc_filename_unix_no_version = 0;
static int decc_filename_unix_only = 0;
int decc_filename_unix_report = 0;
int vms_vtf7_filenames = 0;
int gnv_unix_shell = 0;
static int vms_unlink_all_versions = 0;
+static int vms_posix_exit = 0;
/* bug workarounds if needed */
-int decc_bug_readdir_efs1 = 0;
int decc_bug_devnull = 1;
-int decc_bug_fgetname = 0;
int decc_dir_barename = 0;
+int vms_bug_stat_filename = 0;
static int vms_debug_on_exception = 0;
+static int vms_debug_fileify = 0;
+
+/* Simple logical name translation */
+static int simple_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 result;
+ }
+
+ return 0;
+}
+
/* Is this a UNIX file specification?
* No longer a simple check with EFS file specs
case ']':
case '%':
case '^':
+ case '\\':
/* Don't escape again if following character is
* already something we escape.
*/
- if (strchr(".~!#&\'`()+@{},;[]%^=_", *(inspec+1))) {
+ if (strchr(".~!#&\'`()+@{},;[]%^=_\\", *(inspec+1))) {
*outspec = *inspec;
*output_cnt = 1;
return 1;
int i;
if (!environ) {
ivenv = 1;
- Perl_warn(aTHX_ "Can't read CRTL environ\n");
+#if defined(PERL_IMPLICIT_CONTEXT)
+ if (aTHX == NULL) {
+ fprintf(stderr,
+ "%%PERL-W-VMS_INIT Can't read CRTL environ\n");
+ } else
+#endif
+ Perl_warn(aTHX_ "Can't read CRTL environ\n");
continue;
}
retsts = SS$_NOLOGNAM;
unsigned short int deflen = LNM$C_NAMLENGTH;
struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
/* dynamic dsc to accomodate possible long value */
- _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
+ _ckvmssts_noperl(lib$sget1_dd(&deflen,&eqvdsc));
retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
if (retsts & 1) {
if (eqvlen > MAX_DCL_SYMBOL) {
}
strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
}
- _ckvmssts(lib$sfree1_dd(&eqvdsc));
+ _ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
if (retsts == LIB$_NOSUCHSYM) continue;
break;
retsts == SS$_NOLOGNAM) {
set_errno(EINVAL); set_vaxc_errno(retsts);
}
- else _ckvmssts(retsts);
+ else _ckvmssts_noperl(retsts);
return 0;
} /* end of vmstrnenv */
/*}}}*/
* for an optional name, and this "error" often shows up as the
* (bogus) exit status for a die() call later on. */
if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
- return success ? eqv : Nullch;
+ return success ? eqv : NULL;
}
} /* end of my_getenv() */
* for an optional name, and this "error" often shows up as the
* (bogus) exit status for a die() call later on. */
if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
- return *len ? buf : Nullch;
+ return *len ? buf : NULL;
}
} /* end of my_getenv_len() */
static int primed = 0;
HV *seenhv = NULL, *envhv;
SV *sv = NULL;
- char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
+ char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
unsigned short int chan;
#ifndef CLI$M_TRUSTED
# define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
if (PL_curinterp) {
aTHX = PERL_GET_INTERP;
} else {
+ /* we never get here because the NULL pointer will cause the */
+ /* several of the routines called by this routine to access violate */
+
+ /* This routine is only called by hv.c/hv_iterinit which has a */
+ /* context, so the real fix may be to pass it through instead of */
+ /* the hoops above */
aTHX = NULL;
}
#endif
* system services won't do this by themselves, so we may miss
* a file "hiding" behind a logical name or search list. */
vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
- if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
+ if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
rslt = do_rmsexpand(name,
vmsname,
* and the insert an ACE at the head of the ACL which allows us
* to delete the file.
*/
- _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
+ _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
fildsc.dsc$w_length = strlen(vmsname);
fildsc.dsc$a_pointer = vmsname;
cxt = 0;
case RMS$_PRV:
set_errno(EACCES); break;
default:
- _ckvmssts(aclsts);
+ _ckvmssts_noperl(aclsts);
}
set_vaxc_errno(aclsts);
PerlMem_free(vmsname);
/* First convert this to a VMS format specification */
vms_src = PerlMem_malloc(VMS_MAXRSS);
if (vms_src == NULL)
- _ckvmssts(SS$_INSFMEM);
+ _ckvmssts_noperl(SS$_INSFMEM);
rslt = do_tovmsspec(file_spec, vms_src, 0, NULL);
if (rslt == NULL) {
/* Now make it a directory spec so chmod is happy */
vms_dir = PerlMem_malloc(VMS_MAXRSS + 1);
if (vms_dir == NULL)
- _ckvmssts(SS$_INSFMEM);
+ _ckvmssts_noperl(SS$_INSFMEM);
rslt = do_fileify_dirspec(vms_src, vms_dir, 0, NULL);
PerlMem_free(vms_src);
case SS$_INSFMEM:
set_errno(ENOMEM); break;
default:
- _ckvmssts(iss);
+ _ckvmssts_noperl(iss);
set_errno(EVMSERR);
}
set_vaxc_errno(iss);
case RMS$_WLK: /* Device write locked */
unix_status = EACCES;
break;
+ case RMS$_MKD: /* Failed to mark for delete */
+ unix_status = EPERM;
+ break;
/* case RMS$_NMF: */ /* No more files */
}
}
* keep the size between 128 and MAXBUF.
*
*/
- _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
+ _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
}
if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
if (mbxbufsiz < 128) mbxbufsiz = 128;
if (mbxbufsiz > syssize) mbxbufsiz = syssize;
- _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
+ _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
- _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
+ sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
+ _ckvmssts_noperl(sts);
namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
} /* end of create_mbx() */
static unsigned long int
-pipe_exit_routine(pTHX)
+pipe_exit_routine()
{
pInfo info;
unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
info = open_pipes;
while (info) {
if (info->fp) {
+#if defined(PERL_IMPLICIT_CONTEXT)
+ /* We need to use the Perl context of the thread that created */
+ /* the pipe. */
+ pTHX;
+ if (info->err)
+ aTHX = info->err->thx;
+ else if (info->out)
+ aTHX = info->out->thx;
+ else if (info->in)
+ aTHX = info->in->thx;
+#endif
if (!info->useFILE
#if defined(USE_ITHREADS)
&& my_perl
_ckvmssts_noperl(sys$setast(0));
if (info->in && !info->in->shut_on_empty) {
_ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
- 0, 0, 0, 0, 0, 0));
+ 0, 0, 0, 0, 0, 0));
info->waiting = 1;
did_stuff = 1;
}
}
while(open_pipes) {
+
+#if defined(PERL_IMPLICIT_CONTEXT)
+ /* We need to use the Perl context of the thread that created */
+ /* the pipe. */
+ pTHX;
+ if (info->err)
+ aTHX = info->err->thx;
+ else if (info->out)
+ aTHX = info->out->thx;
+ else if (info->in)
+ aTHX = info->in->thx;
+#endif
if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
else if (!(sts & 1)) retsts = sts;
}
int j, n;
n = sizeof(Pipe);
- _ckvmssts(lib$get_vm(&n, &p));
+ _ckvmssts_noperl(lib$get_vm(&n, &p));
create_mbx(aTHX_ &p->chan_in , &d_mbx1);
create_mbx(aTHX_ &p->chan_out, &d_mbx2);
- _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
+ _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
p->buf = 0;
p->shut_on_empty = FALSE;
n = sizeof(CBuf) + p->bufsize;
for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
- _ckvmssts(lib$get_vm(&n, &b));
+ _ckvmssts_noperl(lib$get_vm(&n, &b));
b->buf = (char *) b + sizeof(CBuf);
- _ckvmssts(lib$insqhi(b, &p->free));
+ _ckvmssts_noperl(lib$insqhi(b, &p->free));
}
pipe_tochild2_ast(p);
if (eof) {
p->shut_on_empty = TRUE;
b->eof = TRUE;
- _ckvmssts(sys$dassgn(p->chan_in));
+ _ckvmssts_noperl(sys$dassgn(p->chan_in));
} else {
- _ckvmssts(iss);
+ _ckvmssts_noperl(iss);
}
b->eof = eof;
b->size = p->iosb.count;
- _ckvmssts(sts = lib$insqhi(b, &p->wait));
+ _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
if (p->need_wake) {
p->need_wake = FALSE;
- _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
+ _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
}
} else {
p->retry = 1; /* initial call */
while (1) {
iss = lib$remqti(&p->free, &b);
if (iss == LIB$_QUEWASEMP) return;
- _ckvmssts(iss);
- _ckvmssts(lib$free_vm(&n, &b));
+ _ckvmssts_noperl(iss);
+ _ckvmssts_noperl(lib$free_vm(&n, &b));
}
}
iss = lib$remqti(&p->free, &b);
if (iss == LIB$_QUEWASEMP) {
int n = sizeof(CBuf) + p->bufsize;
- _ckvmssts(lib$get_vm(&n, &b));
+ _ckvmssts_noperl(lib$get_vm(&n, &b));
b->buf = (char *) b + sizeof(CBuf);
} else {
- _ckvmssts(iss);
+ _ckvmssts_noperl(iss);
}
p->curr = b;
&p->iosb,
pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
- _ckvmssts(iss);
+ _ckvmssts_noperl(iss);
}
do {
if (p->type) { /* type=1 has old buffer, dispose */
if (p->shut_on_empty) {
- _ckvmssts(lib$free_vm(&n, &b));
+ _ckvmssts_noperl(lib$free_vm(&n, &b));
} else {
- _ckvmssts(lib$insqhi(b, &p->free));
+ _ckvmssts_noperl(lib$insqhi(b, &p->free));
}
p->type = 0;
}
if (iss == LIB$_QUEWASEMP) {
if (p->shut_on_empty) {
if (done) {
- _ckvmssts(sys$dassgn(p->chan_out));
+ _ckvmssts_noperl(sys$dassgn(p->chan_out));
*p->pipe_done = TRUE;
- _ckvmssts(sys$setef(pipe_ef));
+ _ckvmssts_noperl(sys$setef(pipe_ef));
} else {
- _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
+ _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
&p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
}
return;
p->need_wake = TRUE;
return;
}
- _ckvmssts(iss);
+ _ckvmssts_noperl(iss);
p->type = 1;
} while (done);
p->curr2 = b;
if (b->eof) {
- _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
+ _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
&p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
} else {
- _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
+ _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
&p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
}
unsigned int dviitm = DVI$_DEVBUFSIZ;
int n = sizeof(Pipe);
- _ckvmssts(lib$get_vm(&n, &p));
+ _ckvmssts_noperl(lib$get_vm(&n, &p));
create_mbx(aTHX_ &p->chan_in , &d_mbx1);
create_mbx(aTHX_ &p->chan_out, &d_mbx2);
- _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
+ _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
n = p->bufsize * sizeof(char);
- _ckvmssts(lib$get_vm(&n, &p->buf));
+ _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
p->shut_on_empty = FALSE;
p->info = 0;
p->type = 0;
#endif
if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
- _ckvmssts(sys$dassgn(p->chan_out));
+ _ckvmssts_noperl(sys$dassgn(p->chan_out));
p->chan_out = 0;
}
if (p->type == 1) {
p->type = 0;
if (myeof && p->chan_in) { /* input shutdown */
- _ckvmssts(sys$dassgn(p->chan_in));
+ _ckvmssts_noperl(sys$dassgn(p->chan_in));
p->chan_in = 0;
}
if (p->chan_out) {
if (myeof || kideof) { /* pass EOF to parent */
- _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
- pipe_infromchild_ast, p,
- 0, 0, 0, 0, 0, 0));
+ _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
+ pipe_infromchild_ast, p,
+ 0, 0, 0, 0, 0, 0));
return;
} else if (eof) { /* eat EOF --- fall through to read*/
} else { /* transmit data */
- _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
- pipe_infromchild_ast,p,
- p->buf, p->iosb.count, 0, 0, 0, 0));
+ _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
+ pipe_infromchild_ast,p,
+ p->buf, p->iosb.count, 0, 0, 0, 0));
return;
}
}
if (!p->chan_in && !p->chan_out) {
*p->pipe_done = TRUE;
- _ckvmssts(sys$setef(pipe_ef));
+ _ckvmssts_noperl(sys$setef(pipe_ef));
return;
}
pipe_infromchild_ast,p,
p->buf, p->bufsize, 0, 0, 0, 0);
if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
- _ckvmssts(iss);
+ _ckvmssts_noperl(iss);
} else { /* send EOFs for extra reads */
p->iosb.status = SS$_ENDOFFILE;
p->iosb.dvispec = 0;
- _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
- 0, 0, 0,
- pipe_infromchild_ast, p, 0, 0, 0, 0));
+ _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
+ 0, 0, 0,
+ pipe_infromchild_ast, p, 0, 0, 0, 0));
}
}
}
unsigned short dvi_iosb[4];
cptr = getname(fd, out, 1);
- if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
+ if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
d_dev.dsc$a_pointer = out;
d_dev.dsc$w_length = strlen(out);
d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
status = sys$getdviw
(NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
- _ckvmssts(status);
+ _ckvmssts_noperl(status);
if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
device[dev_len] = 0;
}
}
- _ckvmssts(lib$get_vm(&n, &p));
+ _ckvmssts_noperl(lib$get_vm(&n, &p));
p->fd_out = dup(fd);
create_mbx(aTHX_ &p->chan_in, &d_mbx);
- _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
+ _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
n = (p->bufsize+1) * sizeof(char);
- _ckvmssts(lib$get_vm(&n, &p->buf));
+ _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
p->shut_on_empty = FALSE;
p->retry = 0;
p->info = 0;
strcpy(out, mbx);
- _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
- pipe_mbxtofd_ast, p,
- p->buf, p->bufsize, 0, 0, 0, 0));
+ _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
+ pipe_mbxtofd_ast, p,
+ p->buf, p->bufsize, 0, 0, 0, 0));
return p;
}
close(p->fd_out);
sys$dassgn(p->chan_in);
*p->pipe_done = TRUE;
- _ckvmssts(sys$setef(pipe_ef));
+ _ckvmssts_noperl(sys$setef(pipe_ef));
return;
}
if (iss2 < 0) {
p->retry++;
if (p->retry < MAX_RETRY) {
- _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
+ _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
return;
}
}
p->retry = 0;
} else if (err) {
- _ckvmssts(iss);
+ _ckvmssts_noperl(iss);
}
pipe_mbxtofd_ast, p,
p->buf, p->bufsize, 0, 0, 0, 0);
if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
- _ckvmssts(iss);
+ _ckvmssts_noperl(iss);
}
/* the . directory from @INC comes last */
p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
- if (p == NULL) _ckvmssts(SS$_INSFMEM);
+ if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
p->next = head_PLOC;
head_PLOC = p;
strcpy(p->dir,"./");
/* get the directory from $^X */
unixdir = PerlMem_malloc(VMS_MAXRSS);
- if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
+ if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
#ifdef PERL_IMPLICIT_CONTEXT
if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
temp[1] = '\0';
}
- if ((tounixpath_utf8(temp, unixdir, NULL)) != Nullch) {
+ if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
- if (p == NULL) _ckvmssts(SS$_INSFMEM);
+ if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
p->next = head_PLOC;
head_PLOC = p;
strncpy(p->dir,unixdir,sizeof(p->dir)-1);
if (SvROK(dirsv)) continue;
dir = SvPVx(dirsv,n_a);
if (strcmp(dir,".") == 0) continue;
- if ((tounixpath_utf8(dir, unixdir, NULL)) == Nullch)
+ if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
continue;
p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
/* most likely spot (ARCHLIB) put first in the list */
#ifdef ARCHLIB_EXP
- if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != Nullch) {
+ if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
- if (p == NULL) _ckvmssts(SS$_INSFMEM);
+ if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
p->next = head_PLOC;
head_PLOC = p;
strncpy(p->dir,unixdir,sizeof(p->dir)-1);
info->in = 0;
info->out = 0;
info->err = 0;
- info->fp = Nullfp;
+ info->fp = NULL;
info->useFILE = 0;
info->waiting = 0;
info->in_done = TRUE;
/* If any errors, then clean up */
if (!info->fp) {
n = sizeof(Info);
- _ckvmssts(lib$free_vm(&n, &info));
+ _ckvmssts_noperl(lib$free_vm(&n, &info));
return NULL;
}
return info->fp;
}
+static I32 my_pclose_pinfo(pTHX_ pInfo info);
+
static PerlIO *
safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
{
static int handler_set_up = FALSE;
+ PerlIO * ret_fp;
unsigned long int sts, flags = CLI$M_NOWAIT;
/* The use of a GLOBAL table (as was done previously) rendered
* Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
PerlIO * xterm_fd;
xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
- if (xterm_fd != Nullfp)
+ if (xterm_fd != NULL)
return xterm_fd;
}
*/
if (!pipe_ef) {
- _ckvmssts(sys$setast(0));
+ _ckvmssts_noperl(sys$setast(0));
if (!pipe_ef) {
unsigned long int pidcode = JPI$_PID;
$DESCRIPTOR(d_delay, RETRY_DELAY);
- _ckvmssts(lib$get_ef(&pipe_ef));
- _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
- _ckvmssts(sys$bintim(&d_delay, delaytime));
+ _ckvmssts_noperl(lib$get_ef(&pipe_ef));
+ _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
+ _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
}
if (!handler_set_up) {
- _ckvmssts(sys$dclexh(&pipe_exitblock));
+ _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
handler_set_up = TRUE;
}
- _ckvmssts(sys$setast(1));
+ _ckvmssts_noperl(sys$setast(1));
}
/* see if we can find a VMSPIPE.COM */
if (ckWARN(WARN_PIPE)) {
Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
}
- return Nullfp;
+ return NULL;
}
fgetname(tpipe,tfilebuf+1,1);
}
case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
set_errno(E2BIG); break;
case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
- _ckvmssts(sts); /* fall through */
+ _ckvmssts_noperl(sts); /* fall through */
default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
set_errno(EVMSERR);
}
Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
}
*psts = sts;
- return Nullfp;
+ return NULL;
}
n = sizeof(Info);
- _ckvmssts(lib$get_vm(&n, &info));
+ _ckvmssts_noperl(lib$get_vm(&n, &info));
strcpy(mode,in_mode);
info->mode = *mode;
info->in = 0;
info->out = 0;
info->err = 0;
- info->fp = Nullfp;
+ info->fp = NULL;
info->useFILE = 0;
info->waiting = 0;
info->in_done = TRUE;
info->xchan_valid = 0;
in = PerlMem_malloc(VMS_MAXRSS);
- if (in == NULL) _ckvmssts(SS$_INSFMEM);
+ if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
out = PerlMem_malloc(VMS_MAXRSS);
- if (out == NULL) _ckvmssts(SS$_INSFMEM);
+ if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
err = PerlMem_malloc(VMS_MAXRSS);
- if (err == NULL) _ckvmssts(SS$_INSFMEM);
+ if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
in[0] = out[0] = err[0] = '\0';
while (!info->out_done) {
int done;
- _ckvmssts(sys$setast(0));
+ _ckvmssts_noperl(sys$setast(0));
done = info->out_done;
- if (!done) _ckvmssts(sys$clref(pipe_ef));
- _ckvmssts(sys$setast(1));
- if (!done) _ckvmssts(sys$waitfr(pipe_ef));
+ if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
+ _ckvmssts_noperl(sys$setast(1));
+ if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
}
if (info->out->buf) {
n = info->out->bufsize * sizeof(char);
- _ckvmssts(lib$free_vm(&n, &info->out->buf));
+ _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
}
n = sizeof(Pipe);
- _ckvmssts(lib$free_vm(&n, &info->out));
+ _ckvmssts_noperl(lib$free_vm(&n, &info->out));
n = sizeof(Info);
- _ckvmssts(lib$free_vm(&n, &info));
+ _ckvmssts_noperl(lib$free_vm(&n, &info));
*psts = RMS$_FNF;
- return Nullfp;
+ return NULL;
}
info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
/* error cleanup */
if (!info->fp && info->in) {
info->done = TRUE;
- _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
- 0, 0, 0, 0, 0, 0, 0, 0));
+ _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0));
while (!info->in_done) {
int done;
- _ckvmssts(sys$setast(0));
+ _ckvmssts_noperl(sys$setast(0));
done = info->in_done;
- if (!done) _ckvmssts(sys$clref(pipe_ef));
- _ckvmssts(sys$setast(1));
- if (!done) _ckvmssts(sys$waitfr(pipe_ef));
+ if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
+ _ckvmssts_noperl(sys$setast(1));
+ if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
}
if (info->in->buf) {
n = info->in->bufsize * sizeof(char);
- _ckvmssts(lib$free_vm(&n, &info->in->buf));
+ _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
}
n = sizeof(Pipe);
- _ckvmssts(lib$free_vm(&n, &info->in));
+ _ckvmssts_noperl(lib$free_vm(&n, &info->in));
n = sizeof(Info);
- _ckvmssts(lib$free_vm(&n, &info));
+ _ckvmssts_noperl(lib$free_vm(&n, &info));
*psts = RMS$_FNF;
- return Nullfp;
+ return NULL;
}
strncpy(symbol, in, MAX_DCL_SYMBOL);
d_symbol.dsc$w_length = strlen(symbol);
- _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
+ _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
strncpy(symbol, err, MAX_DCL_SYMBOL);
d_symbol.dsc$w_length = strlen(symbol);
- _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
+ _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
strncpy(symbol, out, MAX_DCL_SYMBOL);
d_symbol.dsc$w_length = strlen(symbol);
- _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
+ _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
/* Done with the names for the pipes */
PerlMem_free(err);
strncpy(symbol, p, MAX_DCL_SYMBOL);
d_symbol.dsc$w_length = strlen(symbol);
- _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
+ _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
if (strlen(p) > MAX_DCL_SYMBOL) {
p += MAX_DCL_SYMBOL;
p += strlen(p);
}
}
- _ckvmssts(sys$setast(0));
+ _ckvmssts_noperl(sys$setast(0));
info->next=open_pipes; /* prepend to list */
open_pipes=info;
- _ckvmssts(sys$setast(1));
+ _ckvmssts_noperl(sys$setast(1));
/* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
* and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
* have SYS$COMMAND if we need it.
*/
- _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
+ _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
0, &info->pid, &info->completion,
0, popen_completion_ast,info,0,0,0));
for (j = 0; j < 4; j++) {
sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
- _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
+ _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
}
- _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
- _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
- _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
+ _ckvmssts_noperl(lib$delete_symbol(&d_sym_in, &table));
+ _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
+ _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
vms_execfree(vmscmd);
#ifdef PERL_IMPLICIT_CONTEXT
#endif
PL_forkprocess = info->pid;
+ ret_fp = info->fp;
if (wait) {
+ dSAVEDERRNO;
int done = 0;
while (!done) {
- _ckvmssts(sys$setast(0));
+ _ckvmssts_noperl(sys$setast(0));
done = info->done;
- if (!done) _ckvmssts(sys$clref(pipe_ef));
- _ckvmssts(sys$setast(1));
- if (!done) _ckvmssts(sys$waitfr(pipe_ef));
+ if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
+ _ckvmssts_noperl(sys$setast(1));
+ if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
}
*psts = info->completion;
/* Caller thinks it is open and tries to close it. */
/* This causes some problems, as it changes the error status */
/* my_pclose(info->fp); */
+
+ /* If we did not have a file pointer open, then we have to */
+ /* clean up here or eventually we will run out of something */
+ SAVE_ERRNO;
+ if (info->fp == NULL) {
+ my_pclose_pinfo(aTHX_ info);
+ }
+ RESTORE_ERRNO;
+
} else {
*psts = info->pid;
}
- return info->fp;
+ return ret_fp;
} /* end of safe_popen */
/*}}}*/
-/*{{{ I32 my_pclose(PerlIO *fp)*/
-I32 Perl_my_pclose(pTHX_ PerlIO *fp)
-{
- pInfo info, last = NULL;
+
+/* Routine to close and cleanup a pipe info structure */
+
+static I32 my_pclose_pinfo(pTHX_ pInfo info) {
+
unsigned long int retsts;
int done, iss, n;
int status;
-
- for (info = open_pipes; info != NULL; last = info, info = info->next)
- if (info->fp == fp) break;
-
- if (info == NULL) { /* no such pipe open */
- set_errno(ECHILD); /* quoth POSIX */
- set_vaxc_errno(SS$_NONEXPR);
- return -1;
- }
+ pInfo next, last;
/* 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
/* remove from list of open pipes */
_ckvmssts(sys$setast(0));
- if (last) last->next = info->next;
- else open_pipes = info->next;
+ last = NULL;
+ for (next = open_pipes; next != NULL; last = next, next = next->next) {
+ if (next == info)
+ break;
+ }
+
+ if (last)
+ last->next = info->next;
+ else
+ open_pipes = info->next;
_ckvmssts(sys$setast(1));
/* free buffers and structures */
_ckvmssts(lib$free_vm(&n, &info));
return retsts;
+}
+
+
+/*{{{ I32 my_pclose(PerlIO *fp)*/
+I32 Perl_my_pclose(pTHX_ PerlIO *fp)
+{
+ pInfo info, last = NULL;
+ I32 ret_status;
+
+ /* Fixme - need ast and mutex protection here */
+ for (info = open_pipes; info != NULL; last = info, info = info->next)
+ if (info->fp == fp) break;
+
+ if (info == NULL) { /* no such pipe open */
+ set_errno(ECHILD); /* quoth POSIX */
+ set_vaxc_errno(SS$_NONEXPR);
+ return -1;
+ }
+
+ ret_status = my_pclose_pinfo(aTHX_ info);
+
+ return ret_status;
} /* end of my_pclose() */
#define rms_set_dna(fab, nam, name, size) \
{ fab.fab$b_dns = size; fab.fab$l_dna = name; }
#define rms_nam_dns(fab, nam) fab.fab$b_dns
-#define rms_set_esa(fab, nam, name, size) \
+#define rms_set_esa(nam, name, size) \
{ nam.nam$b_ess = size; nam.nam$l_esa = name; }
#define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
{ nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
nam.naml$l_long_defname_size = size; \
nam.naml$l_long_defname = name; }
#define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
-#define rms_set_esa(fab, nam, name, size) \
+#define rms_set_esa(nam, name, size) \
{ nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
nam.naml$l_long_expand_alloc = size; \
nam.naml$l_long_expand = name; }
* and the insert an ACE at the head of the ACL which allows us
* to delete the file.
*/
- _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
+ _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
fildsc.dsc$w_length = strlen(vmsname);
fildsc.dsc$a_pointer = vmsname;
vms_src = PerlMem_malloc(VMS_MAXRSS);
if (vms_src == NULL)
- _ckvmssts(SS$_INSFMEM);
+ _ckvmssts_noperl(SS$_INSFMEM);
/* Source is always a VMS format file */
ret_str = do_tovmsspec(src, vms_src, 0, NULL);
vms_dst = PerlMem_malloc(VMS_MAXRSS);
if (vms_dst == NULL)
- _ckvmssts(SS$_INSFMEM);
+ _ckvmssts_noperl(SS$_INSFMEM);
if (S_ISDIR(src_st.st_mode)) {
char * ret_str;
vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
if (vms_dir_file == NULL)
- _ckvmssts(SS$_INSFMEM);
+ _ckvmssts_noperl(SS$_INSFMEM);
/* The source must be a file specification */
ret_str = do_fileify_dirspec(vms_src, vms_dir_file, 0, NULL);
/* The source must be a file specification */
vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
if (vms_dir_file == NULL)
- _ckvmssts(SS$_INSFMEM);
+ _ckvmssts_noperl(SS$_INSFMEM);
ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
if (ret_str == NULL) {
flags = 0;
#if !defined(__VAX) && defined(NAML$C_MAXRSS)
- flags |= 2; /* LIB$M_FIL_LONG_NAMES */
+ flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
#endif
sts = lib$rename_file(&old_file_dsc,
isunix = is_unix_filespec(filespec);
if (isunix) {
vmsfspec = PerlMem_malloc(VMS_MAXRSS);
- if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
+ if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
PerlMem_free(vmsfspec);
if (out)
/* Unless we are forcing to VMS format, a UNIX input means
* UNIX output, and that requires long names to be used
*/
+#if !defined(__VAX) && defined(NAML$C_MAXRSS)
if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
opts |= PERL_RMSEXPAND_M_LONG;
- else {
+ else
+#endif
isunix = 0;
}
}
- }
rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
rms_bind_fab_nam(myfab, mynam);
t_isunix = is_unix_filespec(defspec);
if (t_isunix) {
tmpfspec = PerlMem_malloc(VMS_MAXRSS);
- if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
+ if (tmpfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
PerlMem_free(tmpfspec);
if (vmsfspec != NULL)
}
esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
- if (esa == NULL) _ckvmssts(SS$_INSFMEM);
+ if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
#if !defined(__VAX) && defined(NAML$C_MAXRSS)
esal = PerlMem_malloc(VMS_MAXRSS);
- if (esal == NULL) _ckvmssts(SS$_INSFMEM);
+ if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
#endif
rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
- if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
- rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
- }
- else {
+ /* If a NAML block is used RMS always writes to the long and short
+ * addresses unless you suppress the short name.
+ */
#if !defined(__VAX) && defined(NAML$C_MAXRSS)
- outbufl = PerlMem_malloc(VMS_MAXRSS);
- if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
- rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
-#else
- rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
+ outbufl = PerlMem_malloc(VMS_MAXRSS);
+ if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
#endif
- }
+ rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
#ifdef NAM$M_NO_SHORT_UPCASE
if (decc_efs_case_preserve)
/*------------------------------------*/
if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
if (rms_nam_rsll(mynam)) {
- tbuf = outbuf;
+ tbuf = outbufl;
speclen = rms_nam_rsll(mynam);
}
else {
if (trimver || trimtype) {
if (defspec && *defspec) {
char *defesal = NULL;
- defesal = PerlMem_malloc(VMS_MAXRSS + 1);
- if (defesal != NULL) {
+ char *defesa = NULL;
+ defesa = PerlMem_malloc(VMS_MAXRSS + 1);
+ if (defesa != NULL) {
+#if !defined(__VAX) && defined(NAML$C_MAXRSS)
+ defesal = PerlMem_malloc(VMS_MAXRSS + 1);
+ if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
+#endif
struct FAB deffab = cc$rms_fab;
rms_setup_nam(defnam);
rms_set_fna
(deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
- rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
+ /* RMS needs the esa/esal as a work area if wildcards are involved */
+ rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
rms_clear_nam_nop(defnam);
rms_set_nam_nop(defnam, NAM$M_SYNCHK);
trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
}
}
- PerlMem_free(defesal);
+ if (defesal != NULL)
+ PerlMem_free(defesal);
+ PerlMem_free(defesa);
}
}
if (trimver) {
/* If we just had a directory spec on input, $PARSE "helpfully"
* adds an empty name and type for us */
+#if !defined(__VAX) && defined(NAML$C_MAXRSS)
if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
!(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
speclen = rms_nam_namel(mynam) - tbuf;
}
- else {
+ else
+#endif
+ {
if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
!(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
/* Have we been working with an expanded, but not resultant, spec? */
/* Also, convert back to Unix syntax if necessary. */
+ {
+ int rsl;
- if (!rms_nam_rsll(mynam)) {
- if (isunix) {
- if (do_tounixspec(tbuf, outbuf ,0 , fs_utf8) == NULL) {
- if (out) Safefree(out);
- if (esal != NULL)
+#if !defined(__VAX) && defined(NAML$C_MAXRSS)
+ if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
+ rsl = rms_nam_rsll(mynam);
+ } else
+#endif
+ {
+ rsl = rms_nam_rsl(mynam);
+ }
+ if (!rsl) {
+ if (isunix) {
+ if (do_tounixspec(tbuf, outbuf ,0 , fs_utf8) == NULL) {
+ if (out) Safefree(out);
+ if (esal != NULL)
PerlMem_free(esal);
- PerlMem_free(esa);
- if (outbufl != NULL)
+ PerlMem_free(esa);
+ if (outbufl != NULL)
PerlMem_free(outbufl);
- return NULL;
+ return NULL;
+ }
}
+ else strcpy(outbuf, tbuf);
}
- else strcpy(outbuf, tbuf);
- }
- else if (isunix) {
- tmpfspec = PerlMem_malloc(VMS_MAXRSS);
- if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
- if (do_tounixspec(outbuf,tmpfspec,0,fs_utf8) == NULL) {
+ else if (isunix) {
+ tmpfspec = PerlMem_malloc(VMS_MAXRSS);
+ if (tmpfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
+ if (do_tounixspec(tbuf,tmpfspec,0,fs_utf8) == NULL) {
if (out) Safefree(out);
PerlMem_free(esa);
if (esal != NULL)
if (outbufl != NULL)
PerlMem_free(outbufl);
return NULL;
+ }
+ strcpy(outbuf,tmpfspec);
+ PerlMem_free(tmpfspec);
}
- strcpy(outbuf,tmpfspec);
- PerlMem_free(tmpfspec);
}
-
rms_set_rsal(mynam, NULL, 0, NULL, 0);
sts = rms_free_search_context(&myfab); /* Free search context */
PerlMem_free(esa);
return NULL;
}
trndir = PerlMem_malloc(VMS_MAXRSS + 1);
- if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
+ if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
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)) {
+ while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,0)) {
trnlnm_iter_count++;
if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
}
}
vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
- if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
+ if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
cp1 = strpbrk(trndir,"]:>");
if (hasfilename || !cp1) { /* Unix-style path or filename */
if (trndir[0] == '.') {
}
else { /* VMS-style directory spec */
- char *esa, term, *cp;
+ char *esa, *esal, term, *cp;
+ char *my_esa;
+ int my_esa_len;
unsigned long int sts, cmplen, haslower = 0;
unsigned int nam_fnb;
char * nam_type;
rms_setup_nam(savnam);
rms_setup_nam(dirnam);
- esa = PerlMem_malloc(VMS_MAXRSS + 1);
- if (esa == NULL) _ckvmssts(SS$_INSFMEM);
+ esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
+ if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
+ esal = NULL;
+#if !defined(__VAX) && defined(NAML$C_MAXRSS)
+ esal = PerlMem_malloc(VMS_MAXRSS);
+ if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
+#endif
rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
rms_bind_fab_nam(dirfab, dirnam);
rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
- rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
+ rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
#ifdef NAM$M_NO_SHORT_UPCASE
if (decc_efs_case_preserve)
rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
}
if (!sts) {
PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
PerlMem_free(trndir);
PerlMem_free(vmsdir);
set_errno(EVMSERR);
fab_sts = dirfab.fab$l_sts;
sts = rms_free_search_context(&dirfab);
PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
PerlMem_free(trndir);
PerlMem_free(vmsdir);
set_errno(EVMSERR); set_vaxc_errno(fab_sts);
}
}
}
- esa[rms_nam_esll(dirnam)] = '\0';
+
+ /* Make sure we are using the right buffer */
+ if (esal != NULL) {
+ my_esa = esal;
+ my_esa_len = rms_nam_esll(dirnam);
+ } else {
+ my_esa = esa;
+ my_esa_len = rms_nam_esl(dirnam);
+ }
+ my_esa[my_esa_len] = '\0';
if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
- cp1 = strchr(esa,']');
- if (!cp1) cp1 = strchr(esa,'>');
+ cp1 = strchr(my_esa,']');
+ if (!cp1) cp1 = strchr(my_esa,'>');
if (cp1) { /* Should always be true */
- rms_nam_esll(dirnam) -= cp1 - esa - 1;
- memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
+ my_esa_len -= cp1 - my_esa - 1;
+ memmove(my_esa, cp1 + 1, my_esa_len);
}
}
if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
/* Something other than .DIR[;1]. Bzzt. */
sts = rms_free_search_context(&dirfab);
PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
PerlMem_free(trndir);
PerlMem_free(vmsdir);
set_errno(ENOTDIR);
if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
/* They provided at least the name; we added the type, if necessary, */
if (buf) retspec = buf; /* in sys$parse() */
- else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
+ else if (ts) Newx(retspec, my_esa_len + 1, char);
else retspec = __fileify_retbuf;
- strcpy(retspec,esa);
+ strcpy(retspec,my_esa);
sts = rms_free_search_context(&dirfab);
PerlMem_free(trndir);
PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
PerlMem_free(vmsdir);
return retspec;
}
if ((cp1 = strstr(esa,".][000000]")) != NULL) {
for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
*cp1 = '\0';
- rms_nam_esll(dirnam) -= 9;
+ my_esa_len -= 9;
}
- if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
+ if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
if (cp1 == NULL) { /* should never happen */
sts = rms_free_search_context(&dirfab);
PerlMem_free(trndir);
PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
PerlMem_free(vmsdir);
return NULL;
}
term = *cp1;
*cp1 = '\0';
- retlen = strlen(esa);
- cp1 = strrchr(esa,'.');
+ retlen = strlen(my_esa);
+ cp1 = strrchr(my_esa,'.');
/* ODS-5 directory specifications can have extra "." in them. */
/* Fix-me, can not scan EFS file specifications backwards */
while (cp1 != NULL) {
- if ((cp1-1 == esa) || (*(cp1-1) != '^'))
+ if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
break;
else {
cp1--;
- while ((cp1 > esa) && (*cp1 != '.'))
+ while ((cp1 > my_esa) && (*cp1 != '.'))
cp1--;
}
- if (cp1 == esa)
+ if (cp1 == my_esa)
cp1 = NULL;
}
if (buf) retspec = buf;
else if (ts) Newx(retspec,retlen+7,char);
else retspec = __fileify_retbuf;
- strcpy(retspec,esa);
+ strcpy(retspec,my_esa);
}
else {
if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
sts = rms_free_search_context(&dirfab);
PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
PerlMem_free(trndir);
PerlMem_free(vmsdir);
set_errno(EVMSERR);
set_vaxc_errno(dirfab.fab$l_sts);
return NULL;
}
- retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
+
+ /* This changes the length of the string of course */
+ if (esal != NULL) {
+ my_esa_len = rms_nam_esll(dirnam);
+ } else {
+ my_esa_len = rms_nam_esl(dirnam);
+ }
+
+ retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
if (buf) retspec = buf;
else if (ts) Newx(retspec,retlen+16,char);
else retspec = __fileify_retbuf;
- cp1 = strstr(esa,"][");
- if (!cp1) cp1 = strstr(esa,"]<");
- dirlen = cp1 - esa;
- memcpy(retspec,esa,dirlen);
+ cp1 = strstr(my_esa,"][");
+ if (!cp1) cp1 = strstr(my_esa,"]<");
+ dirlen = cp1 - my_esa;
+ memcpy(retspec,my_esa,dirlen);
if (!strncmp(cp1+2,"000000]",7)) {
retspec[dirlen-1] = '\0';
/* fix-me Not full ODS-5, just extra dots in directories for now */
if (buf) retspec = buf;
else if (ts) Newx(retspec,retlen+16,char);
else retspec = __fileify_retbuf;
- cp1 = esa;
+ cp1 = my_esa;
cp2 = retspec;
while ((*cp1 != ':') && (*cp1 != '\0')) *(cp2++) = *(cp1++);
strcpy(cp2,":[000000]");
if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
PerlMem_free(trndir);
PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
PerlMem_free(vmsdir);
return retspec;
}
}
trndir = PerlMem_malloc(VMS_MAXRSS);
- if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
+ if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
if (*dir) strcpy(trndir,dir);
else getcwd(trndir,VMS_MAXRSS - 1);
trnlnm_iter_count = 0;
while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
- && my_trnlnm(trndir,trndir,0)) {
+ && simple_trnlnm(trndir,trndir,0)) {
trnlnm_iter_count++;
if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
trnlen = strlen(trndir);
else retpath[retlen-1] = '\0';
}
else { /* VMS-style directory spec */
- char *esa, *cp;
+ char *esa, *esal, *cp;
+ char *my_esa;
+ int my_esa_len;
unsigned long int sts, cmplen, haslower;
struct FAB dirfab = cc$rms_fab;
int dirlen;
}
rms_set_fna(dirfab, dirnam, trndir, dirlen);
esa = PerlMem_malloc(VMS_MAXRSS);
- if (esa == NULL) _ckvmssts(SS$_INSFMEM);
+ if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
+ esal = NULL;
+#if !defined(__VAX) && defined(NAML$C_MAXRSS)
+ esal = PerlMem_malloc(VMS_MAXRSS);
+ if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
+#endif
rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
rms_bind_fab_nam(dirfab, dirnam);
- rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
+ rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
#ifdef NAM$M_NO_SHORT_UPCASE
if (decc_efs_case_preserve)
rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
if (!sts) {
PerlMem_free(trndir);
PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
set_errno(EVMSERR);
set_vaxc_errno(dirfab.fab$l_sts);
return NULL;
sts1 = rms_free_search_context(&dirfab);
PerlMem_free(trndir);
PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
set_errno(EVMSERR);
set_vaxc_errno(dirfab.fab$l_sts);
return NULL;
sts2 = rms_free_search_context(&dirfab);
PerlMem_free(trndir);
PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
set_errno(ENOTDIR);
set_vaxc_errno(RMS$_DIR);
return NULL;
}
}
+ /* Make sure we are using the right buffer */
+ if (esal != NULL) {
+ /* We only need one, clean up the other */
+ my_esa = esal;
+ my_esa_len = rms_nam_esll(dirnam);
+ } else {
+ my_esa = esa;
+ my_esa_len = rms_nam_esl(dirnam);
+ }
+
+ /* Null terminate the buffer */
+ my_esa[my_esa_len] = '\0';
+
/* OK, the type was fine. Now pull any file name into the
directory path. */
- if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
+ if ((cp1 = strrchr(my_esa,']'))) *(rms_nam_typel(dirnam)) = ']';
else {
- cp1 = strrchr(esa,'>');
+ cp1 = strrchr(my_esa,'>');
*(rms_nam_typel(dirnam)) = '>';
}
*cp1 = '.';
*(rms_nam_typel(dirnam) + 1) = '\0';
- retlen = (rms_nam_typel(dirnam)) - esa + 2;
+ retlen = (rms_nam_typel(dirnam)) - my_esa + 2;
if (buf) retpath = buf;
else if (ts) Newx(retpath,retlen,char);
else retpath = __pathify_retbuf;
- strcpy(retpath,esa);
+ strcpy(retpath,my_esa);
PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
sts = rms_free_search_context(&dirfab);
/* $PARSE may have upcased filespec, so convert output to lower
* case if input contained any lowercase characters. */
int nl_flag;
tunix = PerlMem_malloc(VMS_MAXRSS);
- if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
+ if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
strcpy(tunix, spec);
tunix_len = strlen(tunix);
nl_flag = 0;
cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
#endif
tmp = PerlMem_malloc(VMS_MAXRSS);
- if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
+ if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
if (cmp_rslt == 0) {
int islnm;
- islnm = my_trnlnm(tmp, "TMP", 0);
+ islnm = simple_trnlnm(tmp, "TMP", 0);
if (!islnm) {
strcpy(rslt, "/tmp");
cp1 = cp1 + 4;
static int posix_root_to_vms
(char *vmspath, int vmspath_len,
const char *unixpath,
- const int * utf8_fl) {
+ const int * utf8_fl)
+{
int sts;
struct FAB myfab = cc$rms_fab;
-struct NAML mynam = cc$rms_naml;
+rms_setup_nam(mynam);
struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
- struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
-char *esa;
+struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
+char * esa, * esal, * rsa, * rsal;
char *vms_delim;
int dir_flag;
int unixlen;
dir_flag = 0;
+ vmspath[0] = '\0';
unixlen = strlen(unixpath);
if (unixlen == 0) {
- vmspath[0] = '\0';
return RMS$_FNF;
}
vmspath[vmspath_len] = 0;
if (unixpath[unixlen - 1] == '/')
dir_flag = 1;
- esa = PerlMem_malloc(VMS_MAXRSS);
+ esal = PerlMem_malloc(VMS_MAXRSS);
+ if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
+ esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
- myfab.fab$l_fna = vmspath;
- myfab.fab$b_fns = strlen(vmspath);
- myfab.fab$l_naml = &mynam;
- mynam.naml$l_esa = NULL;
- mynam.naml$b_ess = 0;
- mynam.naml$l_long_expand = esa;
- mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
- mynam.naml$l_rsa = NULL;
- mynam.naml$b_rss = 0;
+ rsal = PerlMem_malloc(VMS_MAXRSS);
+ if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
+ rsa = PerlMem_malloc(NAM$C_MAXRSS + 1);
+ if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
+ rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
+ rms_bind_fab_nam(myfab, mynam);
+ rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
+ rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
if (decc_efs_case_preserve)
mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
#ifdef NAML$M_OPEN_SPECIAL
/* It failed! Try again as a UNIX filespec */
if (!(sts & 1)) {
+ PerlMem_free(esal);
PerlMem_free(esa);
+ PerlMem_free(rsal);
+ PerlMem_free(rsa);
return sts;
}
/* get the Device ID and the FID */
sts = sys$search(&myfab);
+
+ /* These are no longer needed */
+ PerlMem_free(esa);
+ PerlMem_free(rsal);
+ PerlMem_free(rsa);
+
/* on any failure, returned the POSIX ^UP^ filespec */
if (!(sts & 1)) {
- PerlMem_free(esa);
+ PerlMem_free(esal);
return sts;
}
specdsc.dsc$a_pointer = vmspath;
}
}
}
- PerlMem_free(esa);
+ PerlMem_free(esal);
return sts;
}
while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
*cp1 = '\0';
trndev = PerlMem_malloc(VMS_MAXRSS);
- if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
- islnm = my_trnlnm(rslt,trndev,0);
+ if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
+ islnm = simple_trnlnm(rslt,trndev,0);
/* DECC special handling */
if (!islnm) {
strcpy(rslt,"sys$system");
cp1 = rslt + 10;
*cp1 = 0;
- islnm = my_trnlnm(rslt,trndev,0);
+ islnm = simple_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);
+ islnm = simple_trnlnm(rslt,trndev,0);
}
else if (!decc_disable_posix_root) {
strcpy(rslt, "sys$posix_root");
*cp1 = 0;
cp2 = path;
while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
- islnm = my_trnlnm(rslt,trndev,0);
+ islnm = simple_trnlnm(rslt,trndev,0);
}
else if (strcmp(rslt,"dev") == 0) {
if (strncmp(cp2,"/null", 5) == 0) {
cp1 = rslt + 4;
*cp1 = 0;
cp2 = cp2 + 5;
- islnm = my_trnlnm(rslt,trndev,0);
+ islnm = simple_trnlnm(rslt,trndev,0);
}
}
}
*p = '\0';
fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
- if (fp == Nullfp) {
+ if (fp == NULL) {
PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
}
}
void
vms_image_init(int *argcp, char ***argvp)
{
+ int status;
+ char val_str[10];
char eqv[LNM$C_NAMLENGTH+1] = "";
unsigned int len, tabct = 8, tabidx = 0;
unsigned long int *mask, iosb[2], i, rlst[128], rsz;
Perl_csighandler_init();
#endif
+ /* This was moved from the pre-image init handler because on threaded */
+ /* Perl it was always returning 0 for the default value. */
+ status = simple_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
+ if (status > 0) {
+ int s;
+ s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
+ if (s > 0) {
+ int initial;
+ initial = decc$feature_get_value(s, 4);
+ if (initial >= 0) {
+ /* initial is -1 if nothing has set the feature */
+ /* initial is 1 if the logical name is present */
+ decc_disable_posix_root = decc$feature_get_value(s, 1);
+
+ /* If the value is not valid, force the feature off */
+ 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);
+ }
+ }
+ }
+
+
_ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
_ckvmssts_noperl(iosb[0]);
for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
*template, *base, *end, *cp1, *cp2;
register int tmplen, reslen = 0, dirs = 0;
- unixwild = PerlMem_malloc(VMS_MAXRSS);
- if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
if (!wildspec || !fspec) return 0;
+
+ unixwild = PerlMem_malloc(VMS_MAXRSS);
+ if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
template = unixwild;
if (strpbrk(wildspec,"]>:") != NULL) {
if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
unixwild[VMS_MAXRSS-1] = 0;
}
unixified = PerlMem_malloc(VMS_MAXRSS);
- if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
+ if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
if (strpbrk(fspec,"]>:") != NULL) {
if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
PerlMem_free(unixwild);
totells = ells;
for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
tpl = PerlMem_malloc(VMS_MAXRSS);
- if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
+ if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
if (ellipsis == template && opts & 1) {
/* Template begins with an ellipsis. Since we can't tell how many
* directory names at the front of the resultant to keep for an
if (*front == '/' && !dirs--) { front++; break; }
}
lcres = PerlMem_malloc(VMS_MAXRSS);
- if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
+ if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
cp1++,cp2++) {
if (!decc_efs_case_preserve) {
char def[NAM$C_MAXRSS+1], *st;
if (getcwd(def, sizeof def,0) == NULL) {
- Safefree(unixified);
- Safefree(unixwild);
- Safefree(lcres);
- Safefree(tpl);
+ PerlMem_free(unixified);
+ PerlMem_free(unixwild);
+ PerlMem_free(lcres);
+ PerlMem_free(tpl);
return 0;
}
if (!decc_efs_case_preserve) {
}
dd->count++;
/* Force the buffer to end with a NUL, and downcase name to match C convention. */
+ buff[res.dsc$w_length] = '\0';
+ p = buff + res.dsc$w_length;
+ while (--p >= buff) if (!isspace(*p)) break;
+ *p = '\0';
if (!decc_efs_case_preserve) {
- buff[VMS_MAXRSS - 1] = '\0';
for (p = buff; *p; p++) *p = _tolower(*p);
}
- else {
- /* we don't want to force to lowercase, just null terminate */
- buff[res.dsc$w_length] = '\0';
- }
- while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
- *p = '\0';
/* Skip any directory component and just copy the name. */
sts = vms_split_path
&vs_spec,
&vs_len);
- /* Drop NULL extensions on UNIX file specification */
- if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
- (e_len == 1) && decc_readdir_dropdotnotype)) {
- e_len = 0;
- e_spec[0] = '\0';
+ if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
+
+ /* In Unix report mode, remove the ".dir;1" from the name */
+ /* if it is a real directory. */
+ if (decc_filename_unix_report || decc_efs_charset) {
+ if ((e_len == 4) && (vs_len == 2) && (vs_spec[1] == '1')) {
+ if ((toupper(e_spec[1]) == 'D') &&
+ (toupper(e_spec[2]) == 'I') &&
+ (toupper(e_spec[3]) == 'R')) {
+ Stat_t statbuf;
+ int ret_sts;
+
+ ret_sts = stat(buff, (stat_t *)&statbuf);
+ if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
+ e_len = 0;
+ e_spec[0] = 0;
+ }
+ }
+ }
+ }
+
+ /* Drop NULL extensions on UNIX file specification */
+ if ((e_len == 1) && decc_readdir_dropdotnotype) {
+ e_len = 0;
+ e_spec[0] = '\0';
+ }
}
strncpy(dd->entry.d_name, n_spec, n_len + e_len);
static char *
setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
{
- char *junk, *tmps = Nullch;
+ char *junk, *tmps = NULL;
register size_t cmdlen = 0;
size_t rlen;
register SV **idx;
register int isdcl;
vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
- if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
+ if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
/* Make a copy for modification */
cmdlen = strlen(incmd);
cmd = PerlMem_malloc(cmdlen+1);
- if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
+ if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
strncpy(cmd, incmd, cmdlen);
cmd[cmdlen] = 0;
image_name[0] = 0;
*cp2 = '\0';
if (do_tovmsspec(resspec,cp,0,NULL)) {
s = vmsspec;
+
+ /* When a UNIX spec with no file type is translated to VMS, */
+ /* A trailing '.' is appended under ODS-5 rules. */
+ /* Here we do not want that trailing "." as it prevents */
+ /* Looking for a implied ".exe" type. */
+ if (decc_efs_charset) {
+ int i;
+ i = strlen(vmsspec);
+ if (vmsspec[i-1] == '.') {
+ vmsspec[i-1] = '\0';
+ }
+ }
+
if (*rest) {
for (cp2 = vmsspec + strlen(vmsspec);
*rest && cp2 - vmsspec < sizeof vmsspec;
imgdsc.dsc$w_length = wordbreak - s;
retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
if (!(retsts&1)) {
- _ckvmssts(lib$find_file_end(&cxt));
+ _ckvmssts_noperl(lib$find_file_end(&cxt));
retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
if (!(retsts & 1) && *s == '$') {
- _ckvmssts(lib$find_file_end(&cxt));
+ _ckvmssts_noperl(lib$find_file_end(&cxt));
imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
if (!(retsts&1)) {
- _ckvmssts(lib$find_file_end(&cxt));
+ _ckvmssts_noperl(lib$find_file_end(&cxt));
retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
}
}
}
- _ckvmssts(lib$find_file_end(&cxt));
+ _ckvmssts_noperl(lib$find_file_end(&cxt));
if (retsts & 1) {
FILE *fp;
if (cando_by_name(S_IXUSR,0,resspec)) {
vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
- if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
+ if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
if (!isdcl) {
strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
if (image_name[0] != 0) {
if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
(retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
- else { _ckvmssts(retsts); }
+ else { _ckvmssts_noperl(retsts); }
}
return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
set_errno(E2BIG); break;
case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
- _ckvmssts(retsts); /* fall through */
+ _ckvmssts_noperl(retsts); /* fall through */
default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
set_errno(EVMSERR);
}
} /* end of vms_do_exec() */
/*}}}*/
-unsigned long int Perl_do_spawn(pTHX_ const char *);
-unsigned long int do_spawn2(pTHX_ const char *, int);
+int do_spawn2(pTHX_ const char *, int);
-/* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
-unsigned long int
-Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
+int
+Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
{
unsigned long int sts;
char * cmd;
* through do_aspawn is a value of 1, which means spawn without
* waiting for completion -- other values are ignored.
*/
- if (SvNIOKp(*((SV**)mark+1)) && !SvPOKp(*((SV**)mark+1))) {
+ if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
++mark;
- flags = SvIVx(*(SV**)mark);
+ flags = SvIVx(*mark);
}
if (flags && flags == 1) /* the Win32 P_NOWAIT value */
else
flags = 0;
- cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
+ cmd = setup_argstr(aTHX_ really, mark, sp);
sts = do_spawn2(aTHX_ cmd, flags);
/* pp_sys will clean up cmd */
return sts;
/*}}}*/
-/* {{{unsigned long int do_spawn(char *cmd) */
-unsigned long int
-Perl_do_spawn(pTHX_ const char *cmd)
+/* {{{int do_spawn(char* cmd) */
+int
+Perl_do_spawn(pTHX_ char* cmd)
{
+ PERL_ARGS_ASSERT_DO_SPAWN;
+
return do_spawn2(aTHX_ cmd, 0);
}
/*}}}*/
-/* {{{unsigned long int do_spawn2(char *cmd) */
-unsigned long int
+/* {{{int do_spawn_nowait(char* cmd) */
+int
+Perl_do_spawn_nowait(pTHX_ char* cmd)
+{
+ PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
+
+ return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
+}
+/*}}}*/
+
+/* {{{int do_spawn2(char *cmd) */
+int
do_spawn2(pTHX_ const char *cmd, int flags)
{
unsigned long int sts, substs;
case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
set_errno(E2BIG); break;
case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
- _ckvmssts(sts); /* fall through */
+ _ckvmssts_noperl(sts); /* fall through */
default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
set_errno(EVMSERR);
}
unsigned int fd = fileno(fp);
unsigned int fdoff = fd / sizeof(unsigned int);
- if (sockflagsize && fdoff <= sockflagsize)
+ if (sockflagsize && fdoff < sockflagsize)
sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
}
return fclose(fp);
if ((res = fflush(fp)) == 0 && fp) {
#ifdef VMS_DO_SOCKETS
Stat_t s;
- if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
+ if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
#endif
res = fsync(fileno(fp));
}
/* Make sure we expand logical names, since sys$check_access doesn't */
fileified = PerlMem_malloc(VMS_MAXRSS);
- if (fileified == NULL) _ckvmssts(SS$_INSFMEM);
+ if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
if (!strpbrk(fname,"/]>:")) {
strcpy(fileified,fname);
trnlnm_iter_count = 0;
}
vmsname = PerlMem_malloc(VMS_MAXRSS);
- if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
+ if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
/* Don't know if already in VMS format, so make sure */
if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
*/
/* get current process privs and username */
- _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
- _ckvmssts(iosb[0]);
+ _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
+ _ckvmssts_noperl(iosb[0]);
#if defined(__VMS_VER) && __VMS_VER >= 60000000
/* find out the space required for the profile */
- _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
+ _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
&usrprodsc.dsc$w_length,&profile_context));
/* allocate space for the profile and get it filled in */
usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
- if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
- _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
+ if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
+ _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
&usrprodsc.dsc$w_length,&profile_context));
/* use the profile to check access to the file; free profile & analyze results */
PerlMem_free(vmsname);
return TRUE;
}
- _ckvmssts(retsts);
+ _ckvmssts_noperl(retsts);
if (fileified != NULL)
PerlMem_free(fileified);
char temp_fspec[VMS_MAXRSS];
char *save_spec;
int retval = -1;
- int saved_errno, saved_vaxc_errno;
+ dSAVEDERRNO;
if (!fspec) return retval;
- saved_errno = errno; saved_vaxc_errno = vaxc$errno;
+ SAVE_ERRNO;
strcpy(temp_fspec, fspec);
if (decc_bug_devnull != 0) {
if (!retval) {
char * cptr;
+ int rmsex_flags = PERL_RMSEXPAND_M_VMS;
+
+ /* If this is an lstat, do not follow the link */
+ if (lstat_flag)
+ rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
+
cptr = do_rmsexpand
- (save_spec, statbufp->st_devnam, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
+ (save_spec, statbufp->st_devnam, 0, NULL, rmsex_flags, NULL, NULL);
if (cptr == NULL)
statbufp->st_devnam[0] = 0;
# endif
}
/* If we were successful, leave errno where we found it */
- if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
+ if (retval == 0) RESTORE_ERRNO;
return retval;
} /* end of flex_stat_int() */
int
Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
{
- char *vmsin, * vmsout, *esa, *esa_out,
- *rsa, *ubf;
+ char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
+ *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
unsigned long int i, sts, sts2;
int dna_len;
struct FAB fab_in, fab_out;
struct XABSUM xabsum;
vmsin = PerlMem_malloc(VMS_MAXRSS);
- if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
+ if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
vmsout = PerlMem_malloc(VMS_MAXRSS);
- if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
+ if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
!spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
PerlMem_free(vmsin);
}
esa = PerlMem_malloc(VMS_MAXRSS);
- if (esa == NULL) _ckvmssts(SS$_INSFMEM);
+ if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
+ esal = NULL;
+#if !defined(__VAX) && defined(NAML$C_MAXRSS)
+ esal = PerlMem_malloc(VMS_MAXRSS);
+ if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
+#endif
fab_in = cc$rms_fab;
rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
fab_in.fab$l_xab = (void *) &xabdat;
rsa = PerlMem_malloc(VMS_MAXRSS);
- if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
- rms_set_rsa(nam, rsa, (VMS_MAXRSS-1));
- rms_set_esa(fab_in, nam, esa, (VMS_MAXRSS-1));
+ if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
+ rsal = NULL;
+#if !defined(__VAX) && defined(NAML$C_MAXRSS)
+ rsal = PerlMem_malloc(VMS_MAXRSS);
+ if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
+#endif
+ rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
+ rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
rms_nam_esl(nam) = 0;
rms_nam_rsl(nam) = 0;
rms_nam_esll(nam) = 0;
PerlMem_free(vmsin);
PerlMem_free(vmsout);
PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
PerlMem_free(rsa);
+ if (rsal != NULL)
+ PerlMem_free(rsal);
set_vaxc_errno(sts);
switch (sts) {
case RMS$_FNF: case RMS$_DNF:
rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
- esa_out = PerlMem_malloc(VMS_MAXRSS);
- if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
- rms_set_rsa(nam_out, NULL, 0);
- rms_set_esa(fab_out, nam_out, esa_out, (VMS_MAXRSS - 1));
+ esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
+ if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
+ rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
+ if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
+ esal_out = NULL;
+ rsal_out = NULL;
+#if !defined(__VAX) && defined(NAML$C_MAXRSS)
+ esal_out = PerlMem_malloc(VMS_MAXRSS);
+ if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
+ rsal_out = PerlMem_malloc(VMS_MAXRSS);
+ if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
+#endif
+ rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
+ rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
if (preserve_dates == 0) { /* Act like DCL COPY */
rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
PerlMem_free(vmsin);
PerlMem_free(vmsout);
PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
PerlMem_free(rsa);
+ if (rsal != NULL)
+ PerlMem_free(rsal);
PerlMem_free(esa_out);
+ if (esal_out != NULL)
+ PerlMem_free(esal_out);
+ PerlMem_free(rsa_out);
+ if (rsal_out != NULL)
+ PerlMem_free(rsal_out);
set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
set_vaxc_errno(sts);
return 0;
PerlMem_free(vmsin);
PerlMem_free(vmsout);
PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
PerlMem_free(rsa);
+ if (rsal != NULL)
+ PerlMem_free(rsal);
PerlMem_free(esa_out);
+ if (esal_out != NULL)
+ PerlMem_free(esal_out);
+ PerlMem_free(rsa_out);
+ if (rsal_out != NULL)
+ PerlMem_free(rsal_out);
set_vaxc_errno(sts);
switch (sts) {
case RMS$_DNF:
}
ubf = PerlMem_malloc(32256);
- if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
+ if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
rab_in = cc$rms_rab;
rab_in.rab$l_fab = &fab_in;
rab_in.rab$l_rop = RAB$M_BIO;
sys$close(&fab_in); sys$close(&fab_out);
PerlMem_free(vmsin);
PerlMem_free(vmsout);
- PerlMem_free(esa);
PerlMem_free(ubf);
+ PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
PerlMem_free(rsa);
+ if (rsal != NULL)
+ PerlMem_free(rsal);
PerlMem_free(esa_out);
+ if (esal_out != NULL)
+ PerlMem_free(esal_out);
+ PerlMem_free(rsa_out);
+ if (rsal_out != NULL)
+ PerlMem_free(rsal_out);
set_errno(EVMSERR); set_vaxc_errno(sts);
return 0;
}
sys$close(&fab_in); sys$close(&fab_out);
PerlMem_free(vmsin);
PerlMem_free(vmsout);
- PerlMem_free(esa);
PerlMem_free(ubf);
+ PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
PerlMem_free(rsa);
+ if (rsal != NULL)
+ PerlMem_free(rsal);
PerlMem_free(esa_out);
+ if (esal_out != NULL)
+ PerlMem_free(esal_out);
+ PerlMem_free(rsa_out);
+ if (rsal_out != NULL)
+ PerlMem_free(rsal_out);
set_errno(EVMSERR); set_vaxc_errno(sts);
return 0;
}
sys$close(&fab_in); sys$close(&fab_out);
PerlMem_free(vmsin);
PerlMem_free(vmsout);
- PerlMem_free(esa);
PerlMem_free(ubf);
+ PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
PerlMem_free(rsa);
+ if (rsal != NULL)
+ PerlMem_free(rsal);
PerlMem_free(esa_out);
+ if (esal_out != NULL)
+ PerlMem_free(esal_out);
+ PerlMem_free(rsa_out);
+ if (rsal_out != NULL)
+ PerlMem_free(rsal_out);
set_errno(EVMSERR); set_vaxc_errno(sts);
return 0;
}
fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
sys$close(&fab_in); sys$close(&fab_out);
sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
- if (!(sts & 1)) {
- PerlMem_free(vmsin);
- PerlMem_free(vmsout);
- PerlMem_free(esa);
- PerlMem_free(ubf);
- PerlMem_free(rsa);
- PerlMem_free(esa_out);
- set_errno(EVMSERR); set_vaxc_errno(sts);
- return 0;
- }
PerlMem_free(vmsin);
PerlMem_free(vmsout);
- PerlMem_free(esa);
PerlMem_free(ubf);
+ PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
PerlMem_free(rsa);
+ if (rsal != NULL)
+ PerlMem_free(rsal);
PerlMem_free(esa_out);
+ if (esal_out != NULL)
+ PerlMem_free(esal_out);
+ PerlMem_free(rsa_out);
+ if (rsal_out != NULL)
+ PerlMem_free(rsal_out);
+
+ if (!(sts & 1)) {
+ set_errno(EVMSERR); set_vaxc_errno(sts);
+ return 0;
+ }
+
return 1;
} /* end of rmscopy() */
if (counter) {
strcat(work_name, "__");
}
- strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
- PL_na));
+ strcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)));
}
/* Check to see if we actually have to bother...*/
unsigned long int lff_flags = 0;
int rms_sts;
+ if (!SvOK(tmpglob)) {
+ SETERRNO(ENOENT,RMS$_FNF);
+ return NULL;
+ }
+
#ifdef VMS_LONGNAME_SUPPORT
lff_flags = LIB$M_FIL_LONG_NAMES;
#endif
if (!found) {
/* Be POSIXish: return the input pattern when no matches */
- begin = SvPVX(tmpglob);
- strcat(begin,"\n");
- ok = (PerlIO_puts(tmpfp,begin) != EOF);
+ strcpy(rstr,SvPVX(tmpglob));
+ strcat(rstr,"\n");
+ ok = (PerlIO_puts(tmpfp,rstr) != EOF);
}
if (ok && sts != RMS$_NMF &&
}
-#ifdef HAS_SYMLINK
static char *
mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
- const int *utf8_fl);
+ int *utf8_fl);
void
-vms_realpath_fromperl(pTHX_ CV *cv)
+unixrealpath_fromperl(pTHX_ CV *cv)
{
- dXSARGS;
- char *fspec, *rslt_spec, *rslt;
- STRLEN n_a;
+ dXSARGS;
+ char *fspec, *rslt_spec, *rslt;
+ STRLEN n_a;
- if (!items || items != 1)
- Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
+ if (!items || items != 1)
+ Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
- fspec = SvPV(ST(0),n_a);
- if (!fspec || !*fspec) XSRETURN_UNDEF;
+ fspec = SvPV(ST(0),n_a);
+ if (!fspec || !*fspec) XSRETURN_UNDEF;
- Newx(rslt_spec, VMS_MAXRSS + 1, char);
- rslt = do_vms_realpath(fspec, rslt_spec, NULL);
- ST(0) = sv_newmortal();
- if (rslt != NULL)
- sv_usepvn(ST(0),rslt,strlen(rslt));
- else
- Safefree(rslt_spec);
- XSRETURN(1);
+ Newx(rslt_spec, VMS_MAXRSS + 1, char);
+ rslt = do_vms_realpath(fspec, rslt_spec, NULL);
+
+ ST(0) = sv_newmortal();
+ if (rslt != NULL)
+ sv_usepvn(ST(0),rslt,strlen(rslt));
+ else
+ Safefree(rslt_spec);
+ XSRETURN(1);
}
+static char *
+mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
+ int *utf8_fl);
+
+void
+vmsrealpath_fromperl(pTHX_ CV *cv)
+{
+ dXSARGS;
+ char *fspec, *rslt_spec, *rslt;
+ STRLEN n_a;
+
+ if (!items || items != 1)
+ Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
+
+ fspec = SvPV(ST(0),n_a);
+ if (!fspec || !*fspec) XSRETURN_UNDEF;
+
+ Newx(rslt_spec, VMS_MAXRSS + 1, char);
+ rslt = do_vms_realname(fspec, rslt_spec, NULL);
+
+ ST(0) = sv_newmortal();
+ if (rslt != NULL)
+ sv_usepvn(ST(0),rslt,strlen(rslt));
+ else
+ Safefree(rslt_spec);
+ XSRETURN(1);
+}
+
+#ifdef HAS_SYMLINK
/*
* A thin wrapper around decc$symlink to make sure we follow the
* standard and do not create a symlink with a zero-length name.
+ *
+ * Also in ODS-2 mode, existing tests assume that the link target
+ * will be converted to UNIX format.
*/
-/*{{{ int my_symlink(const char *path1, const char *path2)*/
-int my_symlink(const char *path1, const char *path2) {
- if (!path2 || !*path2) {
+/*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
+int Perl_my_symlink(pTHX_ const char *contents, const char *link_name) {
+ if (!link_name || !*link_name) {
SETERRNO(ENOENT, SS$_NOSUCHFILE);
return -1;
}
- return symlink(path1, path2);
+
+ if (decc_efs_charset) {
+ return symlink(contents, link_name);
+ } else {
+ int sts;
+ char * utarget;
+
+ /* Unless we are in ODS-5 mode, convert the symlink target to UNIX */
+ /* because in order to work, the symlink target must be in UNIX format */
+
+ /* As symbolic links can hold things other than files, we will only do */
+ /* the conversion in in ODS-2 mode */
+
+ Newx(utarget, VMS_MAXRSS + 1, char);
+ if (do_tounixspec(contents, utarget, 0, NULL) == NULL) {
+
+ /* This should not fail, as an untranslatable filename */
+ /* should be passed through */
+ utarget = (char *)contents;
+ }
+ sts = symlink(utarget, link_name);
+ Safefree(utarget);
+ return sts;
+ }
+
}
/*}}}*/
#endif /* HAS_SYMLINK */
-#if __CRTL_VER >= 70301000 && !defined(__VAX)
int do_vms_case_tolerant(void);
void
-vms_case_tolerant_fromperl(pTHX_ CV *cv)
+case_tolerant_process_fromperl(pTHX_ CV *cv)
{
dXSARGS;
ST(0) = boolSV(do_vms_case_tolerant());
XSRETURN(1);
}
-#endif
+
+#ifdef USE_ITHREADS
void
Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
struct interp_intern *dst)
{
+ PERL_ARGS_ASSERT_SYS_INTERN_DUP;
+
memcpy(dst,src,sizeof(struct interp_intern));
}
+#endif
+
void
Perl_sys_intern_clear(pTHX)
{
VMSISH_HUSHED = 0;
- /* fix me later to track running under GNV */
- /* this allows some limited testing */
- MY_POSIX_EXIT = decc_filename_unix_report;
+ MY_POSIX_EXIT = vms_posix_exit;
x = (float)ix;
MY_INV_RAND_MAX = 1./x;
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 __CRTL_VER >= 70301000 && !defined(__VAX)
- newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
-#endif
+ newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
+ newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
+ newXSproto("VMS::Filespec::case_tolerant_process",
+ case_tolerant_process_fromperl,file,"");
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, ...);
* The perl fallback routine to provide realpath() is not as efficient
* on OpenVMS.
*/
+
+/* Hack, use old stat() as fastest way of getting ino_t and device */
+int decc$stat(const char *name, void * statbuf);
+
+
+/* Realpath is fragile. In 8.3 it does not work if the feature
+ * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
+ * links are implemented in RMS, not the CRTL. It also can fail if the
+ * user does not have read/execute access to some of the directories.
+ * So in order for Do What I Mean mode to work, if realpath() fails,
+ * fall back to looking up the filename by the device name and FID.
+ */
+
+int vms_fid_to_name(char * outname, int outlen, const char * name)
+{
+struct statbuf_t {
+ char * st_dev;
+ unsigned short st_ino[3];
+ unsigned short padw;
+ unsigned long padl[30]; /* plenty of room */
+} statbuf;
+int sts;
+struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
+struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
+
+ sts = decc$stat(name, &statbuf);
+ if (sts == 0) {
+
+ dvidsc.dsc$a_pointer=statbuf.st_dev;
+ dvidsc.dsc$w_length=strlen(statbuf.st_dev);
+
+ specdsc.dsc$a_pointer = outname;
+ specdsc.dsc$w_length = outlen-1;
+
+ sts = lib$fid_to_name
+ (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
+ if ($VMS_STATUS_SUCCESS(sts)) {
+ outname[specdsc.dsc$w_length] = 0;
+ return 0;
+ }
+ }
+ return sts;
+}
+
+
+
static char *
mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
- const int *utf8_fl)
+ int *utf8_fl)
+{
+ char * rslt = NULL;
+
+#ifdef HAS_SYMLINK
+ if (decc_posix_compliant_pathnames > 0 ) {
+ /* realpath currently only works if posix compliant pathnames are
+ * enabled. It may start working when they are not, but in that
+ * case we still want the fallback behavior for backwards compatibility
+ */
+ rslt = realpath(filespec, outbuf);
+ }
+#endif
+
+ if (rslt == NULL) {
+ char * vms_spec;
+ char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
+ int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
+ int file_len;
+
+ /* Fall back to fid_to_name */
+
+ Newx(vms_spec, VMS_MAXRSS + 1, char);
+
+ sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec);
+ if (sts == 0) {
+
+
+ /* Now need to trim the version off */
+ sts = vms_split_path
+ (vms_spec,
+ &v_spec,
+ &v_len,
+ &r_spec,
+ &r_len,
+ &d_spec,
+ &d_len,
+ &n_spec,
+ &n_len,
+ &e_spec,
+ &e_len,
+ &vs_spec,
+ &vs_len);
+
+
+ if (sts == 0) {
+ int haslower = 0;
+ const char *cp;
+
+ /* Trim off the version */
+ int file_len = v_len + r_len + d_len + n_len + e_len;
+ vms_spec[file_len] = 0;
+
+ /* The result is expected to be in UNIX format */
+ rslt = do_tounixspec(vms_spec, outbuf, 0, utf8_fl);
+
+ /* Downcase if input had any lower case letters and
+ * case preservation is not in effect.
+ */
+ if (!decc_efs_case_preserve) {
+ for (cp = filespec; *cp; cp++)
+ if (islower(*cp)) { haslower = 1; break; }
+
+ if (haslower) __mystrtolower(rslt);
+ }
+ }
+ } else {
+
+ /* Now for some hacks to deal with backwards and forward */
+ /* compatibilty */
+ if (!decc_efs_charset) {
+
+ /* 1. ODS-2 mode wants to do a syntax only translation */
+ rslt = do_rmsexpand(filespec, outbuf,
+ 0, NULL, 0, NULL, utf8_fl);
+
+ } else {
+ if (decc_filename_unix_report) {
+ char * dir_name;
+ char * vms_dir_name;
+ char * file_name;
+
+ /* 2. ODS-5 / UNIX report mode should return a failure */
+ /* if the parent directory also does not exist */
+ /* Otherwise, get the real path for the parent */
+ /* and add the child to it.
+
+ /* basename / dirname only available for VMS 7.0+ */
+ /* So we may need to implement them as common routines */
+
+ Newx(dir_name, VMS_MAXRSS + 1, char);
+ Newx(vms_dir_name, VMS_MAXRSS + 1, char);
+ dir_name[0] = '\0';
+ file_name = NULL;
+
+ /* First try a VMS parse */
+ sts = vms_split_path
+ (filespec,
+ &v_spec,
+ &v_len,
+ &r_spec,
+ &r_len,
+ &d_spec,
+ &d_len,
+ &n_spec,
+ &n_len,
+ &e_spec,
+ &e_len,
+ &vs_spec,
+ &vs_len);
+
+ if (sts == 0) {
+ /* This is VMS */
+
+ int dir_len = v_len + r_len + d_len + n_len;
+ if (dir_len > 0) {
+ strncpy(dir_name, filespec, dir_len);
+ dir_name[dir_len] = '\0';
+ file_name = (char *)&filespec[dir_len + 1];
+ }
+ } else {
+ /* This must be UNIX */
+ char * tchar;
+
+ tchar = strrchr(filespec, '/');
+
+ if (tchar != NULL) {
+ int dir_len = tchar - filespec;
+ strncpy(dir_name, filespec, dir_len);
+ dir_name[dir_len] = '\0';
+ file_name = (char *) &filespec[dir_len + 1];
+ }
+ }
+
+ /* Dir name is defaulted */
+ if (dir_name[0] == 0) {
+ dir_name[0] = '.';
+ dir_name[1] = '\0';
+ }
+
+ /* Need realpath for the directory */
+ sts = vms_fid_to_name(vms_dir_name,
+ VMS_MAXRSS + 1,
+ dir_name);
+
+ if (sts == 0) {
+ /* Now need to pathify it.
+ char *tdir = do_pathify_dirspec(vms_dir_name,
+ outbuf, utf8_fl);
+
+ /* And now add the original filespec to it */
+ if (file_name != NULL) {
+ strcat(outbuf, file_name);
+ }
+ return outbuf;
+ }
+ Safefree(vms_dir_name);
+ Safefree(dir_name);
+ }
+ }
+ }
+ Safefree(vms_spec);
+ }
+ return rslt;
+}
+
+static char *
+mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
+ int *utf8_fl)
{
- return realpath(filespec, outbuf);
+ char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
+ int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
+ int file_len;
+
+ /* Fall back to fid_to_name */
+
+ sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec);
+ if (sts != 0) {
+ return NULL;
+ }
+ else {
+
+
+ /* Now need to trim the version off */
+ sts = vms_split_path
+ (outbuf,
+ &v_spec,
+ &v_len,
+ &r_spec,
+ &r_len,
+ &d_spec,
+ &d_len,
+ &n_spec,
+ &n_len,
+ &e_spec,
+ &e_len,
+ &vs_spec,
+ &vs_len);
+
+
+ if (sts == 0) {
+ int haslower = 0;
+ const char *cp;
+
+ /* Trim off the version */
+ int file_len = v_len + r_len + d_len + n_len + e_len;
+ outbuf[file_len] = 0;
+
+ /* Downcase if input had any lower case letters and
+ * case preservation is not in effect.
+ */
+ if (!decc_efs_case_preserve) {
+ for (cp = filespec; *cp; cp++)
+ if (islower(*cp)) { haslower = 1; break; }
+
+ if (haslower) __mystrtolower(outbuf);
+ }
+ }
+ }
+ return outbuf;
}
+
/*}}}*/
/* External entry points */
char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
{ return do_vms_realpath(filespec, outbuf, utf8_fl); }
-#else
-char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
-{ return NULL; }
-#endif
+char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
+{ return do_vms_realname(filespec, outbuf, utf8_fl); }
-#if __CRTL_VER >= 70301000 && !defined(__VAX)
/* case_tolerant */
/*{{{int do_vms_case_tolerant(void)*/
}
/*}}}*/
/* External entry points */
+#if __CRTL_VER >= 70301000 && !defined(__VAX)
int Perl_vms_case_tolerant(void)
{ return do_vms_case_tolerant(); }
#else
{
int status;
int s;
- int dflt;
char* str;
char val_str[10];
#if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
vms_debug_on_exception = 0;
status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", 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'))
vms_debug_on_exception = 1;
else
vms_debug_on_exception = 0;
}
+ /* Debug unix/vms file translation routines */
+ vms_debug_fileify = 0;
+ status = sys_trnlnm("PERL_VMS_FILEIFY_DEBUG", 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'))
+ vms_debug_fileify = 1;
+ else
+ vms_debug_fileify = 0;
+ }
+
+
+ /* Historically PERL has been doing vmsify / stat differently than */
+ /* the CRTL. In particular, under some conditions the CRTL will */
+ /* remove some illegal characters like spaces from filenames */
+ /* resulting in some differences. The stat()/lstat() wrapper has */
+ /* been reporting such file names as invalid and fails to stat them */
+ /* fixing this bug so that stat()/lstat() accept these like the */
+ /* CRTL does will result in several tests failing. */
+ /* This should really be fixed, but for now, set up a feature to */
+ /* enable it so that the impact can be studied. */
+ vms_bug_stat_filename = 0;
+ status = sys_trnlnm("PERL_VMS_BUG_STAT_FILENAME", 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'))
+ vms_bug_stat_filename = 1;
+ else
+ vms_bug_stat_filename = 0;
+ }
+
+
/* Create VTF-7 filenames from Unicode instead of UTF-8 */
vms_vtf7_filenames = 0;
status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", 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'))
vms_vtf7_filenames = 1;
else
vms_vtf7_filenames = 0;
}
-
/* unlink all versions on unlink() or rename() */
- vms_vtf7_filenames = 0;
+ vms_unlink_all_versions = 0;
status = sys_trnlnm
("PERL_VMS_UNLINK_ALL_VERSIONS", 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'))
vms_unlink_all_versions = 1;
else
gnv_unix_shell = 0;
status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
if ($VMS_STATUS_SUCCESS(status)) {
- if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
gnv_unix_shell = 1;
set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
set_feature_default("DECC$EFS_CHARSET", 1);
set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
vms_unlink_all_versions = 1;
- }
- else
- gnv_unix_shell = 0;
+ vms_posix_exit = 1;
}
#endif
/* hacks to see if known bugs are still present for testing */
- /* Readdir is returning filenames in VMS syntax always */
- decc_bug_readdir_efs1 = 1;
- status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
- if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
- decc_bug_readdir_efs1 = 1;
- else
- decc_bug_readdir_efs1 = 0;
- }
-
/* PCP mode requires creating /dev/null special device file */
decc_bug_devnull = 0;
status = sys_trnlnm("DECC_BUG_DEVNULL", 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_bug_devnull = 1;
else
decc_bug_devnull = 0;
}
- /* fgetname returning a VMS name in UNIX mode */
- decc_bug_fgetname = 1;
- status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
- if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
- decc_bug_fgetname = 1;
- else
- decc_bug_fgetname = 0;
- }
-
/* UNIX directory names with no paths are broken in a lot of places */
decc_dir_barename = 1;
status = sys_trnlnm("DECC_DIR_BARENAME", 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_dir_barename = 1;
else
}
s = decc$feature_get_index("DECC$EFS_CHARSET");
+ decc_efs_charset_index = s;
if (s >= 0) {
decc_efs_charset = decc$feature_get_value(s, 1);
if (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)
+ if (decc_filename_unix_report > 0) {
decc_filename_unix_report = 1;
+ vms_posix_exit = 1;
+ }
else
decc_filename_unix_report = 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) {
}
#endif
-#if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
+#if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
/* Report true case tolerance */
/*----------------------------*/
#endif
+ /* USE POSIX/DCL Exit codes - Recommended, but needs to default to */
+ /* for strict backward compatibilty */
+ status = sys_trnlnm
+ ("PERL_VMS_POSIX_EXIT", 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'))
+ vms_posix_exit = 1;
+ else
+ vms_posix_exit = 0;
+ }
+
/* CRTL can be initialized past this point, but not before. */
/* DECC$CRTL_INIT(); */