diff options
| -rw-r--r-- | doio.c | 4 | ||||
| -rw-r--r-- | ext/File/Glob/bsd_glob.c | 2 | ||||
| -rw-r--r-- | perl.c | 4 | ||||
| -rw-r--r-- | perl.h | 2 | ||||
| -rw-r--r-- | pp_sys.c | 4 | ||||
| -rw-r--r-- | thread.h | 4 | ||||
| -rw-r--r-- | vms/vms.c | 296 | ||||
| -rw-r--r-- | vms/vmsish.h | 163 |
8 files changed, 268 insertions, 211 deletions
@@ -565,8 +565,8 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, if (savefd != PerlIO_fileno(PerlIO_stdin())) { char newname[FILENAME_MAX+1]; if (fgetname(fp, newname)) { - if (savefd == PerlIO_fileno(PerlIO_stdout())) Perl_vmssetuserlnm("SYS$OUTPUT", newname); - if (savefd == PerlIO_fileno(PerlIO_stderr())) Perl_vmssetuserlnm("SYS$ERROR", newname); + if (fd == PerlIO_fileno(PerlIO_stdout())) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT", newname); + if (fd == PerlIO_fileno(PerlIO_stderr())) Perl_vmssetuserlnm(aTHX_ "SYS$ERROR", newname); } } #endif diff --git a/ext/File/Glob/bsd_glob.c b/ext/File/Glob/bsd_glob.c index 0ea502ad1b..3c3ae40048 100644 --- a/ext/File/Glob/bsd_glob.c +++ b/ext/File/Glob/bsd_glob.c @@ -73,7 +73,7 @@ static char sscsid[]= "$OpenBSD: glob.c,v 1.8.10.1 2001/04/10 jason Exp $"; #ifdef I_PWD # include <pwd.h> #else -#ifdef HAS_PASSWD +#if defined(HAS_PASSWD) && !defined(VMS) struct passwd *getpwnam(char *); struct passwd *getpwuid(Uid_t); #endif @@ -1304,7 +1304,11 @@ print \" \\@INC:\\n @INC\\n\";"); (*xsinit)(aTHXo); /* in case linked C routines want magical variables */ #ifndef PERL_MICRO #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC) +# if defined(VMS) + init_os_extras(aTHXo); +# else init_os_extras(); +# endif #endif #endif @@ -2357,7 +2357,7 @@ END_EXTERN_C # if defined(NeXT) || defined(__NeXT__) /* or whatever catches all NeXTs */ char *crypt (); /* Maybe more hosts will need the unprototyped version */ # else -# if !defined(WIN32) +# if !defined(WIN32) && !defined(VMS) char *crypt (const char*, const char*); # endif /* !WIN32 */ # endif /* !NeXT && !__NeXT__ */ @@ -70,8 +70,10 @@ extern int h_errno; # ifdef I_PWD # include <pwd.h> # else +# if !defined(VMS) struct passwd *getpwnam (char *); struct passwd *getpwuid (Uid_t); +# endif # endif # ifdef HAS_GETPWENT struct passwd *getpwent (void); @@ -3697,7 +3699,7 @@ PP(pp_readdir) { dSP; #if defined(Direntry_t) && defined(HAS_READDIR) -#ifndef I_DIRENT +#if !defined(I_DIRENT) && !defined(VMS) Direntry_t *readdir (DIR *); #endif register Direntry_t *dp; @@ -1,5 +1,9 @@ #if defined(USE_THREADS) || defined(USE_ITHREADS) +#if defined(VMS) +#include <builtins.h> +#endif + #ifdef WIN32 # include <win32thread.h> #else @@ -129,7 +129,7 @@ static int tz_updated = 1; /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */ int -Perl_vmstrnenv(pTHX_ const char *lnm, char *eqv, unsigned long int idx, +Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) { char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2; @@ -142,17 +142,26 @@ Perl_vmstrnenv(pTHX_ 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) +#if defined(PERL_IMPLICIT_CONTEXT) + pTHX = NULL; +# if defined(USE_5005THREADS) /* 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); + aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv); + } else { + aTHX = NULL; + } +# else + if (PL_curinterp) { + aTHX = PERL_GET_INTERP; } else { - thr = NULL; + aTHX = NULL; } + +# endif #endif if (!lnm || !eqv || idx > PERL_LNM_MAX_ALLOWED_INDEX) { @@ -344,9 +353,8 @@ Perl_my_getenv(pTHX_ 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) +Perl_my_getenv_len(pTHX_ 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]; @@ -398,7 +406,7 @@ my_getenv_len(const char *lnm, unsigned long *len, bool sys) } /* end of my_getenv_len() */ /*}}}*/ -static void create_mbx(unsigned short int *, struct dsc$descriptor_s *); +static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *); static void riseandshine(unsigned long int dummy) { sys$wake(0,0); } @@ -409,7 +417,6 @@ prime_env_iter(void) * find, in preparation for iterating over it. */ { - dTHX; static int primed = 0; HV *seenhv = NULL, *envhv; char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch; @@ -426,11 +433,34 @@ prime_env_iter(void) $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES"); $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM"); $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam); +#if defined(PERL_IMPLICIT_CONTEXT) + pTHX; +#endif #if defined(USE_THREADS) || defined(USE_ITHREADS) static perl_mutex primenv_mutex; MUTEX_INIT(&primenv_mutex); #endif +#if defined(PERL_IMPLICIT_CONTEXT) + /* 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 */ +#if defined(USE_5005THREADS) + if (PL_curinterp) { + aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv); + } else { + aTHX = NULL; + } +#else + if (PL_curinterp) { + aTHX = PERL_GET_INTERP; + } else { + aTHX = NULL; + } +#endif +#endif + if (primed || !PL_envgv) return; MUTEX_LOCK(&primenv_mutex); if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; } @@ -585,7 +615,7 @@ prime_env_iter(void) * Like setenv() returns 0 for success, non-zero on error. */ int -vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec) +Perl_vmssetenv(pTHX_ char *lnm, char *eqv, struct dsc$descriptor_s **tabvec) { char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2; unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0; @@ -595,7 +625,6 @@ 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); @@ -755,7 +784,7 @@ Perl_my_setenv(pTHX_ char *lnm,char *eqv) * used for redirection of sys$error */ void -Perl_vmssetuserlnm(char *name, char *eqv) +Perl_vmssetuserlnm(pTHX_ char *name, char *eqv) { $DESCRIPTOR(d_tab, "LNM$PROCESS"); struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0}; @@ -786,7 +815,7 @@ Perl_vmssetuserlnm(char *name, char *eqv) * be upcased by the caller. */ char * -my_crypt(const char *textpasswd, const char *usrname) +Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname) { # ifndef UAI$C_PREFERRED_ALGORITHM # define UAI$C_PREFERRED_ALGORITHM 127 @@ -866,12 +895,11 @@ Perl_do_rmdir(pTHX_ char *name) */ /*{{{int kill_file(char *name)*/ int -kill_file(char *name) +Perl_kill_file(pTHX_ 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; @@ -968,10 +996,9 @@ kill_file(char *name) /*{{{int my_mkdir(char *,Mode_t)*/ int -my_mkdir(char *dir, Mode_t mode) +Perl_my_mkdir(pTHX_ char *dir, Mode_t mode) { STRLEN dirlen = strlen(dir); - dTHX; /* zero length string sometimes gives ACCVIO */ if (dirlen == 0) return -1; @@ -992,10 +1019,9 @@ my_mkdir(char *dir, Mode_t mode) /*{{{int my_chdir(char *)*/ int -my_chdir(char *dir) +Perl_my_chdir(pTHX_ char *dir) { STRLEN dirlen = strlen(dir); - dTHX; /* zero length string sometimes gives ACCVIO */ if (dirlen == 0) return -1; @@ -1022,7 +1048,6 @@ my_tmpfile(void) { FILE *fp; char *cp; - dTHX; if ((fp = tmpfile())) return fp; @@ -1041,12 +1066,11 @@ my_tmpfile(void) static void -create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc) +create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc) { unsigned long int mbxbufsiz; static unsigned long int syssize = 0; unsigned long int dviitm = DVI$_DEVNAM; - dTHX; char csize[LNM$C_NAMLENGTH+1]; if (!syssize) { @@ -1131,6 +1155,10 @@ struct _pipe { pInfo info; pCBuf curr; pCBuf curr2; +#if defined(PERL_IMPLICIT_CONTEXT) + void *thx; /* Either a thread or an interpreter */ + /* pointer, depending on how we're built */ +#endif }; @@ -1172,12 +1200,11 @@ static $DESCRIPTOR(nl_desc, "NL:"); static unsigned long int -pipe_exit_routine() +pipe_exit_routine(pTHX) { pInfo info; unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT; int sts, did_stuff, need_eof; - dTHX; /* first we try sending an EOF...ignore if doesn't work, make sure we @@ -1242,7 +1269,6 @@ static void pipe_tochild2_ast(pPipe p); static void popen_completion_ast(pInfo info) { - dTHX; pInfo i = open_pipes; int iss; @@ -1274,9 +1300,9 @@ popen_completion_ast(pInfo info) if (info->in && !info->in_done) { /* only for mode=w */ if (info->in->shut_on_empty && info->in->need_wake) { info->in->need_wake = FALSE; - _ckvmssts(sys$dclast(pipe_tochild2_ast,info->in,0)); + _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0)); } else { - _ckvmssts(sys$cancel(info->in->chan_out)); + _ckvmssts_noperl(sys$cancel(info->in->chan_out)); } } @@ -1284,20 +1310,20 @@ popen_completion_ast(pInfo info) info->out->shut_on_empty = TRUE; iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0); if (iss == SS$_MBFULL) iss = SS$_NORMAL; - _ckvmssts(iss); + _ckvmssts_noperl(iss); } if (info->err && !info->err_done) { /* we were piping stderr */ info->err->shut_on_empty = TRUE; iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0); if (iss == SS$_MBFULL) iss = SS$_NORMAL; - _ckvmssts(iss); + _ckvmssts_noperl(iss); } - _ckvmssts(sys$setef(pipe_ef)); + _ckvmssts_noperl(sys$setef(pipe_ef)); } -static unsigned long int setup_cmddsc(char *cmd, int check_img); +static unsigned long int setup_cmddsc(pTHX_ char *cmd, int check_img); static void vms_execfree(pTHX); /* @@ -1307,7 +1333,7 @@ static void vms_execfree(pTHX); */ static unsigned short -popen_translate(char *logical, char *result) +popen_translate(pTHX_ char *logical, char *result) { int iss; $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE"); @@ -1367,9 +1393,8 @@ static void pipe_infromchild_ast(pPipe p); #define INITIAL_TOCHILDQUEUE 2 static pPipe -pipe_tochild_setup(char *rmbx, char *wmbx) +pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx) { - dTHX; pPipe p; pCBuf b; char mbx1[64], mbx2[64]; @@ -1382,8 +1407,8 @@ pipe_tochild_setup(char *rmbx, char *wmbx) New(1368, p, 1, Pipe); - create_mbx(&p->chan_in , &d_mbx1); - create_mbx(&p->chan_out, &d_mbx2); + 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)); p->buf = 0; @@ -1398,6 +1423,9 @@ pipe_tochild_setup(char *rmbx, char *wmbx) p->curr = 0; p->curr2 = 0; p->info = 0; +#ifdef PERL_IMPLICIT_CONTEXT + p->thx = aTHX; +#endif n = sizeof(CBuf) + p->bufsize; @@ -1419,10 +1447,12 @@ pipe_tochild_setup(char *rmbx, char *wmbx) static void pipe_tochild1_ast(pPipe p) { - dTHX; pCBuf b = p->curr; int iss = p->iosb.status; int eof = (iss == SS$_ENDOFFILE); +#ifdef PERL_IMPLICIT_CONTEXT + pTHX = p->thx; +#endif if (p->retry) { if (eof) { @@ -1479,12 +1509,14 @@ pipe_tochild1_ast(pPipe p) static void pipe_tochild2_ast(pPipe p) { - dTHX; pCBuf b = p->curr2; int iss = p->iosb2.status; int n = sizeof(CBuf) + p->bufsize; int done = (p->info && p->info->done) || iss == SS$_CANCEL || iss == SS$_ABORT; +#if defined(PERL_IMPLICIT_CONTEXT) + pTHX = p->thx; +#endif do { if (p->type) { /* type=1 has old buffer, dispose */ @@ -1532,9 +1564,8 @@ pipe_tochild2_ast(pPipe p) static pPipe -pipe_infromchild_setup(char *rmbx, char *wmbx) +pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx) { - dTHX; pPipe p; char mbx1[64], mbx2[64]; struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T, @@ -1544,8 +1575,8 @@ pipe_infromchild_setup(char *rmbx, char *wmbx) unsigned int dviitm = DVI$_DEVBUFSIZ; New(1367, p, 1, Pipe); - create_mbx(&p->chan_in , &d_mbx1); - create_mbx(&p->chan_out, &d_mbx2); + 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)); New(1367, p->buf, p->bufsize, char); @@ -1553,6 +1584,9 @@ pipe_infromchild_setup(char *rmbx, char *wmbx) p->info = 0; p->type = 0; p->iosb.status = SS$_NORMAL; +#if defined(PERL_IMPLICIT_CONTEXT) + p->thx = aTHX; +#endif pipe_infromchild_ast(p); strcpy(wmbx, mbx1); @@ -1563,11 +1597,13 @@ pipe_infromchild_setup(char *rmbx, char *wmbx) static void pipe_infromchild_ast(pPipe p) { - dTHX; int iss = p->iosb.status; int eof = (iss == SS$_ENDOFFILE); int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0)); int kideof = (eof && (p->iosb.dvispec == p->info->pid)); +#if defined(PERL_IMPLICIT_CONTEXT) + pTHX = p->thx; +#endif if (p->info && p->info->closing && p->chan_out) { /* output shutdown */ _ckvmssts(sys$dassgn(p->chan_out)); @@ -1639,9 +1675,8 @@ pipe_infromchild_ast(pPipe p) } static pPipe -pipe_mbxtofd_setup(int fd, char *out) +pipe_mbxtofd_setup(pTHX_ int fd, char *out) { - dTHX; pPipe p; char mbx[64]; unsigned long dviitm = DVI$_DEVBUFSIZ; @@ -1664,7 +1699,7 @@ pipe_mbxtofd_setup(int fd, char *out) New(1366, p, 1, Pipe); p->fd_out = dup(fd); - create_mbx(&p->chan_in, &d_mbx); + create_mbx(aTHX_ &p->chan_in, &d_mbx); _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize)); New(1366, p->buf, p->bufsize+1, char); p->shut_on_empty = FALSE; @@ -1682,14 +1717,15 @@ pipe_mbxtofd_setup(int fd, char *out) static void pipe_mbxtofd_ast(pPipe p) { - dTHX; int iss = p->iosb.status; int done = p->info->done; int iss2; int eof = (iss == SS$_ENDOFFILE); int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0)); int err = !(iss&1) && !eof; - +#if defined(PERL_IMPLICIT_CONTEXT) + pTHX = p->thx; +#endif if (done && myeof) { /* end piping */ close(p->fd_out); @@ -1733,7 +1769,7 @@ struct _pipeloc { static pPLOC head_PLOC = 0; void -free_pipelocs(void *head) +free_pipelocs(pTHX_ void *head) { pPLOC p, pnext; @@ -1746,7 +1782,7 @@ free_pipelocs(void *head) } static void -store_pipelocs() +store_pipelocs(pTHX) { int i; pPLOC p; @@ -1810,12 +1846,12 @@ store_pipelocs() p->dir[NAM$C_MAXRSS] = '\0'; } #endif - Perl_call_atexit(&free_pipelocs, head_PLOC); + Perl_call_atexit(aTHX_ &free_pipelocs, head_PLOC); } static char * -find_vmspipe(void) +find_vmspipe(pTHX) { static int vmspipe_file_status = 0; static char vmspipe_file[NAM$C_MAXRSS+1]; @@ -1857,7 +1893,7 @@ find_vmspipe(void) } static FILE * -vmspipe_tempfile(void) +vmspipe_tempfile(pTHX) { char file[NAM$C_MAXRSS+1]; FILE *fp; @@ -1936,9 +1972,8 @@ vmspipe_tempfile(void) static PerlIO * -safe_popen(char *cmd, char *mode) +safe_popen(pTHX_ char *cmd, char *mode) { - dTHX; static int handler_set_up = FALSE; unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */ unsigned int table = LIB$K_CLI_GLOBAL_SYM; @@ -1986,11 +2021,11 @@ safe_popen(char *cmd, char *mode) /* see if we can find a VMSPIPE.COM */ tfilebuf[0] = '@'; - vmspipe = find_vmspipe(); + vmspipe = find_vmspipe(aTHX); if (vmspipe) { strcpy(tfilebuf+1,vmspipe); } else { /* uh, oh...we're in tempfile hell */ - tpipe = vmspipe_tempfile(); + tpipe = vmspipe_tempfile(aTHX); if (!tpipe) { /* a fish popular in Boston */ if (ckWARN(WARN_PIPE)) { Perl_warner(aTHX_ WARN_PIPE,"unable to find VMSPIPE.COM for i/o piping"); @@ -2002,7 +2037,7 @@ safe_popen(char *cmd, char *mode) vmspipedsc.dsc$a_pointer = tfilebuf; vmspipedsc.dsc$w_length = strlen(tfilebuf); - if (!(setup_cmddsc(cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; } + if (!(setup_cmddsc(aTHX_ cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; } New(1301,info,1,Info); info->mode = *mode; @@ -2019,7 +2054,7 @@ safe_popen(char *cmd, char *mode) if (*mode == 'r') { /* piping from subroutine */ - info->out = pipe_infromchild_setup(mbx,out); + info->out = pipe_infromchild_setup(aTHX_ mbx,out); if (info->out) { info->out->pipe_done = &info->out_done; info->out_done = FALSE; @@ -2044,7 +2079,7 @@ safe_popen(char *cmd, char *mode) return Nullfp; } - info->err = pipe_mbxtofd_setup(fileno(stderr), err); + info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err); if (info->err) { info->err->pipe_done = &info->err_done; info->err_done = FALSE; @@ -2053,7 +2088,7 @@ safe_popen(char *cmd, char *mode) } else { /* piping to subroutine , mode=w*/ - info->in = pipe_tochild_setup(in,mbx); + info->in = pipe_tochild_setup(aTHX_ in,mbx); info->fp = PerlIO_open(mbx, mode); if (info->in) { info->in->pipe_done = &info->in_done; @@ -2083,14 +2118,14 @@ safe_popen(char *cmd, char *mode) } - info->out = pipe_mbxtofd_setup(fileno(stdout), out); + info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out); if (info->out) { info->out->pipe_done = &info->out_done; info->out_done = FALSE; info->out->info = info; } - info->err = pipe_mbxtofd_setup(fileno(stderr), err); + info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err); if (info->err) { info->err->pipe_done = &info->err_done; info->err_done = FALSE; @@ -2156,7 +2191,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) TAINT_ENV(); TAINT_PROPER("popen"); PERL_FLUSHALL_FOR_CHILD; - return safe_popen(cmd,mode); + return safe_popen(aTHX_ cmd,mode); } /*}}}*/ @@ -2164,7 +2199,6 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) /*{{{ I32 my_pclose(FILE *fp)*/ I32 Perl_my_pclose(pTHX_ FILE *fp) { - dTHX; pInfo info, last = NULL; unsigned long int retsts; int done, iss; @@ -2250,11 +2284,10 @@ I32 Perl_my_pclose(pTHX_ FILE *fp) /* sort-of waitpid; use only with popen() */ /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/ Pid_t -my_waitpid(Pid_t pid, int *statusp, int flags) +Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags) { pInfo info; int done; - dTHX; for (info = open_pipes; info != NULL; info = info->next) if (info->pid == pid) break; @@ -3407,7 +3440,7 @@ static void mp_expand_wild_cards(pTHX_ char *item, static int background_process(int argc, char **argv); -static void pipe_and_fork(char **cmargv); +static void pipe_and_fork(pTHX_ char **cmargv); /*{{{ void getredirection(int *ac, char ***av)*/ static void @@ -3571,7 +3604,7 @@ mp_getredirection(pTHX_ int *ac, char ***av) PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line"); exit(LIB$_INVARGORD); } - pipe_and_fork(cmargv); + pipe_and_fork(aTHX_ cmargv); } /* Check for input from a pipe (mailbox) */ @@ -3615,12 +3648,12 @@ mp_getredirection(pTHX_ int *ac, char ***av) PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out); exit(vaxc$errno); } - if (out != NULL) Perl_vmssetuserlnm("SYS$OUTPUT",out); + if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out); if (err != NULL) { if (strcmp(err,"&1") == 0) { dup2(fileno(stdout), fileno(Perl_debug_log)); - Perl_vmssetuserlnm("SYS$ERROR","SYS$OUTPUT"); + Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT"); } else { FILE *tmperr; if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2"))) @@ -3633,7 +3666,7 @@ mp_getredirection(pTHX_ int *ac, char ***av) { exit(vaxc$errno); } - Perl_vmssetuserlnm("SYS$ERROR",err); + Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err); } } #ifdef ARGPROC_DEBUG @@ -3804,7 +3837,7 @@ static struct exit_control_block exit_block = 0 }; -static void pipe_and_fork(char **cmargv) +static void pipe_and_fork(pTHX_ char **cmargv) { char subcmd[2048]; $DESCRIPTOR(cmddsc, ""); @@ -3823,7 +3856,7 @@ static void pipe_and_fork(char **cmargv) cmddsc.dsc$a_pointer = subcmd; cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer); - create_mbx(&child_chan,&mbxdsc); + create_mbx(aTHX_ &child_chan,&mbxdsc); #ifdef ARGPROC_DEBUG PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer); PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer); @@ -3903,17 +3936,19 @@ 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; +#if defined(PERL_IMPLICIT_CONTEXT) + pTHX = NULL; +#endif struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy}, {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen}, { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy}, { 0, 0, 0, 0} }; - _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL)); - _ckvmssts(iosb[0]); + _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++) { if (iprv[i]) { /* Running image installed with privs? */ - _ckvmssts(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */ + _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */ will_taint = TRUE; break; } @@ -3938,8 +3973,8 @@ vms_image_init(int *argcp, char ***argvp) if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr); jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int); jpilist[1].buflen = rsz * sizeof(unsigned long int); - _ckvmssts(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL)); - _ckvmssts(iosb[0]); + _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL)); + _ckvmssts_noperl(iosb[0]); } mask = jpilist[1].bufadr; /* Check attribute flags for each identifier (2nd longword); protected @@ -3995,7 +4030,7 @@ vms_image_init(int *argcp, char ***argvp) tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T; tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D; tabvec[tabidx]->dsc$a_pointer = NULL; - _ckvmssts(lib$scopy_r_dx(&len,eqv,tabvec[tabidx])); + _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx])); } if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; } @@ -4251,8 +4286,7 @@ closedir(DIR *dd) * Collect all the version numbers for the current file. */ static void -collectversions(dd) - DIR *dd; +collectversions(pTHX_ DIR *dd) { struct dsc$descriptor_s pat; struct dsc$descriptor_s res; @@ -4260,7 +4294,6 @@ collectversions(dd) char *p, *text, buff[sizeof dd->entry.d_name]; int i; unsigned long context, tmpsts; - dTHX; /* Convenient shorthand. */ e = &dd->entry; @@ -4307,7 +4340,7 @@ collectversions(dd) */ /*{{{ struct dirent *readdir(DIR *dd)*/ struct dirent * -readdir(DIR *dd) +Perl_readdir(pTHX_ DIR *dd) { struct dsc$descriptor_s res; char *p, buff[sizeof dd->entry.d_name]; @@ -4352,7 +4385,7 @@ readdir(DIR *dd) dd->entry.d_namlen = strlen(dd->entry.d_name); dd->entry.vms_verscount = 0; - if (dd->vms_wantversions) collectversions(dd); + if (dd->vms_wantversions) collectversions(aTHX_ dd); return &dd->entry; } /* end of readdir() */ @@ -4374,10 +4407,9 @@ telldir(DIR *dd) */ /*{{{ void seekdir(DIR *dd,long count)*/ void -seekdir(DIR *dd, long count) +Perl_seekdir(pTHX_ DIR *dd, long count) { int vms_wantversions; - dTHX; /* If we haven't done anything yet... */ if (dd->count == 0) @@ -4454,9 +4486,8 @@ vms_execfree(pTHX) { } static char * -setup_argstr(SV *really, SV **mark, SV **sp) +setup_argstr(pTHX_ SV *really, SV **mark, SV **sp) { - dTHX; char *junk, *tmps = Nullch; register size_t cmdlen = 0; size_t rlen; @@ -4499,7 +4530,7 @@ setup_argstr(SV *really, SV **mark, SV **sp) static unsigned long int -setup_cmddsc(char *cmd, int check_img) +setup_cmddsc(pTHX_ char *cmd, int check_img) { char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1]; $DESCRIPTOR(defdsc,".EXE"); @@ -4509,7 +4540,6 @@ setup_cmddsc(char *cmd, int check_img) unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL; register char *s, *rest, *cp, *wordbreak; register int isdcl; - dTHX; if (strlen(cmd) > (sizeof(vmsspec) > sizeof(resspec) ? sizeof(resspec) : sizeof(vmsspec))) @@ -4624,9 +4654,8 @@ setup_cmddsc(char *cmd, int check_img) /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */ bool -vms_do_aexec(SV *really,SV **mark,SV **sp) +Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp) { - dTHX; if (sp > mark) { if (vfork_called) { /* this follows a vfork - act Unixish */ vfork_called--; @@ -4637,7 +4666,7 @@ vms_do_aexec(SV *really,SV **mark,SV **sp) else return do_aexec(really,mark,sp); } /* no vfork - act VMSish */ - return vms_do_exec(setup_argstr(really,mark,sp)); + return vms_do_exec(setup_argstr(aTHX_ really,mark,sp)); } @@ -4647,10 +4676,9 @@ vms_do_aexec(SV *really,SV **mark,SV **sp) /* {{{bool vms_do_exec(char *cmd) */ bool -vms_do_exec(char *cmd) +Perl_vms_do_exec(pTHX_ char *cmd) { - dTHX; if (vfork_called) { /* this follows a vfork - act Unixish */ vfork_called--; if (vfork_called < 0) { @@ -4665,7 +4693,7 @@ vms_do_exec(char *cmd) TAINT_ENV(); TAINT_PROPER("exec"); - if ((retsts = setup_cmddsc(cmd,1)) & 1) + if ((retsts = setup_cmddsc(aTHX_ cmd,1)) & 1) retsts = lib$do_command(&VMScmd); switch (retsts) { @@ -4699,14 +4727,13 @@ vms_do_exec(char *cmd) } /* end of vms_do_exec() */ /*}}}*/ -unsigned long int do_spawn(char *); +unsigned long int Perl_do_spawn(pTHX_ char *); /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */ unsigned long int -do_aspawn(void *really,void **mark,void **sp) +Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp) { - dTHX; - if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp)); + if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp)); return SS$_ABORT; } /* end of do_aspawn() */ @@ -4714,10 +4741,9 @@ do_aspawn(void *really,void **mark,void **sp) /* {{{unsigned long int do_spawn(char *cmd) */ unsigned long int -do_spawn(char *cmd) +Perl_do_spawn(pTHX_ char *cmd) { unsigned long int sts, substs, hadcmd = 1; - dTHX; TAINT_ENV(); TAINT_PROPER("spawn"); @@ -4725,7 +4751,7 @@ do_spawn(char *cmd) hadcmd = 0; sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0); } - else if ((sts = setup_cmddsc(cmd,0)) & 1) { + else if ((sts = setup_cmddsc(aTHX_ cmd,0)) & 1) { sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0); } @@ -4861,7 +4887,7 @@ my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest) /*{{{ int my_flush(FILE *fp)*/ int -my_flush(FILE *fp) +Perl_my_flush(pTHX_ FILE *fp) { int res; if ((res = fflush(fp)) == 0 && fp) { @@ -4942,9 +4968,8 @@ static char __pw_namecache[UAI$S_IDENT+1]; /* * This routine does most of the work extracting the user information. */ -static int fillpasswd (const char *name, struct passwd *pwd) +static int fillpasswd (pTHX_ const char *name, struct passwd *pwd) { - dTHX; static struct { unsigned char length; char pw_gecos[UAI$S_OWNER+1]; @@ -5024,15 +5049,14 @@ static int fillpasswd (const char *name, struct passwd *pwd) * Get information for a named user. */ /*{{{struct passwd *getpwnam(char *name)*/ -struct passwd *my_getpwnam(char *name) +struct passwd *Perl_my_getpwnam(pTHX_ char *name) { struct dsc$descriptor_s name_desc; union uicdef uic; unsigned long int status, sts; - dTHX; __pwdcache = __passwd_empty; - if (!fillpasswd(name, &__pwdcache)) { + if (!fillpasswd(aTHX_ name, &__pwdcache)) { /* We still may be able to determine pw_uid and pw_gid */ name_desc.dsc$w_length= strlen(name); name_desc.dsc$b_dtype= DSC$K_DTYPE_T; @@ -5063,13 +5087,12 @@ struct passwd *my_getpwnam(char *name) * Called by my_getpwent with uid=-1 to list all users. */ /*{{{struct passwd *my_getpwuid(Uid_t uid)*/ -struct passwd *my_getpwuid(Uid_t uid) +struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid) { const $DESCRIPTOR(name_desc,__pw_namecache); unsigned short lname; union uicdef uic; unsigned long int status; - dTHX; if (uid == (unsigned int) -1) { do { @@ -5109,7 +5132,7 @@ struct passwd *my_getpwuid(Uid_t uid) __pwdcache.pw_uid = uic.uic$l_uic; __pwdcache.pw_gid = uic.uic$v_group; - fillpasswd(__pw_namecache, &__pwdcache); + fillpasswd(aTHX_ __pw_namecache, &__pwdcache); return &__pwdcache; } /* end of my_getpwuid() */ @@ -5119,7 +5142,7 @@ struct passwd *my_getpwuid(Uid_t uid) * Get information for next user. */ /*{{{struct passwd *my_getpwent()*/ -struct passwd *my_getpwent() +struct passwd *Perl_my_getpwent(pTHX) { return (my_getpwuid((unsigned int) -1)); } @@ -5129,9 +5152,8 @@ struct passwd *my_getpwent() * Finish searching rights database for users. */ /*{{{void my_endpwent()*/ -void my_endpwent() +void Perl_my_endpwent(pTHX) { - dTHX; if (contxt) { _ckvmssts(sys$finish_rdb(&contxt)); contxt= 0; @@ -5474,7 +5496,7 @@ tz_parse_offset(char *s, int *offset) */ static int -tz_parse(time_t *w, int *dst, char *zone, int *gmtoff) +tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff) { time_t when; struct tm *w2; @@ -5600,9 +5622,8 @@ done: */ /*{{{time_t my_time(time_t *timep)*/ -time_t my_time(time_t *timep) +time_t Perl_my_time(pTHX_ time_t *timep) { - dTHX; time_t when; struct tm *tm_p; @@ -5654,9 +5675,8 @@ time_t my_time(time_t *timep) /*{{{struct tm *my_gmtime(const time_t *timep)*/ struct tm * -my_gmtime(const time_t *timep) +Perl_my_gmtime(pTHX_ const time_t *timep) { - dTHX; char *p; time_t when; struct tm *rsltmp; @@ -5685,9 +5705,8 @@ my_gmtime(const time_t *timep) /*{{{struct tm *my_localtime(const time_t *timep)*/ struct tm * -my_localtime(const time_t *timep) +Perl_my_localtime(pTHX_ const time_t *timep) { - dTHX; time_t when, whenutc; struct tm *rsltmp; int dst, offset; @@ -5752,9 +5771,8 @@ my_localtime(const time_t *timep) 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) +int Perl_my_utime(pTHX_ char *file, struct utimbuf *utimes) { - dTHX; register int i; long int bintime[2], len = 2, lowbit, unixtime, secscale = 10000000; /* seconds --> 100 ns intervals */ @@ -5937,14 +5955,13 @@ int my_utime(char *file, struct utimbuf *utimes) * on the first call. */ #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */ -static mydev_t encode_dev (const char *dev) +static mydev_t encode_dev (pTHX_ const char *dev) { int i; unsigned long int f; mydev_t enc; char c; const char *q; - dTHX; if (!dev || !dev[0]) return 0; @@ -5990,7 +6007,6 @@ 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 @@ -6054,7 +6070,7 @@ Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp) /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/ I32 -cando_by_name(I32 bit, Uid_t effective, char *fname) +Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname) { static char usrname[L_cuserid]; static struct dsc$descriptor_s usrdsc = @@ -6062,7 +6078,6 @@ cando_by_name(I32 bit, Uid_t 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}, @@ -6141,12 +6156,11 @@ cando_by_name(I32 bit, Uid_t effective, char *fname) /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/ int -flex_fstat(int fd, Stat_t *statbufp) +Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp) { - dTHX; if (!fstat(fd,(stat_t *) statbufp)) { if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0'; - statbufp->st_dev = encode_dev(statbufp->st_devnam); + statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam); # ifdef RTL_USES_UTC # ifdef VMSISH_TIME if (VMSISH_TIME) { @@ -6175,9 +6189,8 @@ flex_fstat(int fd, Stat_t *statbufp) /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/ int -flex_stat(const char *fspec, Stat_t *statbufp) +Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp) { - dTHX; char fileified[NAM$C_MAXRSS+1]; char temp_fspec[NAM$C_MAXRSS+300]; int retval = -1; @@ -6187,7 +6200,7 @@ flex_stat(const char *fspec, Stat_t *statbufp) 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_dev = encode_dev(aTHX_ "_NLA0:"); statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC; statbufp->st_uid = 0x00010001; statbufp->st_gid = 0x0001; @@ -6211,7 +6224,7 @@ flex_stat(const char *fspec, Stat_t *statbufp) } if (retval) retval = stat(temp_fspec,(stat_t *) statbufp); if (!retval) { - statbufp->st_dev = encode_dev(statbufp->st_devnam); + statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam); # ifdef RTL_USES_UTC # ifdef VMSISH_TIME if (VMSISH_TIME) { @@ -6639,7 +6652,7 @@ rmscopy_fromperl(pTHX_ CV *cv) void -mod2fname(CV *cv) +mod2fname(pTHX_ CV *cv) { dXSARGS; char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1], @@ -6714,10 +6727,9 @@ mod2fname(CV *cv) } void -init_os_extras() +init_os_extras(pTHX) { char* file = __FILE__; - dTHX; char temp_buff[512]; if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) { no_translate_barewords = TRUE; @@ -6736,7 +6748,7 @@ init_os_extras() newXSproto("DynaLoader::mod2fname", mod2fname, file, "$"); newXS("File::Copy::rmscopy",rmscopy_fromperl,file); - store_pipelocs(); + store_pipelocs(aTHX); return; } diff --git a/vms/vmsish.h b/vms/vmsish.h index a8551daf98..01aa644b23 100644 --- a/vms/vmsish.h +++ b/vms/vmsish.h @@ -63,17 +63,30 @@ #define HAS_GETENV_SV #define HAS_GETENV_LEN +/* All this stiff is for the x2P programs. Hopefully they'll still work */ +#if defined(PERL_FOR_X2P) +#ifndef aTHX_ +#define aTHX_ +#endif +#ifndef pTHX_ +#define pTHX_ +#endif +#ifndef pTHX +#define pTHX +#endif +#endif + #ifndef DONT_MASK_RTL_CALLS # ifdef getenv # undef getenv # endif /* getenv used for regular logical names */ -# define getenv(v) my_getenv(v,TRUE) +# define getenv(v) Perl_my_getenv(aTHX_ v,TRUE) #endif #ifdef getenv_len # undef getenv_len #endif -#define getenv_len(v,l) my_getenv_len(v,l,TRUE) +#define getenv_len(v,l) Perl_my_getenv_len(aTHX_ v,l,TRUE) /* DECC introduces this routine in the RTL as of VMS 7.0; for now, * we'll use ours, since it gives us the full VMS exit status. */ @@ -86,12 +99,14 @@ #define DONT_DECLARE_STD 1 /* Our own contribution to PerlShr's global symbols . . . */ -#define my_getenv_len Perl_my_getenv_len #define prime_env_iter Perl_prime_env_iter -#define vmssetenv Perl_vmssetenv +#define vms_image_init Perl_vms_image_init +#define my_tmpfile Perl_my_tmpfile +#define vmstrnenv Perl_vmstrnenv #if !defined(PERL_IMPLICIT_CONTEXT) +#define my_getenv_len Perl_my_getenv_len +#define vmssetenv Perl_vmssetenv #define my_trnlnm Perl_my_trnlnm -#define vmstrnenv Perl_vmstrnenv #define my_setenv Perl_my_setenv #define my_getenv Perl_my_getenv #define tounixspec Perl_tounixspec @@ -110,9 +125,31 @@ #define trim_unixpath Perl_trim_unixpath #define opendir Perl_opendir #define rmscopy Perl_rmscopy +#define my_mkdir Perl_my_mkdir +#define vms_do_aexec Perl_vms_do_aexec +#define vms_do_exec Perl_vms_do_exec +#define my_waitpid Perl_my_waitpid +#define my_crypt Perl_my_crypt +#define kill_file Perl_kill_file +#define my_utime Perl_my_utime +#define my_chdir Perl_my_chdir +#define do_aspawn Perl_do_aspawn +#define seekdir Perl_seekdir +#define my_gmtime Perl_my_gmtime +#define my_localtime Perl_my_localtime +#define my_time Perl_my_time +#define do_spawn Perl_do_spawn +#define flex_fstat Perl_flex_fstat +#define flex_stat Perl_flex_stat +#define cando_by_name Perl_cando_by_name +#define my_getpwnam Perl_my_getpwnam +#define my_getpwuid Perl_my_getpwuid +#define my_flush Perl_my_flush +#define readdir Perl_readdir #else +#define my_getenv_len(a,b,c) Perl_my_getenv_len(aTHX_ a,b,c) +#define vmssetenv(a,b,c) Perl_vmssetenv(aTHX_ a,b,c) #define my_trnlnm(a,b,c) Perl_my_trnlnm(aTHX_ a,b,c) -#define vmstrnenv(a,b,c,d,e) Perl_vmstrnenv(aTHX_ a,b,c,d,e) #define my_setenv(a,b) Perl_my_setenv(aTHX_ a,b) #define my_getenv(a,b) Perl_my_getenv(aTHX_ a,b) #define tounixspec(a,b) Perl_tounixspec(aTHX_ a,b) @@ -133,44 +170,42 @@ #define trim_unixpath(a,b,c) Perl_trim_unixpath(aTHX_ a,b,c) #define opendir(a) Perl_opendir(aTHX_ a) #define rmscopy(a,b,c) Perl_rmscopy(aTHX_ a,b,c) +#define my_mkdir(a,b) Perl_my_mkdir(aTHX_ a,b) +#define vms_do_aexec(a,b,c) Perl_vms_do_aexec(aTHX_ a,b,c) +#define vms_do_exec(a) Perl_vms_do_exec(aTHX_ a) +#define my_waitpid(a,b,c) Perl_my_waitpid(aTHX_ a,b,c) +#define my_crypt(a,b) Perl_my_crypt(aTHX_ a,b) +#define kill_file(a) Perl_kill_file(aTHX_ a) +#define my_utime(a,b) Perl_my_utime(aTHX_ a,b) +#define my_chdir(a) Perl_my_chdir(aTHX_ a) +#define do_aspawn(a,b,c) Perl_do_aspawn(aTHX_ a,b,c) +#define seekdir(a,b) Perl_seekdir(aTHX_ a,b) +#define my_gmtime(a) Perl_my_gmtime(aTHX_ a) +#define my_localtime(a) Perl_my_localtime(aTHX_ a) +#define my_time(a) Perl_my_time(aTHX_ a) +#define do_spawn(a) Perl_do_spawn(aTHX_ a) +#define flex_fstat(a,b) Perl_flex_fstat(aTHX_ a,b) +#define cando_by_name(a,b,c) Perl_cando_by_name(aTHX_ a,b,c) +#define flex_stat(a,b) Perl_flex_stat(aTHX_ a,b) +#define my_getpwnam(a) Perl_my_getpwnam(aTHX_ a) +#define my_getpwuid(a) Perl_my_getpwuid(aTHX_ a) +#define my_flush(a) Perl_my_flush(aTHX_ a) +#define readdir(a) Perl_readdir(aTHX_ a) #endif -#define my_crypt Perl_my_crypt -#define my_waitpid Perl_my_waitpid #define my_gconvert Perl_my_gconvert -#define kill_file Perl_kill_file -#define my_mkdir Perl_my_mkdir -#define my_chdir Perl_my_chdir -#define my_tmpfile Perl_my_tmpfile -#define my_utime Perl_my_utime -#define vms_image_init Perl_vms_image_init -#define readdir Perl_readdir #define telldir Perl_telldir -#define seekdir Perl_seekdir #define closedir Perl_closedir #define vmsreaddirversions Perl_vmsreaddirversions -#define my_gmtime Perl_my_gmtime -#define my_localtime Perl_my_localtime -#define my_time Perl_my_time #define my_sigemptyset Perl_my_sigemptyset #define my_sigfillset Perl_my_sigfillset #define my_sigaddset Perl_my_sigaddset #define my_sigdelset Perl_my_sigdelset #define my_sigismember Perl_my_sigismember #define my_sigprocmask Perl_my_sigprocmask -#define cando_by_name Perl_cando_by_name -#define flex_fstat Perl_flex_fstat -#define flex_stat Perl_flex_stat #define my_vfork Perl_my_vfork -#define vms_do_aexec Perl_vms_do_aexec -#define vms_do_exec Perl_vms_do_exec -#define do_aspawn Perl_do_aspawn -#define do_spawn Perl_do_spawn #define my_fdopen Perl_my_fdopen #define my_fclose Perl_my_fclose #define my_fwrite Perl_my_fwrite -#define my_flush Perl_my_flush -#define my_getpwnam Perl_my_getpwnam -#define my_getpwuid Perl_my_getpwuid #define my_getpwent Perl_my_getpwent #define my_endpwent Perl_my_endpwent #define my_getlogin Perl_my_getlogin @@ -197,7 +232,7 @@ * from a specific directory to permit creation of files). */ #ifndef DONT_MASK_RTL_CALLS -# define tmpfile my_tmpfile +# define tmpfile Perl_my_tmpfile #endif @@ -476,15 +511,15 @@ struct utimbuf { #define getlogin my_getlogin /* Ditto for sys$hash_password() . . . */ -#define crypt my_crypt +#define crypt(a,b) Perl_my_crypt(aTHX_ a,b) /* Tweak arg to mkdir & chdir first, so we can tolerate trailing /. */ -#define Mkdir(dir,mode) my_mkdir((dir),(mode)) +#define Mkdir(dir,mode) Perl_my_mkdir(aTHX_ (dir),(mode)) #define Chdir(dir) my_chdir((dir)) /* Use our own stat() clones, which handle Unix-style directory names */ #define Stat(name,bufptr) flex_stat(name,bufptr) -#define Fstat(fd,bufptr) flex_fstat(fd,bufptr) +#define Fstat(fd,bufptr) Perl_flex_fstat(aTHX_ fd,bufptr) /* Setup for the dirent routines: * opendir(), closedir(), readdir(), seekdir(), telldir(), and @@ -655,9 +690,9 @@ void prime_env_iter (void); void init_os_extras (); /* prototype section start marker; `typedef' passes through cpp */ typedef char __VMS_PROTOTYPES__; +int Perl_vmstrnenv (const char *, char *, unsigned long int, struct dsc$descriptor_s **, unsigned long int); #if !defined(PERL_IMPLICIT_CONTEXT) char * Perl_my_getenv (const char *, bool); -int Perl_vmstrnenv (const char *, char *, unsigned long int, struct dsc$descriptor_s **, unsigned long int); int Perl_my_trnlnm (const char *, char *, unsigned long int); char * Perl_tounixspec (char *, char *); char * Perl_tounixspec_ts (char *, char *); @@ -677,8 +712,9 @@ char * Perl_rmsexpand_ts (char *, char *, char *, unsigned); int Perl_trim_unixpath (char *, char*, int); DIR * Perl_opendir (char *); int Perl_rmscopy (char *, char *, int); +int Perl_my_mkdir (char *, Mode_t); +bool Perl_vms_do_aexec (SV *, SV **, SV **); #else -int Perl_vmstrnenv (pTHX_ const char *, char *, unsigned long int, struct dsc$descriptor_s **, unsigned long int); char * Perl_my_getenv (pTHX_ const char *, bool); int Perl_my_trnlnm (pTHX_ const char *, char *, unsigned long int); char * Perl_tounixspec (pTHX_ char *, char *); @@ -699,27 +735,28 @@ char * Perl_rmsexpand_ts (pTHX_ char *, char *, char *, unsigned); int Perl_trim_unixpath (pTHX_ char *, char*, int); DIR * Perl_opendir (pTHX_ char *); int Perl_rmscopy (pTHX_ char *, char *, int); -#endif -char * my_getenv_len (const char *, unsigned long *, bool); -int vmssetenv (char *, char *, struct dsc$descriptor_s **); -void Perl_vmssetuserlnm(char *name, char *eqv); -char * my_crypt (const char *, const char *); -Pid_t my_waitpid (Pid_t, int *, int); +int Perl_my_mkdir (pTHX_ char *, Mode_t); +bool Perl_vms_do_aexec (pTHX_ SV *, SV **, SV **); +#endif +char * Perl_my_getenv_len (pTHX_ const char *, unsigned long *, bool); +int Perl_vmssetenv (pTHX_ char *, char *, struct dsc$descriptor_s **); +void Perl_vmssetuserlnm(pTHX_ char *name, char *eqv); +char * Perl_my_crypt (pTHX_ const char *, const char *); +Pid_t Perl_my_waitpid (pTHX_ Pid_t, int *, int); char * my_gconvert (double, int, int, char *); -int kill_file (char *); -int my_mkdir (char *, Mode_t); -int my_chdir (char *); -FILE * my_tmpfile (void); -int my_utime (char *, struct utimbuf *); -void vms_image_init (int *, char ***); -struct dirent * readdir (DIR *); +int Perl_kill_file (pTHX_ char *); +int Perl_my_chdir (pTHX_ char *); +FILE * Perl_my_tmpfile (); +int Perl_my_utime (pTHX_ char *, struct utimbuf *); +void Perl_vms_image_init (int *, char ***); +struct dirent * Perl_readdir (pTHX_ DIR *); long telldir (DIR *); -void seekdir (DIR *, long); +void Perl_seekdir (pTHX_ DIR *, long); void closedir (DIR *); void vmsreaddirversions (DIR *, int); -struct tm * my_gmtime (const time_t *); -struct tm * my_localtime (const time_t *); -time_t my_time (time_t *); +struct tm * Perl_my_gmtime (pTHX_ const time_t *); +struct tm * Perl_my_localtime (pTHX_ const time_t *); +time_t Perl_my_time (pTHX_ time_t *); #ifdef HOMEGROWN_POSIX_SIGNALS int my_sigemptyset (sigset_t *); int my_sigfillset (sigset_t *); @@ -728,21 +765,19 @@ int my_sigdelset (sigset_t *, int); int my_sigismember (sigset_t *, int); int my_sigprocmask (int, sigset_t *, sigset_t *); #endif -I32 cando_by_name (I32, Uid_t, char *); -int flex_fstat (int, Stat_t *); -int flex_stat (const char *, Stat_t *); +I32 Perl_cando_by_name (pTHX_ I32, Uid_t, char *); +int Perl_flex_fstat (pTHX_ int, Stat_t *); +int Perl_flex_stat (pTHX_ const char *, Stat_t *); int my_vfork (); -bool vms_do_aexec (SV *, SV **, SV **); -bool vms_do_exec (char *); -unsigned long int do_aspawn (void *, void **, void **); -unsigned long int do_spawn (char *); -FILE * my_fdopen (int, const char *); +bool Perl_vms_do_exec (pTHX_ char *); +unsigned long int Perl_do_aspawn (pTHX_ void *, void **, void **); +unsigned long int Perl_do_spawn (pTHX_ char *); +FILE * my_fdopen (int, char *); int my_fclose (FILE *); int my_fwrite (void *, size_t, size_t, FILE *); -int my_flush (FILE *); -struct passwd * my_getpwnam (char *name); -struct passwd * my_getpwuid (Uid_t uid); -struct passwd * my_getpwent (); +int Perl_my_flush (pTHX_ FILE *); +struct passwd * Perl_my_getpwnam (pTHX_ char *name); +struct passwd * Perl_my_getpwuid (pTHX_ Uid_t uid); void my_endpwent (); char * my_getlogin (); typedef char __VMS_SEPYTOTORP__; |