From: Dan Sugalski Date: Tue, 10 Aug 1999 16:34:56 +0000 (-0700) Subject: Patches needed to get _60 building with X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d28f7c377ae191ca53d9157f124642cf323614a0;p=p5sagit%2Fp5-mst-13.2.git Patches needed to get _60 building with To: vmsperl@perl.org, perl5-porters@perl.org, sarathy@activestate.com, bailey@newman.upenn.edu threads on VMS Message-ID: p4raw-id: //depot/cfgperl@3955 --- diff --git a/ext/Devel/DProf/DProf.xs b/ext/Devel/DProf/DProf.xs index 2917421..e5b7788 100644 --- a/ext/Devel/DProf/DProf.xs +++ b/ext/Devel/DProf/DProf.xs @@ -35,6 +35,7 @@ static U32 dprof_ticks; # include /* prototype for sys$gettim() */ clock_t dprof_times(struct tms *bufptr) { clock_t retval; + dTHX; /* Get wall time and convert to 10 ms intervals to * produce the return value dprof expects */ # if defined(__DECC) && defined (__ALPHA) diff --git a/ext/DynaLoader/dl_vms.xs b/ext/DynaLoader/dl_vms.xs index d83d532..1024c41 100644 --- a/ext/DynaLoader/dl_vms.xs +++ b/ext/DynaLoader/dl_vms.xs @@ -112,6 +112,7 @@ dl_set_error(sts,stv) vmssts stv; { vmssts vec[3]; + dTHX; vec[0] = stv ? 2 : 1; vec[1] = sts; vec[2] = stv; @@ -121,6 +122,7 @@ dl_set_error(sts,stv) static unsigned int findsym_handler(void *sig, void *mech) { + dTHX; unsigned long int myvec[8],args, *usig = (unsigned long int *) sig; /* Be paranoid and assume signal vector passed in might be readonly */ myvec[0] = args = usig[0] > 10 ? 9 : usig[0] - 1; diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs index 9cca0e3..cc3f0c1 100644 --- a/ext/POSIX/POSIX.xs +++ b/ext/POSIX/POSIX.xs @@ -81,6 +81,7 @@ /* The non-POSIX CRTL times() has void return type, so we just get the current time directly */ clock_t vms_times(struct tms *PL_bufptr) { + dTHX; clock_t retval; /* Get wall time and convert to 10 ms intervals to * produce the return value that the POSIX standard expects */ diff --git a/pp.c b/pp.c index 8a0f0f7..3cc9759 100644 --- a/pp.c +++ b/pp.c @@ -28,37 +28,6 @@ static double UV_MAX_cxux = ((double)UV_MAX); #endif /* - * Types used in bitwise operations. - * - * Normally we'd just use IV and UV. However, some hardware and - * software combinations (e.g. Alpha and current OSF/1) don't have a - * floating-point type to use for NV that has adequate bits to fully - * hold an IV/UV. (In other words, sizeof(long) == sizeof(double).) - * - * It just so happens that "int" is the right size almost everywhere. - */ -typedef int IBW; -typedef unsigned UBW; - -/* - * Mask used after bitwise operations. - * - * There is at least one realm (Cray word machines) that doesn't - * have an integral type (except char) small enough to be represented - * in a double without loss; that is, it has no 32-bit type. - */ -#if LONGSIZE > 4 && defined(_CRAY) && !defined(_CRAYMPP) -# define BW_BITS 32 -# define BW_MASK ((1 << BW_BITS) - 1) -# define BW_SIGN (1 << (BW_BITS - 1)) -# define BWi(i) (((i) & BW_SIGN) ? ((i) | ~BW_MASK) : ((i) & BW_MASK)) -# define BWu(u) ((u) & BW_MASK) -#else -# define BWi(i) (i) -# define BWu(u) (u) -#endif - -/* * Offset for integer pack/unpack. * * On architectures where I16 and I32 aren't really 16 and 32 bits, @@ -931,6 +900,7 @@ PP(pp_pow) PP(pp_multiply) { djSP; dATARGET; tryAMAGICbin(mult,opASSIGN); + tryIVIVbin(*); { dPOPTOPnnrl; SETn( left * right ); @@ -941,6 +911,16 @@ PP(pp_multiply) PP(pp_divide) { djSP; dATARGET; tryAMAGICbin(div,opASSIGN); + if (TOPIOKbin) { + dPOPTOPiirl_ul; + if (right == 0) + DIE(aTHX_ "Illegal division by zero"); + if ((left % right) && !(PL_op->op_private & HINT_INTEGER)) + SETn( (NV)left / (NV)right ); + else + SETi( left / right ); + RETURN; + } { dPOPPOPnnrl; NV value; @@ -1120,6 +1100,7 @@ PP(pp_repeat) PP(pp_subtract) { djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); + tryIVIVbin(-); { dPOPTOPnnrl_ul; SETn( left - right ); @@ -1131,16 +1112,14 @@ PP(pp_left_shift) { djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN); { - IBW shift = POPi; + IV shift = POPi; if (PL_op->op_private & HINT_INTEGER) { - IBW i = TOPi; - i = BWi(i) << shift; - SETi(BWi(i)); + IV i = TOPi; + SETi(i << shift); } else { - UBW u = TOPu; - u <<= shift; - SETu(BWu(u)); + UV u = TOPu; + SETu(u << shift); } RETURN; } @@ -1150,16 +1129,14 @@ PP(pp_right_shift) { djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN); { - IBW shift = POPi; + IV shift = POPi; if (PL_op->op_private & HINT_INTEGER) { - IBW i = TOPi; - i = BWi(i) >> shift; - SETi(BWi(i)); + IV i = TOPi; + SETi(i >> shift); } else { - UBW u = TOPu; - u >>= shift; - SETu(BWu(u)); + UV u = TOPu; + SETu(u >> shift); } RETURN; } @@ -1329,12 +1306,12 @@ PP(pp_bit_and) dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { if (PL_op->op_private & HINT_INTEGER) { - IBW value = SvIV(left) & SvIV(right); - SETi(BWi(value)); + IV value = SvIV(left) & SvIV(right); + SETi(value); } else { - UBW value = SvUV(left) & SvUV(right); - SETu(BWu(value)); + UV value = SvUV(left) & SvUV(right); + SETu(value); } } else { @@ -1352,12 +1329,12 @@ PP(pp_bit_xor) dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { if (PL_op->op_private & HINT_INTEGER) { - IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right); - SETi(BWi(value)); + IV value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right); + SETi(value); } else { - UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right); - SETu(BWu(value)); + UV value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right); + SETu(value); } } else { @@ -1375,12 +1352,12 @@ PP(pp_bit_or) dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { if (PL_op->op_private & HINT_INTEGER) { - IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right); - SETi(BWi(value)); + IV value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right); + SETi(value); } else { - UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right); - SETu(BWu(value)); + UV value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right); + SETu(value); } } else { @@ -1441,12 +1418,12 @@ PP(pp_complement) dTOPss; if (SvNIOKp(sv)) { if (PL_op->op_private & HINT_INTEGER) { - IBW value = ~SvIV(sv); - SETi(BWi(value)); + IV value = ~SvIV(sv); + SETi(value); } else { - UBW value = ~SvUV(sv); - SETu(BWu(value)); + UV value = ~SvUV(sv); + SETu(value); } } else { diff --git a/pp.h b/pp.h index 0eac5a5..adf3cc9 100644 --- a/pp.h +++ b/pp.h @@ -143,6 +143,18 @@ #define dPOPTOPiirl dPOPXiirl(TOP) #define dPOPTOPiirl_ul dPOPXiirl_ul(TOP) +#define TOPIOKbin (SvIOK(TOPs) && SvIOK(*(sp-1))) +#define tryIVIVbin(op) \ + if (TOPIOKbin) { \ + dPOPTOPiirl_ul; \ + NV result = (NV)left op (NV)right; \ + if (result >= (NV)IV_MIN && result <= (NV)IV_MAX) \ + SETi( left op right ); \ + else \ + SETn( result ); \ + RETURN; \ + } + #define RETPUSHYES RETURNX(PUSHs(&PL_sv_yes)) #define RETPUSHNO RETURNX(PUSHs(&PL_sv_no)) #define RETPUSHUNDEF RETURNX(PUSHs(&PL_sv_undef)) diff --git a/pp_hot.c b/pp_hot.c index 78f07a1..a7ce618 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -248,6 +248,7 @@ PP(pp_or) PP(pp_add) { djSP; dATARGET; tryAMAGICbin(add,opASSIGN); + tryIVIVbin(+); { dPOPTOPnnrl_ul; SETn( left + right ); diff --git a/vms/vms.c b/vms/vms.c index 031f1c6..0845ff9 100644 --- a/vms/vms.c +++ b/vms/vms.c @@ -109,7 +109,7 @@ vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, #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 dTHR since that relies on the */ + /* 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) { @@ -142,7 +142,7 @@ vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, 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; @@ -179,11 +179,11 @@ vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, if (thr && PL_curcop) { #endif if (ckWARN(WARN_MISC)) { - warner(WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm); + Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm); } #if defined(USE_THREADS) } else { - warner(WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm); + Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm); } #endif @@ -238,7 +238,7 @@ 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; @@ -285,6 +285,7 @@ my_getenv(const char *lnm, bool sys) char * my_getenv_len(const char *lnm, unsigned long *len, bool sys) { + dTHX; char *buf, *cp1, *cp2; unsigned long idx = 0; static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1]; @@ -338,7 +339,7 @@ prime_env_iter(void) * 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; @@ -387,7 +388,7 @@ prime_env_iter(void) 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++; @@ -451,12 +452,12 @@ prime_env_iter(void) 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 */ @@ -477,7 +478,7 @@ prime_env_iter(void) cp1--; /* stop on last non-space char */ } if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) { - warner(WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf); + Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf); continue; } PERL_HASH(hash,key,keylen); @@ -524,6 +525,7 @@ 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); @@ -549,7 +551,7 @@ vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec) 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; } @@ -584,7 +586,7 @@ vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec) 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 } @@ -643,7 +645,7 @@ vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec) /*{{{ 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]; @@ -757,6 +759,7 @@ kill_file(char *name) 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; @@ -858,6 +861,7 @@ int 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, @@ -879,6 +883,7 @@ create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc) { static unsigned long int mbxbufsiz; long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM; + dTHX; if (!mbxbufsiz) { /* @@ -929,6 +934,7 @@ 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 @@ -954,6 +960,7 @@ pipe_exit_routine() 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 @@ -1021,6 +1028,7 @@ safe_popen(char *cmd, char *mode) 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}, @@ -1078,7 +1086,7 @@ safe_popen(char *cmd, char *mode) /*{{{ 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"); @@ -1089,7 +1097,7 @@ my_popen(char *cmd, char *mode) /*}}}*/ /*{{{ 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; @@ -1127,7 +1135,7 @@ Pid_t my_waitpid(Pid_t pid, int *statusp, int flags) { struct pipe_details *info; - dTHR; + dTHX; for (info = open_pipes; info != NULL; info = info->next) if (info->pid == pid) break; @@ -1150,7 +1158,7 @@ my_waitpid(Pid_t pid, int *statusp, int flags) _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)); @@ -2746,6 +2754,7 @@ vms_image_init(int *argcp, char ***argvp) 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}, @@ -3093,6 +3102,7 @@ collectversions(dd) char *p, *text, buff[sizeof dd->entry.d_name]; int i; unsigned long context, tmpsts; + dTHX; /* Convenient shorthand. */ e = &dd->entry; @@ -3208,6 +3218,7 @@ void seekdir(DIR *dd, long count) { int vms_wantversions; + dTHX; /* If we haven't done anything yet... */ if (dd->count == 0) @@ -3288,7 +3299,7 @@ vms_execfree() { static char * setup_argstr(SV *really, SV **mark, SV **sp) { - dTHR; + dTHX; char *junk, *tmps = Nullch; register size_t cmdlen = 0; size_t rlen; @@ -3340,6 +3351,7 @@ setup_cmddsc(char *cmd, int check_img) 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++; @@ -3402,12 +3414,12 @@ setup_cmddsc(char *cmd, int check_img) 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); @@ -3426,11 +3438,11 @@ bool vms_do_exec(char *cmd) { - dTHR; + 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); @@ -3462,7 +3474,7 @@ vms_do_exec(char *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(); @@ -3479,7 +3491,7 @@ unsigned long int do_spawn(char *); 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; @@ -3491,7 +3503,7 @@ unsigned long int do_spawn(char *cmd) { unsigned long int sts, substs, hadcmd = 1; - dTHR; + dTHX; TAINT_ENV(); TAINT_PROPER("spawn"); @@ -3522,7 +3534,7 @@ do_spawn(char *cmd) } 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)); @@ -3637,6 +3649,7 @@ static char __pw_namecache[UAI$S_IDENT+1]; */ static int fillpasswd (const char *name, struct passwd *pwd) { + dTHX; static struct { unsigned char length; char pw_gecos[UAI$S_OWNER+1]; @@ -3695,7 +3708,7 @@ static int fillpasswd (const char *name, struct passwd *pwd) 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; @@ -3721,6 +3734,7 @@ struct passwd *my_getpwnam(char *name) struct dsc$descriptor_s name_desc; union uicdef uic; unsigned long int status, sts; + dTHX; __pwdcache = __passwd_empty; if (!fillpasswd(name, &__pwdcache)) { @@ -3760,6 +3774,7 @@ struct passwd *my_getpwuid(Uid_t uid) unsigned short lname; union uicdef uic; unsigned long int status; + dTHX; if (uid == (unsigned int) -1) { do { @@ -3821,6 +3836,7 @@ struct passwd *my_getpwent() /*{{{void my_endpwent()*/ void my_endpwent() { + dTHX; if (contxt) { _ckvmssts(sys$finish_rdb(&contxt)); contxt= 0; @@ -3990,7 +4006,7 @@ static time_t toloc_dst(time_t utc) { /*{{{time_t my_time(time_t *timep)*/ time_t my_time(time_t *timep) { - dTHR; + dTHX; time_t when; struct tm *tm_p; @@ -4007,7 +4023,7 @@ time_t my_time(time_t *timep) 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); } } @@ -4043,7 +4059,7 @@ time_t my_time(time_t *timep) struct tm * my_gmtime(const time_t *timep) { - dTHR; + dTHX; char *p; time_t when; struct tm *rsltmp; @@ -4074,7 +4090,7 @@ my_gmtime(const time_t *timep) struct tm * my_localtime(const time_t *timep) { - dTHR; + dTHX; time_t when; struct tm *rsltmp; @@ -4131,7 +4147,7 @@ static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 }; /*{{{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 */ @@ -4315,6 +4331,7 @@ static mydev_t encode_dev (const char *dev) mydev_t enc; char c; const char *q; + dTHX; if (!dev || !dev[0]) return 0; @@ -4360,6 +4377,7 @@ static int 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 @@ -4380,9 +4398,8 @@ is_null_device(name) */ /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/ I32 -cando(I32 bit, I32 effective, Stat_t *statbufp) +Perl_cando(pTHX_ I32 bit, I32 effective, Stat_t *statbufp) { - dTHR; if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache); else { char fname[NAM$C_MAXRSS+1]; @@ -4404,7 +4421,7 @@ cando(I32 bit, I32 effective, Stat_t *statbufp) 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); @@ -4424,6 +4441,7 @@ cando_by_name(I32 bit, I32 effective, char *fname) 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}, @@ -4516,7 +4534,7 @@ cando_by_name(I32 bit, I32 effective, char *fname) 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); @@ -4550,7 +4568,7 @@ flex_fstat(int fd, Stat_t *statbufp) int 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; @@ -4819,14 +4837,14 @@ rmscopy(char *spec_in, char *spec_out, int preserve_dates) */ 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); @@ -4838,13 +4856,13 @@ rmsexpand_fromperl(CV *cv) } 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)); @@ -4852,13 +4870,13 @@ vmsify_fromperl(CV *cv) } 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)); @@ -4866,13 +4884,13 @@ unixify_fromperl(CV *cv) } 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)); @@ -4880,13 +4898,13 @@ fileify_fromperl(CV *cv) } 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)); @@ -4894,13 +4912,13 @@ pathify_fromperl(CV *cv) } 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)); @@ -4908,13 +4926,13 @@ vmspath_fromperl(CV *cv) } 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)); @@ -4922,7 +4940,7 @@ unixpath_fromperl(CV *cv) } void -candelete_fromperl(CV *cv) +candelete_fromperl(pTHX_ CV *cv) { dXSARGS; char fspec[NAM$C_MAXRSS+1], *fsp; @@ -4930,7 +4948,7 @@ candelete_fromperl(CV *cv) 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) { @@ -4954,7 +4972,7 @@ candelete_fromperl(CV *cv) } void -rmscopy_fromperl(CV *cv) +rmscopy_fromperl(pTHX_ CV *cv) { dXSARGS; char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp; @@ -4967,7 +4985,7 @@ rmscopy_fromperl(CV *cv) 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) { @@ -5011,6 +5029,7 @@ void init_os_extras() { char* file = __FILE__; + dTHX; newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$"); newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$"); diff --git a/vms/vmsish.h b/vms/vmsish.h index 709e34e..1f7e2c9 100644 --- a/vms/vmsish.h +++ b/vms/vmsish.h @@ -93,11 +93,16 @@ /* Our own contribution to PerlShr's global symbols . . . */ #define vmstrnenv Perl_vmstrnenv #define my_trnlnm Perl_my_trnlnm -#define my_getenv Perl_my_getenv #define my_getenv_len Perl_my_getenv_len #define prime_env_iter Perl_prime_env_iter #define vmssetenv Perl_vmssetenv +#if !defined(PERL_IMPLICIT_CONTEXT) #define my_setenv Perl_my_setenv +#define my_getenv Perl_my_getenv +#else +#define my_setenv(a,b) Perl_my_setenv(aTHX_ a,b) +#define my_getenv(a,b) Perl_my_getenv(aTHX_ a,b) +#endif #define my_crypt Perl_my_crypt #define my_waitpid Perl_my_waitpid #define my_gconvert Perl_my_gconvert @@ -225,7 +230,7 @@ #define _ckvmssts(call) STMT_START { register unsigned long int __ckvms_sts; \ if (!((__ckvms_sts=(call))&1)) { \ set_errno(EVMSERR); set_vaxc_errno(__ckvms_sts); \ - croak("Fatal VMS error (status=%d) at %s, line %d", \ + Perl_croak(aTHX_ "Fatal VMS error (status=%d) at %s, line %d", \ __ckvms_sts,__FILE__,__LINE__); } } STMT_END /* Same thing, but don't call back to Perl's croak(); useful for errors @@ -584,7 +589,11 @@ void init_os_extras (); typedef char __VMS_PROTOTYPES__; int vmstrnenv (const char *, char *, unsigned long int, struct dsc$descriptor_s **, unsigned long int); int my_trnlnm (const char *, char *, unsigned long int); -char * my_getenv (const char *, bool); +#if !defined(PERL_IMPLICIT_CONTEXT) +char * Perl_my_getenv (const char *, bool); +#else +char * Perl_my_getenv (pTHX_ const char *, bool); +#endif char * my_getenv_len (const char *, unsigned long *, bool); int vmssetenv (char *, char *, struct dsc$descriptor_s **); char * my_crypt (const char *, const char *); diff --git a/vms/writemain.pl b/vms/writemain.pl index b08bf1d..1843b30 100644 --- a/vms/writemain.pl +++ b/vms/writemain.pl @@ -34,7 +34,7 @@ if (!$ok) { print OUT <<'EOH'; static void -xs_init() +xs_init(pTHX) { EOH @@ -50,7 +50,7 @@ if (@exts) { foreach $ext (@exts) { my($subname) = $ext; $subname =~ s/::/__/g; - print OUT "extern void boot_${subname} (CV* cv);\n" + print OUT "extern void boot_${subname} (pTHX_ CV* cv);\n" } # May not actually be a declaration, so put after other declarations print OUT " dXSUB_SYS;\n";