diff options
-rw-r--r-- | bytecode.pl | 6 | ||||
-rw-r--r-- | dosish.h | 9 | ||||
-rw-r--r-- | embed.h | 33 | ||||
-rwxr-xr-x | embed.pl | 24 | ||||
-rw-r--r-- | ext/B/B.xs | 13 | ||||
-rw-r--r-- | ext/ByteLoader/ByteLoader.xs | 6 | ||||
-rw-r--r-- | ext/ByteLoader/bytecode.h | 6 | ||||
-rw-r--r-- | ext/ByteLoader/byterun.h | 6 | ||||
-rw-r--r-- | ext/SDBM_File/sdbm/sdbm.c | 3 | ||||
-rw-r--r-- | globals.c | 14 | ||||
-rw-r--r-- | mg.c | 2 | ||||
-rw-r--r-- | objXSUB.h | 4 | ||||
-rw-r--r-- | op.h | 2 | ||||
-rw-r--r-- | perl.c | 4 | ||||
-rw-r--r-- | perl.h | 19 | ||||
-rw-r--r-- | pp_sys.c | 10 | ||||
-rw-r--r-- | proto.h | 23 | ||||
-rw-r--r-- | sv.c | 2 | ||||
-rw-r--r-- | util.c | 36 | ||||
-rw-r--r-- | win32/Makefile | 3 | ||||
-rw-r--r-- | win32/config_H.bc | 5 | ||||
-rw-r--r-- | win32/config_H.gc | 5 | ||||
-rw-r--r-- | win32/config_H.vc | 5 | ||||
-rw-r--r-- | win32/config_h.PL | 3 | ||||
-rw-r--r-- | win32/dl_win32.xs | 22 | ||||
-rw-r--r-- | win32/makedef.pl | 41 | ||||
-rw-r--r-- | win32/makefile.mk | 3 | ||||
-rw-r--r-- | win32/perllib.c | 11 | ||||
-rw-r--r-- | win32/win32.c | 85 | ||||
-rw-r--r-- | win32/win32.h | 35 | ||||
-rw-r--r-- | win32/win32sck.c | 40 | ||||
-rw-r--r-- | win32/win32thread.c | 2 | ||||
-rw-r--r-- | win32/win32thread.h | 40 |
33 files changed, 235 insertions, 287 deletions
diff --git a/bytecode.pl b/bytecode.pl index c9bb491009..955db20ea3 100644 --- a/bytecode.pl +++ b/bytecode.pl @@ -188,9 +188,9 @@ open(BYTERUN_H, ">ext/ByteLoader/byterun.h") or die "ext/ByteLoader/byterun.h: $ print BYTERUN_H $c_header, <<'EOT'; struct bytestream { void *data; - int (*fgetc)(void *); - int (*fread)(char *, size_t, size_t, void *); - void (*freadpv)(U32, void *, XPV *); + int (*pfgetc)(void *); + int (*pfread)(char *, size_t, size_t, void *); + void (*pfreadpv)(U32, void *, XPV *); }; enum { @@ -123,13 +123,4 @@ # define HAS_KILL # define HAS_WAIT # define HAS_CHOWN -/* - * This provides a layer of functions and macros to ensure extensions will - * get to use the same RTL functions as the core. - */ -# ifndef HASATTRIBUTE -# ifndef PERL_OBJECT -# include <win32iop.h> -# endif -# endif #endif /* WIN32 */ @@ -693,11 +693,6 @@ #define do_trans_UC_trivial S_do_trans_UC_trivial #define do_trans_CU_trivial S_do_trans_CU_trivial #endif -#if defined(PERL_IN_GLOBALS_C) -# if defined(WIN32) -#define do_aspawn S_do_aspawn -# endif -#endif #if defined(PERL_IN_GV_C) #define gv_init_sv S_gv_init_sv #endif @@ -1928,15 +1923,15 @@ #if defined(MYMALLOC) #define dump_mstats(a) Perl_dump_mstats(aTHX_ a) #endif -#define safesysmalloc(a) Perl_safesysmalloc(aTHX_ a) -#define safesyscalloc(a,b) Perl_safesyscalloc(aTHX_ a,b) -#define safesysrealloc(a,b) Perl_safesysrealloc(aTHX_ a,b) -#define safesysfree(a) Perl_safesysfree(aTHX_ a) +#define safesysmalloc Perl_safesysmalloc +#define safesyscalloc Perl_safesyscalloc +#define safesysrealloc Perl_safesysrealloc +#define safesysfree Perl_safesysfree #if defined(LEAKTEST) -#define safexmalloc(a,b) Perl_safexmalloc(aTHX_ a,b) -#define safexcalloc(a,b,c) Perl_safexcalloc(aTHX_ a,b,c) -#define safexrealloc(a,b) Perl_safexrealloc(aTHX_ a,b) -#define safexfree(a) Perl_safexfree(aTHX_ a) +#define safexmalloc Perl_safexmalloc +#define safexcalloc Perl_safexcalloc +#define safexrealloc Perl_safexrealloc +#define safexfree Perl_safexfree #endif #if defined(PERL_GLOBAL_STRUCT) #define GetVars() Perl_GetVars(aTHX) @@ -1990,11 +1985,6 @@ #define do_trans_UC_trivial(a) S_do_trans_UC_trivial(aTHX_ a) #define do_trans_CU_trivial(a) S_do_trans_CU_trivial(aTHX_ a) #endif -#if defined(PERL_IN_GLOBALS_C) -# if defined(WIN32) -#define do_aspawn(a,b,c) S_do_aspawn(aTHX_ a,b,c) -# endif -#endif #if defined(PERL_IN_GV_C) #define gv_init_sv(a,b) S_gv_init_sv(aTHX_ a,b) #endif @@ -2182,7 +2172,7 @@ #define reg_add(a) S_reg_add(aTHX_ a) #define reg_remove(a) S_reg_remove(aTHX_ a) # else -#define my_safemalloc(a) S_my_safemalloc(aTHX_ a) +#define my_safemalloc S_my_safemalloc # endif #define sv_add_backref(a,b) S_sv_add_backref(aTHX_ a,b) #define sv_del_backref(a) S_sv_del_backref(aTHX_ a) @@ -3309,11 +3299,6 @@ #define S_do_trans_UC_trivial CPerlObj::do_trans_UC_trivial #define S_do_trans_CU_trivial CPerlObj::do_trans_CU_trivial #endif -#if defined(PERL_IN_GLOBALS_C) -# if defined(WIN32) -#define S_do_aspawn CPerlObj::do_aspawn -# endif -#endif #if defined(PERL_IN_GV_C) #define S_gv_init_sv CPerlObj::gv_init_sv #endif @@ -1384,15 +1384,15 @@ pno |Malloc_t|calloc |MEM_SIZE elements|MEM_SIZE size pno |Malloc_t|realloc |Malloc_t where|MEM_SIZE nbytes pno |Free_t |mfree |Malloc_t where #endif -p |Malloc_t|safesysmalloc |MEM_SIZE nbytes -p |Malloc_t|safesyscalloc |MEM_SIZE elements|MEM_SIZE size -p |Malloc_t|safesysrealloc|Malloc_t where|MEM_SIZE nbytes -p |Free_t |safesysfree |Malloc_t where +pn |Malloc_t|safesysmalloc |MEM_SIZE nbytes +pn |Malloc_t|safesyscalloc |MEM_SIZE elements|MEM_SIZE size +pn |Malloc_t|safesysrealloc|Malloc_t where|MEM_SIZE nbytes +pn |Free_t |safesysfree |Malloc_t where #if defined(LEAKTEST) -p |Malloc_t|safexmalloc |I32 x|MEM_SIZE size -p |Malloc_t|safexcalloc |I32 x|MEM_SIZE elements|MEM_SIZE size -p |Malloc_t|safexrealloc |Malloc_t where|MEM_SIZE size -p |void |safexfree |Malloc_t where +pn |Malloc_t|safexmalloc |I32 x|MEM_SIZE size +pn |Malloc_t|safexcalloc |I32 x|MEM_SIZE elements|MEM_SIZE size +pn |Malloc_t|safexrealloc |Malloc_t where|MEM_SIZE size +pn |void |safexfree |Malloc_t where #endif #if defined(PERL_GLOBAL_STRUCT) p |struct perl_vars *|GetVars @@ -1457,12 +1457,6 @@ s |I32 |do_trans_UC_trivial |SV *sv s |I32 |do_trans_CU_trivial |SV *sv #endif -#if defined(PERL_IN_GLOBALS_C) -# if defined(WIN32) -s |int |do_aspawn |void *vreally|void **vmark|void **vsp -# endif -#endif - #if defined(PERL_IN_GV_C) s |void |gv_init_sv |GV *gv|I32 sv_type #endif @@ -1668,7 +1662,7 @@ s |void |visit |SVFUNC_t f s |void |reg_add |SV *sv s |void |reg_remove |SV *sv # else -s |void* |my_safemalloc |MEM_SIZE size +ns |void* |my_safemalloc |MEM_SIZE size # endif s |void |sv_add_backref |SV *tsv|SV *sv s |void |sv_del_backref |SV *sv diff --git a/ext/B/B.xs b/ext/B/B.xs index f9193ae692..6413a241aa 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -443,19 +443,6 @@ walkoptree_debug(...) OUTPUT: RETVAL -int -byteload_fh(fp) - InputStream fp - CODE: - byteload_fh(fp); - RETVAL = 1; - OUTPUT: - RETVAL - -void -byteload_string(str) - char * str - #define address(sv) (IV)sv IV diff --git a/ext/ByteLoader/ByteLoader.xs b/ext/ByteLoader/ByteLoader.xs index e927d16f31..34002f12b2 100644 --- a/ext/ByteLoader/ByteLoader.xs +++ b/ext/ByteLoader/ByteLoader.xs @@ -25,9 +25,9 @@ byteloader_filter(pTHX_ int idx, SV *buf_sv, int maxlen) struct bytestream bs; bs.data = PL_rsfp; - bs.fgetc = (int(*) (void*))fgetc; - bs.fread = (int(*) (char*,size_t,size_t,void*))fread; - bs.freadpv = freadpv; + bs.pfgetc = (int(*) (void*))fgetc; + bs.pfread = (int(*) (char*,size_t,size_t,void*))fread; + bs.pfreadpv = freadpv; byterun(bs); diff --git a/ext/ByteLoader/bytecode.h b/ext/ByteLoader/bytecode.h index e743583b61..8a59bb1273 100644 --- a/ext/ByteLoader/bytecode.h +++ b/ext/ByteLoader/bytecode.h @@ -8,8 +8,8 @@ typedef OP *opindex; typedef IV IV64; #define BGET_FREAD(argp, len, nelem) \ - bs.fread((char*)(argp),(len),(nelem),bs.data) -#define BGET_FGETC() bs.fgetc(bs.data) + bs.pfread((char*)(argp),(len),(nelem),bs.data) +#define BGET_FGETC() bs.pfgetc(bs.data) #define BGET_U32(arg) \ BGET_FREAD(&arg, sizeof(U32), 1); arg = PerlSock_ntohl((U32)arg) @@ -22,7 +22,7 @@ typedef IV IV64; #define BGET_PV(arg) STMT_START { \ BGET_U32(arg); \ if (arg) \ - bs.freadpv(arg, bs.data, &bytecode_pv); \ + bs.pfreadpv(arg, bs.data, &bytecode_pv); \ else { \ bytecode_pv.xpv_pv = 0; \ bytecode_pv.xpv_len = 0; \ diff --git a/ext/ByteLoader/byterun.h b/ext/ByteLoader/byterun.h index c293160340..3c5b2343c5 100644 --- a/ext/ByteLoader/byterun.h +++ b/ext/ByteLoader/byterun.h @@ -10,9 +10,9 @@ */ struct bytestream { void *data; - int (*fgetc)(void *); - int (*fread)(char *, size_t, size_t, void *); - void (*freadpv)(U32, void *, XPV *); + int (*pfgetc)(void *); + int (*pfread)(char *, size_t, size_t, void *); + void (*pfreadpv)(U32, void *, XPV *); }; enum { diff --git a/ext/SDBM_File/sdbm/sdbm.c b/ext/SDBM_File/sdbm/sdbm.c index 47de0b9b11..c1e2e4a8a4 100644 --- a/ext/SDBM_File/sdbm/sdbm.c +++ b/ext/SDBM_File/sdbm/sdbm.c @@ -9,6 +9,9 @@ #include "INTERN.h" #include "config.h" +#ifdef WIN32 +#include "io.h" +#endif #include "sdbm.h" #include "tune.h" #include "pair.h" @@ -50,18 +50,4 @@ CPerlObj::Init(void) { } -#ifdef WIN32 /* XXX why are these needed? */ -bool -Perl_do_exec(pTHX_ char *cmd) -{ - return PerlProc_Cmd(cmd); -} - -int -S_do_aspawn(pTHX_ void *vreally, void **vmark, void **vsp) -{ - return PerlProc_aspawn(vreally, vmark, vsp); -} -#endif /* WIN32 */ - #endif /* PERL_OBJECT */ @@ -532,7 +532,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) sv_setpvn(sv, sMsg, dwLen); PerlProc_FreeBuf(sMsg); #else - win32_str_os_error(sv, dwErr); + win32_str_os_error(aTHX_ sv, dwErr); #endif } else @@ -2066,10 +2066,6 @@ #endif #if defined(PERL_IN_DOOP_C) #endif -#if defined(PERL_IN_GLOBALS_C) -# if defined(WIN32) -# endif -#endif #if defined(PERL_IN_GV_C) #endif #if defined(PERL_IN_HV_C) @@ -38,7 +38,7 @@ typedef U32 PADOFFSET; #define BASEOP \ OP* op_next; \ OP* op_sibling; \ - OP* (CPERLscope(*op_ppaddr))(ARGSproto); \ + OP* (CPERLscope(*op_ppaddr))(pTHX); \ PADOFFSET op_targ; \ OPCODE op_type; \ U16 op_seq; \ @@ -947,7 +947,7 @@ print \" \\@INC:\\n @INC\\n\";"); if (xsinit) (*xsinit)(aTHX); /* in case linked C routines want magical variables */ #if defined(VMS) || defined(WIN32) || defined(DJGPP) - init_os_extras(); + init_os_extras(aTHX); #endif init_predump_symbols(); @@ -2916,7 +2916,7 @@ S_init_main_thread(pTHX) MUTEX_UNLOCK(&PL_threads_mutex); #ifdef HAVE_THREAD_INTERN - init_thread_intern(thr); + Perl_init_thread_intern(thr); #endif #ifdef SET_THREAD_SELF @@ -327,8 +327,6 @@ register struct op *Perl_op asm(stringify(OP_IN_REGISTER)); # endif #endif -#include "iperlsys.h" - #ifdef USE_NEXT_CTYPE #if NX_CURRENT_COMPILER_RELEASE >= 500 @@ -1568,6 +1566,11 @@ typedef I32 (*filter_t) (pTHX_ int, SV *, int); #define FILTER_DATA(idx) (AvARRAY(PL_rsfp_filters)[idx]) #define FILTER_ISREADER(idx) (idx >= AvFILLp(PL_rsfp_filters)) +#ifdef WIN32 +#include "win32.h" +#endif + +#include "iperlsys.h" #include "regexp.h" #include "sv.h" #include "util.h" @@ -2520,18 +2523,6 @@ PERLVAR(object_compatibility[30], char) #undef PERLVARI #undef PERLVARIC -#if defined(HASATTRIBUTE) && defined(WIN32) && !defined(CYGWIN32) -/* - * This provides a layer of functions and macros to ensure extensions will - * get to use the same RTL functions as the core. - * It has to go here or #define of printf messes up __attribute__ - * stuff in proto.h - */ -#ifndef PERL_OBJECT -# include <win32iop.h> -#endif /* PERL_OBJECT */ -#endif /* WIN32 */ - #ifdef DOINIT EXT MGVTBL PL_vtbl_sv = {Perl_magic_get, @@ -3602,12 +3602,12 @@ PP(pp_system) #else /* ! FORK or VMS or OS/2 */ if (PL_op->op_flags & OPf_STACKED) { SV *really = *++MARK; - value = (I32)do_aspawn(really, (void **)MARK, (void **)SP); + value = (I32)do_aspawn(aTHX_ really, (void **)MARK, (void **)SP); } else if (SP - MARK != 1) - value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP); + value = (I32)do_aspawn(aTHX_ Nullsv, (void **)MARK, (void **)SP); else { - value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a)); + value = (I32)do_spawn(aTHX_ SvPVx(sv_mortalcopy(*SP), n_a)); } STATUS_NATIVE_SET(value); do_execfree(); @@ -3634,7 +3634,7 @@ PP(pp_exec) #else # ifdef __OPEN_VM { - (void ) do_aspawn(Nullsv, MARK, SP); + (void ) do_aspawn(aTHX_ Nullsv, MARK, SP); value = 0; } # else @@ -3651,7 +3651,7 @@ PP(pp_exec) value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a)); #else # ifdef __OPEN_VM - (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a)); + (void) do_spawn(aTHX_ SvPVx(sv_mortalcopy(*SP), n_a)); value = 0; # else value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a)); @@ -630,15 +630,15 @@ Malloc_t Perl_calloc(MEM_SIZE elements, MEM_SIZE size); Malloc_t Perl_realloc(Malloc_t where, MEM_SIZE nbytes); Free_t Perl_mfree(Malloc_t where); #endif -Malloc_t Perl_safesysmalloc(pTHX_ MEM_SIZE nbytes); -Malloc_t Perl_safesyscalloc(pTHX_ MEM_SIZE elements, MEM_SIZE size); -Malloc_t Perl_safesysrealloc(pTHX_ Malloc_t where, MEM_SIZE nbytes); -Free_t Perl_safesysfree(pTHX_ Malloc_t where); +Malloc_t Perl_safesysmalloc(MEM_SIZE nbytes); +Malloc_t Perl_safesyscalloc(MEM_SIZE elements, MEM_SIZE size); +Malloc_t Perl_safesysrealloc(Malloc_t where, MEM_SIZE nbytes); +Free_t Perl_safesysfree(Malloc_t where); #if defined(LEAKTEST) -Malloc_t Perl_safexmalloc(pTHX_ I32 x, MEM_SIZE size); -Malloc_t Perl_safexcalloc(pTHX_ I32 x, MEM_SIZE elements, MEM_SIZE size); -Malloc_t Perl_safexrealloc(pTHX_ Malloc_t where, MEM_SIZE size); -void Perl_safexfree(pTHX_ Malloc_t where); +Malloc_t Perl_safexmalloc(I32 x, MEM_SIZE size); +Malloc_t Perl_safexcalloc(I32 x, MEM_SIZE elements, MEM_SIZE size); +Malloc_t Perl_safexrealloc(Malloc_t where, MEM_SIZE size); +void Perl_safexfree(Malloc_t where); #endif #if defined(PERL_GLOBAL_STRUCT) struct perl_vars * Perl_GetVars(pTHX); @@ -696,11 +696,6 @@ STATIC I32 S_do_trans_CU_simple(pTHX_ SV *sv); STATIC I32 S_do_trans_UC_trivial(pTHX_ SV *sv); STATIC I32 S_do_trans_CU_trivial(pTHX_ SV *sv); #endif -#if defined(PERL_IN_GLOBALS_C) -# if defined(WIN32) -STATIC int S_do_aspawn(pTHX_ void *vreally, void **vmark, void **vsp); -# endif -#endif #if defined(PERL_IN_GV_C) STATIC void S_gv_init_sv(pTHX_ GV *gv, I32 sv_type); #endif @@ -889,7 +884,7 @@ STATIC void S_visit(pTHX_ SVFUNC_t f); STATIC void S_reg_add(pTHX_ SV *sv); STATIC void S_reg_remove(pTHX_ SV *sv); # else -STATIC void* S_my_safemalloc(pTHX_ MEM_SIZE size); +STATIC void* S_my_safemalloc(MEM_SIZE size); # endif STATIC void S_sv_add_backref(pTHX_ SV *tsv, SV *sv); STATIC void S_sv_del_backref(pTHX_ SV *sv); @@ -582,7 +582,7 @@ S_more_xpv(pTHX) # define my_safefree(s) safefree(s) #else STATIC void* -S_my_safemalloc(pTHX_ MEM_SIZE size) +S_my_safemalloc(MEM_SIZE size) { char *p; New(717, p, size, char); @@ -71,18 +71,18 @@ long lastxycount[MAXXCOUNT][MAXYCOUNT]; */ Malloc_t -Perl_safesysmalloc(pTHX_ MEM_SIZE size) +Perl_safesysmalloc(MEM_SIZE size) { Malloc_t ptr; #ifdef HAS_64K_LIMIT if (size > 0xffff) { PerlIO_printf(PerlIO_stderr(), "Allocation too large: %lx\n", size) FLUSH; - my_exit(1); + WITH_THX(my_exit(1)); } #endif /* HAS_64K_LIMIT */ #ifdef DEBUGGING if ((long)size < 0) - Perl_croak(aTHX_ "panic: malloc"); + Perl_croak_nocontext("panic: malloc"); #endif ptr = PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */ #if !(defined(I286) || defined(atarist)) @@ -96,7 +96,7 @@ Perl_safesysmalloc(pTHX_ MEM_SIZE size) return Nullch; else { PerlIO_puts(PerlIO_stderr(),PL_no_mem) FLUSH; - my_exit(1); + WITH_THX(my_exit(1)); return Nullch; } /*NOTREACHED*/ @@ -105,7 +105,7 @@ Perl_safesysmalloc(pTHX_ MEM_SIZE size) /* paranoid version of system's realloc() */ Malloc_t -Perl_safesysrealloc(pTHX_ Malloc_t where,MEM_SIZE size) +Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) { Malloc_t ptr; #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) @@ -116,7 +116,7 @@ Perl_safesysrealloc(pTHX_ Malloc_t where,MEM_SIZE size) if (size > 0xffff) { PerlIO_printf(PerlIO_stderr(), "Reallocation too large: %lx\n", size) FLUSH; - my_exit(1); + WITH_THX(my_exit(1)); } #endif /* HAS_64K_LIMIT */ if (!size) { @@ -128,7 +128,7 @@ Perl_safesysrealloc(pTHX_ Malloc_t where,MEM_SIZE size) return safesysmalloc(size); #ifdef DEBUGGING if ((long)size < 0) - Perl_croak(aTHX_ "panic: realloc"); + Perl_croak_nocontext("panic: realloc"); #endif ptr = PerlMem_realloc(where,size); @@ -150,7 +150,7 @@ Perl_safesysrealloc(pTHX_ Malloc_t where,MEM_SIZE size) return Nullch; else { PerlIO_puts(PerlIO_stderr(),PL_no_mem) FLUSH; - my_exit(1); + WITH_THX(my_exit(1)); return Nullch; } /*NOTREACHED*/ @@ -159,7 +159,7 @@ Perl_safesysrealloc(pTHX_ Malloc_t where,MEM_SIZE size) /* safe version of system's free() */ Free_t -Perl_safesysfree(pTHX_ Malloc_t where) +Perl_safesysfree(Malloc_t where) { #if !(defined(I286) || defined(atarist)) DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%x: (%05d) free\n",(char *) where,PL_an++)); @@ -175,7 +175,7 @@ Perl_safesysfree(pTHX_ Malloc_t where) /* safe version of system's calloc() */ Malloc_t -Perl_safesyscalloc(pTHX_ MEM_SIZE count, MEM_SIZE size) +Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) { Malloc_t ptr; @@ -183,12 +183,12 @@ Perl_safesyscalloc(pTHX_ MEM_SIZE count, MEM_SIZE size) if (size * count > 0xffff) { PerlIO_printf(PerlIO_stderr(), "Allocation too large: %lx\n", size * count) FLUSH; - my_exit(1); + WITH_THX(my_exit(1)); } #endif /* HAS_64K_LIMIT */ #ifdef DEBUGGING if ((long)size < 0 || (long)count < 0) - Perl_croak(aTHX_ "panic: calloc"); + Perl_croak_nocontext("panic: calloc"); #endif size *= count; ptr = PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */ @@ -205,7 +205,7 @@ Perl_safesyscalloc(pTHX_ MEM_SIZE count, MEM_SIZE size) return Nullch; else { PerlIO_puts(PerlIO_stderr(),PL_no_mem) FLUSH; - my_exit(1); + WITH_THX(my_exit(1)); return Nullch; } /*NOTREACHED*/ @@ -235,7 +235,7 @@ struct mem_test_strut { : ((size) - 1)/4)) Malloc_t -Perl_safexmalloc(pTHX_ I32 x, MEM_SIZE size) +Perl_safexmalloc(I32 x, MEM_SIZE size) { register char* where = (char*)safemalloc(size + ALIGN); @@ -247,7 +247,7 @@ Perl_safexmalloc(pTHX_ I32 x, MEM_SIZE size) } Malloc_t -Perl_safexrealloc(pTHX_ Malloc_t wh, MEM_SIZE size) +Perl_safexrealloc(Malloc_t wh, MEM_SIZE size) { char *where = (char*)wh; @@ -268,7 +268,7 @@ Perl_safexrealloc(pTHX_ Malloc_t wh, MEM_SIZE size) } void -Perl_safexfree(pTHX_ Malloc_t wh) +Perl_safexfree(Malloc_t wh) { I32 x; char *where = (char*)wh; @@ -285,7 +285,7 @@ Perl_safexfree(pTHX_ Malloc_t wh) } Malloc_t -Perl_safexcalloc(pTHX_ I32 x,MEM_SIZE count, MEM_SIZE size) +Perl_safexcalloc(I32 x,MEM_SIZE count, MEM_SIZE size) { register char * where = (char*)safexmalloc(x, size * count + ALIGN); xcount[x] += size; @@ -3224,7 +3224,7 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) MUTEX_UNLOCK(&t->mutex); #ifdef HAVE_THREAD_INTERN - init_thread_intern(thr); + Perl_init_thread_intern(thr); #endif /* HAVE_THREAD_INTERN */ return thr; } diff --git a/win32/Makefile b/win32/Makefile index e1a864fa96..42b8a9deee 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -379,7 +379,6 @@ XSUBPP = ..\$(MINIPERL) -I..\..\lib ..\$(EXTUTILSDIR)\xsubpp \ MICROCORE_SRC = \ ..\av.c \ - ..\byterun.c \ ..\deb.c \ ..\doio.c \ ..\doop.c \ @@ -451,8 +450,6 @@ X2P_SRC = \ CORE_NOCFG_H = \ ..\av.h \ - ..\byterun.h \ - ..\bytecode.h \ ..\cop.h \ ..\cv.h \ ..\dosish.h \ diff --git a/win32/config_H.bc b/win32/config_H.bc index 611e03149f..5b795f5d03 100644 --- a/win32/config_H.bc +++ b/win32/config_H.bc @@ -2357,7 +2357,7 @@ * in programs that are not prepared to deal with ~ expansion at run-time. */ #define PRIVLIB "c:\\perl\\5.00557\\lib" /**/ -#define PRIVLIB_EXP (win32_get_privlib("5.00557")) /**/ +#define PRIVLIB_EXP (win32_get_privlib(aTHX_ "5.00557")) /**/ /* SELECT_MIN_BITS: * This symbol holds the minimum number of bits operated by select. @@ -2398,7 +2398,7 @@ * in programs that are not prepared to deal with ~ expansion at run-time. */ #define SITELIB "c:\\perl\\site\\5.00557\\lib" /**/ -#define SITELIB_EXP (win32_get_sitelib("5.00557")) /**/ +#define SITELIB_EXP (win32_get_sitelib(aTHX_ "5.00557")) /**/ /* STARTPERL: * This variable contains the string to put in front of a perl @@ -2679,4 +2679,3 @@ #define Uid_t uid_t /* UID type */ #endif -#include <win32.h> diff --git a/win32/config_H.gc b/win32/config_H.gc index efae62faf8..783f4e2c0d 100644 --- a/win32/config_H.gc +++ b/win32/config_H.gc @@ -2357,7 +2357,7 @@ * in programs that are not prepared to deal with ~ expansion at run-time. */ #define PRIVLIB "c:\\perl\\5.00557\\lib" /**/ -#define PRIVLIB_EXP (win32_get_privlib("5.00557")) /**/ +#define PRIVLIB_EXP (win32_get_privlib(aTHX_ "5.00557")) /**/ /* SELECT_MIN_BITS: * This symbol holds the minimum number of bits operated by select. @@ -2398,7 +2398,7 @@ * in programs that are not prepared to deal with ~ expansion at run-time. */ #define SITELIB "c:\\perl\\site\\5.00557\\lib" /**/ -#define SITELIB_EXP (win32_get_sitelib("5.00557")) /**/ +#define SITELIB_EXP (win32_get_sitelib(aTHX_ "5.00557")) /**/ /* STARTPERL: * This variable contains the string to put in front of a perl @@ -2679,4 +2679,3 @@ #define Uid_t uid_t /* UID type */ #endif -#include <win32.h> diff --git a/win32/config_H.vc b/win32/config_H.vc index 620afdef75..4f858d71ac 100644 --- a/win32/config_H.vc +++ b/win32/config_H.vc @@ -2357,7 +2357,7 @@ * in programs that are not prepared to deal with ~ expansion at run-time. */ #define PRIVLIB "c:\\perl\\5.00557\\lib" /**/ -#define PRIVLIB_EXP (win32_get_privlib("5.00557")) /**/ +#define PRIVLIB_EXP (win32_get_privlib(aTHX_ "5.00557")) /**/ /* SELECT_MIN_BITS: * This symbol holds the minimum number of bits operated by select. @@ -2398,7 +2398,7 @@ * in programs that are not prepared to deal with ~ expansion at run-time. */ #define SITELIB "c:\\perl\\site\\5.00557\\lib" /**/ -#define SITELIB_EXP (win32_get_sitelib("5.00557")) /**/ +#define SITELIB_EXP (win32_get_sitelib(aTHX_ "5.00557")) /**/ /* STARTPERL: * This variable contains the string to put in front of a perl @@ -2679,4 +2679,3 @@ #define Uid_t uid_t /* UID type */ #endif -#include <win32.h> diff --git a/win32/config_h.PL b/win32/config_h.PL index 617b996cdb..850b134ba3 100644 --- a/win32/config_h.PL +++ b/win32/config_h.PL @@ -51,7 +51,7 @@ while (<SH>) s#/[ *\*]*\*/#/**/#; if (/^\s*#define\s+(PRIVLIB|SITELIB)_EXP/) { - $_ = "#define ". $1 . "_EXP (win32_get_". lc($1) . "($patchlevel))\t/**/\n"; + $_ = "#define ". $1 . "_EXP (win32_get_". lc($1) . "(aTHX_ $patchlevel))\t/**/\n"; } # incpush() handles archlibs, so disable them elsif (/^\s*#define\s+(ARCHLIB|SITEARCH)_EXP/) @@ -60,7 +60,6 @@ while (<SH>) } print H; } -print H "#include <win32.h>\n"; close(H); close(SH); diff --git a/win32/dl_win32.xs b/win32/dl_win32.xs index 6c1b424740..5c6f627437 100644 --- a/win32/dl_win32.xs +++ b/win32/dl_win32.xs @@ -37,22 +37,22 @@ calls. static SV *error_sv; static char * -OS_Error_String(CPERLarg) +OS_Error_String(pTHX) { DWORD err = GetLastError(); STRLEN len; if (!error_sv) error_sv = newSVpvn("",0); - win32_str_os_error(error_sv,err); + win32_str_os_error(aTHX_ error_sv,err); return SvPV(error_sv,len); } #include "dlutils.c" /* SaveError() etc */ static void -dl_private_init(CPERLarg) +dl_private_init(pTHX) { - (void)dl_generic_private_init(PERL_OBJECT_THIS); + (void)dl_generic_private_init(aTHX); } /* @@ -94,7 +94,7 @@ dl_static_linked(char *filename) MODULE = DynaLoader PACKAGE = DynaLoader BOOT: - (void)dl_private_init(PERL_OBJECT_THIS); + (void)dl_private_init(aTHX); void * dl_load_file(filename,flags=0) @@ -119,8 +119,8 @@ dl_load_file(filename,flags=0) DLDEBUG(2,PerlIO_printf(PerlIO_stderr()," libref=%x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) - SaveError(PERL_OBJECT_THIS_ "load_file:%s", - OS_Error_String(PERL_OBJECT_THIS)) ; + SaveError(aTHX_ "load_file:%s", + OS_Error_String(aTHX)) ; else sv_setiv( ST(0), (IV)RETVAL); } @@ -136,8 +136,8 @@ dl_find_symbol(libhandle, symbolname) DLDEBUG(2,PerlIO_printf(PerlIO_stderr()," symbolref = %x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) - SaveError(PERL_OBJECT_THIS_ "find_symbol:%s", - OS_Error_String(PERL_OBJECT_THIS)) ; + SaveError(aTHX_ "find_symbol:%s", + OS_Error_String(aTHX)) ; else sv_setiv( ST(0), (IV)RETVAL); @@ -158,7 +158,9 @@ dl_install_xsub(perl_name, symref, filename="$Package") CODE: DLDEBUG(2,PerlIO_printf(PerlIO_stderr(),"dl_install_xsub(name=%s, symref=%x)\n", perl_name, symref)); - ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)(CV* _CPERLarg))symref, filename))); + ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, + (void(*)(pTHX_ CV *))symref, + filename))); char * diff --git a/win32/makedef.pl b/win32/makedef.pl index c47dc65197..2071220e20 100644 --- a/win32/makedef.pl +++ b/win32/makedef.pl @@ -79,6 +79,9 @@ PL_pending_ident PL_sortcxix PL_sublex_info PL_timesbuf +main +Perl_ErrorNo +Perl_GetVars Perl_do_exec3 Perl_do_ipcctl Perl_do_ipcget @@ -122,6 +125,10 @@ else { skip_symbols [qw( Perl_dump_mstats + Perl_malloc + Perl_mfree + Perl_realloc + Perl_calloc Perl_malloced_size)]; } @@ -155,6 +162,20 @@ Perl_unlock_condpair Perl_magic_mutexfree )]; } +unless ($define{'USE_THREADS'} or $define{'PERL_IMPLICIT_CONTEXT'}) + { + skip_symbols [qw( + Perl_croak_nocontext + Perl_die_nocontext + Perl_form_nocontext + Perl_warn_nocontext + Perl_newSVpvf_nocontext + Perl_sv_catpvf_nocontext + Perl_sv_setpvf_nocontext + Perl_sv_catpvf_mg_nocontext + Perl_sv_setpvf_mg_nocontext + )]; + } unless ($define{'FAKE_THREADS'}) { @@ -228,7 +249,7 @@ for my $syms ('../global.sym','../pp.sym', '../globvar.sym') # Functions have a Perl_ prefix # Variables have a PL_ prefix chomp($_); - my $symbol = ($syms =~ /var\.sym$/i ? "PL_" : "Perl_"); + my $symbol = ($syms =~ /var\.sym$/i ? "PL_" : ""); $symbol .= $_; emit_symbol($symbol) unless exists $skip{$symbol}; } @@ -303,30 +324,12 @@ sub output_symbol { 1; __DATA__ # extra globals not included above. -perl_init_i18nl10n perl_alloc -perl_atexit perl_construct perl_destruct perl_free perl_parse perl_run -perl_get_sv -perl_get_av -perl_get_hv -perl_get_cv -perl_call_argv -perl_call_pv -perl_call_method -perl_call_sv -perl_require_pv -perl_eval_pv -perl_eval_sv -perl_new_ctype -perl_new_collate -perl_new_numeric -perl_set_numeric_standard -perl_set_numeric_local boot_DynaLoader Perl_thread_create win32_errno diff --git a/win32/makefile.mk b/win32/makefile.mk index 1b2fa4ebd2..7a97dab387 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -497,7 +497,6 @@ XSUBPP = ..\$(MINIPERL) -I..\..\lib ..\$(EXTUTILSDIR)\xsubpp \ MICROCORE_SRC = \ ..\av.c \ - ..\byterun.c \ ..\deb.c \ ..\doio.c \ ..\doop.c \ @@ -569,8 +568,6 @@ X2P_SRC = \ CORE_NOCFG_H = \ ..\av.h \ - ..\byterun.h \ - ..\bytecode.h \ ..\cop.h \ ..\cv.h \ ..\dosish.h \ diff --git a/win32/perllib.c b/win32/perllib.c index 2494b44cd0..255ad39040 100644 --- a/win32/perllib.c +++ b/win32/perllib.c @@ -7,13 +7,14 @@ #include "perl.h" #include "XSUB.h" -static void xs_init (void); +static void xs_init (pTHX); DllExport int RunPerl(int argc, char **argv, char **env, void *iosubsystem) { int exitstatus; PerlInterpreter *my_perl; + struct perl_thread *thr; #ifdef PERL_GLOBAL_STRUCT #define PERLVAR(var,type) /**/ @@ -27,14 +28,14 @@ RunPerl(int argc, char **argv, char **env, void *iosubsystem) PERL_SYS_INIT(&argc,&argv); - perl_init_i18nl10n(1); + init_i18nl10n(1); if (!(my_perl = perl_alloc())) return (1); perl_construct( my_perl ); PL_perl_destruct_level = 0; - exitstatus = perl_parse( my_perl, xs_init, argc, argv, env); + exitstatus = perl_parse(my_perl, xs_init, argc, argv, env); if (!exitstatus) { exitstatus = perl_run( my_perl ); } @@ -96,10 +97,10 @@ char *staticlinkmodules[] = { NULL, }; -EXTERN_C void boot_DynaLoader (CV* cv); +EXTERN_C void boot_DynaLoader (pTHX_ CV* cv); static void -xs_init() +xs_init(pTHX) { char *file = __FILE__; dXSUB_SYS; diff --git a/win32/win32.c b/win32/win32.c index 49a487e559..694f48a758 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -90,7 +90,7 @@ int _CRT_glob = 0; static DWORD os_id(void); static void get_shell(void); static long tokenize(char *str, char **dest, char ***destv); - int do_spawn2(char *cmd, int exectype); + int do_spawn2(pTHX_ char *cmd, int exectype); static BOOL has_shell_metachars(char *ptr); static long filetime_to_clock(PFILETIME ft); static BOOL filetime_from_time(PFILETIME ft, time_t t); @@ -254,7 +254,7 @@ get_emd_part(char **prev_path, char *trailing_path, ...) } char * -win32_get_privlib(char *pl) +win32_get_privlib(pTHX_ char *pl) { char *stdlib = "lib"; char buffer[MAX_PATH+1]; @@ -276,7 +276,7 @@ win32_get_privlib(char *pl) } char * -win32_get_sitelib(char *pl) +win32_get_sitelib(pTHX_ char *pl) { char *sitelib = "sitelib"; char regstr[40]; @@ -375,7 +375,7 @@ has_shell_metachars(char *ptr) * the library functions will get the correct environment */ PerlIO * -my_popen(char *cmd, char *mode) +Perl_my_popen(pTHX_ char *cmd, char *mode) { #ifdef FIXCMD #define fixcmd(x) { \ @@ -398,7 +398,7 @@ my_popen(char *cmd, char *mode) } long -my_pclose(PerlIO *fp) +Perl_my_pclose(pTHX_ PerlIO *fp) { return win32_pclose(fp); } @@ -490,7 +490,7 @@ get_shell(void) } int -do_aspawn(void *vreally, void **vmark, void **vsp) +do_aspawn(pTHX_ void *vreally, void **vmark, void **vsp) { SV *really = (SV*)vreally; SV **mark = (SV**)vmark; @@ -541,7 +541,7 @@ do_aspawn(void *vreally, void **vmark, void **vsp) if (flag != P_NOWAIT) { if (status < 0) { if (PL_dowarn) - warn("Can't spawn \"%s\": %s", argv[0], strerror(errno)); + Perl_warn(aTHX_ "Can't spawn \"%s\": %s", argv[0], strerror(errno)); status = 255 * 256; } else @@ -553,7 +553,7 @@ do_aspawn(void *vreally, void **vmark, void **vsp) } int -do_spawn2(char *cmd, int exectype) +do_spawn2(pTHX_ char *cmd, int exectype) { char **a; char *s; @@ -628,7 +628,7 @@ do_spawn2(char *cmd, int exectype) if (exectype != EXECF_SPAWN_NOWAIT) { if (status < 0) { if (PL_dowarn) - warn("Can't %s \"%s\": %s", + Perl_warn(aTHX_ "Can't %s \"%s\": %s", (exectype == EXECF_EXEC ? "exec" : "spawn"), cmd, strerror(errno)); status = 255 * 256; @@ -641,21 +641,21 @@ do_spawn2(char *cmd, int exectype) } int -do_spawn(char *cmd) +do_spawn(pTHX_ char *cmd) { - return do_spawn2(cmd, EXECF_SPAWN); + return do_spawn2(aTHX_ cmd, EXECF_SPAWN); } int -do_spawn_nowait(char *cmd) +do_spawn_nowait(pTHX_ char *cmd) { - return do_spawn2(cmd, EXECF_SPAWN_NOWAIT); + return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT); } bool -do_exec(char *cmd) +Perl_do_exec(pTHX_ char *cmd) { - do_spawn2(cmd, EXECF_EXEC); + do_spawn2(aTHX_ cmd, EXECF_EXEC); return FALSE; } @@ -734,7 +734,7 @@ win32_opendir(char *filename) idx = strlen(ptr)+1; New(1304, p->start, idx, char); if (p->start == NULL) - croak("opendir: malloc failed!\n"); + Perl_croak_nocontext("opendir: malloc failed!\n"); strcpy(p->start, ptr); p->nfiles++; @@ -756,7 +756,7 @@ win32_opendir(char *filename) */ Renew(p->start, idx+len+1, char); if (p->start == NULL) - croak("opendir: malloc failed!\n"); + Perl_croak_nocontext("opendir: malloc failed!\n"); strcpy(&p->start[idx], ptr); p->nfiles++; idx += len+1; @@ -885,7 +885,7 @@ setgid(gid_t agid) char * getlogin(void) { - dTHR; + dTHX; char *buf = getlogin_buffer; DWORD size = sizeof(getlogin_buffer); if (GetUserName(buf,&size)) @@ -1540,7 +1540,7 @@ win32_alarm(unsigned int sec) { timerid = SetTimer(NULL,timerid,sec*1000,(TIMERPROC)TimerProc); if (!timerid) - croak("Cannot set timer"); + Perl_croak_nocontext("Cannot set timer"); } else { @@ -1685,7 +1685,7 @@ win32_flock(int fd, int oper) HANDLE fh; if (!IsWinNT()) { - croak("flock() unimplemented on this platform"); + Perl_croak_nocontext("flock() unimplemented on this platform"); return -1; } fh = (HANDLE)_get_osfhandle(fd); @@ -1783,7 +1783,7 @@ win32_strerror(int e) DWORD source = 0; if (e < 0 || e > sys_nerr) { - dTHR; + dTHX; if (e < 0) e = GetLastError(); @@ -1797,7 +1797,7 @@ win32_strerror(int e) } DllExport void -win32_str_os_error(void *sv, DWORD dwErr) +win32_str_os_error(pTHX_ void *sv, DWORD dwErr) { DWORD dwLen; char *sMsg; @@ -2078,17 +2078,20 @@ win32_popen(const char *command, const char *mode) win32_close(p[child]); /* start the child */ - if ((childpid = do_spawn_nowait((char*)command)) == -1) - goto cleanup; + { + dTHX; + if ((childpid = do_spawn_nowait(aTHX_ (char*)command)) == -1) + goto cleanup; - /* revert stdfd to whatever it was before */ - if (win32_dup2(oldfd, stdfd) == -1) - goto cleanup; + /* revert stdfd to whatever it was before */ + if (win32_dup2(oldfd, stdfd) == -1) + goto cleanup; - /* close saved handle */ - win32_close(oldfd); + /* close saved handle */ + win32_close(oldfd); - sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid); + sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid); + } /* we have an fd, return a file stream */ return (win32_fdopen(p[parent], (char *)mode)); @@ -2116,7 +2119,7 @@ win32_pclose(FILE *pf) #ifdef USE_RTL_POPEN return _pclose(pf); #else - + dTHX; int childpid, status; SV *sv; @@ -2802,7 +2805,7 @@ XS(w32_SetCwd) { dXSARGS; if (items != 1) - croak("usage: Win32::SetCurrentDirectory($cwd)"); + Perl_croak(aTHX_ "usage: Win32::SetCurrentDirectory($cwd)"); if (SetCurrentDirectory(SvPV_nolen(ST(0)))) XSRETURN_YES; @@ -2840,7 +2843,7 @@ XS(w32_SetLastError) { dXSARGS; if (items != 1) - croak("usage: Win32::SetLastError($error)"); + Perl_croak(aTHX_ "usage: Win32::SetLastError($error)"); SetLastError(SvIV(ST(0))); XSRETURN_EMPTY; } @@ -2984,7 +2987,7 @@ XS(w32_FormatMessage) char msgbuf[1024]; if (items != 1) - croak("usage: Win32::FormatMessage($errno)"); + Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)"); if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, SvIV(ST(0)), 0, @@ -3004,7 +3007,7 @@ XS(w32_Spawn) BOOL bSuccess = FALSE; if (items != 3) - croak("usage: Win32::Spawn($cmdName, $args, $PID)"); + Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)"); cmd = SvPV_nolen(ST(0)); args = SvPV_nolen(ST(1)); @@ -3052,7 +3055,7 @@ XS(w32_GetShortPathName) DWORD len; if (items != 1) - croak("usage: Win32::GetShortPathName($longPathName)"); + Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)"); shortpath = sv_mortalcopy(ST(0)); SvUPGRADE(shortpath, SVt_PV); @@ -3080,7 +3083,7 @@ XS(w32_GetFullPathName) DWORD len; if (items != 1) - croak("usage: Win32::GetFullPathName($filename)"); + Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)"); filename = ST(0); fullpath = sv_mortalcopy(filename); @@ -3115,7 +3118,7 @@ XS(w32_GetLongPathName) STRLEN len; if (items != 1) - croak("usage: Win32::GetLongPathName($pathname)"); + Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)"); path = ST(0); pathstr = SvPV(path,len); @@ -3133,7 +3136,7 @@ XS(w32_Sleep) { dXSARGS; if (items != 1) - croak("usage: Win32::Sleep($milliseconds)"); + Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)"); Sleep(SvIV(ST(0))); XSRETURN_YES; } @@ -3143,14 +3146,14 @@ XS(w32_CopyFile) { dXSARGS; if (items != 3) - croak("usage: Win32::CopyFile($from, $to, $overwrite)"); + Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)"); if (CopyFile(SvPV_nolen(ST(0)), SvPV_nolen(ST(1)), !SvTRUE(ST(2)))) XSRETURN_YES; XSRETURN_NO; } void -Perl_init_os_extras() +Perl_init_os_extras(pTHX) { char *file = __FILE__; dXSUB_SYS; diff --git a/win32/win32.h b/win32/win32.h index 18f8fabf4a..61aa2233f5 100644 --- a/win32/win32.h +++ b/win32/win32.h @@ -194,23 +194,23 @@ typedef unsigned short mode_t; #define STRUCT_MGVTBL_DEFINITION \ struct mgvtbl { \ union { \ - int (CPERLscope(*svt_get)) (SV *sv, MAGIC* mg); \ + int (CPERLscope(*svt_get))(pTHX_ SV *sv, MAGIC* mg); \ char handle_VC_problem1[16]; \ }; \ union { \ - int (CPERLscope(*svt_set)) (SV *sv, MAGIC* mg); \ + int (CPERLscope(*svt_set))(pTHX_ SV *sv, MAGIC* mg); \ char handle_VC_problem2[16]; \ }; \ union { \ - U32 (CPERLscope(*svt_len)) (SV *sv, MAGIC* mg); \ + U32 (CPERLscope(*svt_len))(pTHX_ SV *sv, MAGIC* mg); \ char handle_VC_problem3[16]; \ }; \ union { \ - int (CPERLscope(*svt_clear)) (SV *sv, MAGIC* mg); \ + int (CPERLscope(*svt_clear))(pTHX_ SV *sv, MAGIC* mg); \ char handle_VC_problem4[16]; \ }; \ union { \ - int (CPERLscope(*svt_free)) (SV *sv, MAGIC* mg); \ + int (CPERLscope(*svt_free))(pTHX_ SV *sv, MAGIC* mg); \ char handle_VC_problem5[16]; \ }; \ } @@ -218,7 +218,7 @@ struct mgvtbl { \ #define BASEOP_DEFINITION \ OP* op_next; \ OP* op_sibling; \ - OP* (CPERLscope(*op_ppaddr))(ARGSproto); \ + OP* (CPERLscope(*op_ppaddr))(pTHX); \ char handle_VC_problem[12]; \ PADOFFSET op_targ; \ OPCODE op_type; \ @@ -231,7 +231,7 @@ struct mgvtbl { \ I32 any_i32; \ IV any_iv; \ long any_long; \ - void (CPERLscope(*any_dptr)) (void*); \ + void (CPERLscope(*any_dptr)) (pTHX_ void*); \ char handle_VC_problem[16]; \ } @@ -294,19 +294,18 @@ extern int chown(const char *p, uid_t o, gid_t g); #define init_os_extras Perl_init_os_extras DllExport void Perl_win32_init(int *argcp, char ***argvp); -DllExport void Perl_init_os_extras(void); -DllExport void win32_str_os_error(void *sv, DWORD err); +DllExport void Perl_init_os_extras(pTHX); +DllExport void win32_str_os_error(pTHX_ void *sv, DWORD err); #ifndef USE_SOCKETS_AS_HANDLES extern FILE * my_fdopen(int, char *); #endif extern int my_fclose(FILE *); -extern int do_aspawn(void *really, void **mark, void **sp); -extern int do_spawn(char *cmd); -extern int do_spawn_nowait(char *cmd); -extern char do_exec(char *cmd); -extern char * win32_get_privlib(char *pl); -extern char * win32_get_sitelib(char *pl); +extern int do_aspawn(pTHX_ void *really, void **mark, void **sp); +extern int do_spawn(pTHX_ char *cmd); +extern int do_spawn_nowait(pTHX_ char *cmd); +extern char * win32_get_privlib(pTHX_ char *pl); +extern char * win32_get_sitelib(pTHX_ char *pl); extern int IsWin95(void); extern int IsWinNT(void); @@ -406,5 +405,11 @@ struct thread_intern { #define USING_WIDE() 0 #define GETINTERPMODE() CP_ACP +/* + * This provides a layer of functions and macros to ensure extensions will + * get to use the same RTL functions as the core. + */ +#include "win32iop.h" + #endif /* _INC_WIN32_PERL5 */ diff --git a/win32/win32sck.c b/win32/win32sck.c index 2713605840..8bd6b6cfd5 100644 --- a/win32/win32sck.c +++ b/win32/win32sck.c @@ -103,9 +103,9 @@ start_sockets(void) */ version = 0x101; if(ret = WSAStartup(version, &retdata)) - croak("Unable to locate winsock library!\n"); + Perl_croak_nocontext("Unable to locate winsock library!\n"); if(retdata.wVersion != version) - croak("Could not find version 1.1 of winsock dll\n"); + Perl_croak_nocontext("Could not find version 1.1 of winsock dll\n"); /* atexit((void (*)(void)) EndSockets); */ wsock_started = 1; @@ -116,7 +116,7 @@ set_socktype(void) { #ifdef USE_SOCKETS_AS_HANDLES #ifdef USE_THREADS - dTHR; + dTHX; if(!init_socktype) { #endif int iSockOpt = SO_SYNCHRONOUS_NONALERT; @@ -496,7 +496,7 @@ struct servent * win32_getservbyname(const char *name, const char *proto) { struct servent *r; - dTHR; + dTHX; SOCKET_TEST(r = getservbyname(name, proto), NULL); if (r) { @@ -509,7 +509,7 @@ struct servent * win32_getservbyport(int port, const char *proto) { struct servent *r; - dTHR; + dTHX; SOCKET_TEST(r = getservbyport(port, proto), NULL); if (r) { @@ -525,14 +525,14 @@ win32_ioctl(int i, unsigned int u, char *data) int retval; if (!wsock_started) { - croak("ioctl implemented only on sockets"); + Perl_croak_nocontext("ioctl implemented only on sockets"); /* NOTREACHED */ } retval = ioctlsocket(TO_SOCKET(i), (long)u, &argp); if (retval == SOCKET_ERROR) { if (WSAGetLastError() == WSAENOTSOCK) { - croak("ioctl implemented only on sockets"); + Perl_croak_nocontext("ioctl implemented only on sockets"); /* NOTREACHED */ } errno = WSAGetLastError(); @@ -561,88 +561,88 @@ win32_inet_addr(const char FAR *cp) void win32_endhostent() { - croak("endhostent not implemented!\n"); + Perl_croak_nocontext("endhostent not implemented!\n"); } void win32_endnetent() { - croak("endnetent not implemented!\n"); + Perl_croak_nocontext("endnetent not implemented!\n"); } void win32_endprotoent() { - croak("endprotoent not implemented!\n"); + Perl_croak_nocontext("endprotoent not implemented!\n"); } void win32_endservent() { - croak("endservent not implemented!\n"); + Perl_croak_nocontext("endservent not implemented!\n"); } struct netent * win32_getnetent(void) { - croak("getnetent not implemented!\n"); + Perl_croak_nocontext("getnetent not implemented!\n"); return (struct netent *) NULL; } struct netent * win32_getnetbyname(char *name) { - croak("getnetbyname not implemented!\n"); + Perl_croak_nocontext("getnetbyname not implemented!\n"); return (struct netent *)NULL; } struct netent * win32_getnetbyaddr(long net, int type) { - croak("getnetbyaddr not implemented!\n"); + Perl_croak_nocontext("getnetbyaddr not implemented!\n"); return (struct netent *)NULL; } struct protoent * win32_getprotoent(void) { - croak("getprotoent not implemented!\n"); + Perl_croak_nocontext("getprotoent not implemented!\n"); return (struct protoent *) NULL; } struct servent * win32_getservent(void) { - croak("getservent not implemented!\n"); + Perl_croak_nocontext("getservent not implemented!\n"); return (struct servent *) NULL; } void win32_sethostent(int stayopen) { - croak("sethostent not implemented!\n"); + Perl_croak_nocontext("sethostent not implemented!\n"); } void win32_setnetent(int stayopen) { - croak("setnetent not implemented!\n"); + Perl_croak_nocontext("setnetent not implemented!\n"); } void win32_setprotoent(int stayopen) { - croak("setprotoent not implemented!\n"); + Perl_croak_nocontext("setprotoent not implemented!\n"); } void win32_setservent(int stayopen) { - croak("setservent not implemented!\n"); + Perl_croak_nocontext("setservent not implemented!\n"); } static struct servent* diff --git a/win32/win32thread.c b/win32/win32thread.c index b40c5aa251..543fc130f5 100644 --- a/win32/win32thread.c +++ b/win32/win32thread.c @@ -44,7 +44,7 @@ Perl_alloc_thread_key(void) static int key_allocated = 0; if (!key_allocated) { if ((PL_thr_key = TlsAlloc()) == TLS_OUT_OF_INDEXES) - croak("panic: TlsAlloc"); + Perl_croak_nocontext("panic: TlsAlloc"); key_allocated = 1; } #endif diff --git a/win32/win32thread.h b/win32/win32thread.h index 1fddc9e7d5..4fa3e2f3bf 100644 --- a/win32/win32thread.h +++ b/win32/win32thread.h @@ -1,5 +1,9 @@ #ifndef _WIN32THREAD_H #define _WIN32THREAD_H + +#define WIN32_LEAN_AND_MEAN +#include <windows.h> + typedef struct win32_cond { LONG waiters; HANDLE sem; } perl_cond; typedef DWORD perl_key; typedef HANDLE perl_os_thread; @@ -14,6 +18,8 @@ typedef CRITICAL_SECTION perl_mutex; #define MUTEX_INIT(m) InitializeCriticalSection(m) #define MUTEX_LOCK(m) EnterCriticalSection(m) #define MUTEX_UNLOCK(m) LeaveCriticalSection(m) +#define MUTEX_LOCK_NOCONTEXT(m) EnterCriticalSection(m) +#define MUTEX_UNLOCK_NOCONTEXT(m) LeaveCriticalSection(m) #define MUTEX_DESTROY(m) DeleteCriticalSection(m) #else @@ -22,22 +28,32 @@ typedef HANDLE perl_mutex; #define MUTEX_INIT(m) \ STMT_START { \ if ((*(m) = CreateMutex(NULL,FALSE,NULL)) == NULL) \ - croak("panic: MUTEX_INIT"); \ + Perl_croak(aTHX_ "panic: MUTEX_INIT"); \ } STMT_END #define MUTEX_LOCK(m) \ STMT_START { \ if (WaitForSingleObject(*(m),INFINITE) == WAIT_FAILED) \ - croak("panic: MUTEX_LOCK"); \ + Perl_croak(aTHX_ "panic: MUTEX_LOCK"); \ } STMT_END #define MUTEX_UNLOCK(m) \ STMT_START { \ if (ReleaseMutex(*(m)) == 0) \ - croak("panic: MUTEX_UNLOCK"); \ + Perl_croak(aTHX_ "panic: MUTEX_UNLOCK"); \ + } STMT_END +#define MUTEX_LOCK_NOCONTEXT(m) \ + STMT_START { \ + if (WaitForSingleObject(*(m),INFINITE) == WAIT_FAILED) \ + Perl_croak_nocontext("panic: MUTEX_LOCK"); \ + } STMT_END +#define MUTEX_UNLOCK_NOCONTEXT(m) \ + STMT_START { \ + if (ReleaseMutex(*(m)) == 0) \ + Perl_croak_nocontext("panic: MUTEX_UNLOCK"); \ } STMT_END #define MUTEX_DESTROY(m) \ STMT_START { \ if (CloseHandle(*(m)) == 0) \ - croak("panic: MUTEX_DESTROY"); \ + Perl_croak(aTHX_ "panic: MUTEX_DESTROY"); \ } STMT_END #endif @@ -51,21 +67,21 @@ typedef HANDLE perl_mutex; (c)->waiters = 0; \ (c)->sem = CreateSemaphore(NULL,0,LONG_MAX,NULL); \ if ((c)->sem == NULL) \ - croak("panic: COND_INIT (%ld)",GetLastError()); \ + Perl_croak(aTHX_ "panic: COND_INIT (%ld)",GetLastError()); \ } STMT_END #define COND_SIGNAL(c) \ STMT_START { \ if ((c)->waiters > 0 && \ ReleaseSemaphore((c)->sem,1,NULL) == 0) \ - croak("panic: COND_SIGNAL (%ld)",GetLastError()); \ + Perl_croak(aTHX_ "panic: COND_SIGNAL (%ld)",GetLastError()); \ } STMT_END #define COND_BROADCAST(c) \ STMT_START { \ if ((c)->waiters > 0 && \ ReleaseSemaphore((c)->sem,(c)->waiters,NULL) == 0) \ - croak("panic: COND_BROADCAST (%ld)",GetLastError());\ + Perl_croak(aTHX_ "panic: COND_BROADCAST (%ld)",GetLastError());\ } STMT_END #define COND_WAIT(c, m) \ @@ -76,7 +92,7 @@ typedef HANDLE perl_mutex; * COND_BROADCAST() on another thread will have seen the\ * right number of waiters (i.e. including this one) */ \ if (WaitForSingleObject((c)->sem,INFINITE)==WAIT_FAILED)\ - croak("panic: COND_WAIT (%ld)",GetLastError()); \ + Perl_croak(aTHX_ "panic: COND_WAIT (%ld)",GetLastError()); \ /* XXX there may be an inconsequential race here */ \ MUTEX_LOCK(m); \ (c)->waiters--; \ @@ -86,14 +102,14 @@ typedef HANDLE perl_mutex; STMT_START { \ (c)->waiters = 0; \ if (CloseHandle((c)->sem) == 0) \ - croak("panic: COND_DESTROY (%ld)",GetLastError()); \ + Perl_croak(aTHX_ "panic: COND_DESTROY (%ld)",GetLastError()); \ } STMT_END #define DETACH(t) \ STMT_START { \ if (CloseHandle((t)->self) == 0) { \ MUTEX_UNLOCK(&(t)->mutex); \ - croak("panic: DETACH"); \ + Perl_croak(aTHX_ "panic: DETACH"); \ } \ } STMT_END @@ -168,7 +184,7 @@ END_EXTERN_C if ((WaitForSingleObject((t)->self,INFINITE) == WAIT_FAILED) \ || (GetExitCodeThread((t)->self,(LPDWORD)(avp)) == 0) \ || (CloseHandle((t)->self) == 0)) \ - croak("panic: JOIN"); \ + Perl_croak(aTHX_ "panic: JOIN"); \ *avp = (AV *)((t)->i.retv); \ } STMT_END #else /* !USE_RTL_THREAD_API || _MSC_VER */ @@ -177,7 +193,7 @@ END_EXTERN_C if ((WaitForSingleObject((t)->self,INFINITE) == WAIT_FAILED) \ || (GetExitCodeThread((t)->self,(LPDWORD)(avp)) == 0) \ || (CloseHandle((t)->self) == 0)) \ - croak("panic: JOIN"); \ + Perl_croak(aTHX_ "panic: JOIN"); \ } STMT_END #endif /* !USE_RTL_THREAD_API || _MSC_VER */ |