*
* VMS-specific routines for perl5
*
- * Last revised: 13-Sep-1998 by Charles Bailey bailey@newman.upenn.edu
- * Version: 5.5.2
+ * Last revised: 15-Aug-1999 by Charles Bailey bailey@newman.upenn.edu
+ * Version: 5.5.60
*/
#include <acedef.h>
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
+/* Anticipating future expansion in lexical warnings . . . */
+#ifndef WARN_INTERNAL
+# define WARN_INTERNAL WARN_MISC
+#endif
/* gcc's header files don't #define direct access macros
* corresponding to VAXC's variant structs */
static struct dsc$descriptor_s **env_tables = defenv;
static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
+/* True if we shouldn't treat barewords as logicals during directory */
+/* munching */
+static int no_translate_barewords;
+
/*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
int
vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
{LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
{0, 0, 0, 0}};
$DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
+#if defined(USE_THREADS)
+ /* We jump through these hoops because we can be called at */
+ /* platform-specific initialization time, which is before anything is */
+ /* set up--we can't even do a plain dTHX since that relies on the */
+ /* interpreter structure to be initialized */
+ struct perl_thread *thr;
+ if (PL_curinterp) {
+ thr = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
+ } else {
+ thr = NULL;
+ }
+#endif
if (!lnm || !eqv || idx > LNM$_MAX_INDEX) {
set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
int i;
if (!environ) {
ivenv = 1;
- warn("Can't read CRTL environ\n");
+ Perl_warn(aTHX_ "Can't read CRTL environ\n");
continue;
}
retsts = SS$_NOLOGNAM;
retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
if (retsts & 1) {
if (eqvlen > 1024) {
- if (PL_curinterp && PL_dowarn) warn("Value of CLI symbol \"%s\" too long",lnm);
- eqvlen = 1024;
set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
+ eqvlen = 1024;
+ /* Special hack--we might be called before the interpreter's */
+ /* 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(USE_THREADS)
+ if (thr && PL_curcop) {
+#endif
+ if (ckWARN(WARN_MISC)) {
+ Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
+ }
+#if defined(USE_THREADS)
+ } else {
+ Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
+ }
+#endif
+
}
strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
}
} /* end of vmstrnenv */
/*}}}*/
-
/*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
/* Define as a function so we can access statics. */
int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)
* Note: Uses Perl temp to store result so char * can be returned to
* caller; this pointer will be invalidated at next Perl statement
* transition.
- * We define this as a function rather than a macro in terms of my_getenv_sv()
+ * We define this as a function rather than a macro in terms of my_getenv_len()
* so that it'll work when PL_curinterp is undefined (and we therefore can't
* allocate SVs).
*/
/*{{{ char *my_getenv(const char *lnm, bool sys)*/
char *
-my_getenv(const char *lnm, bool sys)
+Perl_my_getenv(pTHX_ const char *lnm, bool sys)
{
static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
/*}}}*/
-/*{{{ SV *my_getenv_sv(const char *lnm, bool sys)*/
-SV *
-my_getenv_sv(const char *lnm, bool sys)
+/*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
+char *
+my_getenv_len(const char *lnm, unsigned long *len, bool sys)
{
- char buf[LNM$C_NAMLENGTH+1], *cp1, *cp2;
- unsigned long int len, idx = 0;
-
+ dTHX;
+ char *buf, *cp1, *cp2;
+ unsigned long idx = 0;
+ static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
+ SV *tmpsv;
+
+ if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
+ /* Set up a temporary buffer for the return value; Perl will
+ * clean it up at the next statement transition */
+ tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
+ if (!tmpsv) return NULL;
+ buf = SvPVX(tmpsv);
+ }
+ else buf = __my_getenv_len_eqv; /* Assume no interpreter ==> single thread */
for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
getcwd(buf,LNM$C_NAMLENGTH);
- return newSVpv(buf,0);
+ *len = strlen(buf);
+ return buf;
}
else {
if ((cp2 = strchr(lnm,';')) != NULL) {
idx = strtoul(cp2+1,NULL,0);
lnm = buf;
}
- if ((len = vmstrnenv(lnm,buf,idx,
+ if ((*len = vmstrnenv(lnm,buf,idx,
sys ? fildev : NULL,
#ifdef SECURE_INTERNAL_GETENV
sys ? PERL__TRNENV_SECURE : 0
#else
0
#endif
- ))) return newSVpv(buf,len);
- else return &PL_sv_undef;
+ )))
+ return buf;
+ else
+ return Nullch;
}
-} /* end of my_getenv_sv() */
+} /* end of my_getenv_len() */
/*}}}*/
static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
* find, in preparation for iterating over it.
*/
{
- dTHR;
+ dTHX;
static int primed = 0;
- HV *seenhv = NULL, *envhv = GvHVn(PL_envgv);
+ HV *seenhv = NULL, *envhv;
char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
unsigned short int chan;
#ifndef CLI$M_TRUSTED
MUTEX_INIT(&primenv_mutex);
#endif
- if (primed) return;
+ if (primed || !PL_envgv) return;
MUTEX_LOCK(&primenv_mutex);
if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
+ envhv = GvHVn(PL_envgv);
/* Perform a dummy fetch as an lval to insure that the hash table is
* set up. Otherwise, the hv_store() will turn into a nullop. */
(void) hv_fetch(envhv,"DEFAULT",7,TRUE);
int j;
for (j = 0; environ[j]; j++) {
if (!(start = strchr(environ[j],'='))) {
- if (PL_curinterp && PL_dowarn)
- warn("Ill-formed CRTL environ value \"%s\"\n",environ[j]);
+ if (ckWARN(WARN_INTERNAL))
+ Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
}
else {
start++;
buf[retlen] = '\0';
if (iosb[1] != subpid) {
if (iosb[1]) {
- croak("Unknown process %x sent message to prime_env_iter: %s",buf);
+ Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
}
continue;
}
- if (sts == SS$_BUFFEROVF && PL_curinterp && PL_dowarn)
- warn("Buffer overflow in prime_env_iter: %s",buf);
+ if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
+ Perl_warner(aTHX_ WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
if (*cp1 == '(' || /* Logical name table name */
key = cp1; keylen = cp2 - cp1;
if (keylen && hv_exists(seenhv,key,keylen)) continue;
while (*cp2 && *cp2 != '=') cp2++;
- while (*cp2 && *cp2 != '"') cp2++;
- for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
- if (!keylen || (cp1 - cp2 <= 0)) {
- warn("Ill-formed message in prime_env_iter: |%s|",buf);
+ while (*cp2 && *cp2 == '=') cp2++;
+ while (*cp2 && *cp2 == ' ') cp2++;
+ if (*cp2 == '"') { /* String translation; may embed "" */
+ for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
+ cp2++; cp1--; /* Skip "" surrounding translation */
+ }
+ else { /* Numeric translation */
+ for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
+ cp1--; /* stop on last non-space char */
+ }
+ if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
+ Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
continue;
}
- /* Skip "" surrounding translation */
PERL_HASH(hash,key,keylen);
- hv_store(envhv,key,keylen,newSVpv(cp2+1,cp1 - cp2 - 1),hash);
+ hv_store(envhv,key,keylen,newSVpvn(cp2,cp1 - cp2 + 1),hash);
hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
}
if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
* vmstrnenv(). If an element is to be deleted, it's removed from
* the first place it's found. If it's to be set, it's set in the
* place designated by the first element of the table vector.
+ * Like setenv() returns 0 for success, non-zero on error.
*/
int
vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
$DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
$DESCRIPTOR(local,"_LOCAL");
+ dTHX;
for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
*cp2 = _toupper(*cp1);
lnmdsc.dsc$w_length = cp1 - lnm;
if (!tabvec || !*tabvec) tabvec = env_tables;
- if (!eqv || !*eqv) { /* we're deleting a symbol */
+ if (!eqv) { /* we're deleting n element */
for (curtab = 0; tabvec[curtab]; curtab++) {
if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
int i;
-#ifdef HAS_SETENV
for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
if ((cp1 = strchr(environ[i],'=')) &&
!strncmp(environ[i],lnm,cp1 - environ[i])) {
- setenv(lnm,eqv,1);
- return;
+#ifdef HAS_SETENV
+ return setenv(lnm,eqv,1) ? vaxc$errno : 0;
}
}
ivenv = 1; retsts = SS$_NOLOGNAM;
#else
- if (PL_curinterp && PL_dowarn)
- warn("This Perl can't reset CRTL environ elements (%s)",lnm)
- ivenv = 1; retsts = SS$_NOSUCHPGM;
+ if (ckWARN(WARN_INTERNAL))
+ Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
+ ivenv = 1; retsts = SS$_NOSUCHPGM;
+ break;
+ }
+ }
#endif
}
else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
symtype = LIB$K_CLI_LOCAL_SYM;
else symtype = LIB$K_CLI_GLOBAL_SYM;
retsts = lib$delete_symbol(&lnmdsc,&symtype);
- if (retsts = LIB$_INVSYMNAM) { ivsym = 1; continue; }
- if (retsts = LIB$_NOSUCHSYM) continue;
+ if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
+ if (retsts == LIB$_NOSUCHSYM) continue;
break;
}
else if (!ivlnm) {
else { /* we're defining a value */
if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
#ifdef HAS_SETENV
- return setenv(lnm,eqv,1) ? vaxc$errno : SS$_NORMAL;
+ return setenv(lnm,eqv,1) ? vaxc$errno : 0;
#else
- if (PL_curinterp && PL_dowarn)
- warn("This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv)
+ if (ckWARN(WARN_INTERNAL))
+ Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
retsts = SS$_NOSUCHPGM;
#endif
}
else symtype = LIB$K_CLI_GLOBAL_SYM;
retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
}
- else retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
+ else {
+ if (!*eqv) eqvdsc.dsc$w_length = 1;
+ retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
+ }
}
}
if (!(retsts & 1)) {
set_vaxc_errno(retsts);
return (int) retsts || 44; /* retsts should never be 0, but just in case */
}
- else if (retsts != SS$_NORMAL) { /* alternate success codes */
+ else {
+ /* We reset error values on success because Perl does an hv_fetch()
+ * before each hv_store(), and if the thing we're setting didn't
+ * previously exist, we've got a leftover error message. (Of course,
+ * this fails in the face of
+ * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
+ * in that the error reported in $! isn't spurious,
+ * but it's right more often than not.)
+ */
set_errno(0); set_vaxc_errno(retsts);
return 0;
}
/*{{{ void my_setenv(char *lnm, char *eqv)*/
/* This has to be a function since there's a prototype for it in proto.h */
void
-my_setenv(char *lnm,char *eqv)
+Perl_my_setenv(pTHX_ char *lnm,char *eqv)
{
if (lnm && *lnm && strlen(lnm) == 7) {
char uplnm[8];
char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
+ dTHX;
struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
struct myacedef {
unsigned char myace$b_length;
my_mkdir(char *dir, Mode_t mode)
{
STRLEN dirlen = strlen(dir);
+ dTHX;
/* CRTL mkdir() doesn't tolerate trailing /, since that implies
* null file name/type. However, it's commonplace under Unix,
{
static unsigned long int mbxbufsiz;
long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
+ dTHX;
if (!mbxbufsiz) {
/*
static $DESCRIPTOR(nl_desc, "NL:");
static int waitpid_asleep = 0;
+/* Send an EOF to a mbx. N.B. We don't check that fp actually points
+ * to a mbx; that's the caller's responsibility.
+ */
+static unsigned long int
+pipe_eof(FILE *fp, int immediate)
+{
+ char devnam[NAM$C_MAXRSS+1], *cp;
+ unsigned long int chan, iosb[2], retsts, retsts2;
+ struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
+ dTHX;
+
+ if (fgetname(fp,devnam,1)) {
+ /* It oughta be a mailbox, so fgetname should give just the device
+ * name, but just in case . . . */
+ if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
+ devdsc.dsc$w_length = strlen(devnam);
+ _ckvmssts(sys$assign(&devdsc,&chan,0,0));
+ retsts = sys$qiow(0,chan,IO$_WRITEOF|(immediate?IO$M_NOW|IO$M_NORSWAIT:0),
+ iosb,0,0,0,0,0,0,0,0);
+ if (retsts & 1) retsts = iosb[0];
+ retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */
+ if (retsts & 1) retsts = retsts2;
+ _ckvmssts(retsts);
+ return retsts;
+ }
+ else _ckvmssts(vaxc$errno); /* Should never happen */
+ return (unsigned long int) vaxc$errno;
+}
+
static unsigned long int
pipe_exit_routine()
{
+ struct pipe_details *info;
unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
- int sts;
+ int sts, did_stuff;
+ dTHX;
+
+ /*
+ first we try sending an EOF...ignore if doesn't work, make sure we
+ don't hang
+ */
+ did_stuff = 0;
+ info = open_pipes;
+
+ while (info) {
+ if (info->mode != 'r' && !info->done) {
+ if (pipe_eof(info->fp, 1) & 1) did_stuff = 1;
+ }
+ info = info->next;
+ }
+ if (did_stuff) sleep(1); /* wait for EOF to have an effect */
+
+ did_stuff = 0;
+ info = open_pipes;
+ while (info) {
+ if (!info->done) { /* Tap them gently on the shoulder . . .*/
+ sts = sys$forcex(&info->pid,0,&abort);
+ if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
+ did_stuff = 1;
+ }
+ info = info->next;
+ }
+ if (did_stuff) sleep(1); /* wait for them to respond */
- while (open_pipes != NULL) {
- if (!open_pipes->done) { /* Tap them gently on the shoulder . . .*/
- _ckvmssts(sys$forcex(&open_pipes->pid,0,&abort));
- sleep(1);
+ info = open_pipes;
+ while (info) {
+ if (!info->done) { /* We tried to be nice . . . */
+ sts = sys$delprc(&info->pid,0);
+ if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
+ info->done = 1; /* so my_pclose doesn't try to write EOF */
}
- if (!open_pipes->done) /* We tried to be nice . . . */
- _ckvmssts(sys$delprc(&open_pipes->pid,0));
+ info = info->next;
+ }
+
+ while(open_pipes) {
if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
else if (!(sts & 1)) retsts = sts;
}
char mbxname[64];
unsigned short int chan;
unsigned long int flags=1; /* nowait - gnu c doesn't allow &1 */
+ dTHX;
struct pipe_details *info;
struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
DSC$K_CLASS_S, mbxname},
/*{{{ FILE *my_popen(char *cmd, char *mode)*/
FILE *
-my_popen(char *cmd, char *mode)
+Perl_my_popen(pTHX_ char *cmd, char *mode)
{
TAINT_ENV();
TAINT_PROPER("popen");
/*}}}*/
/*{{{ I32 my_pclose(FILE *fp)*/
-I32 my_pclose(FILE *fp)
+I32 Perl_my_pclose(pTHX_ FILE *fp)
{
struct pipe_details *info, *last = NULL;
unsigned long int retsts;
/* If we were writing to a subprocess, insure that someone reading from
* the mailbox gets an EOF. It looks like a simple fclose() doesn't
* produce an EOF record in the mailbox. */
- if (info->mode != 'r') {
- char devnam[NAM$C_MAXRSS+1], *cp;
- unsigned long int chan, iosb[2], retsts, retsts2;
- struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
-
- if (fgetname(info->fp,devnam,1)) {
- /* It oughta be a mailbox, so fgetname should give just the device
- * name, but just in case . . . */
- if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
- devdsc.dsc$w_length = strlen(devnam);
- _ckvmssts(sys$assign(&devdsc,&chan,0,0));
- retsts = sys$qiow(0,chan,IO$_WRITEOF,iosb,0,0,0,0,0,0,0,0);
- if (retsts & 1) retsts = iosb[0];
- retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */
- if (retsts & 1) retsts = retsts2;
- _ckvmssts(retsts);
- }
- else _ckvmssts(vaxc$errno); /* Should never happen */
- }
+ if (info->mode != 'r' && !info->done) pipe_eof(info->fp,0);
PerlIO_close(info->fp);
if (info->done) retsts = info->completion;
my_waitpid(Pid_t pid, int *statusp, int flags)
{
struct pipe_details *info;
+ dTHX;
for (info = open_pipes; info != NULL; info = info->next)
if (info->pid == pid) break;
unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
unsigned long int interval[2],sts;
- if (PL_dowarn) {
+ if (ckWARN(WARN_EXEC)) {
_ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
_ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
if (ownerpid != mypid)
- warn("pid %x not a child",pid);
+ Perl_warner(aTHX_ WARN_EXEC,"pid %x not a child",pid);
}
_ckvmssts(sys$bintim(&intdsc,interval));
struct FAB myfab = cc$rms_fab;
struct NAM mynam = cc$rms_nam;
STRLEN speclen;
- unsigned long int retsts, haslower = 0, isunix = 0;
+ unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
if (!filespec || !*filespec) {
set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
if (islower(*out)) { haslower = 1; break; }
if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
else { out = esa; speclen = mynam.nam$b_esl; }
- if (!(mynam.nam$l_fnb & NAM$M_EXP_VER) &&
- (!defspec || !*defspec || !strchr(myfab.fab$l_dna,';')))
- speclen = mynam.nam$l_ver - out;
- if (!(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
- (!defspec || !*defspec || defspec[myfab.fab$b_dns-1] != '.' ||
- defspec[myfab.fab$b_dns-2] == '.'))
- speclen = mynam.nam$l_type - out;
+ /* Trim off null fields added by $PARSE
+ * If type > 1 char, must have been specified in original or default spec
+ * (not true for version; $SEARCH may have added version of existing file).
+ */
+ trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
+ trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
+ (mynam.nam$l_ver - mynam.nam$l_type == 1);
+ if (trimver || trimtype) {
+ if (defspec && *defspec) {
+ char defesa[NAM$C_MAXRSS];
+ struct FAB deffab = cc$rms_fab;
+ struct NAM defnam = cc$rms_nam;
+
+ deffab.fab$l_nam = &defnam;
+ deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
+ defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
+ defnam.nam$b_nop = NAM$M_SYNCHK;
+ if (sys$parse(&deffab,0,0) & 1) {
+ if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
+ if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
+ }
+ }
+ if (trimver) speclen = mynam.nam$l_ver - out;
+ if (trimtype) {
+ /* If we didn't already trim version, copy down */
+ if (speclen > mynam.nam$l_ver - out)
+ memcpy(mynam.nam$l_type, mynam.nam$l_ver,
+ speclen - (mynam.nam$l_ver - out));
+ speclen -= mynam.nam$l_ver - mynam.nam$l_type;
+ }
+ }
/* If we just had a directory spec on input, $PARSE "helpfully"
* adds an empty name and type for us */
if (mynam.nam$l_name == mynam.nam$l_type &&
if (*dir) strcpy(trndir,dir);
else getcwd(trndir,sizeof trndir - 1);
- while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir,0)) {
+ while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
+ && my_trnlnm(trndir,trndir,0)) {
STRLEN trnlen = strlen(trndir);
/* Trap simple rooted lnms, and return lnm:[000000] */
unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
unsigned short int dummy, rlen;
struct dsc$descriptor_s **tabvec;
+ dTHX;
struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
{sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
{ sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
char *p, *text, buff[sizeof dd->entry.d_name];
int i;
unsigned long context, tmpsts;
+ dTHX;
/* Convenient shorthand. */
e = &dd->entry;
seekdir(DIR *dd, long count)
{
int vms_wantversions;
+ dTHX;
/* If we haven't done anything yet... */
if (dd->count == 0)
* in 'VMSish fashion' (i.e. not after a call to vfork) The args
* are concatenated to form a DCL command string. If the first arg
* begins with '$' (i.e. the perl script had "\$ Type" or some such),
- * the the command string is hrnded off to DCL directly. Otherwise,
+ * the the command string is handed off to DCL directly. Otherwise,
* the first token of the command is taken as the filespec of an image
* to run. The filespec is expanded using a default type of '.EXE' and
- * the process defaults for device, directory, etc., and the resultant
+ * the process defaults for device, directory, etc., and if found, the resultant
* filespec is invoked using the DCL verb 'MCR', and passed the rest of
- * the command string as parameters. This is perhaps a bit compicated,
+ * the command string as parameters. This is perhaps a bit complicated,
* but I hope it will form a happy medium between what VMS folks expect
* from lib$spawn and what Unix folks expect from exec.
*/
static char *
setup_argstr(SV *really, SV **mark, SV **sp)
{
- dTHR;
+ dTHX;
char *junk, *tmps = Nullch;
register size_t cmdlen = 0;
size_t rlen;
else *PL_Cmd = '\0';
while (++mark <= sp) {
if (*mark) {
- strcat(PL_Cmd," ");
- strcat(PL_Cmd,SvPVx(*mark,n_a));
+ char *s = SvPVx(*mark,n_a);
+ if (!*s) continue;
+ if (*PL_Cmd) strcat(PL_Cmd," ");
+ strcat(PL_Cmd,s);
}
}
return PL_Cmd;
$DESCRIPTOR(defdsc,".EXE");
$DESCRIPTOR(resdsc,resspec);
struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
- unsigned long int cxt = 0, flags = 1, retsts;
+ unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
register char *s, *rest, *cp;
register int isdcl = 0;
+ dTHX;
s = cmd;
while (*s && isspace(*s)) s++;
}
}
else isdcl = 1;
- if (isdcl) { /* It's a DCL command, just do it. */
- VMScmd.dsc$w_length = strlen(cmd);
- if (cmd == PL_Cmd) {
- VMScmd.dsc$a_pointer = PL_Cmd;
- PL_Cmd = Nullch; /* Don't try to free twice in vms_execfree() */
- }
- else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
- }
- else { /* assume first token is an image spec */
+ if (!isdcl) {
cmd = s;
while (*s && !isspace(*s)) s++;
rest = *s ? s : 0;
imgdsc.dsc$a_pointer = cmd;
imgdsc.dsc$w_length = s - cmd;
retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
- if (!(retsts & 1)) {
- /* just hand off status values likely to be due to user error */
- if (retsts == RMS$_FNF || retsts == RMS$_DNF ||
- retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
- (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
- else { _ckvmssts(retsts); }
- }
- else {
+ if (retsts & 1) {
_ckvmssts(lib$find_file_end(&cxt));
s = resspec;
while (*s && !isspace(*s)) s++;
*s = '\0';
- if (!cando_by_name(S_IXUSR,0,resspec)) return RMS$_PRV;
- New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
- strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
- strcat(VMScmd.dsc$a_pointer,resspec);
- if (rest) strcat(VMScmd.dsc$a_pointer,rest);
- VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
+ if (cando_by_name(S_IXUSR,0,resspec)) {
+ New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
+ strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
+ strcat(VMScmd.dsc$a_pointer,resspec);
+ if (rest) strcat(VMScmd.dsc$a_pointer,rest);
+ VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
+ return retsts;
+ }
+ else retsts = RMS$_PRV;
}
}
+ /* It's either a DCL command or we couldn't find a suitable image */
+ VMScmd.dsc$w_length = strlen(cmd);
+ if (cmd == PL_Cmd) {
+ VMScmd.dsc$a_pointer = PL_Cmd;
+ PL_Cmd = Nullch; /* Don't try to free twice in vms_execfree() */
+ }
+ else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
+ if (!(retsts & 1)) {
+ /* just hand off status values likely to be due to user error */
+ 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); }
+ }
- return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : SS$_NORMAL);
+ return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : retsts);
} /* end of setup_cmddsc() */
bool
vms_do_aexec(SV *really,SV **mark,SV **sp)
{
- dTHR;
+ dTHX;
if (sp > mark) {
if (vfork_called) { /* this follows a vfork - act Unixish */
vfork_called--;
if (vfork_called < 0) {
- warn("Internal inconsistency in tracking vforks");
+ Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
vfork_called = 0;
}
else return do_aexec(really,mark,sp);
vms_do_exec(char *cmd)
{
+ dTHX;
if (vfork_called) { /* this follows a vfork - act Unixish */
vfork_called--;
if (vfork_called < 0) {
- warn("Internal inconsistency in tracking vforks");
+ Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
vfork_called = 0;
}
else return do_exec(cmd);
set_errno(EVMSERR);
}
set_vaxc_errno(retsts);
- if (PL_dowarn)
- warn("Can't exec \"%s\": %s", VMScmd.dsc$a_pointer, Strerror(errno));
+ if (ckWARN(WARN_EXEC)) {
+ Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
+ VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
+ }
vms_execfree();
}
unsigned long int
do_aspawn(void *really,void **mark,void **sp)
{
- dTHR;
+ dTHX;
if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp));
return SS$_ABORT;
do_spawn(char *cmd)
{
unsigned long int sts, substs, hadcmd = 1;
+ dTHX;
TAINT_ENV();
TAINT_PROPER("spawn");
set_errno(EVMSERR);
}
set_vaxc_errno(sts);
- if (PL_dowarn)
- warn("Can't spawn \"%s\": %s",
- hadcmd ? VMScmd.dsc$a_pointer : "", Strerror(errno));
+ if (ckWARN(WARN_EXEC)) {
+ Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%*s\": %s",
+ hadcmd ? VMScmd.dsc$w_length : 0,
+ hadcmd ? VMScmd.dsc$a_pointer : "",
+ Strerror(errno));
+ }
}
vms_execfree();
return substs;
my_flush(FILE *fp)
{
int res;
- if ((res = fflush(fp)) == 0) {
+ if ((res = fflush(fp)) == 0 && fp) {
#ifdef VMS_DO_SOCKETS
Stat_t s;
if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
*/
static int fillpasswd (const char *name, struct passwd *pwd)
{
+ dTHX;
static struct {
unsigned char length;
char pw_gecos[UAI$S_OWNER+1];
pwd->pw_gid= uic.uic$v_group;
}
else
- warn("getpwnam returned invalid UIC %#o for user \"%s\"");
+ Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
pwd->pw_passwd= pw_passwd;
pwd->pw_gecos= owner.pw_gecos;
pwd->pw_dir= defdev.pw_dir;
struct dsc$descriptor_s name_desc;
union uicdef uic;
unsigned long int status, sts;
+ dTHX;
__pwdcache = __passwd_empty;
if (!fillpasswd(name, &__pwdcache)) {
unsigned short lname;
union uicdef uic;
unsigned long int status;
+ dTHX;
if (uid == (unsigned int) -1) {
do {
/*{{{void my_endpwent()*/
void my_endpwent()
{
+ dTHX;
if (contxt) {
_ckvmssts(sys$finish_rdb(&contxt));
contxt= 0;
/*{{{time_t my_time(time_t *timep)*/
time_t my_time(time_t *timep)
{
- dTHR;
+ dTHX;
time_t when;
struct tm *tm_p;
gmtime_emulation_type++;
if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
gmtime_emulation_type++;
- warn("no UTC offset information; assuming local time is UTC");
+ Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
}
else { utc_offset_secs = atol(off); }
}
struct tm *
my_gmtime(const time_t *timep)
{
- dTHR;
+ dTHX;
char *p;
time_t when;
struct tm *rsltmp;
struct tm *
my_localtime(const time_t *timep)
{
- dTHR;
+ dTHX;
time_t when;
struct tm *rsltmp;
/*{{{int my_utime(char *path, struct utimbuf *utimes)*/
int my_utime(char *file, struct utimbuf *utimes)
{
- dTHR;
+ dTHX;
register int i;
long int bintime[2], len = 2, lowbit, unixtime,
secscale = 10000000; /* seconds --> 100 ns intervals */
mydev_t enc;
char c;
const char *q;
+ dTHX;
if (!dev || !dev[0]) return 0;
is_null_device(name)
const char *name;
{
+ dTHX;
/* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
The underscore prefix, controller letter, and unit number are
independently optional; for our purposes, the colon punctuation
/* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
* subset of the applicable information.
*/
-/*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
-I32
-cando(I32 bit, I32 effective, Stat_t *statbufp)
+bool
+Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
{
- dTHR;
if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
else {
char fname[NAM$C_MAXRSS+1];
return cando_by_name(bit,effective,fname);
}
else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
- warn("Can't get filespec - stale stat buffer?\n");
+ Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
return FALSE;
}
_ckvmssts(retsts);
/*}}}*/
-/*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
+/*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
I32
-cando_by_name(I32 bit, I32 effective, char *fname)
+cando_by_name(I32 bit, Uid_t effective, char *fname)
{
static char usrname[L_cuserid];
static struct dsc$descriptor_s usrdsc =
char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
unsigned short int retlen;
+ dTHX;
struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
union prvdef curprv;
struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
int
flex_fstat(int fd, Stat_t *statbufp)
{
- dTHR;
+ dTHX;
if (!fstat(fd,(stat_t *) statbufp)) {
if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
statbufp->st_dev = encode_dev(statbufp->st_devnam);
} /* end of flex_fstat() */
/*}}}*/
-/*{{{ int flex_stat(char *fspec, Stat_t *statbufp)*/
+/*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
int
-flex_stat(char *fspec, Stat_t *statbufp)
+flex_stat(const char *fspec, Stat_t *statbufp)
{
- dTHR;
+ dTHX;
char fileified[NAM$C_MAXRSS+1];
+ char temp_fspec[NAM$C_MAXRSS+300];
int retval = -1;
+ strcpy(temp_fspec, fspec);
if (statbufp == (Stat_t *) &PL_statcache)
- do_tovmsspec(fspec,namecache,0);
- if (is_null_device(fspec)) { /* Fake a stat() for the null device */
+ do_tovmsspec(temp_fspec,namecache,0);
+ if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
memset(statbufp,0,sizeof *statbufp);
statbufp->st_dev = encode_dev("_NLA0:");
statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
* the file with null type, specify this by calling flex_stat() with
* a '.' at the end of fspec.
*/
- if (do_fileify_dirspec(fspec,fileified,0) != NULL) {
+ if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
retval = stat(fileified,(stat_t *) statbufp);
if (!retval && statbufp == (Stat_t *) &PL_statcache)
strcpy(namecache,fileified);
}
- if (retval) retval = stat(fspec,(stat_t *) statbufp);
+ if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
if (!retval) {
statbufp->st_dev = encode_dev(statbufp->st_devnam);
# ifdef RTL_USES_UTC
*/
void
-rmsexpand_fromperl(CV *cv)
+rmsexpand_fromperl(pTHX_ CV *cv)
{
dXSARGS;
char *fspec, *defspec = NULL, *rslt;
STRLEN n_a;
if (!items || items > 2)
- croak("Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
+ Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
fspec = SvPV(ST(0),n_a);
if (!fspec || !*fspec) XSRETURN_UNDEF;
if (items == 2) defspec = SvPV(ST(1),n_a);
}
void
-vmsify_fromperl(CV *cv)
+vmsify_fromperl(pTHX_ CV *cv)
{
dXSARGS;
char *vmsified;
STRLEN n_a;
- if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
+ if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
ST(0) = sv_newmortal();
if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
}
void
-unixify_fromperl(CV *cv)
+unixify_fromperl(pTHX_ CV *cv)
{
dXSARGS;
char *unixified;
STRLEN n_a;
- if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
+ if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
ST(0) = sv_newmortal();
if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
}
void
-fileify_fromperl(CV *cv)
+fileify_fromperl(pTHX_ CV *cv)
{
dXSARGS;
char *fileified;
STRLEN n_a;
- if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
+ if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
ST(0) = sv_newmortal();
if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
}
void
-pathify_fromperl(CV *cv)
+pathify_fromperl(pTHX_ CV *cv)
{
dXSARGS;
char *pathified;
STRLEN n_a;
- if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
+ if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
ST(0) = sv_newmortal();
if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
}
void
-vmspath_fromperl(CV *cv)
+vmspath_fromperl(pTHX_ CV *cv)
{
dXSARGS;
char *vmspath;
STRLEN n_a;
- if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
+ if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
ST(0) = sv_newmortal();
if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
}
void
-unixpath_fromperl(CV *cv)
+unixpath_fromperl(pTHX_ CV *cv)
{
dXSARGS;
char *unixpath;
STRLEN n_a;
- if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
+ if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
ST(0) = sv_newmortal();
if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
}
void
-candelete_fromperl(CV *cv)
+candelete_fromperl(pTHX_ CV *cv)
{
dXSARGS;
char fspec[NAM$C_MAXRSS+1], *fsp;
IO *io;
STRLEN n_a;
- if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)");
+ if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
if (SvTYPE(mysv) == SVt_PVGV) {
}
void
-rmscopy_fromperl(CV *cv)
+rmscopy_fromperl(pTHX_ CV *cv)
{
dXSARGS;
char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
STRLEN n_a;
if (items < 2 || items > 3)
- croak("Usage: File::Copy::rmscopy(from,to[,date_flag])");
+ Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
if (SvTYPE(mysv) == SVt_PVGV) {
init_os_extras()
{
char* file = __FILE__;
+ dTHX;
+ char temp_buff[512];
+ if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
+ no_translate_barewords = TRUE;
+ } else {
+ no_translate_barewords = FALSE;
+ }
newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
projects / p5sagit/p5-mst-13.2.git / blobdiff