*/
/*
- * 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.
+ * 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
*
- * The Lay of Leithian, 135-40
+ * [p.162 of _The Lays of Beleriand_]
*/
#include <acedef.h>
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 */
/*}}}*/
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);
* 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 */
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);
#ifdef ARCHLIB_EXP
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);
/* 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
*/
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 */
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);
}
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->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 NULL;
}
/* 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 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() */
* 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)
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 !defined(__VAX) && defined(NAML$C_MAXRSS)
outbufl = PerlMem_malloc(VMS_MAXRSS);
- if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
+ if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
#endif
rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
if (defesa != NULL) {
#if !defined(__VAX) && defined(NAML$C_MAXRSS)
defesal = PerlMem_malloc(VMS_MAXRSS + 1);
- if (defesal == NULL) _ckvmssts(SS$_INSFMEM);
+ if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
#endif
struct FAB deffab = cc$rms_fab;
rms_setup_nam(defnam);
}
else if (isunix) {
tmpfspec = PerlMem_malloc(VMS_MAXRSS);
- if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
+ if (tmpfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
if (do_tounixspec(tbuf,tmpfspec,0,fs_utf8) == NULL) {
if (out) Safefree(out);
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] == '.') {
rms_setup_nam(dirnam);
esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
- 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(SS$_INSFMEM);
+ if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
#endif
rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
rms_bind_fab_nam(dirfab, dirnam);
}
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);
}
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(SS$_INSFMEM);
+ if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
#endif
rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
rms_bind_fab_nam(dirfab, dirnam);
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;
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);
}
}
}
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) {
&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);
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);
}
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);
/* 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) {
# 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() */
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(SS$_INSFMEM);
+ 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$l_xab = (void *) &xabdat;
rsa = PerlMem_malloc(VMS_MAXRSS);
- if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
+ 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(SS$_INSFMEM);
+ 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));
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(NAM$C_MAXRSS + 1);
- if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
+ if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
- if (rsa_out == NULL) _ckvmssts(SS$_INSFMEM);
+ 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(SS$_INSFMEM);
+ if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
rsal_out = PerlMem_malloc(VMS_MAXRSS);
- if (rsal_out == NULL) _ckvmssts(SS$_INSFMEM);
+ 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));
}
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;
/*
* 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;
+ }
+
}
/*}}}*/
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;
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;
{
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_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(); */
https://perl5.git.perl.org / perl5.git / blobdiff