*
* VMS-specific routines for perl5
*
- * Last revised: 24-Apr-1999 by Charles Bailey bailey@newman.upenn.edu
- * Version: 5.5.58
+ * Last revised: 15-Aug-1999 by Charles Bailey bailey@newman.upenn.edu
+ * Version: 5.5.60
*/
#include <acedef.h>
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;
if (eqvlen > 1024) {
set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
eqvlen = 1024;
- if (ckWARN(WARN_MISC))
- warner(WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
+ /* 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)
*/
/*{{{ 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;
char *
my_getenv_len(const char *lnm, unsigned long *len, bool sys)
{
- char buf[LNM$C_NAMLENGTH+1], *cp1, *cp2;
+ 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);
#endif
)))
return buf;
- else return Nullch;
+ else
+ return Nullch;
}
} /* end of my_getenv_len() */
* find, in preparation for iterating over it.
*/
{
- dTHR;
+ dTHX;
static int primed = 0;
HV *seenhv = NULL, *envhv;
char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
for (j = 0; environ[j]; j++) {
if (!(start = strchr(environ[j],'='))) {
if (ckWARN(WARN_INTERNAL))
- warner(WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
+ 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 && ckWARN(WARN_INTERNAL))
- warner(WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
+ 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)) && ckWARN(WARN_INTERNAL)) {
- warner(WARN_INTERNAL,"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 */
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);
ivenv = 1; retsts = SS$_NOLOGNAM;
#else
if (ckWARN(WARN_INTERNAL))
- warner(WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
+ Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
ivenv = 1; retsts = SS$_NOSUCHPGM;
break;
}
return setenv(lnm,eqv,1) ? vaxc$errno : 0;
#else
if (ckWARN(WARN_INTERNAL))
- warner(WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
+ Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
retsts = SS$_NOSUCHPGM;
#endif
}
/*{{{ 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) {
/*
* to a mbx; that's the caller's responsibility.
*/
static unsigned long int
-pipe_eof(FILE *fp)
+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
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);
+ 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;
struct pipe_details *info;
unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
int sts, did_stuff;
+ dTHX;
/*
first we try sending an EOF...ignore if doesn't work, make sure we
while (info) {
if (info->mode != 'r' && !info->done) {
- if (pipe_eof(info->fp) & 1) did_stuff = 1;
+ if (pipe_eof(info->fp, 1) & 1) did_stuff = 1;
}
info = info->next;
}
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' && !info->done) pipe_eof(info->fp);
+ 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;
_ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
_ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
if (ownerpid != mypid)
- warner(WARN_EXEC,"pid %x not a child",pid);
+ Perl_warner(aTHX_ WARN_EXEC,"pid %x not a child",pid);
}
_ckvmssts(sys$bintim(&intdsc,interval));
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)
static char *
setup_argstr(SV *really, SV **mark, SV **sp)
{
- dTHR;
+ dTHX;
char *junk, *tmps = Nullch;
register size_t cmdlen = 0;
size_t rlen;
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++;
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_vaxc_errno(retsts);
if (ckWARN(WARN_EXEC)) {
- warner(WARN_EXEC,"Can't exec \"%*s\": %s",
+ 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_vaxc_errno(sts);
if (ckWARN(WARN_EXEC)) {
- warner(WARN_EXEC,"Can't spawn \"%*s\": %s",
+ Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%*s\": %s",
hadcmd ? VMScmd.dsc$w_length : 0,
hadcmd ? VMScmd.dsc$a_pointer : "",
Strerror(errno));
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;
# define RTL_USES_UTC 1
#endif
+/*
+ * DEC C previous to 6.0 corrupts the behavior of the /prefix
+ * qualifier with the extern prefix pragma. This provisional
+ * hack circumvents this prefix pragma problem in previous
+ * precompilers.
+ */
+#if defined(__VMS_VER) && __VMS_VER >= 70000000
+# if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
+# pragma __extern_prefix save
+# pragma __extern_prefix "" /* set to empty to prevent prefixing */
+# define gmtime decc$__utctz_gmtime
+# define localtime decc$__utctz_localtime
+# define time decc$__utc_time
+# pragma __extern_prefix restore
+
+ struct tm *gmtime(), *localtime();
+
+# endif
+#endif
+
+
static time_t toutc_dst(time_t loc) {
struct tm *rsltmp;
if (rsltmp->tm_isdst) loc -= 3600;
return loc;
}
-#define _toutc(secs) ((secs) == -1 ? -1 : \
+#define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
((gmtime_emulation_type || my_time(NULL)), \
(gmtime_emulation_type == 1 ? toutc_dst(secs) : \
((secs) - utc_offset_secs))))
if (rsltmp->tm_isdst) utc += 3600;
return utc;
}
-#define _toloc(secs) ((secs) == -1 ? -1 : \
+#define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
((gmtime_emulation_type || my_time(NULL)), \
(gmtime_emulation_type == 1 ? toloc_dst(secs) : \
((secs) + utc_offset_secs))))
/*{{{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