summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--bytecode.pl6
-rw-r--r--dosish.h9
-rw-r--r--embed.h33
-rwxr-xr-xembed.pl24
-rw-r--r--ext/B/B.xs13
-rw-r--r--ext/ByteLoader/ByteLoader.xs6
-rw-r--r--ext/ByteLoader/bytecode.h6
-rw-r--r--ext/ByteLoader/byterun.h6
-rw-r--r--ext/SDBM_File/sdbm/sdbm.c3
-rw-r--r--globals.c14
-rw-r--r--mg.c2
-rw-r--r--objXSUB.h4
-rw-r--r--op.h2
-rw-r--r--perl.c4
-rw-r--r--perl.h19
-rw-r--r--pp_sys.c10
-rw-r--r--proto.h23
-rw-r--r--sv.c2
-rw-r--r--util.c36
-rw-r--r--win32/Makefile3
-rw-r--r--win32/config_H.bc5
-rw-r--r--win32/config_H.gc5
-rw-r--r--win32/config_H.vc5
-rw-r--r--win32/config_h.PL3
-rw-r--r--win32/dl_win32.xs22
-rw-r--r--win32/makedef.pl41
-rw-r--r--win32/makefile.mk3
-rw-r--r--win32/perllib.c11
-rw-r--r--win32/win32.c85
-rw-r--r--win32/win32.h35
-rw-r--r--win32/win32sck.c40
-rw-r--r--win32/win32thread.c2
-rw-r--r--win32/win32thread.h40
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 {
diff --git a/dosish.h b/dosish.h
index 4056606c7e..4116deca67 100644
--- a/dosish.h
+++ b/dosish.h
@@ -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 */
diff --git a/embed.h b/embed.h
index 2db477c5ea..17acf1e76f 100644
--- a/embed.h
+++ b/embed.h
@@ -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
diff --git a/embed.pl b/embed.pl
index 6fad12441f..452a4dec54 100755
--- a/embed.pl
+++ b/embed.pl
@@ -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"
diff --git a/globals.c b/globals.c
index 857a32c78a..8ac296d009 100644
--- a/globals.c
+++ b/globals.c
@@ -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 */
diff --git a/mg.c b/mg.c
index 770452fd07..96e4bd21eb 100644
--- a/mg.c
+++ b/mg.c
@@ -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
diff --git a/objXSUB.h b/objXSUB.h
index cdb91386dd..08356c0fe7 100644
--- a/objXSUB.h
+++ b/objXSUB.h
@@ -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)
diff --git a/op.h b/op.h
index 21404bc012..a13df7752e 100644
--- a/op.h
+++ b/op.h
@@ -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; \
diff --git a/perl.c b/perl.c
index c137c22f7a..976b7b5f23 100644
--- a/perl.c
+++ b/perl.c
@@ -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
diff --git a/perl.h b/perl.h
index 73f1dc6fcf..4015a90143 100644
--- a/perl.h
+++ b/perl.h
@@ -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,
diff --git a/pp_sys.c b/pp_sys.c
index f2d0bc342c..8eee9442f2 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -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));
diff --git a/proto.h b/proto.h
index dad622a265..3d17fea32b 100644
--- a/proto.h
+++ b/proto.h
@@ -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);
diff --git a/sv.c b/sv.c
index 889d9f9f43..edf1f1e5ef 100644
--- a/sv.c
+++ b/sv.c
@@ -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);
diff --git a/util.c b/util.c
index 2c897a4776..6755c4895e 100644
--- a/util.c
+++ b/util.c
@@ -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 */