*/
/*
- * 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 char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
+static char *int_tovmsspec
+ (const char *path, char *buf, int dir_flag, int * utf8_flag);
+
/* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
#define PERL_LNM_MAX_ALLOWED_INDEX 127
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;
return ret_stat;
}
+/* Routine to determine if the file specification ends with .dir */
+static int is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len) {
+
+ /* e_len must be 4, and version must be <= 2 characters */
+ if (e_len != 4 || vs_len > 2)
+ return 0;
+
+ /* If a version number is present, it needs to be one */
+ if ((vs_len == 2) && (vs_spec[1] != '1'))
+ return 0;
+
+ /* Look for the DIR on the extension */
+ if (vms_process_case_tolerant) {
+ if ((toupper(e_spec[1]) == 'D') &&
+ (toupper(e_spec[2]) == 'I') &&
+ (toupper(e_spec[3]) == 'R')) {
+ return 1;
+ }
+ } else {
+ /* Directory extensions are supposed to be in upper case only */
+ /* I would not be surprised if this rule can not be enforced */
+ /* if and when someone fully debugs the case sensitive mode */
+ if ((e_spec[1] == 'D') &&
+ (e_spec[2] == 'I') &&
+ (e_spec[3] == 'R')) {
+ return 1;
+ }
+ }
+ return 0;
+}
+
/* my_maxidx
* Routine to retrieve the maximum equivalence index for an input
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) {
/* fully initialized, in which case either thr or PL_curcop */
/* might be bogus. We have to check, since ckWARN needs them */
/* both to be valid if running threaded */
+#if defined(PERL_IMPLICIT_CONTEXT)
+ if (aTHX == NULL) {
+ fprintf(stderr,
+ "%Perl-VMS-Init, Value of CLI symbol \"%s\" too long",lnm);
+ } else
+#endif
if (ckWARN(WARN_MISC)) {
Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
}
}
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 */
/*}}}*/
/* Define as a function so we can access statics. */
int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
{
- return vmstrnenv(lnm,eqv,idx,fildev,
+ int flags = 0;
+
+#if defined(PERL_IMPLICIT_CONTEXT)
+ if (aTHX != NULL)
+#endif
#ifdef SECURE_INTERNAL_GETENV
- (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
-#else
- 0
+ flags = (PL_curinterp ? PL_tainting : will_taint) ?
+ PERL__TRNENV_SECURE : 0;
#endif
- );
+
+ return vmstrnenv(lnm, eqv, idx, fildev, flags);
}
/*}}}*/
* 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 void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
+static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
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 */
}
}
static void
-create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
+create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
{
unsigned long int mbxbufsiz;
static unsigned long int syssize = 0;
* 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 (open_pipes->err)
+ aTHX = open_pipes->err->thx;
+ else if (open_pipes->out)
+ aTHX = open_pipes->out->thx;
+ else if (open_pipes->in)
+ aTHX = open_pipes->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));
+ create_mbx(&p->chan_in , &d_mbx1);
+ create_mbx(&p->chan_out, &d_mbx2);
+ _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));
- create_mbx(aTHX_ &p->chan_in , &d_mbx1);
- create_mbx(aTHX_ &p->chan_out, &d_mbx2);
+ _ckvmssts_noperl(lib$get_vm(&n, &p));
+ create_mbx(&p->chan_in , &d_mbx1);
+ create_mbx(&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));
+ create_mbx(&p->chan_in, &d_mbx);
+ _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;
/* Now create a mailbox to be read by the application */
- create_mbx(aTHX_ &p_chan, &d_mbx1);
+ create_mbx(&p_chan, &d_mbx1);
/* write the name of the created terminal to the mailbox */
status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
/* 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() */
* 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 dest must be a VMS file specification */
- ret_str = do_tovmsspec(dst, vms_dst, 0, NULL);
+ ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
if (ret_str == NULL) {
PerlMem_free(vms_src);
PerlMem_free(vms_dst);
/* 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) {
} else {
/* fileify a target VMS file specification */
- ret_str = do_tovmsspec(dst, vms_dst, 0, NULL);
+ ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
if (ret_str == NULL) {
PerlMem_free(vms_src);
PerlMem_free(vms_dst);
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 (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
+ if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
+ if (int_tovmsspec(filespec, vmsfspec, 0, fs_utf8) == NULL) {
PerlMem_free(vmsfspec);
if (out)
Safefree(out);
t_isunix = is_unix_filespec(defspec);
if (t_isunix) {
tmpfspec = PerlMem_malloc(VMS_MAXRSS);
- if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
- if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
+ if (tmpfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
+ if (int_tovmsspec(defspec, tmpfspec, 0, dfs_utf8) == NULL) {
PerlMem_free(tmpfspec);
if (vmsfspec != NULL)
PerlMem_free(vmsfspec);
}
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);
char *retspec, *cp1, *cp2, *lastdir;
char *trndir, *vmsdir;
unsigned short int trnlnm_iter_count;
+ int is_vms = 0;
+ int is_unix = 0;
int sts;
if (utf8_fl != NULL)
*utf8_fl = 0;
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,VMS_MAXRSS-1)) {
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] == '.') {
if (*(cp1+2) == '.') cp1++;
if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
char * ret_chr;
- if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
+ if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
PerlMem_free(trndir);
PerlMem_free(vmsdir);
return NULL;
}
if (strchr(vmsdir,'/') != NULL) {
- /* If do_tovmsspec() returned it, it must have VMS syntax
+ /* If int_tovmsspec() returned it, it must have VMS syntax
* delimiters in it, so it's a mixed VMS/Unix spec. We take
* the time to check this here only so we avoid a recursion
* loop; otherwise, gigo.
*/
trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
- if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
+ if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
PerlMem_free(trndir);
PerlMem_free(vmsdir);
return NULL;
set_errno(ENOTDIR);
set_vaxc_errno(RMS$_DIR);
return NULL;
- }
- }
+ }
+ }
dirlen = cp2 - trndir;
}
}
/* We've picked up everything up to the directory file name.
Now just add the type and version, and we're set. */
- if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
- strcat(retspec,".dir;1");
- else
- strcat(retspec,".DIR;1");
+
+ /* We should only add type for VMS syntax, but historically Perl
+ has added it for UNIX style also */
+
+ /* Fix me - we should not be using the same routine for VMS and
+ UNIX format files. Things are too tangled so we need to lookup
+ what syntax the output is */
+
+ is_unix = 0;
+ is_vms = 0;
+ lastdir = strrchr(trndir,'/');
+ if (lastdir) {
+ is_unix = 1;
+ } else {
+ lastdir = strpbrk(trndir,"]:>");
+ if (lastdir) {
+ is_vms = 1;
+ }
+ }
+
+ if ((is_vms == 0) && (is_unix == 0)) {
+ /* We still do not know? */
+ is_unix = decc_filename_unix_report;
+ if (is_unix == 0)
+ is_vms = 1;
+ }
+
+ if ((is_unix && !decc_efs_charset) || is_vms) {
+
+ /* It is a bug to add a .dir to a UNIX format directory spec */
+ /* However Perl on VMS may have programs that expect this so */
+ /* If not using EFS character specifications allow it. */
+
+ if ((!decc_efs_case_preserve) && vms_process_case_tolerant) {
+ /* Traditionally Perl expects filenames in lower case */
+ strcat(retspec, ".dir");
+ } else {
+ /* VMS expects the .DIR to be in upper case */
+ strcat(retspec, ".DIR");
+ }
+
+ /* It is also a bug to put a VMS format version on a UNIX file */
+ /* specification. Perl self tests are looking for this */
+ if (is_vms || !(decc_efs_charset || decc_filename_unix_report))
+ strcat(retspec, ";1");
+ }
PerlMem_free(trndir);
PerlMem_free(vmsdir);
return retspec;
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,VMS_MAXRSS-1)) {
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, VMS_MAXRSS-1);
if (!islnm) {
strcpy(rslt, "/tmp");
cp1 = cp1 + 4;
}
+
/*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
-static char *mp_do_tovmsspec
- (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
- static char __tovmsspec_retbuf[VMS_MAXRSS];
- char *rslt, *dirend;
+static char *int_tovmsspec
+ (const char *path, char *rslt, int dir_flag, int * utf8_flag) {
+ char *dirend;
char *lastdot;
char *vms_delim;
register char *cp1;
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;
- if (path == NULL) return NULL;
+ if (vms_debug_fileify) {
+ if (path == NULL)
+ fprintf(stderr, "int_tovmsspec: path = NULL\n");
+ else
+ fprintf(stderr, "int_tovmsspec: path = %s\n", path);
+ }
+
+ if (path == NULL) {
+ /* If we fail, we should be setting errno */
+ set_errno(EINVAL);
+ set_vaxc_errno(SS$_BADPARAM);
+ return NULL;
+ }
rslt_len = VMS_MAXRSS-1;
- if (buf) rslt = buf;
- else if (ts) Newx(rslt, VMS_MAXRSS, char);
- else rslt = __tovmsspec_retbuf;
/* '.' and '..' are "[]" and "[-]" for a quick check */
if (path[0] == '.') {
if (utf8_flag != NULL)
*utf8_flag = 0;
strcpy(rslt, path);
+ if (vms_debug_fileify) {
+ fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
+ }
return rslt;
}
/* Now, what to do with trailing "." cases where there is no
if (utf8_flag != NULL)
*utf8_flag = 0;
strcpy(rslt, path);
+ if (vms_debug_fileify) {
+ fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
+ }
return rslt;
}
dirend = strrchr(path,'/');
if (dirend == NULL) {
+ char *macro_start;
+ int has_macro;
+
/* If we get here with no UNIX directory delimiters, then this is
not a complete file specification, either garbage a UNIX glob
specification that can not be converted to a VMS wildcard, or
- it a UNIX shell macro. MakeMaker wants these passed through AS-IS,
- so apparently other programs expect this also.
+ it a UNIX shell macro. MakeMaker wants shell macros passed
+ through AS-IS,
utf8 flag setting needs to be preserved.
*/
- strcpy(rslt, path);
- return rslt;
+ hasdir = 0;
+
+ has_macro = 0;
+ macro_start = strchr(path,'$');
+ if (macro_start != NULL) {
+ if (macro_start[1] == '(') {
+ has_macro = 1;
+ }
+ }
+ if ((decc_efs_charset == 0) || (has_macro)) {
+ strcpy(rslt, path);
+ if (vms_debug_fileify) {
+ fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
+ }
+ return rslt;
+ }
}
/* If POSIX mode active, handle the conversion */
#if __CRTL_VER >= 80200000 && !defined(__VAX)
if (decc_efs_charset) {
posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
+ if (vms_debug_fileify) {
+ fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
+ }
return rslt;
}
#endif
}
if (utf8_flag != NULL)
*utf8_flag = 0;
+ if (vms_debug_fileify) {
+ fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
+ }
return rslt;
}
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,VMS_MAXRSS-1);
/* 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,VMS_MAXRSS-1);
}
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,VMS_MAXRSS-1);
}
else if (!decc_disable_posix_root) {
strcpy(rslt, "sys$posix_root");
- cp1 = rslt + 13;
+ cp1 = rslt + 14;
*cp1 = 0;
cp2 = path;
while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
- islnm = my_trnlnm(rslt,trndev,0);
+ islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
}
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,VMS_MAXRSS-1);
}
}
}
if (utf8_flag != NULL)
*utf8_flag = 0;
+ if (vms_debug_fileify) {
+ fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
+ }
return rslt;
-} /* end of do_tovmsspec() */
+} /* end of int_tovmsspec() */
+
+
+/*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
+static char *mp_do_tovmsspec
+ (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
+ static char __tovmsspec_retbuf[VMS_MAXRSS];
+ char * vmsspec, *ret_spec, *ret_buf;
+
+ vmsspec = NULL;
+ ret_buf = buf;
+ if (ret_buf == NULL) {
+ if (ts) {
+ Newx(vmsspec, VMS_MAXRSS, char);
+ if (vmsspec == NULL)
+ _ckvmssts(SS$_INSFMEM);
+ ret_buf = vmsspec;
+ } else {
+ ret_buf = __tovmsspec_retbuf;
+ }
+ }
+
+ ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
+
+ if (ret_spec == NULL) {
+ /* Cleanup on isle 5, if this is thread specific we need to deallocate */
+ if (vmsspec)
+ Safefree(vmsspec);
+ }
+
+ return ret_spec;
+
+} /* end of mp_do_tovmsspec() */
/*}}}*/
/* External entry points */
char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
vmsspec = PerlMem_malloc(VMS_MAXRSS);
if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
if ((isunix = (int) strchr(item,'/')) != (int) NULL)
- filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
+ filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
if (!isunix || !filespec.dsc$a_pointer)
filespec.dsc$a_pointer = item;
filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
*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) {
&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;
setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
struct dsc$descriptor_s **pvmscmd)
{
- char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
+ char * vmsspec;
+ char * resspec;
char image_name[NAM$C_MAXRSS+1];
char image_argv[NAM$C_MAXRSS+1];
$DESCRIPTOR(defdsc,".EXE");
$DESCRIPTOR(defdsc2,".");
- $DESCRIPTOR(resdsc,resspec);
+ struct dsc$descriptor_s resdsc;
struct dsc$descriptor_s *vmscmd;
struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
register int isdcl;
vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
- if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
+ if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
+
+ /* vmsspec is a DCL command buffer, not just a filename */
+ vmsspec = PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
+ if (vmsspec == NULL)
+ _ckvmssts_noperl(SS$_INSFMEM);
+
+ resspec = PerlMem_malloc(VMS_MAXRSS);
+ if (resspec == 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;
image_argv[0] = 0;
+ resdsc.dsc$a_pointer = resspec;
+ resdsc.dsc$b_dtype = DSC$K_DTYPE_T;
+ resdsc.dsc$b_class = DSC$K_CLASS_S;
+ resdsc.dsc$w_length = VMS_MAXRSS - 1;
+
vmscmd->dsc$a_pointer = NULL;
vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
vmscmd->dsc$b_class = DSC$K_CLASS_S;
if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
PerlMem_free(cmd);
+ PerlMem_free(vmsspec);
+ PerlMem_free(resspec);
return CLI$_BUFOVF; /* continuation lines currently unsupported */
}
if (*rest == '.' || *rest == '/') {
char *cp2;
for (cp2 = resspec;
- *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
+ *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
rest++, cp2++) *cp2 = *rest;
*cp2 = '\0';
- if (do_tovmsspec(resspec,cp,0,NULL)) {
+ if (int_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;
+ *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
rest++, cp2++) *cp2 = *rest;
*cp2 = '\0';
}
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;
}
fclose(fp);
}
- if (check_img && isdcl) return RMS$_FNF;
+ if (check_img && isdcl) {
+ PerlMem_free(cmd);
+ PerlMem_free(resspec);
+ PerlMem_free(vmsspec);
+ return RMS$_FNF;
+ }
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) {
}
vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
PerlMem_free(cmd);
+ PerlMem_free(vmsspec);
+ PerlMem_free(resspec);
return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
}
else
vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
PerlMem_free(cmd);
+ PerlMem_free(resspec);
+ PerlMem_free(vmsspec);
/* check if it's a symbol (for quoting purposes) */
if (suggest_quote && !*suggest_quote) {
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) {
# 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 (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
- !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
+ if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
+ if (!spec_in || !*spec_in || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
+ !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
PerlMem_free(vmsin);
PerlMem_free(vmsout);
set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
}
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;
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
/*
* 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;
+ }
+
}
/*}}}*/
XSRETURN(1);
}
+#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;
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