From: Gurusamy Sarathy <gsar@cpan.org>
Date: Wed, 1 Dec 1999 01:00:09 +0000 (+0000)
Subject: more complete pseudo-fork() support for Windows
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7766f1371a6d2b58d0f46fbe6a60785860a39c1e;p=p5sagit%2Fp5-mst-13.2.git
more complete pseudo-fork() support for Windows
p4raw-id: //depot/perl@4602
---
diff --git a/MANIFEST b/MANIFEST
index db6f5d6..483b3bb 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1065,6 +1065,7 @@ pod/perlfaq7.pod Frequently Asked Questions, Part 7
pod/perlfaq8.pod Frequently Asked Questions, Part 8
pod/perlfaq9.pod Frequently Asked Questions, Part 9
pod/perlfilter.pod Source filters info
+pod/perlfork.pod Info about fork()
pod/perlform.pod Format info
pod/perlfunc.pod Function info
pod/perlguts.pod Internals info
@@ -1543,10 +1544,13 @@ win32/include/netdb.h Win32 port
win32/include/sys/socket.h Win32 port
win32/makefile.mk Win32 makefile for DMAKE (BC++, VC++ builds)
win32/perlglob.c Win32 port
+win32/perlhost.h Perl "host" implementation
win32/perllib.c Win32 port
win32/pod.mak Win32 port
win32/runperl.c Win32 port
win32/splittree.pl Win32 port
+win32/vdir.h Perl "host" virtual directory manager
+win32/vmem.h Perl "host" memory manager
win32/win32.c Win32 port
win32/win32.h Win32 port
win32/win32iop.h Win32 port
diff --git a/XSUB.h b/XSUB.h
index 9eee838..e9b6dc3 100644
--- a/XSUB.h
+++ b/XSUB.h
@@ -238,6 +238,7 @@
# define setjmp PerlProc_setjmp
# define longjmp PerlProc_longjmp
# define signal PerlProc_signal
+# define getpid PerlProc_getpid
# define htonl PerlSock_htonl
# define htons PerlSock_htons
# define ntohl PerlSock_ntohl
diff --git a/cop.h b/cop.h
index 88627d6..ede2fce 100644
--- a/cop.h
+++ b/cop.h
@@ -96,19 +96,27 @@ struct block_sub {
(void)SvREFCNT_inc(cx->blk_sub.dfoutgv)
#ifdef USE_THREADS
-#define POPSAVEARRAY() NOOP
+# define POP_SAVEARRAY() NOOP
#else
-#define POPSAVEARRAY() \
+# define POP_SAVEARRAY() \
STMT_START { \
SvREFCNT_dec(GvAV(PL_defgv)); \
GvAV(PL_defgv) = cx->blk_sub.savearray; \
} STMT_END
#endif /* USE_THREADS */
+#ifdef USE_ITHREADS
+ /* junk in @_ spells trouble when cloning CVs, so don't leave any */
+# define CLEAR_ARGARRAY() av_clear(cx->blk_sub.argarray)
+#else
+# define CLEAR_ARGARRAY() NOOP
+#endif /* USE_ITHREADS */
+
+
#define POPSUB(cx,sv) \
STMT_START { \
if (cx->blk_sub.hasargs) { \
- POPSAVEARRAY(); \
+ POP_SAVEARRAY(); \
/* abandon @_ if it got reified */ \
if (AvREAL(cx->blk_sub.argarray)) { \
SSize_t fill = AvFILLp(cx->blk_sub.argarray); \
@@ -118,6 +126,9 @@ struct block_sub {
AvFLAGS(cx->blk_sub.argarray) = AVf_REIFY; \
PL_curpad[0] = (SV*)cx->blk_sub.argarray; \
} \
+ else { \
+ CLEAR_ARGARRAY(); \
+ } \
} \
sv = (SV*)cx->blk_sub.cv; \
if (sv && (CvDEPTH((CV*)sv) = cx->blk_sub.olddepth)) \
@@ -146,14 +157,15 @@ struct block_eval {
#define PUSHEVAL(cx,n,fgv) \
cx->blk_eval.old_in_eval = PL_in_eval; \
cx->blk_eval.old_op_type = PL_op->op_type; \
- cx->blk_eval.old_name = n; \
+ cx->blk_eval.old_name = (n ? savepv(n) : Nullch); \
cx->blk_eval.old_eval_root = PL_eval_root; \
cx->blk_eval.cur_text = PL_linestr;
#define POPEVAL(cx) \
PL_in_eval = cx->blk_eval.old_in_eval; \
optype = cx->blk_eval.old_op_type; \
- PL_eval_root = cx->blk_eval.old_eval_root;
+ PL_eval_root = cx->blk_eval.old_eval_root; \
+ Safefree(cx->blk_eval.old_name);
/* loop context */
struct block_loop {
@@ -162,7 +174,11 @@ struct block_loop {
OP * redo_op;
OP * next_op;
OP * last_op;
+#ifdef USE_ITHREADS
+ void * iterdata;
+#else
SV ** itervar;
+#endif
SV * itersave;
SV * iterlval;
AV * iterary;
@@ -170,23 +186,40 @@ struct block_loop {
IV itermax;
};
-#define PUSHLOOP(cx, ivar, s) \
+#ifdef USE_ITHREADS
+# define CxITERVAR(c) \
+ ((c)->blk_loop.iterdata \
+ ? (CxPADLOOP(cx) \
+ ? &PL_curpad[(PADOFFSET)(c)->blk_loop.iterdata] \
+ : &GvSV((GV*)(c)->blk_loop.iterdata)) \
+ : (SV**)NULL)
+# define CX_ITERDATA_SET(cx,idata) \
+ if (cx->blk_loop.iterdata = (idata)) \
+ cx->blk_loop.itersave = SvREFCNT_inc(*CxITERVAR(cx));
+#else
+# define CxITERVAR(c) ((c)->blk_loop.itervar)
+# define CX_ITERDATA_SET(cx,ivar) \
+ if (cx->blk_loop.itervar = (SV**)(ivar)) \
+ cx->blk_loop.itersave = SvREFCNT_inc(*CxITERVAR(cx));
+#endif
+
+#define PUSHLOOP(cx, dat, s) \
cx->blk_loop.label = PL_curcop->cop_label; \
cx->blk_loop.resetsp = s - PL_stack_base; \
cx->blk_loop.redo_op = cLOOP->op_redoop; \
cx->blk_loop.next_op = cLOOP->op_nextop; \
cx->blk_loop.last_op = cLOOP->op_lastop; \
- if (cx->blk_loop.itervar = (ivar)) \
- cx->blk_loop.itersave = SvREFCNT_inc(*cx->blk_loop.itervar);\
cx->blk_loop.iterlval = Nullsv; \
cx->blk_loop.iterary = Nullav; \
- cx->blk_loop.iterix = -1;
+ cx->blk_loop.iterix = -1; \
+ CX_ITERDATA_SET(cx,dat);
#define POPLOOP(cx) \
SvREFCNT_dec(cx->blk_loop.iterlval); \
- if (cx->blk_loop.itervar) { \
- sv_2mortal(*(cx->blk_loop.itervar)); \
- *(cx->blk_loop.itervar) = cx->blk_loop.itersave; \
+ if (CxITERVAR(cx)) { \
+ SV **s_v_p = CxITERVAR(cx); \
+ sv_2mortal(*s_v_p); \
+ *s_v_p = cx->blk_loop.itersave; \
} \
if (cx->blk_loop.iterary && cx->blk_loop.iterary != PL_curstack)\
SvREFCNT_dec(cx->blk_loop.iterary);
@@ -319,12 +352,23 @@ struct context {
#define CXt_LOOP 3
#define CXt_SUBST 4
#define CXt_BLOCK 5
+#define CXt_FORMAT 6
/* private flags for CXt_EVAL */
#define CXp_REAL 0x00000100 /* truly eval'', not a lookalike */
+#ifdef USE_ITHREADS
+/* private flags for CXt_LOOP */
+# define CXp_PADVAR 0x00000100 /* itervar lives on pad, iterdata
+ has pad offset; if not set,
+ iterdata holds GV* */
+# define CxPADLOOP(c) (((c)->cx_type & (CXt_LOOP|CXp_PADVAR)) \
+ == (CXt_LOOP|CXp_PADVAR))
+#endif
+
#define CxTYPE(c) ((c)->cx_type & CXTYPEMASK)
-#define CxREALEVAL(c) (((c)->cx_type & (CXt_EVAL|CXp_REAL)) == (CXt_EVAL|CXp_REAL))
+#define CxREALEVAL(c) (((c)->cx_type & (CXt_EVAL|CXp_REAL)) \
+ == (CXt_EVAL|CXp_REAL))
#define CXINC (cxstack_ix < cxstack_max ? ++cxstack_ix : (cxstack_ix = cxinc()))
diff --git a/dump.c b/dump.c
index 38778d6..b8eaa54 100644
--- a/dump.c
+++ b/dump.c
@@ -531,6 +531,8 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o)
#endif
break;
case OP_CONST:
+ Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
+ break;
case OP_METHOD_NAMED:
Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo->op_sv));
break;
diff --git a/embed.h b/embed.h
index 55a8c88..758a0c2 100644
--- a/embed.h
+++ b/embed.h
@@ -45,8 +45,19 @@
#if !defined(PERL_OBJECT)
#if !defined(PERL_IMPLICIT_CONTEXT)
+#if defined(PERL_IMPLICIT_SYS)
+#else
+#endif
+#if defined(USE_ITHREADS)
+#endif
+#if defined(MYMALLOC)
+#define malloced_size Perl_malloced_size
+#endif
#if defined(PERL_OBJECT)
#endif
+#if defined(PERL_OBJECT)
+#else
+#endif
#define amagic_call Perl_amagic_call
#define Gv_AMupdate Perl_Gv_AMupdate
#define append_elem Perl_append_elem
@@ -355,9 +366,6 @@
#define magic_sizepack Perl_magic_sizepack
#define magic_wipepack Perl_magic_wipepack
#define magicname Perl_magicname
-#if defined(MYMALLOC)
-#define malloced_size Perl_malloced_size
-#endif
#define markstack_grow Perl_markstack_grow
#if defined(USE_LOCALE_COLLATE)
#define mem_collxfrm Perl_mem_collxfrm
@@ -473,11 +481,10 @@
#define pad_swipe Perl_pad_swipe
#define peep Perl_peep
#if defined(PERL_OBJECT)
-#else
+#endif
#if defined(USE_THREADS)
#define new_struct_thread Perl_new_struct_thread
#endif
-#endif
#define call_atexit Perl_call_atexit
#define call_argv Perl_call_argv
#define call_method Perl_call_method
@@ -561,6 +568,7 @@
#define save_op Perl_save_op
#define save_scalar Perl_save_scalar
#define save_pptr Perl_save_pptr
+#define save_vptr Perl_save_vptr
#define save_re_context Perl_save_re_context
#define save_sptr Perl_save_sptr
#define save_svref Perl_save_svref
@@ -767,6 +775,7 @@
#define cx_dup Perl_cx_dup
#define si_dup Perl_si_dup
#define ss_dup Perl_ss_dup
+#define any_dup Perl_any_dup
#define he_dup Perl_he_dup
#define re_dup Perl_re_dup
#define fp_dup Perl_fp_dup
@@ -783,6 +792,7 @@
#define ptr_table_split Perl_ptr_table_split
#endif
#if defined(PERL_OBJECT)
+#else
#endif
#if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT)
#define avhv_index_sv S_avhv_index_sv
@@ -1058,6 +1068,8 @@
#define xstat S_xstat
# endif
#endif
+#if defined(PERL_OBJECT)
+#endif
#define ck_anoncode Perl_ck_anoncode
#define ck_bitop Perl_ck_bitop
#define ck_concat Perl_ck_concat
@@ -1444,7 +1456,18 @@
#else /* PERL_IMPLICIT_CONTEXT */
+#if defined(PERL_IMPLICIT_SYS)
+#else
+#endif
+#if defined(USE_ITHREADS)
+#endif
+#if defined(MYMALLOC)
+#define malloced_size Perl_malloced_size
+#endif
+#if defined(PERL_OBJECT)
+#endif
#if defined(PERL_OBJECT)
+#else
#endif
#define amagic_call(a,b,c,d) Perl_amagic_call(aTHX_ a,b,c,d)
#define Gv_AMupdate(a) Perl_Gv_AMupdate(aTHX_ a)
@@ -1737,9 +1760,6 @@
#define magic_sizepack(a,b) Perl_magic_sizepack(aTHX_ a,b)
#define magic_wipepack(a,b) Perl_magic_wipepack(aTHX_ a,b)
#define magicname(a,b,c) Perl_magicname(aTHX_ a,b,c)
-#if defined(MYMALLOC)
-#define malloced_size Perl_malloced_size
-#endif
#define markstack_grow() Perl_markstack_grow(aTHX)
#if defined(USE_LOCALE_COLLATE)
#define mem_collxfrm(a,b,c) Perl_mem_collxfrm(aTHX_ a,b,c)
@@ -1853,11 +1873,10 @@
#define pad_swipe(a) Perl_pad_swipe(aTHX_ a)
#define peep(a) Perl_peep(aTHX_ a)
#if defined(PERL_OBJECT)
-#else
+#endif
#if defined(USE_THREADS)
#define new_struct_thread(a) Perl_new_struct_thread(aTHX_ a)
#endif
-#endif
#define call_atexit(a,b) Perl_call_atexit(aTHX_ a,b)
#define call_argv(a,b,c) Perl_call_argv(aTHX_ a,b,c)
#define call_method(a,b) Perl_call_method(aTHX_ a,b)
@@ -1941,6 +1960,7 @@
#define save_op() Perl_save_op(aTHX)
#define save_scalar(a) Perl_save_scalar(aTHX_ a)
#define save_pptr(a) Perl_save_pptr(aTHX_ a)
+#define save_vptr(a) Perl_save_vptr(aTHX_ a)
#define save_re_context() Perl_save_re_context(aTHX)
#define save_sptr(a) Perl_save_sptr(aTHX_ a)
#define save_svref(a) Perl_save_svref(aTHX_ a)
@@ -2138,7 +2158,8 @@
#if defined(USE_ITHREADS)
#define cx_dup(a,b,c) Perl_cx_dup(aTHX_ a,b,c)
#define si_dup(a) Perl_si_dup(aTHX_ a)
-#define ss_dup(a,b,c) Perl_ss_dup(aTHX_ a,b,c)
+#define ss_dup(a) Perl_ss_dup(aTHX_ a)
+#define any_dup(a,b) Perl_any_dup(aTHX_ a,b)
#define he_dup(a,b) Perl_he_dup(aTHX_ a,b)
#define re_dup(a) Perl_re_dup(aTHX_ a)
#define fp_dup(a,b) Perl_fp_dup(aTHX_ a,b)
@@ -2155,6 +2176,7 @@
#define ptr_table_split(a) Perl_ptr_table_split(aTHX_ a)
#endif
#if defined(PERL_OBJECT)
+#else
#endif
#if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT)
#define avhv_index_sv(a) S_avhv_index_sv(aTHX_ a)
@@ -2429,6 +2451,8 @@
#define xstat(a) S_xstat(aTHX_ a)
# endif
#endif
+#if defined(PERL_OBJECT)
+#endif
#define ck_anoncode(a) Perl_ck_anoncode(aTHX_ a)
#define ck_bitop(a) Perl_ck_bitop(aTHX_ a)
#define ck_concat(a) Perl_ck_concat(aTHX_ a)
@@ -2816,8 +2840,23 @@
#endif /* PERL_IMPLICIT_CONTEXT */
#else /* PERL_OBJECT */
+#if defined(PERL_IMPLICIT_SYS)
+#else
+#endif
+#if defined(USE_ITHREADS)
+#endif
+#if defined(MYMALLOC)
+#define malloc Perl_malloc
+#define calloc Perl_calloc
+#define realloc Perl_realloc
+#define mfree Perl_mfree
+#define malloced_size Perl_malloced_size
+#endif
#if defined(PERL_OBJECT)
#endif
+#if defined(PERL_OBJECT)
+#else
+#endif
#define Perl_amagic_call CPerlObj::Perl_amagic_call
#define amagic_call Perl_amagic_call
#define Perl_Gv_AMupdate CPerlObj::Perl_Gv_AMupdate
@@ -3414,10 +3453,6 @@
#define magic_wipepack Perl_magic_wipepack
#define Perl_magicname CPerlObj::Perl_magicname
#define magicname Perl_magicname
-#if defined(MYMALLOC)
-#define Perl_malloced_size CPerlObj::Perl_malloced_size
-#define malloced_size Perl_malloced_size
-#endif
#define Perl_markstack_grow CPerlObj::Perl_markstack_grow
#define markstack_grow Perl_markstack_grow
#if defined(USE_LOCALE_COLLATE)
@@ -3633,23 +3668,16 @@
#define Perl_peep CPerlObj::Perl_peep
#define peep Perl_peep
#if defined(PERL_OBJECT)
-#define perl_construct CPerlObj::perl_construct
-#define perl_destruct CPerlObj::perl_destruct
-#define perl_free CPerlObj::perl_free
-#define perl_run CPerlObj::perl_run
-#define perl_parse CPerlObj::perl_parse
-#else
-#define perl_alloc CPerlObj::perl_alloc
-#define perl_construct CPerlObj::perl_construct
-#define perl_destruct CPerlObj::perl_destruct
-#define perl_free CPerlObj::perl_free
-#define perl_run CPerlObj::perl_run
-#define perl_parse CPerlObj::perl_parse
+#define Perl_construct CPerlObj::Perl_construct
+#define Perl_destruct CPerlObj::Perl_destruct
+#define Perl_free CPerlObj::Perl_free
+#define Perl_run CPerlObj::Perl_run
+#define Perl_parse CPerlObj::Perl_parse
+#endif
#if defined(USE_THREADS)
#define Perl_new_struct_thread CPerlObj::Perl_new_struct_thread
#define new_struct_thread Perl_new_struct_thread
#endif
-#endif
#define Perl_call_atexit CPerlObj::Perl_call_atexit
#define call_atexit Perl_call_atexit
#define Perl_call_argv CPerlObj::Perl_call_argv
@@ -3814,6 +3842,8 @@
#define save_scalar Perl_save_scalar
#define Perl_save_pptr CPerlObj::Perl_save_pptr
#define save_pptr Perl_save_pptr
+#define Perl_save_vptr CPerlObj::Perl_save_vptr
+#define save_vptr Perl_save_vptr
#define Perl_save_re_context CPerlObj::Perl_save_re_context
#define save_re_context Perl_save_re_context
#define Perl_save_sptr CPerlObj::Perl_save_sptr
@@ -4092,14 +4122,6 @@
#if defined(MYMALLOC)
#define Perl_dump_mstats CPerlObj::Perl_dump_mstats
#define dump_mstats Perl_dump_mstats
-#define Perl_malloc CPerlObj::Perl_malloc
-#define malloc Perl_malloc
-#define Perl_calloc CPerlObj::Perl_calloc
-#define calloc Perl_calloc
-#define Perl_realloc CPerlObj::Perl_realloc
-#define realloc Perl_realloc
-#define Perl_mfree CPerlObj::Perl_mfree
-#define mfree Perl_mfree
#endif
#define Perl_safesysmalloc CPerlObj::Perl_safesysmalloc
#define safesysmalloc Perl_safesysmalloc
@@ -4216,6 +4238,8 @@
#define si_dup Perl_si_dup
#define Perl_ss_dup CPerlObj::Perl_ss_dup
#define ss_dup Perl_ss_dup
+#define Perl_any_dup CPerlObj::Perl_any_dup
+#define any_dup Perl_any_dup
#define Perl_he_dup CPerlObj::Perl_he_dup
#define he_dup Perl_he_dup
#define Perl_re_dup CPerlObj::Perl_re_dup
@@ -4242,10 +4266,9 @@
#define ptr_table_store Perl_ptr_table_store
#define Perl_ptr_table_split CPerlObj::Perl_ptr_table_split
#define ptr_table_split Perl_ptr_table_split
-#define perl_clone CPerlObj::perl_clone
-#define perl_clone_using CPerlObj::perl_clone_using
#endif
#if defined(PERL_OBJECT)
+#else
#endif
#if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT)
#define S_avhv_index_sv CPerlObj::S_avhv_index_sv
@@ -4738,6 +4761,8 @@
#define xstat S_xstat
# endif
#endif
+#if defined(PERL_OBJECT)
+#endif
#define Perl_ck_anoncode CPerlObj::Perl_ck_anoncode
#define ck_anoncode Perl_ck_anoncode
#define Perl_ck_bitop CPerlObj::Perl_ck_bitop
diff --git a/embed.pl b/embed.pl
index fff791e..b21f21f 100755
--- a/embed.pl
+++ b/embed.pl
@@ -31,6 +31,7 @@ sub walk_table (&@) {
seek DATA, $END, 0; # so we may restart
while (<DATA>) {
chomp;
+ next if /^:/;
while (s|\\$||) {
$_ .= <DATA>;
chomp;
@@ -106,8 +107,7 @@ sub write_protos {
my $ret = "";
if (@_ == 1) {
my $arg = shift;
- $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifdef|else|endif)\b/
- or $arg =~ /^\s*(public|protected|private):/;
+ $ret .= "$arg\n";
}
else {
my ($flags,$retval,$func,@args) = @_;
@@ -144,7 +144,7 @@ sub write_global_sym {
my $ret = "";
if (@_ > 1) {
my ($flags,$retval,$func,@args) = @_;
- unless ($flags =~ /s/) {
+ unless ($flags =~ /[sx]/) {
$func = "Perl_$func" if $flags =~ /p/;
$ret = "$func\n";
}
@@ -422,15 +422,15 @@ walk_table {
else {
my ($flags,$retval,$func,@args) = @_;
if ($flags =~ /s/) {
- $ret .= hide("S_$func","CPerlObj::S_$func");
+ $ret .= hide("S_$func","CPerlObj::S_$func") if $flags !~ /j/;
$ret .= hide($func,"S_$func");
}
elsif ($flags =~ /p/) {
- $ret .= hide("Perl_$func","CPerlObj::Perl_$func");
+ $ret .= hide("Perl_$func","CPerlObj::Perl_$func") if $flags !~ /j/;
$ret .= hide($func,"Perl_$func");
}
else {
- $ret .= hide($func,"CPerlObj::$func");
+ $ret .= hide($func,"CPerlObj::$func") if $flags !~ /j/;
}
}
$ret;
@@ -597,7 +597,26 @@ print EM <<'END';
# endif /* USE_THREADS */
#else /* !MULTIPLICITY */
-/* cases 1, 4 and 6 above */
+
+# if defined(PERL_OBJECT)
+/* case 6 above */
+
+END
+
+for $sym (sort keys %thread) {
+ print EM multon($sym,'T','aTHXo->interp.');
+}
+
+
+for $sym (sort keys %intrp) {
+ print EM multon($sym,'I','aTHXo->interp.');
+}
+
+print EM <<'END';
+
+# else /* !PERL_OBJECT */
+
+/* cases 1 and 4 above */
END
@@ -607,7 +626,7 @@ for $sym (sort keys %intrp) {
print EM <<'END';
-# if defined(USE_THREADS)
+# if defined(USE_THREADS)
/* case 4 above */
END
@@ -618,8 +637,8 @@ for $sym (sort keys %thread) {
print EM <<'END';
-# else /* !USE_THREADS */
-/* cases 1 and 6 above */
+# else /* !USE_THREADS */
+/* case 1 above */
END
@@ -629,7 +648,8 @@ for $sym (sort keys %thread) {
print EM <<'END';
-# endif /* USE_THREADS */
+# endif /* USE_THREADS */
+# endif /* PERL_OBJECT */
#endif /* MULTIPLICITY */
#if defined(PERL_GLOBAL_STRUCT)
@@ -716,7 +736,7 @@ walk_table {
}
else {
my ($flags,$retval,$func,@args) = @_;
- unless ($flags =~ /s/) {
+ unless ($flags =~ /[js]/) {
if ($flags =~ /p/) {
$ret .= undefine("Perl_$func") . hide("Perl_$func","pPerl->Perl_$func");
$ret .= undefine($func) . hide($func,"Perl_$func");
@@ -813,9 +833,9 @@ START_EXTERN_C
#undef PERLVARI
#undef PERLVARIC
#define PERLVAR(v,t) t* Perl_##v##_ptr(pTHXo) \
- { return &(aTHXo->PL_##v); }
+ { return &(aTHXo->interp.v); }
#define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHXo) \
- { return &(aTHXo->PL_##v); }
+ { return &(aTHXo->interp.v); }
#define PERLVARI(v,t,i) PERLVAR(v,t)
#define PERLVARIC(v,t,i) PERLVAR(v, const t)
@@ -928,7 +948,7 @@ walk_table {
else {
my ($flags,$retval,$func,@args) = @_;
return $ret if exists $skipapi_funcs{$func};
- unless ($flags =~ /s/) {
+ unless ($flags =~ /[js]/) {
$ret .= "\n";
my $addctx = 1 if $flags =~ /n/;
if ($flags =~ /p/) {
@@ -965,7 +985,7 @@ Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...)
dTHXo;
va_list(arglist);
va_start(arglist, format);
- return (*pPerl->PL_StdIO->pVprintf)(pPerl->PL_StdIO, stream, format, arglist);
+ return (*PL_StdIO->pVprintf)(PL_StdIO, stream, format, arglist);
}
END_EXTERN_C
@@ -975,33 +995,86 @@ EOT
__END__
-# Lines are of the form:
-# flags|return_type|function_name|arg1|arg2|...|argN
-#
-# A line may be continued on another by ending it with a backslash.
-# Leading and trailing whitespace will be ignored in each component.
-#
-# flags are single letters with following meanings:
-# s static function, should have an S_ prefix in source
-# file
-# n has no implicit interpreter/thread context argument
-# p function has a Perl_ prefix
-# r function never returns
-# o has no compatibility macro (#define foo Perl_foo)
-#
-# Individual flags may be separated by whitespace.
-#
-# New global functions should be added at the end for binary compatibility
-# in some configurations.
-#
-# TODO: 1) Add a flag to mark the functions that are part of the public API.
-# 2) Add a field for documentation, so that L<perlguts/"API LISTING">
-# may be autogenerated.
-#
+: Lines are of the form:
+: flags|return_type|function_name|arg1|arg2|...|argN
+:
+: A line may be continued on another by ending it with a backslash.
+: Leading and trailing whitespace will be ignored in each component.
+:
+: flags are single letters with following meanings:
+: s static function, should have an S_ prefix in source
+: file
+: n has no implicit interpreter/thread context argument
+: p function has a Perl_ prefix
+: r function never returns
+: o has no compatibility macro (#define foo Perl_foo)
+: j not a member of CPerlObj
+: x not exported
+:
+: Individual flags may be separated by whitespace.
+:
+: New global functions should be added at the end for binary compatibility
+: in some configurations.
+:
+: TODO: 1) Add a flag to mark the functions that are part of the public API.
+: 2) Add a field for documentation, so that L<perlguts/"API LISTING">
+: may be autogenerated.
+START_EXTERN_C
+
+#if defined(PERL_IMPLICIT_SYS)
+jno |PerlInterpreter* |perl_alloc_using \
+ |struct IPerlMem* m|struct IPerlMem* ms \
+ |struct IPerlMem* mp|struct IPerlEnv* e \
+ |struct IPerlStdIO* io|struct IPerlLIO* lio \
+ |struct IPerlDir* d|struct IPerlSock* s \
+ |struct IPerlProc* p
+#else
+jno |PerlInterpreter* |perl_alloc
+#endif
+jno |void |perl_construct |PerlInterpreter* interp
+jno |void |perl_destruct |PerlInterpreter* interp
+jno |void |perl_free |PerlInterpreter* interp
+jno |int |perl_run |PerlInterpreter* interp
+jno |int |perl_parse |PerlInterpreter* interp|XSINIT_t xsinit \
+ |int argc|char** argv|char** env
+#if defined(USE_ITHREADS)
+jno |PerlInterpreter*|perl_clone|PerlInterpreter* interp, UV flags
+jno |PerlInterpreter*|perl_clone_using|PerlInterpreter *interp|UV flags \
+ |struct IPerlMem* m|struct IPerlMem* ms \
+ |struct IPerlMem* mp|struct IPerlEnv* e \
+ |struct IPerlStdIO* io|struct IPerlLIO* lio \
+ |struct IPerlDir* d|struct IPerlSock* s \
+ |struct IPerlProc* p
+#endif
+
+#if defined(MYMALLOC)
+jnop |Malloc_t|malloc |MEM_SIZE nbytes
+jnop |Malloc_t|calloc |MEM_SIZE elements|MEM_SIZE size
+jnop |Malloc_t|realloc |Malloc_t where|MEM_SIZE nbytes
+jnop |Free_t |mfree |Malloc_t where
+jnp |MEM_SIZE|malloced_size |void *p
+#endif
+
+END_EXTERN_C
+
+/* functions with flag 'n' should come before here */
+#if defined(PERL_OBJECT)
+class CPerlObj {
+public:
+ struct interpreter interp;
+ CPerlObj(IPerlMem*, IPerlMem*, IPerlMem*, IPerlEnv*, IPerlStdIO*,
+ IPerlLIO*, IPerlDir*, IPerlSock*, IPerlProc*);
+ void* operator new(size_t nSize, IPerlMem *pvtbl);
+ static void operator delete(void* pPerl, IPerlMem *pvtbl);
+ int do_aspawn (void *vreally, void **vmark, void **vsp);
+#endif
#if defined(PERL_OBJECT)
public:
+#else
+START_EXTERN_C
#endif
+# include "pp_proto.h"
p |SV* |amagic_call |SV* left|SV* right|int method|int dir
p |bool |Gv_AMupdate |HV* stash
p |OP* |append_elem |I32 optype|OP* head|OP* tail
@@ -1047,7 +1120,7 @@ p |OP* |convert |I32 optype|I32 flags|OP* o
pr |void |croak |const char* pat|...
pr |void |vcroak |const char* pat|va_list* args
#if defined(PERL_IMPLICIT_CONTEXT)
-npr |void |croak_nocontext|const char* pat|...
+nrp |void |croak_nocontext|const char* pat|...
np |OP* |die_nocontext |const char* pat|...
np |void |deb_nocontext |const char* pat|...
np |char* |form_nocontext |const char* pat|...
@@ -1321,9 +1394,6 @@ p |int |magic_set_all_env|SV* sv|MAGIC* mg
p |U32 |magic_sizepack |SV* sv|MAGIC* mg
p |int |magic_wipepack |SV* sv|MAGIC* mg
p |void |magicname |char* sym|char* name|I32 namlen
-#if defined(MYMALLOC)
-np |MEM_SIZE|malloced_size |void *p
-#endif
p |void |markstack_grow
#if defined(USE_LOCALE_COLLATE)
p |char* |mem_collxfrm |const char* s|STRLEN len|STRLEN* xlen
@@ -1443,24 +1513,16 @@ p |void |pad_reset
p |void |pad_swipe |PADOFFSET po
p |void |peep |OP* o
#if defined(PERL_OBJECT)
-no |void |perl_construct
-no |void |perl_destruct
-no |void |perl_free
-no |int |perl_run
-no |int |perl_parse |XSINIT_t xsinit \
- |int argc|char** argv|char** env
-#else
-no |PerlInterpreter* |perl_alloc
-no |void |perl_construct |PerlInterpreter* interp
-no |void |perl_destruct |PerlInterpreter* interp
-no |void |perl_free |PerlInterpreter* interp
-no |int |perl_run |PerlInterpreter* interp
-no |int |perl_parse |PerlInterpreter* interp|XSINIT_t xsinit \
+ox |void |Perl_construct
+ox |void |Perl_destruct
+ox |void |Perl_free
+ox |int |Perl_run
+ox |int |Perl_parse |XSINIT_t xsinit \
|int argc|char** argv|char** env
+#endif
#if defined(USE_THREADS)
p |struct perl_thread* |new_struct_thread|struct perl_thread *t
#endif
-#endif
p |void |call_atexit |ATEXIT_t fn|void *ptr
p |I32 |call_argv |const char* sub_name|I32 flags|char** argv
p |I32 |call_method |const char* methname|I32 flags
@@ -1551,6 +1613,7 @@ p |void |save_nogv |GV* gv
p |void |save_op
p |SV* |save_scalar |GV* gv
p |void |save_pptr |char** pptr
+p |void |save_vptr |void* pptr
p |void |save_re_context
p |void |save_sptr |SV** sptr
p |SV* |save_svref |SV** sptr
@@ -1705,20 +1768,16 @@ p |int |yyparse
p |int |yywarn |char* s
#if defined(MYMALLOC)
p |void |dump_mstats |char* s
-pno |Malloc_t|malloc |MEM_SIZE nbytes
-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
-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
+np |Malloc_t|safesysmalloc |MEM_SIZE nbytes
+np |Malloc_t|safesyscalloc |MEM_SIZE elements|MEM_SIZE size
+np |Malloc_t|safesysrealloc|Malloc_t where|MEM_SIZE nbytes
+np |Free_t |safesysfree |Malloc_t where
#if defined(LEAKTEST)
-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
+np |Malloc_t|safexmalloc |I32 x|MEM_SIZE size
+np |Malloc_t|safexcalloc |I32 x|MEM_SIZE elements|MEM_SIZE size
+np |Malloc_t|safexrealloc |Malloc_t where|MEM_SIZE size
+np |void |safexfree |Malloc_t where
#endif
#if defined(PERL_GLOBAL_STRUCT)
p |struct perl_vars *|GetVars
@@ -1775,7 +1834,8 @@ p |void |boot_core_xsutils
#if defined(USE_ITHREADS)
p |PERL_CONTEXT*|cx_dup |PERL_CONTEXT* cx|I32 ix|I32 max
p |PERL_SI*|si_dup |PERL_SI* si
-p |ANY* |ss_dup |ANY* ss|I32 ix|I32 max
+p |ANY* |ss_dup |PerlInterpreter* proto_perl
+p |void* |any_dup |void* v|PerlInterpreter* proto_perl
p |HE* |he_dup |HE* e|bool shared
p |REGEXP*|re_dup |REGEXP* r
p |PerlIO*|fp_dup |PerlIO* fp|char type
@@ -1791,17 +1851,14 @@ p |PTR_TBL_t*|ptr_table_new
p |void* |ptr_table_fetch|PTR_TBL_t *tbl|void *sv
p |void |ptr_table_store|PTR_TBL_t *tbl|void *oldsv|void *newsv
p |void |ptr_table_split|PTR_TBL_t *tbl
-no |PerlInterpreter*|perl_clone|PerlInterpreter* interp, UV flags
-no |PerlInterpreter*|perl_clone_using|PerlInterpreter *interp|UV flags \
- |struct IPerlMem* m|struct IPerlEnv* e \
- |struct IPerlStdIO* io|struct IPerlLIO* lio \
- |struct IPerlDir* d|struct IPerlSock* s \
- |struct IPerlProc* p
#endif
#if defined(PERL_OBJECT)
protected:
+#else
+END_EXTERN_C
#endif
+
#if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT)
s |I32 |avhv_index_sv |SV* sv
#endif
@@ -2103,3 +2160,7 @@ s |SV* |mess_alloc
s |void |xstat |int
# endif
#endif
+
+#if defined(PERL_OBJECT)
+};
+#endif
diff --git a/embedvar.h b/embedvar.h
index 610f266..2ceb49e 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -184,6 +184,8 @@
#define PL_Env (PERL_GET_INTERP->IEnv)
#define PL_LIO (PERL_GET_INTERP->ILIO)
#define PL_Mem (PERL_GET_INTERP->IMem)
+#define PL_MemParse (PERL_GET_INTERP->IMemParse)
+#define PL_MemShared (PERL_GET_INTERP->IMemShared)
#define PL_Proc (PERL_GET_INTERP->IProc)
#define PL_Sock (PERL_GET_INTERP->ISock)
#define PL_StdIO (PERL_GET_INTERP->IStdIO)
@@ -350,6 +352,8 @@
#define PL_preambled (PERL_GET_INTERP->Ipreambled)
#define PL_preprocess (PERL_GET_INTERP->Ipreprocess)
#define PL_profiledata (PERL_GET_INTERP->Iprofiledata)
+#define PL_psig_name (PERL_GET_INTERP->Ipsig_name)
+#define PL_psig_ptr (PERL_GET_INTERP->Ipsig_ptr)
#define PL_ptr_table (PERL_GET_INTERP->Iptr_table)
#define PL_replgv (PERL_GET_INTERP->Ireplgv)
#define PL_rsfp (PERL_GET_INTERP->Irsfp)
@@ -445,6 +449,8 @@
#define PL_Env (vTHX->IEnv)
#define PL_LIO (vTHX->ILIO)
#define PL_Mem (vTHX->IMem)
+#define PL_MemParse (vTHX->IMemParse)
+#define PL_MemShared (vTHX->IMemShared)
#define PL_Proc (vTHX->IProc)
#define PL_Sock (vTHX->ISock)
#define PL_StdIO (vTHX->IStdIO)
@@ -611,6 +617,8 @@
#define PL_preambled (vTHX->Ipreambled)
#define PL_preprocess (vTHX->Ipreprocess)
#define PL_profiledata (vTHX->Iprofiledata)
+#define PL_psig_name (vTHX->Ipsig_name)
+#define PL_psig_ptr (vTHX->Ipsig_ptr)
#define PL_ptr_table (vTHX->Iptr_table)
#define PL_replgv (vTHX->Ireplgv)
#define PL_rsfp (vTHX->Irsfp)
@@ -693,7 +701,408 @@
# endif /* USE_THREADS */
#else /* !MULTIPLICITY */
-/* cases 1, 4 and 6 above */
+
+# if defined(PERL_OBJECT)
+/* case 6 above */
+
+#define PL_Sv (aTHXo->interp.TSv)
+#define PL_Xpv (aTHXo->interp.TXpv)
+#define PL_av_fetch_sv (aTHXo->interp.Tav_fetch_sv)
+#define PL_bodytarget (aTHXo->interp.Tbodytarget)
+#define PL_bostr (aTHXo->interp.Tbostr)
+#define PL_chopset (aTHXo->interp.Tchopset)
+#define PL_colors (aTHXo->interp.Tcolors)
+#define PL_colorset (aTHXo->interp.Tcolorset)
+#define PL_curcop (aTHXo->interp.Tcurcop)
+#define PL_curpad (aTHXo->interp.Tcurpad)
+#define PL_curpm (aTHXo->interp.Tcurpm)
+#define PL_curstack (aTHXo->interp.Tcurstack)
+#define PL_curstackinfo (aTHXo->interp.Tcurstackinfo)
+#define PL_curstash (aTHXo->interp.Tcurstash)
+#define PL_defoutgv (aTHXo->interp.Tdefoutgv)
+#define PL_defstash (aTHXo->interp.Tdefstash)
+#define PL_delaymagic (aTHXo->interp.Tdelaymagic)
+#define PL_dirty (aTHXo->interp.Tdirty)
+#define PL_dumpindent (aTHXo->interp.Tdumpindent)
+#define PL_efloatbuf (aTHXo->interp.Tefloatbuf)
+#define PL_efloatsize (aTHXo->interp.Tefloatsize)
+#define PL_errors (aTHXo->interp.Terrors)
+#define PL_extralen (aTHXo->interp.Textralen)
+#define PL_firstgv (aTHXo->interp.Tfirstgv)
+#define PL_formtarget (aTHXo->interp.Tformtarget)
+#define PL_hv_fetch_ent_mh (aTHXo->interp.Thv_fetch_ent_mh)
+#define PL_hv_fetch_sv (aTHXo->interp.Thv_fetch_sv)
+#define PL_in_eval (aTHXo->interp.Tin_eval)
+#define PL_last_in_gv (aTHXo->interp.Tlast_in_gv)
+#define PL_lastgotoprobe (aTHXo->interp.Tlastgotoprobe)
+#define PL_lastscream (aTHXo->interp.Tlastscream)
+#define PL_localizing (aTHXo->interp.Tlocalizing)
+#define PL_mainstack (aTHXo->interp.Tmainstack)
+#define PL_markstack (aTHXo->interp.Tmarkstack)
+#define PL_markstack_max (aTHXo->interp.Tmarkstack_max)
+#define PL_markstack_ptr (aTHXo->interp.Tmarkstack_ptr)
+#define PL_maxscream (aTHXo->interp.Tmaxscream)
+#define PL_modcount (aTHXo->interp.Tmodcount)
+#define PL_na (aTHXo->interp.Tna)
+#define PL_nrs (aTHXo->interp.Tnrs)
+#define PL_ofs (aTHXo->interp.Tofs)
+#define PL_ofslen (aTHXo->interp.Tofslen)
+#define PL_op (aTHXo->interp.Top)
+#define PL_opsave (aTHXo->interp.Topsave)
+#define PL_protect (aTHXo->interp.Tprotect)
+#define PL_reg_call_cc (aTHXo->interp.Treg_call_cc)
+#define PL_reg_curpm (aTHXo->interp.Treg_curpm)
+#define PL_reg_eval_set (aTHXo->interp.Treg_eval_set)
+#define PL_reg_flags (aTHXo->interp.Treg_flags)
+#define PL_reg_ganch (aTHXo->interp.Treg_ganch)
+#define PL_reg_leftiter (aTHXo->interp.Treg_leftiter)
+#define PL_reg_magic (aTHXo->interp.Treg_magic)
+#define PL_reg_maxiter (aTHXo->interp.Treg_maxiter)
+#define PL_reg_oldcurpm (aTHXo->interp.Treg_oldcurpm)
+#define PL_reg_oldpos (aTHXo->interp.Treg_oldpos)
+#define PL_reg_oldsaved (aTHXo->interp.Treg_oldsaved)
+#define PL_reg_oldsavedlen (aTHXo->interp.Treg_oldsavedlen)
+#define PL_reg_poscache (aTHXo->interp.Treg_poscache)
+#define PL_reg_poscache_size (aTHXo->interp.Treg_poscache_size)
+#define PL_reg_re (aTHXo->interp.Treg_re)
+#define PL_reg_start_tmp (aTHXo->interp.Treg_start_tmp)
+#define PL_reg_start_tmpl (aTHXo->interp.Treg_start_tmpl)
+#define PL_reg_starttry (aTHXo->interp.Treg_starttry)
+#define PL_reg_sv (aTHXo->interp.Treg_sv)
+#define PL_reg_whilem_seen (aTHXo->interp.Treg_whilem_seen)
+#define PL_regbol (aTHXo->interp.Tregbol)
+#define PL_regcc (aTHXo->interp.Tregcc)
+#define PL_regcode (aTHXo->interp.Tregcode)
+#define PL_regcomp_parse (aTHXo->interp.Tregcomp_parse)
+#define PL_regcomp_rx (aTHXo->interp.Tregcomp_rx)
+#define PL_regcompp (aTHXo->interp.Tregcompp)
+#define PL_regdata (aTHXo->interp.Tregdata)
+#define PL_regdummy (aTHXo->interp.Tregdummy)
+#define PL_regendp (aTHXo->interp.Tregendp)
+#define PL_regeol (aTHXo->interp.Tregeol)
+#define PL_regexecp (aTHXo->interp.Tregexecp)
+#define PL_regflags (aTHXo->interp.Tregflags)
+#define PL_regfree (aTHXo->interp.Tregfree)
+#define PL_regindent (aTHXo->interp.Tregindent)
+#define PL_reginput (aTHXo->interp.Treginput)
+#define PL_regint_start (aTHXo->interp.Tregint_start)
+#define PL_regint_string (aTHXo->interp.Tregint_string)
+#define PL_reginterp_cnt (aTHXo->interp.Treginterp_cnt)
+#define PL_reglastparen (aTHXo->interp.Treglastparen)
+#define PL_regnarrate (aTHXo->interp.Tregnarrate)
+#define PL_regnaughty (aTHXo->interp.Tregnaughty)
+#define PL_regnpar (aTHXo->interp.Tregnpar)
+#define PL_regprecomp (aTHXo->interp.Tregprecomp)
+#define PL_regprev (aTHXo->interp.Tregprev)
+#define PL_regprogram (aTHXo->interp.Tregprogram)
+#define PL_regsawback (aTHXo->interp.Tregsawback)
+#define PL_regseen (aTHXo->interp.Tregseen)
+#define PL_regsize (aTHXo->interp.Tregsize)
+#define PL_regstartp (aTHXo->interp.Tregstartp)
+#define PL_regtill (aTHXo->interp.Tregtill)
+#define PL_regxend (aTHXo->interp.Tregxend)
+#define PL_restartop (aTHXo->interp.Trestartop)
+#define PL_retstack (aTHXo->interp.Tretstack)
+#define PL_retstack_ix (aTHXo->interp.Tretstack_ix)
+#define PL_retstack_max (aTHXo->interp.Tretstack_max)
+#define PL_rs (aTHXo->interp.Trs)
+#define PL_savestack (aTHXo->interp.Tsavestack)
+#define PL_savestack_ix (aTHXo->interp.Tsavestack_ix)
+#define PL_savestack_max (aTHXo->interp.Tsavestack_max)
+#define PL_scopestack (aTHXo->interp.Tscopestack)
+#define PL_scopestack_ix (aTHXo->interp.Tscopestack_ix)
+#define PL_scopestack_max (aTHXo->interp.Tscopestack_max)
+#define PL_screamfirst (aTHXo->interp.Tscreamfirst)
+#define PL_screamnext (aTHXo->interp.Tscreamnext)
+#define PL_secondgv (aTHXo->interp.Tsecondgv)
+#define PL_seen_evals (aTHXo->interp.Tseen_evals)
+#define PL_seen_zerolen (aTHXo->interp.Tseen_zerolen)
+#define PL_sortcop (aTHXo->interp.Tsortcop)
+#define PL_sortcxix (aTHXo->interp.Tsortcxix)
+#define PL_sortstash (aTHXo->interp.Tsortstash)
+#define PL_stack_base (aTHXo->interp.Tstack_base)
+#define PL_stack_max (aTHXo->interp.Tstack_max)
+#define PL_stack_sp (aTHXo->interp.Tstack_sp)
+#define PL_start_env (aTHXo->interp.Tstart_env)
+#define PL_statbuf (aTHXo->interp.Tstatbuf)
+#define PL_statcache (aTHXo->interp.Tstatcache)
+#define PL_statgv (aTHXo->interp.Tstatgv)
+#define PL_statname (aTHXo->interp.Tstatname)
+#define PL_tainted (aTHXo->interp.Ttainted)
+#define PL_timesbuf (aTHXo->interp.Ttimesbuf)
+#define PL_tmps_floor (aTHXo->interp.Ttmps_floor)
+#define PL_tmps_ix (aTHXo->interp.Ttmps_ix)
+#define PL_tmps_max (aTHXo->interp.Ttmps_max)
+#define PL_tmps_stack (aTHXo->interp.Ttmps_stack)
+#define PL_top_env (aTHXo->interp.Ttop_env)
+#define PL_toptarget (aTHXo->interp.Ttoptarget)
+#define PL_watchaddr (aTHXo->interp.Twatchaddr)
+#define PL_watchok (aTHXo->interp.Twatchok)
+#define PL_Argv (aTHXo->interp.IArgv)
+#define PL_Cmd (aTHXo->interp.ICmd)
+#define PL_DBcv (aTHXo->interp.IDBcv)
+#define PL_DBgv (aTHXo->interp.IDBgv)
+#define PL_DBline (aTHXo->interp.IDBline)
+#define PL_DBsignal (aTHXo->interp.IDBsignal)
+#define PL_DBsingle (aTHXo->interp.IDBsingle)
+#define PL_DBsub (aTHXo->interp.IDBsub)
+#define PL_DBtrace (aTHXo->interp.IDBtrace)
+#define PL_Dir (aTHXo->interp.IDir)
+#define PL_Env (aTHXo->interp.IEnv)
+#define PL_LIO (aTHXo->interp.ILIO)
+#define PL_Mem (aTHXo->interp.IMem)
+#define PL_MemParse (aTHXo->interp.IMemParse)
+#define PL_MemShared (aTHXo->interp.IMemShared)
+#define PL_Proc (aTHXo->interp.IProc)
+#define PL_Sock (aTHXo->interp.ISock)
+#define PL_StdIO (aTHXo->interp.IStdIO)
+#define PL_amagic_generation (aTHXo->interp.Iamagic_generation)
+#define PL_an (aTHXo->interp.Ian)
+#define PL_archpat_auto (aTHXo->interp.Iarchpat_auto)
+#define PL_argvgv (aTHXo->interp.Iargvgv)
+#define PL_argvout_stack (aTHXo->interp.Iargvout_stack)
+#define PL_argvoutgv (aTHXo->interp.Iargvoutgv)
+#define PL_basetime (aTHXo->interp.Ibasetime)
+#define PL_beginav (aTHXo->interp.Ibeginav)
+#define PL_bitcount (aTHXo->interp.Ibitcount)
+#define PL_bufend (aTHXo->interp.Ibufend)
+#define PL_bufptr (aTHXo->interp.Ibufptr)
+#define PL_collation_ix (aTHXo->interp.Icollation_ix)
+#define PL_collation_name (aTHXo->interp.Icollation_name)
+#define PL_collation_standard (aTHXo->interp.Icollation_standard)
+#define PL_collxfrm_base (aTHXo->interp.Icollxfrm_base)
+#define PL_collxfrm_mult (aTHXo->interp.Icollxfrm_mult)
+#define PL_compcv (aTHXo->interp.Icompcv)
+#define PL_compiling (aTHXo->interp.Icompiling)
+#define PL_comppad (aTHXo->interp.Icomppad)
+#define PL_comppad_name (aTHXo->interp.Icomppad_name)
+#define PL_comppad_name_fill (aTHXo->interp.Icomppad_name_fill)
+#define PL_comppad_name_floor (aTHXo->interp.Icomppad_name_floor)
+#define PL_cop_seqmax (aTHXo->interp.Icop_seqmax)
+#define PL_copline (aTHXo->interp.Icopline)
+#define PL_cred_mutex (aTHXo->interp.Icred_mutex)
+#define PL_cryptseen (aTHXo->interp.Icryptseen)
+#define PL_cshlen (aTHXo->interp.Icshlen)
+#define PL_cshname (aTHXo->interp.Icshname)
+#define PL_curcopdb (aTHXo->interp.Icurcopdb)
+#define PL_curstname (aTHXo->interp.Icurstname)
+#define PL_curthr (aTHXo->interp.Icurthr)
+#define PL_dbargs (aTHXo->interp.Idbargs)
+#define PL_debstash (aTHXo->interp.Idebstash)
+#define PL_debug (aTHXo->interp.Idebug)
+#define PL_defgv (aTHXo->interp.Idefgv)
+#define PL_diehook (aTHXo->interp.Idiehook)
+#define PL_doextract (aTHXo->interp.Idoextract)
+#define PL_doswitches (aTHXo->interp.Idoswitches)
+#define PL_dowarn (aTHXo->interp.Idowarn)
+#define PL_e_script (aTHXo->interp.Ie_script)
+#define PL_egid (aTHXo->interp.Iegid)
+#define PL_endav (aTHXo->interp.Iendav)
+#define PL_envgv (aTHXo->interp.Ienvgv)
+#define PL_errgv (aTHXo->interp.Ierrgv)
+#define PL_error_count (aTHXo->interp.Ierror_count)
+#define PL_euid (aTHXo->interp.Ieuid)
+#define PL_eval_cond (aTHXo->interp.Ieval_cond)
+#define PL_eval_mutex (aTHXo->interp.Ieval_mutex)
+#define PL_eval_owner (aTHXo->interp.Ieval_owner)
+#define PL_eval_root (aTHXo->interp.Ieval_root)
+#define PL_eval_start (aTHXo->interp.Ieval_start)
+#define PL_evalseq (aTHXo->interp.Ievalseq)
+#define PL_exitlist (aTHXo->interp.Iexitlist)
+#define PL_exitlistlen (aTHXo->interp.Iexitlistlen)
+#define PL_expect (aTHXo->interp.Iexpect)
+#define PL_fdpid (aTHXo->interp.Ifdpid)
+#define PL_filemode (aTHXo->interp.Ifilemode)
+#define PL_forkprocess (aTHXo->interp.Iforkprocess)
+#define PL_formfeed (aTHXo->interp.Iformfeed)
+#define PL_generation (aTHXo->interp.Igeneration)
+#define PL_gensym (aTHXo->interp.Igensym)
+#define PL_gid (aTHXo->interp.Igid)
+#define PL_glob_index (aTHXo->interp.Iglob_index)
+#define PL_globalstash (aTHXo->interp.Iglobalstash)
+#define PL_he_root (aTHXo->interp.Ihe_root)
+#define PL_hintgv (aTHXo->interp.Ihintgv)
+#define PL_hints (aTHXo->interp.Ihints)
+#define PL_in_clean_all (aTHXo->interp.Iin_clean_all)
+#define PL_in_clean_objs (aTHXo->interp.Iin_clean_objs)
+#define PL_in_my (aTHXo->interp.Iin_my)
+#define PL_in_my_stash (aTHXo->interp.Iin_my_stash)
+#define PL_incgv (aTHXo->interp.Iincgv)
+#define PL_initav (aTHXo->interp.Iinitav)
+#define PL_inplace (aTHXo->interp.Iinplace)
+#define PL_last_lop (aTHXo->interp.Ilast_lop)
+#define PL_last_lop_op (aTHXo->interp.Ilast_lop_op)
+#define PL_last_swash_hv (aTHXo->interp.Ilast_swash_hv)
+#define PL_last_swash_key (aTHXo->interp.Ilast_swash_key)
+#define PL_last_swash_klen (aTHXo->interp.Ilast_swash_klen)
+#define PL_last_swash_slen (aTHXo->interp.Ilast_swash_slen)
+#define PL_last_swash_tmps (aTHXo->interp.Ilast_swash_tmps)
+#define PL_last_uni (aTHXo->interp.Ilast_uni)
+#define PL_lastfd (aTHXo->interp.Ilastfd)
+#define PL_laststatval (aTHXo->interp.Ilaststatval)
+#define PL_laststype (aTHXo->interp.Ilaststype)
+#define PL_lex_brackets (aTHXo->interp.Ilex_brackets)
+#define PL_lex_brackstack (aTHXo->interp.Ilex_brackstack)
+#define PL_lex_casemods (aTHXo->interp.Ilex_casemods)
+#define PL_lex_casestack (aTHXo->interp.Ilex_casestack)
+#define PL_lex_defer (aTHXo->interp.Ilex_defer)
+#define PL_lex_dojoin (aTHXo->interp.Ilex_dojoin)
+#define PL_lex_expect (aTHXo->interp.Ilex_expect)
+#define PL_lex_fakebrack (aTHXo->interp.Ilex_fakebrack)
+#define PL_lex_formbrack (aTHXo->interp.Ilex_formbrack)
+#define PL_lex_inpat (aTHXo->interp.Ilex_inpat)
+#define PL_lex_inwhat (aTHXo->interp.Ilex_inwhat)
+#define PL_lex_op (aTHXo->interp.Ilex_op)
+#define PL_lex_repl (aTHXo->interp.Ilex_repl)
+#define PL_lex_starts (aTHXo->interp.Ilex_starts)
+#define PL_lex_state (aTHXo->interp.Ilex_state)
+#define PL_lex_stuff (aTHXo->interp.Ilex_stuff)
+#define PL_lineary (aTHXo->interp.Ilineary)
+#define PL_linestart (aTHXo->interp.Ilinestart)
+#define PL_linestr (aTHXo->interp.Ilinestr)
+#define PL_localpatches (aTHXo->interp.Ilocalpatches)
+#define PL_main_cv (aTHXo->interp.Imain_cv)
+#define PL_main_root (aTHXo->interp.Imain_root)
+#define PL_main_start (aTHXo->interp.Imain_start)
+#define PL_max_intro_pending (aTHXo->interp.Imax_intro_pending)
+#define PL_maxo (aTHXo->interp.Imaxo)
+#define PL_maxsysfd (aTHXo->interp.Imaxsysfd)
+#define PL_mess_sv (aTHXo->interp.Imess_sv)
+#define PL_min_intro_pending (aTHXo->interp.Imin_intro_pending)
+#define PL_minus_F (aTHXo->interp.Iminus_F)
+#define PL_minus_a (aTHXo->interp.Iminus_a)
+#define PL_minus_c (aTHXo->interp.Iminus_c)
+#define PL_minus_l (aTHXo->interp.Iminus_l)
+#define PL_minus_n (aTHXo->interp.Iminus_n)
+#define PL_minus_p (aTHXo->interp.Iminus_p)
+#define PL_modglobal (aTHXo->interp.Imodglobal)
+#define PL_multi_close (aTHXo->interp.Imulti_close)
+#define PL_multi_end (aTHXo->interp.Imulti_end)
+#define PL_multi_open (aTHXo->interp.Imulti_open)
+#define PL_multi_start (aTHXo->interp.Imulti_start)
+#define PL_multiline (aTHXo->interp.Imultiline)
+#define PL_nexttoke (aTHXo->interp.Inexttoke)
+#define PL_nexttype (aTHXo->interp.Inexttype)
+#define PL_nextval (aTHXo->interp.Inextval)
+#define PL_nice_chunk (aTHXo->interp.Inice_chunk)
+#define PL_nice_chunk_size (aTHXo->interp.Inice_chunk_size)
+#define PL_nomemok (aTHXo->interp.Inomemok)
+#define PL_nthreads (aTHXo->interp.Inthreads)
+#define PL_nthreads_cond (aTHXo->interp.Inthreads_cond)
+#define PL_numeric_local (aTHXo->interp.Inumeric_local)
+#define PL_numeric_name (aTHXo->interp.Inumeric_name)
+#define PL_numeric_radix (aTHXo->interp.Inumeric_radix)
+#define PL_numeric_standard (aTHXo->interp.Inumeric_standard)
+#define PL_ofmt (aTHXo->interp.Iofmt)
+#define PL_oldbufptr (aTHXo->interp.Ioldbufptr)
+#define PL_oldname (aTHXo->interp.Ioldname)
+#define PL_oldoldbufptr (aTHXo->interp.Ioldoldbufptr)
+#define PL_op_mask (aTHXo->interp.Iop_mask)
+#define PL_op_seqmax (aTHXo->interp.Iop_seqmax)
+#define PL_origalen (aTHXo->interp.Iorigalen)
+#define PL_origargc (aTHXo->interp.Iorigargc)
+#define PL_origargv (aTHXo->interp.Iorigargv)
+#define PL_origenviron (aTHXo->interp.Iorigenviron)
+#define PL_origfilename (aTHXo->interp.Iorigfilename)
+#define PL_ors (aTHXo->interp.Iors)
+#define PL_orslen (aTHXo->interp.Iorslen)
+#define PL_osname (aTHXo->interp.Iosname)
+#define PL_pad_reset_pending (aTHXo->interp.Ipad_reset_pending)
+#define PL_padix (aTHXo->interp.Ipadix)
+#define PL_padix_floor (aTHXo->interp.Ipadix_floor)
+#define PL_patchlevel (aTHXo->interp.Ipatchlevel)
+#define PL_pending_ident (aTHXo->interp.Ipending_ident)
+#define PL_perl_destruct_level (aTHXo->interp.Iperl_destruct_level)
+#define PL_perldb (aTHXo->interp.Iperldb)
+#define PL_pidstatus (aTHXo->interp.Ipidstatus)
+#define PL_preambleav (aTHXo->interp.Ipreambleav)
+#define PL_preambled (aTHXo->interp.Ipreambled)
+#define PL_preprocess (aTHXo->interp.Ipreprocess)
+#define PL_profiledata (aTHXo->interp.Iprofiledata)
+#define PL_psig_name (aTHXo->interp.Ipsig_name)
+#define PL_psig_ptr (aTHXo->interp.Ipsig_ptr)
+#define PL_ptr_table (aTHXo->interp.Iptr_table)
+#define PL_replgv (aTHXo->interp.Ireplgv)
+#define PL_rsfp (aTHXo->interp.Irsfp)
+#define PL_rsfp_filters (aTHXo->interp.Irsfp_filters)
+#define PL_runops (aTHXo->interp.Irunops)
+#define PL_sawampersand (aTHXo->interp.Isawampersand)
+#define PL_sh_path (aTHXo->interp.Ish_path)
+#define PL_sighandlerp (aTHXo->interp.Isighandlerp)
+#define PL_splitstr (aTHXo->interp.Isplitstr)
+#define PL_srand_called (aTHXo->interp.Isrand_called)
+#define PL_statusvalue (aTHXo->interp.Istatusvalue)
+#define PL_statusvalue_vms (aTHXo->interp.Istatusvalue_vms)
+#define PL_stderrgv (aTHXo->interp.Istderrgv)
+#define PL_stdingv (aTHXo->interp.Istdingv)
+#define PL_stopav (aTHXo->interp.Istopav)
+#define PL_strtab (aTHXo->interp.Istrtab)
+#define PL_strtab_mutex (aTHXo->interp.Istrtab_mutex)
+#define PL_sub_generation (aTHXo->interp.Isub_generation)
+#define PL_sublex_info (aTHXo->interp.Isublex_info)
+#define PL_subline (aTHXo->interp.Isubline)
+#define PL_subname (aTHXo->interp.Isubname)
+#define PL_sv_arenaroot (aTHXo->interp.Isv_arenaroot)
+#define PL_sv_count (aTHXo->interp.Isv_count)
+#define PL_sv_mutex (aTHXo->interp.Isv_mutex)
+#define PL_sv_no (aTHXo->interp.Isv_no)
+#define PL_sv_objcount (aTHXo->interp.Isv_objcount)
+#define PL_sv_root (aTHXo->interp.Isv_root)
+#define PL_sv_undef (aTHXo->interp.Isv_undef)
+#define PL_sv_yes (aTHXo->interp.Isv_yes)
+#define PL_svref_mutex (aTHXo->interp.Isvref_mutex)
+#define PL_sys_intern (aTHXo->interp.Isys_intern)
+#define PL_tainting (aTHXo->interp.Itainting)
+#define PL_thr_key (aTHXo->interp.Ithr_key)
+#define PL_threadnum (aTHXo->interp.Ithreadnum)
+#define PL_threads_mutex (aTHXo->interp.Ithreads_mutex)
+#define PL_threadsv_names (aTHXo->interp.Ithreadsv_names)
+#define PL_thrsv (aTHXo->interp.Ithrsv)
+#define PL_tokenbuf (aTHXo->interp.Itokenbuf)
+#define PL_uid (aTHXo->interp.Iuid)
+#define PL_unsafe (aTHXo->interp.Iunsafe)
+#define PL_utf8_alnum (aTHXo->interp.Iutf8_alnum)
+#define PL_utf8_alnumc (aTHXo->interp.Iutf8_alnumc)
+#define PL_utf8_alpha (aTHXo->interp.Iutf8_alpha)
+#define PL_utf8_ascii (aTHXo->interp.Iutf8_ascii)
+#define PL_utf8_cntrl (aTHXo->interp.Iutf8_cntrl)
+#define PL_utf8_digit (aTHXo->interp.Iutf8_digit)
+#define PL_utf8_graph (aTHXo->interp.Iutf8_graph)
+#define PL_utf8_lower (aTHXo->interp.Iutf8_lower)
+#define PL_utf8_mark (aTHXo->interp.Iutf8_mark)
+#define PL_utf8_print (aTHXo->interp.Iutf8_print)
+#define PL_utf8_punct (aTHXo->interp.Iutf8_punct)
+#define PL_utf8_space (aTHXo->interp.Iutf8_space)
+#define PL_utf8_tolower (aTHXo->interp.Iutf8_tolower)
+#define PL_utf8_totitle (aTHXo->interp.Iutf8_totitle)
+#define PL_utf8_toupper (aTHXo->interp.Iutf8_toupper)
+#define PL_utf8_upper (aTHXo->interp.Iutf8_upper)
+#define PL_utf8_xdigit (aTHXo->interp.Iutf8_xdigit)
+#define PL_uudmap (aTHXo->interp.Iuudmap)
+#define PL_warnhook (aTHXo->interp.Iwarnhook)
+#define PL_xiv_arenaroot (aTHXo->interp.Ixiv_arenaroot)
+#define PL_xiv_root (aTHXo->interp.Ixiv_root)
+#define PL_xnv_root (aTHXo->interp.Ixnv_root)
+#define PL_xpv_root (aTHXo->interp.Ixpv_root)
+#define PL_xpvav_root (aTHXo->interp.Ixpvav_root)
+#define PL_xpvbm_root (aTHXo->interp.Ixpvbm_root)
+#define PL_xpvcv_root (aTHXo->interp.Ixpvcv_root)
+#define PL_xpvhv_root (aTHXo->interp.Ixpvhv_root)
+#define PL_xpviv_root (aTHXo->interp.Ixpviv_root)
+#define PL_xpvlv_root (aTHXo->interp.Ixpvlv_root)
+#define PL_xpvmg_root (aTHXo->interp.Ixpvmg_root)
+#define PL_xpvnv_root (aTHXo->interp.Ixpvnv_root)
+#define PL_xrv_root (aTHXo->interp.Ixrv_root)
+#define PL_yychar (aTHXo->interp.Iyychar)
+#define PL_yydebug (aTHXo->interp.Iyydebug)
+#define PL_yyerrflag (aTHXo->interp.Iyyerrflag)
+#define PL_yylval (aTHXo->interp.Iyylval)
+#define PL_yynerrs (aTHXo->interp.Iyynerrs)
+#define PL_yyval (aTHXo->interp.Iyyval)
+
+# else /* !PERL_OBJECT */
+
+/* cases 1 and 4 above */
#define PL_IArgv PL_Argv
#define PL_ICmd PL_Cmd
@@ -708,6 +1117,8 @@
#define PL_IEnv PL_Env
#define PL_ILIO PL_LIO
#define PL_IMem PL_Mem
+#define PL_IMemParse PL_MemParse
+#define PL_IMemShared PL_MemShared
#define PL_IProc PL_Proc
#define PL_ISock PL_Sock
#define PL_IStdIO PL_StdIO
@@ -874,6 +1285,8 @@
#define PL_Ipreambled PL_preambled
#define PL_Ipreprocess PL_preprocess
#define PL_Iprofiledata PL_profiledata
+#define PL_Ipsig_name PL_psig_name
+#define PL_Ipsig_ptr PL_psig_ptr
#define PL_Iptr_table PL_ptr_table
#define PL_Ireplgv PL_replgv
#define PL_Irsfp PL_rsfp
@@ -953,7 +1366,7 @@
#define PL_Iyynerrs PL_yynerrs
#define PL_Iyyval PL_yyval
-# if defined(USE_THREADS)
+# if defined(USE_THREADS)
/* case 4 above */
#define PL_Sv (aTHX->TSv)
@@ -1090,8 +1503,8 @@
#define PL_watchaddr (aTHX->Twatchaddr)
#define PL_watchok (aTHX->Twatchok)
-# else /* !USE_THREADS */
-/* cases 1 and 6 above */
+# else /* !USE_THREADS */
+/* case 1 above */
#define PL_TSv PL_Sv
#define PL_TXpv PL_Xpv
@@ -1227,7 +1640,8 @@
#define PL_Twatchaddr PL_watchaddr
#define PL_Twatchok PL_watchok
-# endif /* USE_THREADS */
+# endif /* USE_THREADS */
+# endif /* PERL_OBJECT */
#endif /* MULTIPLICITY */
#if defined(PERL_GLOBAL_STRUCT)
diff --git a/ext/B/B/CC.pm b/ext/B/B/CC.pm
index 0fe5e7d..cf0e81f 100644
--- a/ext/B/B/CC.pm
+++ b/ext/B/B/CC.pm
@@ -1644,8 +1644,8 @@ XS(boot_$cmodule)
perl_init();
ENTER;
SAVETMPS;
- SAVESPTR(PL_curpad);
- SAVESPTR(PL_op);
+ SAVEVPTR(PL_curpad);
+ SAVEVPTR(PL_op);
PL_curpad = AvARRAY($curpad_sym);
PL_op = $start;
pp_main(aTHX);
diff --git a/ext/Opcode/Opcode.xs b/ext/Opcode/Opcode.xs
index 63ff8aa..581cbc9 100644
--- a/ext/Opcode/Opcode.xs
+++ b/ext/Opcode/Opcode.xs
@@ -204,7 +204,7 @@ static void
opmask_addlocal(pTHX_ SV *opset, char *op_mask_buf) /* Localise PL_op_mask then opmask_add() */
{
char *orig_op_mask = PL_op_mask;
- SAVEPPTR(PL_op_mask);
+ SAVEVPTR(PL_op_mask);
#if !defined(PERL_OBJECT)
/* XXX casting to an ordinary function ptr from a member function ptr
* is disallowed by Borland
diff --git a/global.sym b/global.sym
index e219030..796ab64 100644
--- a/global.sym
+++ b/global.sym
@@ -4,6 +4,20 @@
# and run 'make regen_headers' to effect changes.
#
+perl_alloc_using
+perl_alloc
+perl_construct
+perl_destruct
+perl_free
+perl_run
+perl_parse
+perl_clone
+perl_clone_using
+Perl_malloc
+Perl_calloc
+Perl_realloc
+Perl_mfree
+Perl_malloced_size
Perl_amagic_call
Perl_Gv_AMupdate
Perl_append_elem
@@ -292,7 +306,6 @@ Perl_magic_set_all_env
Perl_magic_sizepack
Perl_magic_wipepack
Perl_magicname
-Perl_malloced_size
Perl_markstack_grow
Perl_mem_collxfrm
Perl_mess
@@ -393,17 +406,6 @@ Perl_pad_free
Perl_pad_reset
Perl_pad_swipe
Perl_peep
-perl_construct
-perl_destruct
-perl_free
-perl_run
-perl_parse
-perl_alloc
-perl_construct
-perl_destruct
-perl_free
-perl_run
-perl_parse
Perl_new_struct_thread
Perl_call_atexit
Perl_call_argv
@@ -486,6 +488,7 @@ Perl_save_nogv
Perl_save_op
Perl_save_scalar
Perl_save_pptr
+Perl_save_vptr
Perl_save_re_context
Perl_save_sptr
Perl_save_svref
@@ -619,10 +622,6 @@ Perl_yylex
Perl_yyparse
Perl_yywarn
Perl_dump_mstats
-Perl_malloc
-Perl_calloc
-Perl_realloc
-Perl_mfree
Perl_safesysmalloc
Perl_safesyscalloc
Perl_safesysrealloc
@@ -678,6 +677,7 @@ Perl_boot_core_xsutils
Perl_cx_dup
Perl_si_dup
Perl_ss_dup
+Perl_any_dup
Perl_he_dup
Perl_re_dup
Perl_fp_dup
@@ -690,5 +690,3 @@ Perl_ptr_table_new
Perl_ptr_table_fetch
Perl_ptr_table_store
Perl_ptr_table_split
-perl_clone
-perl_clone_using
diff --git a/globals.c b/globals.c
index 8e19d22..80c659e 100644
--- a/globals.c
+++ b/globals.c
@@ -9,11 +9,12 @@
#undef PERLVARA
#define PERLVARA(x, n, y)
#undef PERLVARI
-#define PERLVARI(x, y, z) PL_##x = z;
+#define PERLVARI(x, y, z) interp.x = z;
#undef PERLVARIC
-#define PERLVARIC(x, y, z) PL_##x = z;
+#define PERLVARIC(x, y, z) interp.x = z;
-CPerlObj::CPerlObj(IPerlMem* ipM, IPerlEnv* ipE, IPerlStdIO* ipStd,
+CPerlObj::CPerlObj(IPerlMem* ipM, IPerlMem* ipMS, IPerlMem* ipMP,
+ IPerlEnv* ipE, IPerlStdIO* ipStd,
IPerlLIO* ipLIO, IPerlDir* ipD, IPerlSock* ipS,
IPerlProc* ipP)
{
@@ -21,9 +22,10 @@ CPerlObj::CPerlObj(IPerlMem* ipM, IPerlEnv* ipE, IPerlStdIO* ipStd,
#include "thrdvar.h"
#include "intrpvar.h"
-#include "perlvars.h"
PL_Mem = ipM;
+ PL_MemShared = ipMS;
+ PL_MemParse = ipMP;
PL_Env = ipE;
PL_StdIO = ipStd;
PL_LIO = ipLIO;
@@ -50,11 +52,6 @@ CPerlObj::operator delete(void *pPerl, IPerlMem *pvtbl)
pvtbl->pFree(pvtbl, pPerl);
}
-void
-CPerlObj::Init(void)
-{
-}
-
#ifdef WIN32 /* XXX why are these needed? */
bool
Perl_do_exec(char *cmd)
diff --git a/globvar.sym b/globvar.sym
index 3cb8ccc..0d76888 100644
--- a/globvar.sym
+++ b/globvar.sym
@@ -32,8 +32,6 @@ opargs
ppaddr
sig_name
sig_num
-psig_name
-psig_ptr
regkind
simple
utf8skip
diff --git a/gv.c b/gv.c
index f6c9744..e1e4ae0 100644
--- a/gv.c
+++ b/gv.c
@@ -655,10 +655,15 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
if (strEQ(name, "SIG")) {
HV *hv;
I32 i;
+ if (!PL_psig_ptr) {
+ int sig_num[] = { SIG_NUM };
+ New(73, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
+ New(73, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
+ }
GvMULTI_on(gv);
hv = GvHVn(gv);
hv_magic(hv, gv, 'S');
- for(i = 1; PL_sig_name[i]; i++) {
+ for (i = 1; PL_sig_name[i]; i++) {
SV ** init;
init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
if (init)
diff --git a/hv.c b/hv.c
index e38c785..c591cbf 100644
--- a/hv.c
+++ b/hv.c
@@ -81,8 +81,16 @@ Perl_he_dup(pTHX_ HE *e, bool shared)
if (!e)
return Nullhe;
+ /* look for it in the table first */
+ ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
+ if (ret)
+ return ret;
+
+ /* create anew and remember what it is */
ret = new_he();
- HeNEXT(ret) = (HE*)NULL;
+ ptr_table_store(PL_ptr_table, e, ret);
+
+ HeNEXT(ret) = he_dup(HeNEXT(e),shared);
if (HeKLEN(e) == HEf_SVKEY)
HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e)));
else if (shared)
diff --git a/intrpvar.h b/intrpvar.h
index c772d79..d7a669c 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -369,8 +369,13 @@ PERLVAR(Icred_mutex, perl_mutex) /* altered credentials in effect */
#endif /* USE_THREADS */
+PERLVAR(Ipsig_ptr, SV**)
+PERLVAR(Ipsig_name, SV**)
+
#if defined(PERL_IMPLICIT_SYS)
PERLVAR(IMem, struct IPerlMem*)
+PERLVAR(IMemShared, struct IPerlMem*)
+PERLVAR(IMemParse, struct IPerlMem*)
PERLVAR(IEnv, struct IPerlEnv*)
PERLVAR(IStdIO, struct IPerlStdIO*)
PERLVAR(ILIO, struct IPerlLIO*)
diff --git a/iperlsys.h b/iperlsys.h
index 9404d18..222d88b 100644
--- a/iperlsys.h
+++ b/iperlsys.h
@@ -86,6 +86,7 @@ typedef struct _PerlIO PerlIO;
/* IPerlStdIO */
struct IPerlStdIO;
+struct IPerlStdIOInfo;
typedef PerlIO* (*LPStdin)(struct IPerlStdIO*);
typedef PerlIO* (*LPStdout)(struct IPerlStdIO*);
typedef PerlIO* (*LPStderr)(struct IPerlStdIO*);
@@ -132,6 +133,7 @@ typedef int (*LPSetpos)(struct IPerlStdIO*, PerlIO*,
const Fpos_t*);
typedef void (*LPInit)(struct IPerlStdIO*);
typedef void (*LPInitOSExtras)(struct IPerlStdIO*);
+typedef PerlIO* (*LPFdupopen)(struct IPerlStdIO*, PerlIO*);
struct IPerlStdIO
{
@@ -173,6 +175,7 @@ struct IPerlStdIO
LPSetpos pSetpos;
LPInit pInit;
LPInitOSExtras pInitOSExtras;
+ LPFdupopen pFdupopen;
};
struct IPerlStdIOInfo
@@ -283,6 +286,8 @@ struct IPerlStdIOInfo
#undef init_os_extras
#define init_os_extras() \
(*PL_StdIO->pInitOSExtras)(PL_StdIO)
+#define PerlIO_fdupopen(f) \
+ (*PL_StdIO->pFdupopen)(PL_StdIO, (f))
#else /* PERL_IMPLICIT_SYS */
@@ -465,6 +470,9 @@ extern int PerlIO_getpos (PerlIO *,Fpos_t *);
#ifndef PerlIO_setpos
extern int PerlIO_setpos (PerlIO *,const Fpos_t *);
#endif
+#ifndef PerlIO_fdupopen
+extern PerlIO * PerlIO_fdupopen (PerlIO *);
+#endif
/*
@@ -475,6 +483,7 @@ extern int PerlIO_setpos (PerlIO *,const Fpos_t *);
/* IPerlDir */
struct IPerlDir;
+struct IPerlDirInfo;
typedef int (*LPMakedir)(struct IPerlDir*, const char*, int);
typedef int (*LPChdir)(struct IPerlDir*, const char*);
typedef int (*LPRmdir)(struct IPerlDir*, const char*);
@@ -484,6 +493,10 @@ typedef struct direct* (*LPDirRead)(struct IPerlDir*, DIR*);
typedef void (*LPDirRewind)(struct IPerlDir*, DIR*);
typedef void (*LPDirSeek)(struct IPerlDir*, DIR*, long);
typedef long (*LPDirTell)(struct IPerlDir*, DIR*);
+#ifdef WIN32
+typedef char* (*LPDirMapPathA)(struct IPerlDir*, const char*);
+typedef WCHAR* (*LPDirMapPathW)(struct IPerlDir*, const WCHAR*);
+#endif
struct IPerlDir
{
@@ -496,6 +509,10 @@ struct IPerlDir
LPDirRewind pRewind;
LPDirSeek pSeek;
LPDirTell pTell;
+#ifdef WIN32
+ LPDirMapPathA pMapPathA;
+ LPDirMapPathW pMapPathW;
+#endif
};
struct IPerlDirInfo
@@ -522,6 +539,12 @@ struct IPerlDirInfo
(*PL_Dir->pSeek)(PL_Dir, (dir), (loc))
#define PerlDir_tell(dir) \
(*PL_Dir->pTell)(PL_Dir, (dir))
+#ifdef WIN32
+#define PerlDir_mapA(dir) \
+ (*PL_Dir->pMapPathA)(PL_Dir, (dir))
+#define PerlDir_mapW(dir) \
+ (*PL_Dir->pMapPathW)(PL_Dir, (dir))
+#endif
#else /* PERL_IMPLICIT_SYS */
@@ -538,6 +561,10 @@ struct IPerlDirInfo
#define PerlDir_rewind(dir) rewinddir((dir))
#define PerlDir_seek(dir, loc) seekdir((dir), (loc))
#define PerlDir_tell(dir) telldir((dir))
+#ifdef WIN32
+#define PerlDir_mapA(dir) dir
+#define PerlDir_mapW(dir) dir
+#endif
#endif /* PERL_IMPLICIT_SYS */
@@ -549,6 +576,7 @@ struct IPerlDirInfo
/* IPerlEnv */
struct IPerlEnv;
+struct IPerlEnvInfo;
typedef char* (*LPEnvGetenv)(struct IPerlEnv*, const char*);
typedef int (*LPEnvPutenv)(struct IPerlEnv*, const char*);
typedef char* (*LPEnvGetenv_len)(struct IPerlEnv*,
@@ -641,7 +669,7 @@ struct IPerlEnvInfo
#define PerlEnv_putenv(str) putenv((str))
#define PerlEnv_getenv(str) getenv((str))
#define PerlEnv_getenv_len(str,l) getenv_len((str), (l))
-#define PerlEnv_clear() clearenv()
+#define PerlEnv_clearenv() clearenv()
#define PerlEnv_get_childenv() get_childenv()
#define PerlEnv_free_childenv(e) free_childenv((e))
#define PerlEnv_get_childdir() get_childdir()
@@ -669,6 +697,7 @@ struct IPerlEnvInfo
/* IPerlLIO */
struct IPerlLIO;
+struct IPerlLIOInfo;
typedef int (*LPLIOAccess)(struct IPerlLIO*, const char*, int);
typedef int (*LPLIOChmod)(struct IPerlLIO*, const char*, int);
typedef int (*LPLIOChown)(struct IPerlLIO*, const char*, uid_t,
@@ -836,15 +865,24 @@ struct IPerlLIOInfo
/* IPerlMem */
struct IPerlMem;
+struct IPerlMemInfo;
typedef void* (*LPMemMalloc)(struct IPerlMem*, size_t);
typedef void* (*LPMemRealloc)(struct IPerlMem*, void*, size_t);
typedef void (*LPMemFree)(struct IPerlMem*, void*);
+typedef void* (*LPMemCalloc)(struct IPerlMem*, size_t, size_t);
+typedef void (*LPMemGetLock)(struct IPerlMem*);
+typedef void (*LPMemFreeLock)(struct IPerlMem*);
+typedef int (*LPMemIsLocked)(struct IPerlMem*);
struct IPerlMem
{
LPMemMalloc pMalloc;
LPMemRealloc pRealloc;
LPMemFree pFree;
+ LPMemCalloc pCalloc;
+ LPMemGetLock pGetLock;
+ LPMemFreeLock pFreeLock;
+ LPMemIsLocked pIsLocked;
};
struct IPerlMemInfo
@@ -853,18 +891,84 @@ struct IPerlMemInfo
struct IPerlMem perlMemList;
};
+/* Interpreter specific memory macros */
#define PerlMem_malloc(size) \
(*PL_Mem->pMalloc)(PL_Mem, (size))
#define PerlMem_realloc(buf, size) \
(*PL_Mem->pRealloc)(PL_Mem, (buf), (size))
#define PerlMem_free(buf) \
(*PL_Mem->pFree)(PL_Mem, (buf))
+#define PerlMem_calloc(num, size) \
+ (*PL_Mem->pCalloc)(PL_Mem, (num), (size))
+#define PerlMem_get_lock() \
+ (*PL_Mem->pGetLock)(PL_Mem)
+#define PerlMem_free_lock() \
+ (*PL_Mem->pFreeLock)(PL_Mem)
+#define PerlMem_is_locked() \
+ (*PL_Mem->pIsLocked)(PL_Mem)
+
+/* Shared memory macros */
+#define PerlMemShared_malloc(size) \
+ (*PL_MemShared->pMalloc)(PL_Mem, (size))
+#define PerlMemShared_realloc(buf, size) \
+ (*PL_MemShared->pRealloc)(PL_Mem, (buf), (size))
+#define PerlMemShared_free(buf) \
+ (*PL_MemShared->pFree)(PL_Mem, (buf))
+#define PerlMemShared_calloc(num, size) \
+ (*PL_MemShared->pCalloc)(PL_Mem, (num), (size))
+#define PerlMemShared_get_lock() \
+ (*PL_MemShared->pGetLock)(PL_Mem)
+#define PerlMemShared_free_lock() \
+ (*PL_MemShared->pFreeLock)(PL_Mem)
+#define PerlMemShared_is_locked() \
+ (*PL_MemShared->pIsLocked)(PL_Mem)
+
+
+/* Parse tree memory macros */
+#define PerlMemParse_malloc(size) \
+ (*PL_MemParse->pMalloc)(PL_Mem, (size))
+#define PerlMemParse_realloc(buf, size) \
+ (*PL_MemParse->pRealloc)(PL_Mem, (buf), (size))
+#define PerlMemParse_free(buf) \
+ (*PL_MemParse->pFree)(PL_Mem, (buf))
+#define PerlMemParse_calloc(num, size) \
+ (*PL_MemParse->pCalloc)(PL_Mem, (num), (size))
+#define PerlMemParse_get_lock() \
+ (*PL_MemParse->pGetLock)(PL_Mem)
+#define PerlMemParse_free_lock() \
+ (*PL_MemParse->pFreeLock)(PL_Mem)
+#define PerlMemParse_is_locked() \
+ (*PL_MemParse->pIsLocked)(PL_Mem)
+
#else /* PERL_IMPLICIT_SYS */
+/* Interpreter specific memory macros */
#define PerlMem_malloc(size) malloc((size))
#define PerlMem_realloc(buf, size) realloc((buf), (size))
#define PerlMem_free(buf) free((buf))
+#define PerlMem_calloc(num, size) calloc((num), (size))
+#define PerlMem_get_lock()
+#define PerlMem_free_lock()
+#define PerlMem_is_locked() 0
+
+/* Shared memory macros */
+#define PerlMemShared_malloc(size) malloc((size))
+#define PerlMemShared_realloc(buf, size) realloc((buf), (size))
+#define PerlMemShared_free(buf) free((buf))
+#define PerlMemShared_calloc(num, size) calloc((num), (size))
+#define PerlMemShared_get_lock()
+#define PerlMemShared_free_lock()
+#define PerlMemShared_is_locked() 0
+
+/* Parse tree memory macros */
+#define PerlMemParse_malloc(size) malloc((size))
+#define PerlMemParse_realloc(buf, size) realloc((buf), (size))
+#define PerlMemParse_free(buf) free((buf))
+#define PerlMemParse_calloc(num, size) calloc((num), (size))
+#define PerlMemParse_get_lock()
+#define PerlMemParse_free_lock()
+#define PerlMemParse_is_locked() 0
#endif /* PERL_IMPLICIT_SYS */
@@ -881,6 +985,7 @@ struct IPerlMemInfo
/* IPerlProc */
struct IPerlProc;
+struct IPerlProcInfo;
typedef void (*LPProcAbort)(struct IPerlProc*);
typedef char* (*LPProcCrypt)(struct IPerlProc*, const char*,
const char*);
@@ -912,8 +1017,10 @@ typedef int (*LPProcTimes)(struct IPerlProc*, struct tms*);
typedef int (*LPProcWait)(struct IPerlProc*, int*);
typedef int (*LPProcWaitpid)(struct IPerlProc*, int, int*, int);
typedef Sighandler_t (*LPProcSignal)(struct IPerlProc*, int, Sighandler_t);
-typedef void* (*LPProcDynaLoader)(struct IPerlProc*, const char*);
+typedef int (*LPProcFork)(struct IPerlProc*);
+typedef int (*LPProcGetpid)(struct IPerlProc*);
#ifdef WIN32
+typedef void* (*LPProcDynaLoader)(struct IPerlProc*, const char*);
typedef void (*LPProcGetOSError)(struct IPerlProc*,
SV* sv, DWORD dwErr);
typedef void (*LPProcFreeBuf)(struct IPerlProc*, char*);
@@ -951,6 +1058,8 @@ struct IPerlProc
LPProcWait pWait;
LPProcWaitpid pWaitpid;
LPProcSignal pSignal;
+ LPProcFork pFork;
+ LPProcGetpid pGetpid;
#ifdef WIN32
LPProcDynaLoader pDynaLoader;
LPProcGetOSError pGetOSError;
@@ -1017,6 +1126,10 @@ struct IPerlProcInfo
(*PL_Proc->pWaitpid)(PL_Proc, (p), (s), (f))
#define PerlProc_signal(n, h) \
(*PL_Proc->pSignal)(PL_Proc, (n), (h))
+#define PerlProc_fork() \
+ (*PL_Proc->pFork)(PL_Proc)
+#define PerlProc_getpid() \
+ (*PL_Proc->pGetpid)(PL_Proc)
#define PerlProc_setjmp(b, n) Sigsetjmp((b), (n))
#define PerlProc_longjmp(b, n) Siglongjmp((b), (n))
@@ -1065,6 +1178,8 @@ struct IPerlProcInfo
#define PerlProc_setjmp(b, n) Sigsetjmp((b), (n))
#define PerlProc_longjmp(b, n) Siglongjmp((b), (n))
#define PerlProc_signal(n, h) signal((n), (h))
+#define PerlProc_fork() fork()
+#define PerlProc_getpid() getpid()
#ifdef WIN32
#define PerlProc_DynaLoad(f) \
@@ -1082,6 +1197,7 @@ struct IPerlProcInfo
/* PerlSock */
struct IPerlSock;
+struct IPerlSockInfo;
typedef u_long (*LPHtonl)(struct IPerlSock*, u_long);
typedef u_short (*LPHtons)(struct IPerlSock*, u_short);
typedef u_long (*LPNtohl)(struct IPerlSock*, u_long);
diff --git a/makedef.pl b/makedef.pl
index 40c9be3..4b1b84f 100644
--- a/makedef.pl
+++ b/makedef.pl
@@ -38,14 +38,13 @@ my %bincompat5005 =
my $bincompat5005 = join("|", keys %bincompat5005);
-while (@ARGV)
- {
- my $flag = shift;
- $define{$1} = 1 if ($flag =~ /^-D(\w+)$/);
- $define{$1} = $2 if ($flag =~ /^-D(\w+)=(.+)$/);
- $CCTYPE = $1 if ($flag =~ /^CCTYPE=(\w+)$/);
- $PLATFORM = $1 if ($flag =~ /^PLATFORM=(\w+)$/);
- }
+while (@ARGV) {
+ my $flag = shift;
+ $define{$1} = 1 if ($flag =~ /^-D(\w+)$/);
+ $define{$1} = $2 if ($flag =~ /^-D(\w+)=(.+)$/);
+ $CCTYPE = $1 if ($flag =~ /^CCTYPE=(\w+)$/);
+ $PLATFORM = $1 if ($flag =~ /^PLATFORM=(\w+)$/);
+}
my @PLATFORM = qw(aix win32 os2);
my %PLATFORM;
@@ -66,7 +65,8 @@ my $perlio_sym = "perlio.sym";
if ($PLATFORM eq 'aix') {
# Nothing for now.
-} elsif ($PLATFORM eq 'win32') {
+}
+elsif ($PLATFORM eq 'win32') {
$CCTYPE = "MSVC" unless defined $CCTYPE;
foreach ($thrdvar_h, $intrpvar_h, $perlvars_h, $global_sym, $pp_sym, $globvar_sym) {
s!^!..\\!;
@@ -75,8 +75,7 @@ if ($PLATFORM eq 'aix') {
unless ($PLATFORM eq 'win32') {
open(CFG,$config_sh) || die "Cannot open $config_sh: $!\n";
- while (<CFG>)
- {
+ while (<CFG>) {
if (/^(?:ccflags|optimize)='(.+)'$/) {
$_ = $1;
$define{$1} = 1 while /-D(\w+)/g;
@@ -90,14 +89,13 @@ unless ($PLATFORM eq 'win32') {
}
open(CFG,$config_h) || die "Cannot open $config_h: $!\n";
-while (<CFG>)
- {
- $define{$1} = 1 if /^\s*#\s*define\s+(MYMALLOC)\b/;
- $define{$1} = 1 if /^\s*#\s*define\s+(USE_THREADS)\b/;
- $define{$1} = 1 if /^\s*#\s*define\s+(USE_PERLIO)\b/;
- $define{$1} = 1 if /^\s*#\s*define\s+(MULTIPLICITY)\b/;
- $define{$1} = 1 if /^\s*#\s*define\s+(PERL_BINCOMPAT_5005)\b/;
- }
+while (<CFG>) {
+ $define{$1} = 1 if /^\s*#\s*define\s+(MYMALLOC)\b/;
+ $define{$1} = 1 if /^\s*#\s*define\s+(USE_THREADS)\b/;
+ $define{$1} = 1 if /^\s*#\s*define\s+(USE_PERLIO)\b/;
+ $define{$1} = 1 if /^\s*#\s*define\s+(MULTIPLICITY)\b/;
+ $define{$1} = 1 if /^\s*#\s*define\s+(PERL_BINCOMPAT_5005)\b/;
+}
close(CFG);
if ($PLATFORM eq 'win32') {
@@ -108,7 +106,7 @@ if ($PLATFORM eq 'win32') {
print "EXPORTS\n";
# output_symbol("perl_alloc");
output_symbol("perl_get_host_info");
- output_symbol("perl_alloc_using");
+ output_symbol("perl_alloc_override");
# output_symbol("perl_construct");
# output_symbol("perl_destruct");
# output_symbol("perl_free");
@@ -128,7 +126,8 @@ if ($PLATFORM eq 'win32') {
}
print "EXPORTS\n";
}
-} elsif ($PLATFORM eq 'os2') {
+}
+elsif ($PLATFORM eq 'os2') {
($v = $]) =~ s/(\d\.\d\d\d)(\d\d)$/$1_$2/;
$v .= '-thread' if $ARCHNAME =~ /-thread/;
#$sum = 0;
@@ -149,7 +148,8 @@ CODE LOADONCALL
DATA LOADONCALL NONSHARED MULTIPLE
EXPORTS
---EOP---
-} elsif ($PLATFORM eq 'aix') {
+}
+elsif ($PLATFORM eq 'aix') {
print "#!\n";
}
@@ -176,318 +176,314 @@ sub emit_symbols {
}
if ($PLATFORM eq 'win32') {
-skip_symbols [qw(
-PL_statusvalue_vms
-PL_archpat_auto
-PL_cryptseen
-PL_DBcv
-PL_generation
-PL_lastgotoprobe
-PL_linestart
-PL_modcount
-PL_pending_ident
-PL_sortcxix
-PL_sublex_info
-PL_timesbuf
-main
-Perl_ErrorNo
-Perl_GetVars
-Perl_do_exec3
-Perl_do_ipcctl
-Perl_do_ipcget
-Perl_do_msgrcv
-Perl_do_msgsnd
-Perl_do_semop
-Perl_do_shmio
-Perl_dump_fds
-Perl_init_thread_intern
-Perl_my_bzero
-Perl_my_htonl
-Perl_my_ntohl
-Perl_my_swap
-Perl_my_chsize
-Perl_same_dirent
-Perl_setenv_getix
-Perl_unlnk
-Perl_watch
-Perl_safexcalloc
-Perl_safexmalloc
-Perl_safexfree
-Perl_safexrealloc
-Perl_my_memcmp
-Perl_my_memset
-PL_cshlen
-PL_cshname
-PL_opsave
-
-Perl_do_exec
-Perl_getenv_len
-Perl_my_pclose
-Perl_my_popen
-)];
-} elsif ($PLATFORM eq 'aix') {
+ skip_symbols [qw(
+ PL_statusvalue_vms
+ PL_archpat_auto
+ PL_cryptseen
+ PL_DBcv
+ PL_generation
+ PL_lastgotoprobe
+ PL_linestart
+ PL_modcount
+ PL_pending_ident
+ PL_sortcxix
+ PL_sublex_info
+ PL_timesbuf
+ main
+ Perl_ErrorNo
+ Perl_GetVars
+ Perl_do_exec3
+ Perl_do_ipcctl
+ Perl_do_ipcget
+ Perl_do_msgrcv
+ Perl_do_msgsnd
+ Perl_do_semop
+ Perl_do_shmio
+ Perl_dump_fds
+ Perl_init_thread_intern
+ Perl_my_bzero
+ Perl_my_htonl
+ Perl_my_ntohl
+ Perl_my_swap
+ Perl_my_chsize
+ Perl_same_dirent
+ Perl_setenv_getix
+ Perl_unlnk
+ Perl_watch
+ Perl_safexcalloc
+ Perl_safexmalloc
+ Perl_safexfree
+ Perl_safexrealloc
+ Perl_my_memcmp
+ Perl_my_memset
+ PL_cshlen
+ PL_cshname
+ PL_opsave
+ Perl_do_exec
+ Perl_getenv_len
+ Perl_my_pclose
+ Perl_my_popen
+ )];
+}
+elsif ($PLATFORM eq 'aix') {
skip_symbols([qw(
-Perl_dump_fds
-Perl_ErrorNo
-Perl_GetVars
-Perl_my_bcopy
-Perl_my_bzero
-Perl_my_chsize
-Perl_my_htonl
-Perl_my_memcmp
-Perl_my_memset
-Perl_my_ntohl
-Perl_my_swap
-Perl_safexcalloc
-Perl_safexfree
-Perl_safexmalloc
-Perl_safexrealloc
-Perl_same_dirent
-Perl_unlnk
-PL_cryptseen
-PL_opsave
-PL_statusvalue_vms
-PL_sys_intern
-)]);
-}
-
-if ($PLATFORM eq 'os2') {
+ Perl_dump_fds
+ Perl_ErrorNo
+ Perl_GetVars
+ Perl_my_bcopy
+ Perl_my_bzero
+ Perl_my_chsize
+ Perl_my_htonl
+ Perl_my_memcmp
+ Perl_my_memset
+ Perl_my_ntohl
+ Perl_my_swap
+ Perl_safexcalloc
+ Perl_safexfree
+ Perl_safexmalloc
+ Perl_safexrealloc
+ Perl_same_dirent
+ Perl_unlnk
+ PL_cryptseen
+ PL_opsave
+ PL_statusvalue_vms
+ PL_sys_intern
+ )]);
+}
+elsif ($PLATFORM eq 'os2') {
emit_symbols([qw(
-ctermid
-get_sysinfo
-Perl_OS2_init
-OS2_Perl_data
-dlopen
-dlsym
-dlerror
-my_tmpfile
-my_tmpnam
-my_flock
-malloc_mutex
-threads_mutex
-nthreads
-nthreads_cond
-os2_cond_wait
-os2_stat
-pthread_join
-pthread_create
-pthread_detach
-XS_Cwd_change_drive
-XS_Cwd_current_drive
-XS_Cwd_extLibpath
-XS_Cwd_extLibpath_set
-XS_Cwd_sys_abspath
-XS_Cwd_sys_chdir
-XS_Cwd_sys_cwd
-XS_Cwd_sys_is_absolute
-XS_Cwd_sys_is_relative
-XS_Cwd_sys_is_rooted
-XS_DynaLoader_mod2fname
-XS_File__Copy_syscopy
-Perl_Register_MQ
-Perl_Deregister_MQ
-Perl_Serve_Messages
-Perl_Process_Messages
-init_PMWIN_entries
-PMWIN_entries
-Perl_hab_GET
-)]);
+ ctermid
+ get_sysinfo
+ Perl_OS2_init
+ OS2_Perl_data
+ dlopen
+ dlsym
+ dlerror
+ my_tmpfile
+ my_tmpnam
+ my_flock
+ malloc_mutex
+ threads_mutex
+ nthreads
+ nthreads_cond
+ os2_cond_wait
+ os2_stat
+ pthread_join
+ pthread_create
+ pthread_detach
+ XS_Cwd_change_drive
+ XS_Cwd_current_drive
+ XS_Cwd_extLibpath
+ XS_Cwd_extLibpath_set
+ XS_Cwd_sys_abspath
+ XS_Cwd_sys_chdir
+ XS_Cwd_sys_cwd
+ XS_Cwd_sys_is_absolute
+ XS_Cwd_sys_is_relative
+ XS_Cwd_sys_is_rooted
+ XS_DynaLoader_mod2fname
+ XS_File__Copy_syscopy
+ Perl_Register_MQ
+ Perl_Deregister_MQ
+ Perl_Serve_Messages
+ Perl_Process_Messages
+ init_PMWIN_entries
+ PMWIN_entries
+ Perl_hab_GET
+ )]);
}
-if ($define{'PERL_OBJECT'}) {
- skip_symbols [qw(
- Perl_getenv_len
- Perl_my_popen
- Perl_my_pclose
- )];
+unless ($define{'DEBUGGING'}) {
+ skip_symbols [qw(
+ Perl_deb
+ Perl_deb_growlevel
+ Perl_debop
+ Perl_debprofdump
+ Perl_debstack
+ Perl_debstackptrs
+ Perl_runops_debug
+ Perl_sv_peek
+ PL_block_type
+ PL_watchaddr
+ PL_watchok
+ )];
+}
+
+if ($define{'PERL_IMPLICIT_SYS'}) {
+ skip_symbols [qw(
+ Perl_getenv_len
+ Perl_my_popen
+ Perl_my_pclose
+ )];
+}
+else {
+ skip_symbols [qw(
+ PL_Mem
+ PL_MemShared
+ PL_MemParse
+ PL_Env
+ PL_StdIO
+ PL_LIO
+ PL_Dir
+ PL_Sock
+ PL_Proc
+ )];
+}
+
+if ($define{'MYMALLOC'}) {
+ emit_symbols [qw(
+ Perl_dump_mstats
+ Perl_malloc
+ Perl_mfree
+ Perl_realloc
+ Perl_calloc
+ )];
}
else {
- skip_symbols [qw(
- PL_Dir
- PL_Env
- PL_LIO
- PL_Mem
- PL_Proc
- PL_Sock
- PL_StdIO
- )];
-}
-
-if ($define{'MYMALLOC'})
- {
- emit_symbols [qw(
- Perl_dump_mstats
- Perl_malloc
- Perl_mfree
- Perl_realloc
- Perl_calloc)];
- }
-else
- {
- skip_symbols [qw(
- Perl_dump_mstats
- Perl_malloc
- Perl_mfree
- Perl_realloc
- Perl_calloc
- Perl_malloced_size)];
- }
-
-unless ($define{'USE_THREADS'})
- {
- skip_symbols [qw(
-PL_thr_key
-PL_sv_mutex
-PL_strtab_mutex
-PL_svref_mutex
-PL_malloc_mutex
-PL_cred_mutex
-PL_eval_mutex
-PL_eval_cond
-PL_eval_owner
-PL_threads_mutex
-PL_nthreads
-PL_nthreads_cond
-PL_threadnum
-PL_threadsv_names
-PL_thrsv
-PL_vtbl_mutex
-Perl_getTHR
-Perl_setTHR
-Perl_condpair_magic
-Perl_new_struct_thread
-Perl_per_thread_magicals
-Perl_thread_create
-Perl_find_threadsv
-Perl_unlock_condpair
-Perl_magic_mutexfree
-)];
- }
-
-unless ($define{'USE_ITHREADS'})
- {
- skip_symbols [qw(
-PL_ptr_table
-Perl_dirp_dup
-Perl_cx_dup
-Perl_si_dup
-Perl_ss_dup
-Perl_fp_dup
-Perl_gp_dup
-Perl_he_dup
-Perl_mg_dup
-Perl_re_dup
-Perl_sv_dup
-Perl_sys_intern_dup
-Perl_ptr_table_fetch
-Perl_ptr_table_new
-Perl_ptr_table_split
-Perl_ptr_table_store
-perl_clone
-perl_clone_using
-)];
- }
-
-unless ($define{'USE_THREADS'} or $define{'PERL_IMPLICIT_CONTEXT'}
- or $define{'PERL_OBJECT'})
-{
- skip_symbols [qw(
- Perl_croak_nocontext
- Perl_die_nocontext
- Perl_deb_nocontext
- Perl_form_nocontext
- Perl_mess_nocontext
- Perl_warn_nocontext
- Perl_warner_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'})
- {
- skip_symbols [qw(PL_curthr)];
- }
-
-sub readvar
-{
- my $file = shift;
- my $proc = shift || sub { "PL_$_[2]" };
- open(VARS,$file) || die "Cannot open $file: $!\n";
- my @syms;
- while (<VARS>)
- {
- # All symbols have a Perl_ prefix because that's what embed.h
- # sticks in front of them.
- push(@syms, &$proc($1,$2,$3)) if (/\bPERLVAR(A?I?C?)\(([IGT])(\w+)/);
- }
- close(VARS);
- return \@syms;
-}
-
-if ($define{'USE_THREADS'} || $define{'MULTIPLICITY'})
- {
- my $thrd = readvar($thrdvar_h);
- skip_symbols $thrd;
- }
-
-if ($define{'MULTIPLICITY'})
- {
- my $interp = readvar($intrpvar_h);
- skip_symbols $interp;
- }
-
-if ($define{'PERL_GLOBAL_STRUCT'})
- {
- my $global = readvar($perlvars_h);
- skip_symbols $global;
- emit_symbol('Perl_GetVars');
- emit_symbols [qw(PL_Vars PL_VarsPtr)] unless $CCTYPE eq 'GCC';
- }
-
-unless ($define{'DEBUGGING'})
- {
- skip_symbols [qw(
- Perl_deb
- Perl_deb_growlevel
- Perl_debop
- Perl_debprofdump
- Perl_debstack
- Perl_debstackptrs
- Perl_runops_debug
- Perl_sv_peek
- PL_block_type
- PL_watchaddr
- PL_watchok)];
- }
+ skip_symbols [qw(
+ PL_malloc_mutex
+ Perl_dump_mstats
+ Perl_malloc
+ Perl_mfree
+ Perl_realloc
+ Perl_calloc
+ Perl_malloced_size
+ )];
+}
+
+unless ($define{'USE_THREADS'}) {
+ skip_symbols [qw(
+ PL_thr_key
+ PL_sv_mutex
+ PL_strtab_mutex
+ PL_svref_mutex
+ PL_malloc_mutex
+ PL_cred_mutex
+ PL_eval_mutex
+ PL_eval_cond
+ PL_eval_owner
+ PL_threads_mutex
+ PL_nthreads
+ PL_nthreads_cond
+ PL_threadnum
+ PL_threadsv_names
+ PL_thrsv
+ PL_vtbl_mutex
+ Perl_getTHR
+ Perl_setTHR
+ Perl_condpair_magic
+ Perl_new_struct_thread
+ Perl_per_thread_magicals
+ Perl_thread_create
+ Perl_find_threadsv
+ Perl_unlock_condpair
+ Perl_magic_mutexfree
+ )];
+}
+
+unless ($define{'USE_ITHREADS'}) {
+ skip_symbols [qw(
+ PL_ptr_table
+ Perl_dirp_dup
+ Perl_cx_dup
+ Perl_si_dup
+ Perl_any_dup
+ Perl_ss_dup
+ Perl_fp_dup
+ Perl_gp_dup
+ Perl_he_dup
+ Perl_mg_dup
+ Perl_re_dup
+ Perl_sv_dup
+ Perl_sys_intern_dup
+ Perl_ptr_table_fetch
+ Perl_ptr_table_new
+ Perl_ptr_table_split
+ Perl_ptr_table_store
+ perl_clone
+ perl_clone_using
+ )];
+}
+
+unless ($define{'PERL_IMPLICIT_CONTEXT'}) {
+ skip_symbols [qw(
+ Perl_croak_nocontext
+ Perl_die_nocontext
+ Perl_deb_nocontext
+ Perl_form_nocontext
+ Perl_mess_nocontext
+ Perl_warn_nocontext
+ Perl_warner_nocontext
+ Perl_newSVpvf_nocontext
+ Perl_sv_catpvf_nocontext
+ Perl_sv_setpvf_nocontext
+ Perl_sv_catpvf_mg_nocontext
+ Perl_sv_setpvf_mg_nocontext
+ )];
+}
+
+unless ($define{'PERL_IMPLICIT_SYS'}) {
+ skip_symbols [qw(
+ perl_alloc_using
+ )];
+}
+
+unless ($define{'FAKE_THREADS'}) {
+ skip_symbols [qw(PL_curthr)];
+}
+
+sub readvar {
+ my $file = shift;
+ my $proc = shift || sub { "PL_$_[2]" };
+ open(VARS,$file) || die "Cannot open $file: $!\n";
+ my @syms;
+ while (<VARS>) {
+ # All symbols have a Perl_ prefix because that's what embed.h
+ # sticks in front of them.
+ push(@syms, &$proc($1,$2,$3)) if (/\bPERLVAR(A?I?C?)\(([IGT])(\w+)/);
+ }
+ close(VARS);
+ return \@syms;
+}
+
+if ($define{'USE_THREADS'} || $define{'MULTIPLICITY'}) {
+ my $thrd = readvar($thrdvar_h);
+ skip_symbols $thrd;
+}
+
+if ($define{'MULTIPLICITY'}) {
+ my $interp = readvar($intrpvar_h);
+ skip_symbols $interp;
+}
+
+if ($define{'PERL_GLOBAL_STRUCT'}) {
+ my $global = readvar($perlvars_h);
+ skip_symbols $global;
+ emit_symbol('Perl_GetVars');
+ emit_symbols [qw(PL_Vars PL_VarsPtr)] unless $CCTYPE eq 'GCC';
+}
# functions from *.sym files
my @syms = ($global_sym, $pp_sym, $globvar_sym);
-if ($define{'USE_PERLIO'})
- {
+if ($define{'USE_PERLIO'}) {
push @syms, $perlio_sym;
- }
-
-for my $syms (@syms)
- {
- open (GLOBAL, "<$syms") || die "failed to open $syms: $!\n";
- while (<GLOBAL>)
- {
- next if (!/^[A-Za-z]/);
- # Functions have a Perl_ prefix
- # Variables have a PL_ prefix
- chomp($_);
- my $symbol = ($syms =~ /var\.sym$/i ? "PL_" : "");
- $symbol .= $_;
- emit_symbol($symbol) unless exists $skip{$symbol};
- }
- close(GLOBAL);
- }
+}
+
+for my $syms (@syms) {
+ open (GLOBAL, "<$syms") || die "failed to open $syms: $!\n";
+ while (<GLOBAL>) {
+ next if (!/^[A-Za-z]/);
+ # Functions have a Perl_ prefix
+ # Variables have a PL_ prefix
+ chomp($_);
+ my $symbol = ($syms =~ /var\.sym$/i ? "PL_" : "");
+ $symbol .= $_;
+ emit_symbol($symbol) unless exists $skip{$symbol};
+ }
+ close(GLOBAL);
+}
# variables
@@ -506,7 +502,6 @@ else {
my $glob = readvar($intrpvar_h);
emit_symbols $glob;
}
-
unless ($define{'MULTIPLICITY'} || $define{'USE_THREADS'}) {
my $glob = readvar($thrdvar_h);
emit_symbols $glob;
@@ -530,178 +525,184 @@ while (<DATA>) {
if ($PLATFORM eq 'win32') {
foreach my $symbol (qw(
-boot_DynaLoader
-Perl_getTHR
-Perl_init_os_extras
-Perl_setTHR
-Perl_thread_create
-Perl_win32_init
-RunPerl
-GetPerlInterpreter
-SetPerlInterpreter
-win32_errno
-win32_environ
-win32_stdin
-win32_stdout
-win32_stderr
-win32_ferror
-win32_feof
-win32_strerror
-win32_fprintf
-win32_printf
-win32_vfprintf
-win32_vprintf
-win32_fread
-win32_fwrite
-win32_fopen
-win32_fdopen
-win32_freopen
-win32_fclose
-win32_fputs
-win32_fputc
-win32_ungetc
-win32_getc
-win32_fileno
-win32_clearerr
-win32_fflush
-win32_ftell
-win32_fseek
-win32_fgetpos
-win32_fsetpos
-win32_rewind
-win32_tmpfile
-win32_abort
-win32_fstat
-win32_stat
-win32_pipe
-win32_popen
-win32_pclose
-win32_rename
-win32_setmode
-win32_lseek
-win32_tell
-win32_dup
-win32_dup2
-win32_open
-win32_close
-win32_eof
-win32_read
-win32_write
-win32_spawnvp
-win32_mkdir
-win32_rmdir
-win32_chdir
-win32_flock
-win32_execv
-win32_execvp
-win32_htons
-win32_ntohs
-win32_htonl
-win32_ntohl
-win32_inet_addr
-win32_inet_ntoa
-win32_socket
-win32_bind
-win32_listen
-win32_accept
-win32_connect
-win32_send
-win32_sendto
-win32_recv
-win32_recvfrom
-win32_shutdown
-win32_closesocket
-win32_ioctlsocket
-win32_setsockopt
-win32_getsockopt
-win32_getpeername
-win32_getsockname
-win32_gethostname
-win32_gethostbyname
-win32_gethostbyaddr
-win32_getprotobyname
-win32_getprotobynumber
-win32_getservbyname
-win32_getservbyport
-win32_select
-win32_endhostent
-win32_endnetent
-win32_endprotoent
-win32_endservent
-win32_getnetent
-win32_getnetbyname
-win32_getnetbyaddr
-win32_getprotoent
-win32_getservent
-win32_sethostent
-win32_setnetent
-win32_setprotoent
-win32_setservent
-win32_getenv
-win32_putenv
-win32_perror
-win32_setbuf
-win32_setvbuf
-win32_flushall
-win32_fcloseall
-win32_fgets
-win32_gets
-win32_fgetc
-win32_putc
-win32_puts
-win32_getchar
-win32_putchar
-win32_malloc
-win32_calloc
-win32_realloc
-win32_free
-win32_sleep
-win32_times
-win32_alarm
-win32_open_osfhandle
-win32_get_osfhandle
-win32_ioctl
-win32_utime
-win32_uname
-win32_wait
-win32_waitpid
-win32_kill
-win32_str_os_error
-win32_opendir
-win32_readdir
-win32_telldir
-win32_seekdir
-win32_rewinddir
-win32_closedir
-win32_longpath
-win32_os_id
-win32_crypt
- )) {
+ boot_DynaLoader
+ Perl_getTHR
+ Perl_init_os_extras
+ Perl_setTHR
+ Perl_thread_create
+ Perl_win32_init
+ RunPerl
+ GetPerlInterpreter
+ SetPerlInterpreter
+ win32_errno
+ win32_environ
+ win32_stdin
+ win32_stdout
+ win32_stderr
+ win32_ferror
+ win32_feof
+ win32_strerror
+ win32_fprintf
+ win32_printf
+ win32_vfprintf
+ win32_vprintf
+ win32_fread
+ win32_fwrite
+ win32_fopen
+ win32_fdopen
+ win32_freopen
+ win32_fclose
+ win32_fputs
+ win32_fputc
+ win32_ungetc
+ win32_getc
+ win32_fileno
+ win32_clearerr
+ win32_fflush
+ win32_ftell
+ win32_fseek
+ win32_fgetpos
+ win32_fsetpos
+ win32_rewind
+ win32_tmpfile
+ win32_abort
+ win32_fstat
+ win32_stat
+ win32_pipe
+ win32_popen
+ win32_pclose
+ win32_rename
+ win32_setmode
+ win32_lseek
+ win32_tell
+ win32_dup
+ win32_dup2
+ win32_open
+ win32_close
+ win32_eof
+ win32_read
+ win32_write
+ win32_spawnvp
+ win32_mkdir
+ win32_rmdir
+ win32_chdir
+ win32_flock
+ win32_execv
+ win32_execvp
+ win32_htons
+ win32_ntohs
+ win32_htonl
+ win32_ntohl
+ win32_inet_addr
+ win32_inet_ntoa
+ win32_socket
+ win32_bind
+ win32_listen
+ win32_accept
+ win32_connect
+ win32_send
+ win32_sendto
+ win32_recv
+ win32_recvfrom
+ win32_shutdown
+ win32_closesocket
+ win32_ioctlsocket
+ win32_setsockopt
+ win32_getsockopt
+ win32_getpeername
+ win32_getsockname
+ win32_gethostname
+ win32_gethostbyname
+ win32_gethostbyaddr
+ win32_getprotobyname
+ win32_getprotobynumber
+ win32_getservbyname
+ win32_getservbyport
+ win32_select
+ win32_endhostent
+ win32_endnetent
+ win32_endprotoent
+ win32_endservent
+ win32_getnetent
+ win32_getnetbyname
+ win32_getnetbyaddr
+ win32_getprotoent
+ win32_getservent
+ win32_sethostent
+ win32_setnetent
+ win32_setprotoent
+ win32_setservent
+ win32_getenv
+ win32_putenv
+ win32_perror
+ win32_setbuf
+ win32_setvbuf
+ win32_flushall
+ win32_fcloseall
+ win32_fgets
+ win32_gets
+ win32_fgetc
+ win32_putc
+ win32_puts
+ win32_getchar
+ win32_putchar
+ win32_malloc
+ win32_calloc
+ win32_realloc
+ win32_free
+ win32_sleep
+ win32_times
+ win32_access
+ win32_alarm
+ win32_chmod
+ win32_open_osfhandle
+ win32_get_osfhandle
+ win32_ioctl
+ win32_link
+ win32_unlink
+ win32_utime
+ win32_uname
+ win32_wait
+ win32_waitpid
+ win32_kill
+ win32_str_os_error
+ win32_opendir
+ win32_readdir
+ win32_telldir
+ win32_seekdir
+ win32_rewinddir
+ win32_closedir
+ win32_longpath
+ win32_os_id
+ win32_getpid
+ win32_crypt
+ win32_dynaload
+ ))
+ {
try_symbol($symbol);
}
}
elsif ($PLATFORM eq 'os2') {
- open MAP, 'miniperl.map' or die 'Cannot read miniperl.map';
- /^\s*[\da-f:]+\s+(\w+)/i and $mapped{$1}++ foreach <MAP>;
- close MAP or die 'Cannot close miniperl.map';
-
- @missing = grep { !exists $mapped{$_} and !exists $bincompat5005{$_} }
- keys %export;
- delete $export{$_} foreach @missing;
+ open MAP, 'miniperl.map' or die 'Cannot read miniperl.map';
+ /^\s*[\da-f:]+\s+(\w+)/i and $mapped{$1}++ foreach <MAP>;
+ close MAP or die 'Cannot close miniperl.map';
+
+ @missing = grep { !exists $mapped{$_} and !exists $bincompat5005{$_} }
+ keys %export;
+ delete $export{$_} foreach @missing;
}
# Now all symbols should be defined because
# next we are going to output them.
-foreach my $symbol (sort keys %export)
- {
- output_symbol($symbol);
- }
+foreach my $symbol (sort keys %export) {
+ output_symbol($symbol);
+}
sub emit_symbol {
- my $symbol = shift;
- chomp($symbol);
- $export{$symbol} = 1;
+ my $symbol = shift;
+ chomp($symbol);
+ $export{$symbol} = 1;
}
sub output_symbol {
@@ -732,9 +733,11 @@ sub output_symbol {
# print "\t$symbol\n";
# print "\t_$symbol = $symbol\n";
# }
- } elsif ($PLATFORM eq 'os2') {
+ }
+ elsif ($PLATFORM eq 'os2') {
print qq( "$symbol"\n);
- } elsif ($PLATFORM eq 'aix') {
+ }
+ elsif ($PLATFORM eq 'aix') {
print "$symbol\n";
}
}
@@ -743,6 +746,7 @@ sub output_symbol {
__DATA__
# extra globals not included above.
perl_alloc
+perl_alloc_using
perl_construct
perl_destruct
perl_free
diff --git a/mg.c b/mg.c
index fdaf3bb..2b35677 100644
--- a/mg.c
+++ b/mg.c
@@ -818,7 +818,10 @@ Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
#if defined(VMS)
Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
#else
-# ifdef WIN32
+# ifdef PERL_IMPLICIT_SYS
+ PerlEnv_clearenv();
+# else
+# ifdef WIN32
char *envv = GetEnvironmentStrings();
char *cur = envv;
STRLEN len;
@@ -834,13 +837,13 @@ Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
cur += len+1;
}
FreeEnvironmentStrings(envv);
-# else
-# ifdef CYGWIN
+# else
+# ifdef CYGWIN
I32 i;
for (i = 0; environ[i]; i++)
Safefree(environ[i]);
-# else
-# ifndef PERL_USE_SAFE_PUTENV
+# else
+# ifndef PERL_USE_SAFE_PUTENV
I32 i;
if (environ == PL_origenviron)
@@ -848,12 +851,13 @@ Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
else
for (i = 0; environ[i]; i++)
safesysfree(environ[i]);
-# endif /* PERL_USE_SAFE_PUTENV */
-# endif /* CYGWIN */
+# endif /* PERL_USE_SAFE_PUTENV */
+# endif /* CYGWIN */
environ[0] = Nullch;
-# endif /* WIN32 */
+# endif /* WIN32 */
+# endif /* PERL_IMPLICIT_SYS */
#endif /* VMS */
return 0;
}
@@ -1178,7 +1182,7 @@ Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
i = SvTRUE(sv);
svp = av_fetch(GvAV(gv),
atoi(MgPV(mg,n_a)), FALSE);
- if (svp && SvIOKp(*svp) && (o = (OP*)SvSTASH(*svp)))
+ if (svp && SvIOKp(*svp) && (o = (OP*)SvIVX(*svp)))
o->op_private = i;
else if (ckWARN_d(WARN_INTERNAL))
Perl_warner(aTHX_ WARN_INTERNAL, "Can't break at that line\n");
@@ -1660,7 +1664,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
case '.':
if (PL_localizing) {
if (PL_localizing == 1)
- save_sptr((SV**)&PL_last_in_gv);
+ SAVESPTR(PL_last_in_gv);
}
else if (SvOK(sv) && GvIO(PL_last_in_gv))
IoLINES(GvIOp(PL_last_in_gv)) = (long)SvIV(sv);
diff --git a/mpeix/mpeixish.h b/mpeix/mpeixish.h
index 2311171..b5e4fa4 100644
--- a/mpeix/mpeixish.h
+++ b/mpeix/mpeixish.h
@@ -97,7 +97,7 @@
#ifndef SIGILL
# define SIGILL 6 /* blech */
#endif
-#define ABORT() kill(getpid(),SIGABRT);
+#define ABORT() kill(PerlProc_getpid(),SIGABRT);
/*
* fwrite1() should be a routine with the same calling sequence as fwrite(),
diff --git a/objXSUB.h b/objXSUB.h
index e8b1ffb..0884936 100644
--- a/objXSUB.h
+++ b/objXSUB.h
@@ -34,6 +34,10 @@
#define PL_LIO (*Perl_ILIO_ptr(aTHXo))
#undef PL_Mem
#define PL_Mem (*Perl_IMem_ptr(aTHXo))
+#undef PL_MemParse
+#define PL_MemParse (*Perl_IMemParse_ptr(aTHXo))
+#undef PL_MemShared
+#define PL_MemShared (*Perl_IMemShared_ptr(aTHXo))
#undef PL_Proc
#define PL_Proc (*Perl_IProc_ptr(aTHXo))
#undef PL_Sock
@@ -366,6 +370,10 @@
#define PL_preprocess (*Perl_Ipreprocess_ptr(aTHXo))
#undef PL_profiledata
#define PL_profiledata (*Perl_Iprofiledata_ptr(aTHXo))
+#undef PL_psig_name
+#define PL_psig_name (*Perl_Ipsig_name_ptr(aTHXo))
+#undef PL_psig_ptr
+#define PL_psig_ptr (*Perl_Ipsig_ptr_ptr(aTHXo))
#undef PL_ptr_table
#define PL_ptr_table (*Perl_Iptr_table_ptr(aTHXo))
#undef PL_replgv
@@ -809,7 +817,17 @@
/* XXX soon to be eliminated, only a few things in PERLCORE need these now */
+#if defined(PERL_IMPLICIT_SYS)
+#else
+#endif
+#if defined(USE_ITHREADS)
+#endif
+#if defined(MYMALLOC)
+#endif
+#if defined(PERL_OBJECT)
+#endif
#if defined(PERL_OBJECT)
+#else
#endif
#undef Perl_amagic_call
#define Perl_amagic_call pPerl->Perl_amagic_call
@@ -1983,12 +2001,6 @@
#define Perl_magicname pPerl->Perl_magicname
#undef magicname
#define magicname Perl_magicname
-#if defined(MYMALLOC)
-#undef Perl_malloced_size
-#define Perl_malloced_size pPerl->Perl_malloced_size
-#undef malloced_size
-#define malloced_size Perl_malloced_size
-#endif
#undef Perl_markstack_grow
#define Perl_markstack_grow pPerl->Perl_markstack_grow
#undef markstack_grow
@@ -2404,36 +2416,23 @@
#undef peep
#define peep Perl_peep
#if defined(PERL_OBJECT)
-#undef perl_construct
-#define perl_construct pPerl->perl_construct
-#undef perl_destruct
-#define perl_destruct pPerl->perl_destruct
-#undef perl_free
-#define perl_free pPerl->perl_free
-#undef perl_run
-#define perl_run pPerl->perl_run
-#undef perl_parse
-#define perl_parse pPerl->perl_parse
-#else
-#undef perl_alloc
-#define perl_alloc pPerl->perl_alloc
-#undef perl_construct
-#define perl_construct pPerl->perl_construct
-#undef perl_destruct
-#define perl_destruct pPerl->perl_destruct
-#undef perl_free
-#define perl_free pPerl->perl_free
-#undef perl_run
-#define perl_run pPerl->perl_run
-#undef perl_parse
-#define perl_parse pPerl->perl_parse
+#undef Perl_construct
+#define Perl_construct pPerl->Perl_construct
+#undef Perl_destruct
+#define Perl_destruct pPerl->Perl_destruct
+#undef Perl_free
+#define Perl_free pPerl->Perl_free
+#undef Perl_run
+#define Perl_run pPerl->Perl_run
+#undef Perl_parse
+#define Perl_parse pPerl->Perl_parse
+#endif
#if defined(USE_THREADS)
#undef Perl_new_struct_thread
#define Perl_new_struct_thread pPerl->Perl_new_struct_thread
#undef new_struct_thread
#define new_struct_thread Perl_new_struct_thread
#endif
-#endif
#undef Perl_call_atexit
#define Perl_call_atexit pPerl->Perl_call_atexit
#undef call_atexit
@@ -2760,6 +2759,10 @@
#define Perl_save_pptr pPerl->Perl_save_pptr
#undef save_pptr
#define save_pptr Perl_save_pptr
+#undef Perl_save_vptr
+#define Perl_save_vptr pPerl->Perl_save_vptr
+#undef save_vptr
+#define save_vptr Perl_save_vptr
#undef Perl_save_re_context
#define Perl_save_re_context pPerl->Perl_save_re_context
#undef save_re_context
@@ -3304,22 +3307,6 @@
#define Perl_dump_mstats pPerl->Perl_dump_mstats
#undef dump_mstats
#define dump_mstats Perl_dump_mstats
-#undef Perl_malloc
-#define Perl_malloc pPerl->Perl_malloc
-#undef malloc
-#define malloc Perl_malloc
-#undef Perl_calloc
-#define Perl_calloc pPerl->Perl_calloc
-#undef calloc
-#define calloc Perl_calloc
-#undef Perl_realloc
-#define Perl_realloc pPerl->Perl_realloc
-#undef realloc
-#define realloc Perl_realloc
-#undef Perl_mfree
-#define Perl_mfree pPerl->Perl_mfree
-#undef mfree
-#define mfree Perl_mfree
#endif
#undef Perl_safesysmalloc
#define Perl_safesysmalloc pPerl->Perl_safesysmalloc
@@ -3546,6 +3533,10 @@
#define Perl_ss_dup pPerl->Perl_ss_dup
#undef ss_dup
#define ss_dup Perl_ss_dup
+#undef Perl_any_dup
+#define Perl_any_dup pPerl->Perl_any_dup
+#undef any_dup
+#define any_dup Perl_any_dup
#undef Perl_he_dup
#define Perl_he_dup pPerl->Perl_he_dup
#undef he_dup
@@ -3596,12 +3587,9 @@
#define Perl_ptr_table_split pPerl->Perl_ptr_table_split
#undef ptr_table_split
#define ptr_table_split Perl_ptr_table_split
-#undef perl_clone
-#define perl_clone pPerl->perl_clone
-#undef perl_clone_using
-#define perl_clone_using pPerl->perl_clone_using
#endif
#if defined(PERL_OBJECT)
+#else
#endif
#if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT)
#endif
@@ -3660,6 +3648,8 @@
# if defined(LEAKTEST)
# endif
#endif
+#if defined(PERL_OBJECT)
+#endif
#undef Perl_ck_anoncode
#define Perl_ck_anoncode pPerl->Perl_ck_anoncode
#undef ck_anoncode
diff --git a/op.c b/op.c
index 73c9634..7824c22 100644
--- a/op.c
+++ b/op.c
@@ -105,7 +105,7 @@ S_no_bareword_allowed(pTHX_ OP *o)
{
qerror(Perl_mess(aTHX_
"Bareword \"%s\" not allowed while \"strict subs\" in use",
- SvPV_nolen(cSVOPo->op_sv)));
+ SvPV_nolen(cSVOPo_sv)));
}
/* "register" allocation */
@@ -319,6 +319,7 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
return 0;
}
break;
+ case CXt_FORMAT:
case CXt_SUB:
if (!saweval)
return 0;
@@ -498,7 +499,7 @@ Perl_pad_free(pTHX_ PADOFFSET po)
Perl_croak(aTHX_ "panic: pad_free po");
#ifdef USE_THREADS
DEBUG_X(PerlIO_printf(Perl_debug_log,
- "0x%"UVxf" Pad 0x%"UVxf" free %"IVd"\n",
+ "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n",
PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
#else
DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n",
@@ -1069,7 +1070,7 @@ Perl_scalarvoid(pTHX_ OP *o)
break;
case OP_CONST:
- sv = cSVOPo->op_sv;
+ sv = cSVOPo_sv;
if (cSVOPo->op_private & OPpCONST_STRICT)
no_bareword_allowed(o);
else {
@@ -1299,7 +1300,7 @@ Perl_mod(pTHX_ OP *o, I32 type)
if (!(o->op_private & (OPpCONST_ARYBASE)))
goto nomod;
if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
- PL_compiling.cop_arybase = (I32)SvIV(((SVOP*)PL_eval_start)->op_sv);
+ PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
PL_eval_start = 0;
}
else if (!type) {
@@ -1979,7 +1980,7 @@ Perl_block_start(pTHX_ int full)
PL_pad_reset_pending = FALSE;
SAVEHINTS();
PL_hints &= ~HINT_BLOCK_SCOPE;
- SAVEPPTR(PL_compiling.cop_warnings);
+ SAVESPTR(PL_compiling.cop_warnings);
if (! specialWARN(PL_compiling.cop_warnings)) {
PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
SAVEFREESV(PL_compiling.cop_warnings) ;
@@ -2948,7 +2949,9 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
padop->op_type = type;
padop->op_ppaddr = PL_ppaddr[type];
padop->op_padix = pad_alloc(type, SVs_PADTMP);
+ SvREFCNT_dec(PL_curpad[padop->op_padix]);
PL_curpad[padop->op_padix] = sv;
+ SvPADTMP_on(sv);
padop->op_next = (OP*)padop;
padop->op_flags = flags;
if (PL_opargs[type] & OA_RETSCALAR)
@@ -3362,13 +3365,7 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
(void)SvIOK_on(*svp);
- SvIVX(*svp) = 1;
-#ifndef USE_ITHREADS
- /* XXX This nameless kludge interferes with cloning SVs. :-(
- * What's more, it seems entirely redundant when considering
- * PL_DBsingle exists to do the same thing */
- SvSTASH(*svp) = (HV*)cop;
-#endif
+ SvIVX(*svp) = (IV)cop;
}
}
@@ -3907,7 +3904,7 @@ Perl_cv_undef(pTHX_ CV *cv)
#endif /* USE_THREADS */
ENTER;
- SAVESPTR(PL_curpad);
+ SAVEVPTR(PL_curpad);
PL_curpad = 0;
if (!CvCLONED(cv))
@@ -4010,7 +4007,7 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside)
assert(!CvUNIQUE(proto));
ENTER;
- SAVESPTR(PL_curpad);
+ SAVEVPTR(PL_curpad);
SAVESPTR(PL_comppad);
SAVESPTR(PL_comppad_name);
SAVESPTR(PL_compcv);
@@ -4085,7 +4082,7 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside)
PL_curpad[ix] = sv;
}
}
- else if (IS_PADGV(ppad[ix])) {
+ else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
}
else {
@@ -4191,9 +4188,9 @@ Perl_op_const_sv(pTHX_ OP *o, CV *cv)
break;
if (sv)
return Nullsv;
- if (type == OP_CONST)
+ if (type == OP_CONST && cSVOPo->op_sv)
sv = cSVOPo->op_sv;
- else if (type == OP_PADSV && cv) {
+ else if ((type == OP_PADSV || type == OP_CONST) && cv) {
AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
if (!sv || (!SvREADONLY(sv) && SvREFCNT(sv) > 1))
@@ -4397,12 +4394,25 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
+ if (CvLVALUE(cv)) {
+ CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, scalarseq(block));
+ }
+ else {
+ CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+ }
+ CvROOT(cv)->op_private |= OPpREFCOUNTED;
+ OpREFCNT_set(CvROOT(cv), 1);
+ CvSTART(cv) = LINKLIST(CvROOT(cv));
+ CvROOT(cv)->op_next = 0;
+ peep(CvSTART(cv));
+
+ /* now that optimizer has done its work, adjust pad values */
if (CvCLONE(cv)) {
SV **namep = AvARRAY(PL_comppad_name);
for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
SV *namesv;
- if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]))
+ if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
continue;
/*
* The only things that a clonable function needs in its
@@ -4426,25 +4436,13 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
AvFLAGS(av) = AVf_REIFY;
for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
- if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]))
+ if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
continue;
if (!SvPADMY(PL_curpad[ix]))
SvPADTMP_on(PL_curpad[ix]);
}
}
- if (CvLVALUE(cv)) {
- CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, scalarseq(block));
- }
- else {
- CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
- }
- CvROOT(cv)->op_private |= OPpREFCOUNTED;
- OpREFCNT_set(CvROOT(cv), 1);
- CvSTART(cv) = LINKLIST(CvROOT(cv));
- CvROOT(cv)->op_next = 0;
- peep(CvSTART(cv));
-
if (name) {
char *s;
@@ -6140,7 +6138,7 @@ Perl_peep(pTHX_ register OP *o)
return;
ENTER;
SAVEOP();
- SAVESPTR(PL_curcop);
+ SAVEVPTR(PL_curcop);
for (; o; o = o->op_next) {
if (o->op_seq)
break;
@@ -6159,6 +6157,19 @@ Perl_peep(pTHX_ register OP *o)
case OP_CONST:
if (cSVOPo->op_private & OPpCONST_STRICT)
no_bareword_allowed(o);
+#ifdef USE_ITHREADS
+ /* Relocate sv to the pad for thread safety.
+ * Despite being a "constant", the SV is written to,
+ * for reference counts, sv_upgrade() etc. */
+ if (cSVOP->op_sv) {
+ PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
+ SvREFCNT_dec(PL_curpad[ix]);
+ SvPADTMP_on(cSVOPo->op_sv);
+ PL_curpad[ix] = cSVOPo->op_sv;
+ cSVOPo->op_sv = Nullsv;
+ o->op_targ = ix;
+ }
+#endif
/* FALL THROUGH */
case OP_UC:
case OP_UCFIRST:
@@ -6337,7 +6348,7 @@ Perl_peep(pTHX_ register OP *o)
fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
if (!fields || !GvHV(*fields))
break;
- svp = &((SVOP*)((BINOP*)o)->op_last)->op_sv;
+ svp = &cSVOPx_sv(((BINOP*)o)->op_last);
key = SvPV(*svp, keylen);
indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
if (!indsvp) {
diff --git a/op.h b/op.h
index 95ecf87..454cbf7 100644
--- a/op.h
+++ b/op.h
@@ -313,6 +313,9 @@ struct loop {
# define cGVOPo_set(v) (PL_curpad[cPADOPo->op_padix] = (SV*)(v))
# define kGVOP_set(v) (PL_curpad[kPADOP->op_padix] = (SV*)(v))
# define IS_PADGV(v) (v && SvTYPE(v) == SVt_PVGV && GvIN_PAD(v))
+# define IS_PADCONST(v) (v && SvREADONLY(v))
+# define cSVOPx_sv(v) (cSVOPx(v)->op_sv \
+ ? cSVOPx(v)->op_sv : PL_curpad[(v)->op_targ])
#else
# define cGVOPx(o) ((GV*)cSVOPx(o)->op_sv)
# define cGVOP ((GV*)cSVOP->op_sv)
@@ -322,8 +325,14 @@ struct loop {
# define cGVOPo_set(v) (cPADOPo->op_sv = (SV*)(v))
# define kGVOP_set(v) (kPADOP->op_sv = (SV*)(v))
# define IS_PADGV(v) FALSE
+# define IS_PADCONST(v) FALSE
+# define cSVOPx_sv(v) (cSVOPx(v)->op_sv)
#endif
+#define cSVOP_sv cSVOPx_sv(PL_op)
+#define cSVOPo_sv cSVOPx_sv(o)
+#define kSVOP_sv cSVOPx_sv(kid)
+
#define Nullop Null(OP*)
/* Lowest byte of PL_opargs */
diff --git a/os2/os2ish.h b/os2/os2ish.h
index 3d7a6fd..f254b5c 100644
--- a/os2/os2ish.h
+++ b/os2/os2ish.h
@@ -64,7 +64,7 @@
#ifndef SIGILL
# define SIGILL 6 /* blech */
#endif
-#define ABORT() kill(getpid(),SIGABRT);
+#define ABORT() kill(PerlProc_getpid(),SIGABRT);
#define BIT_BUCKET "/dev/nul" /* Will this work? */
diff --git a/perl.c b/perl.c
index 9f3a8ae..0fb2f35 100644
--- a/perl.c
+++ b/perl.c
@@ -47,40 +47,42 @@ static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen);
#endif
#ifdef PERL_OBJECT
-CPerlObj*
-perl_alloc(struct IPerlMem* ipM, struct IPerlEnv* ipE,
- struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
- struct IPerlDir* ipD, struct IPerlSock* ipS,
- struct IPerlProc* ipP)
-{
- CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP);
- if (pPerl != NULL)
- pPerl->Init();
-
- return pPerl;
-}
-#else
+#define perl_construct Perl_construct
+#define perl_parse Perl_parse
+#define perl_run Perl_run
+#define perl_destruct Perl_destruct
+#define perl_free Perl_free
+#endif
#ifdef PERL_IMPLICIT_SYS
PerlInterpreter *
-perl_alloc_using(struct IPerlMem* ipM, struct IPerlEnv* ipE,
+perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
+ struct IPerlMem* ipMP, struct IPerlEnv* ipE,
struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
struct IPerlDir* ipD, struct IPerlSock* ipS,
struct IPerlProc* ipP)
{
PerlInterpreter *my_perl;
-
+#ifdef PERL_OBJECT
+ my_perl = (PerlInterpreter*)new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd,
+ ipLIO, ipD, ipS, ipP);
+ PERL_SET_INTERP(my_perl);
+#else
/* New() needs interpreter, so call malloc() instead */
my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
PERL_SET_INTERP(my_perl);
Zero(my_perl, 1, PerlInterpreter);
PL_Mem = ipM;
+ PL_MemShared = ipMS;
+ PL_MemParse = ipMP;
PL_Env = ipE;
PL_StdIO = ipStd;
PL_LIO = ipLIO;
PL_Dir = ipD;
PL_Sock = ipS;
PL_Proc = ipP;
+#endif
+
return my_perl;
}
#else
@@ -95,7 +97,6 @@ perl_alloc(void)
return my_perl;
}
#endif /* PERL_IMPLICIT_SYS */
-#endif /* PERL_OBJECT */
void
perl_construct(pTHXx)
@@ -235,6 +236,9 @@ perl_destruct(pTHXx)
dTHX;
#endif /* USE_THREADS */
+ /* wait for all pseudo-forked children to finish */
+ PERL_WAIT_FOR_CHILDREN;
+
#ifdef USE_THREADS
#ifndef FAKE_THREADS
/* Pass 1 on any remaining threads: detach joinables, join zombies */
@@ -2873,7 +2877,7 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register
}
TAINT_NOT;
if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
- sv_setiv(GvSV(tmpgv), (IV)getpid());
+ sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
}
STATIC void
diff --git a/perl.h b/perl.h
index 3fe64a8..f0dcf1e 100644
--- a/perl.h
+++ b/perl.h
@@ -30,22 +30,12 @@
# ifndef PERL_IMPLICIT_CONTEXT
# define PERL_IMPLICIT_CONTEXT
# endif
-# ifndef PERL_IMPLICIT_SYS
-# if defined(WIN32) && !defined(__MINGW32__)
-# define PERL_IMPLICIT_SYS /* XXX not implemented everywhere yet */
-# endif
-# endif
#endif
#if defined(MULTIPLICITY)
# ifndef PERL_IMPLICIT_CONTEXT
# define PERL_IMPLICIT_CONTEXT
# endif
-# ifndef PERL_IMPLICIT_SYS
-# if defined(WIN32) && !defined(__MINGW32__)
-# define PERL_IMPLICIT_SYS /* XXX not implemented everywhere yet */
-# endif
-# endif
#endif
#ifdef PERL_CAPI
@@ -146,7 +136,7 @@ class CPerlObj;
#define STATIC
#define CPERLscope(x) CPerlObj::x
-#define CALL_FPTR(fptr) (this->*fptr)
+#define CALL_FPTR(fptr) (aTHXo->*fptr)
#define pTHXo CPerlObj *pPerl
#define pTHXo_ pTHXo,
@@ -1621,6 +1611,10 @@ typedef pthread_key_t perl_key;
# endif
#endif
+#ifndef PERL_WAIT_FOR_CHILDREN
+# define PERL_WAIT_FOR_CHILDREN NOOP
+#endif
+
/* the traditional thread-unsafe notion of "current interpreter".
* XXX todo: a thread-safe version that fetches it from TLS (akin to THR)
* needs to be defined elsewhere (conditional on pthread_getspecific()
@@ -2144,13 +2138,9 @@ EXTCONST char PL_uuemap[65]
#ifdef DOINIT
EXT char *PL_sig_name[] = { SIG_NAME };
EXT int PL_sig_num[] = { SIG_NUM };
-EXT SV * PL_psig_ptr[sizeof(PL_sig_num)/sizeof(*PL_sig_num)];
-EXT SV * PL_psig_name[sizeof(PL_sig_num)/sizeof(*PL_sig_num)];
#else
EXT char *PL_sig_name[];
EXT int PL_sig_num[];
-EXT SV * PL_psig_ptr[];
-EXT SV * PL_psig_name[];
#endif
/* fast case folding tables */
@@ -2487,44 +2477,25 @@ typedef struct exitlistentry {
void *ptr;
} PerlExitListEntry;
-#ifdef PERL_OBJECT
-#undef perl_alloc
-#define perl_alloc Perl_alloc
-CPerlObj* Perl_alloc (IPerlMem*, IPerlEnv*, IPerlStdIO*, IPerlLIO*, IPerlDir*, IPerlSock*, IPerlProc*);
-
-#undef EXT
-#define EXT
-#undef EXTCONST
-#define EXTCONST
-#undef INIT
-#define INIT(x)
-
-class CPerlObj {
-public:
- CPerlObj(IPerlMem*, IPerlEnv*, IPerlStdIO*, IPerlLIO*, IPerlDir*, IPerlSock*, IPerlProc*);
- void Init(void);
- void* operator new(size_t nSize, IPerlMem *pvtbl);
- static void operator delete(void* pPerl, IPerlMem *pvtbl);
-#endif /* PERL_OBJECT */
-
#ifdef PERL_GLOBAL_STRUCT
struct perl_vars {
-#include "perlvars.h"
+# include "perlvars.h"
};
-#ifdef PERL_CORE
+# ifdef PERL_CORE
EXT struct perl_vars PL_Vars;
EXT struct perl_vars *PL_VarsPtr INIT(&PL_Vars);
-#else /* PERL_CORE */
-#if !defined(__GNUC__) || !defined(WIN32)
+# else /* PERL_CORE */
+# if !defined(__GNUC__) || !defined(WIN32)
EXT
-#endif /* WIN32 */
+# endif /* WIN32 */
struct perl_vars *PL_VarsPtr;
-#define PL_Vars (*((PL_VarsPtr) ? PL_VarsPtr : (PL_VarsPtr = Perl_GetVars(aTHX))))
-#endif /* PERL_CORE */
+# define PL_Vars (*((PL_VarsPtr) \
+ ? PL_VarsPtr : (PL_VarsPtr = Perl_GetVars(aTHX))))
+# endif /* PERL_CORE */
#endif /* PERL_GLOBAL_STRUCT */
-#ifdef MULTIPLICITY
+#if defined(MULTIPLICITY) || defined(PERL_OBJECT)
/* If we have multiple interpreters define a struct
holding variables which must be per-interpreter
If we don't have threads anything that would have
@@ -2532,17 +2503,22 @@ struct perl_vars *PL_VarsPtr;
*/
struct interpreter {
-#ifndef USE_THREADS
-# include "thrdvar.h"
-#endif
-#include "intrpvar.h"
+# ifndef USE_THREADS
+# include "thrdvar.h"
+# endif
+# include "intrpvar.h"
+/*
+ * The following is a buffer where new variables must
+ * be defined to maintain binary compatibility with PERL_OBJECT
+ */
+PERLVARA(object_compatibility,30, char)
};
#else
struct interpreter {
char broiled;
};
-#endif
+#endif /* MULTIPLICITY || PERL_OBJECT */
#ifdef USE_THREADS
/* If we have threads define a struct with all the variables
@@ -2583,25 +2559,18 @@ typedef void *Thread;
#endif
#ifdef PERL_OBJECT
-#define PERL_DECL_PROT
-#define perl_alloc Perl_alloc
+# define PERL_DECL_PROT
#endif
-#include "proto.h"
-
#undef PERL_CKDEF
#undef PERL_PPDEF
#define PERL_CKDEF(s) OP *s (pTHX_ OP *o);
#define PERL_PPDEF(s) OP *s (pTHX);
-#ifdef PERL_OBJECT
-public:
-#endif
-#include "pp_proto.h"
+#include "proto.h"
#ifdef PERL_OBJECT
-int CPerlObj::do_aspawn (void *vreally, void **vmark, void **vsp);
-#undef PERL_DECL_PROT
+# undef PERL_DECL_PROT
#endif
#ifndef PERL_OBJECT
@@ -2625,29 +2594,17 @@ int CPerlObj::do_aspawn (void *vreally, void **vmark, void **vsp);
#define PERLVARI(var,type,init) EXT type PL_##var INIT(init);
#define PERLVARIC(var,type,init) EXTCONST type PL_##var INIT(init);
-#ifndef MULTIPLICITY
-
+#if !defined(MULTIPLICITY) && !defined(PERL_OBJECT)
+START_EXTERN_C
# include "intrpvar.h"
# ifndef USE_THREADS
# include "thrdvar.h"
# endif
-
+END_EXTERN_C
#endif
#ifdef PERL_OBJECT
-/*
- * The following is a buffer where new variables must
- * be defined to maintain binary compatibility with PERL_OBJECT
- * for 5.005
- */
-PERLVARA(object_compatibility,30, char)
-};
-
-
# include "embed.h"
-# if defined(WIN32) && !defined(WIN32IO_IS_STDIO)
-# define errno CPerlObj::ErrorNo()
-# endif
# ifdef DOINIT
# include "INTERN.h"
diff --git a/perlapi.c b/perlapi.c
index 02795ad..2f902f8 100644
--- a/perlapi.c
+++ b/perlapi.c
@@ -17,9 +17,9 @@ START_EXTERN_C
#undef PERLVARI
#undef PERLVARIC
#define PERLVAR(v,t) t* Perl_##v##_ptr(pTHXo) \
- { return &(aTHXo->PL_##v); }
+ { return &(aTHXo->interp.v); }
#define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHXo) \
- { return &(aTHXo->PL_##v); }
+ { return &(aTHXo->interp.v); }
#define PERLVARI(v,t,i) PERLVAR(v,t)
#define PERLVARIC(v,t,i) PERLVAR(v, const t)
@@ -39,8 +39,18 @@ START_EXTERN_C
#undef PERLVARI
#undef PERLVARIC
+#if defined(PERL_IMPLICIT_SYS)
+#else
+#endif
+#if defined(USE_ITHREADS)
+#endif
+#if defined(MYMALLOC)
+#endif
#if defined(PERL_OBJECT)
#endif
+#if defined(PERL_OBJECT)
+#else
+#endif
#undef Perl_amagic_call
SV*
@@ -2150,16 +2160,6 @@ Perl_magicname(pTHXo_ char* sym, char* name, I32 namlen)
{
((CPerlObj*)pPerl)->Perl_magicname(sym, name, namlen);
}
-#if defined(MYMALLOC)
-
-#undef Perl_malloced_size
-MEM_SIZE
-Perl_malloced_size(void *p)
-{
- dTHXo;
- return ((CPerlObj*)pPerl)->Perl_malloced_size(p);
-}
-#endif
#undef Perl_markstack_grow
void
@@ -2887,15 +2887,42 @@ Perl_peep(pTHXo_ OP* o)
((CPerlObj*)pPerl)->Perl_peep(o);
}
#if defined(PERL_OBJECT)
-#else
-#undef perl_alloc
-PerlInterpreter*
-perl_alloc()
+#undef Perl_construct
+void
+Perl_construct(pTHXo)
{
- dTHXo;
- return ((CPerlObj*)pPerl)->perl_alloc();
+ ((CPerlObj*)pPerl)->Perl_construct();
+}
+
+#undef Perl_destruct
+void
+Perl_destruct(pTHXo)
+{
+ ((CPerlObj*)pPerl)->Perl_destruct();
+}
+
+#undef Perl_free
+void
+Perl_free(pTHXo)
+{
+ ((CPerlObj*)pPerl)->Perl_free();
}
+
+#undef Perl_run
+int
+Perl_run(pTHXo)
+{
+ return ((CPerlObj*)pPerl)->Perl_run();
+}
+
+#undef Perl_parse
+int
+Perl_parse(pTHXo_ XSINIT_t xsinit, int argc, char** argv, char** env)
+{
+ return ((CPerlObj*)pPerl)->Perl_parse(xsinit, argc, argv, env);
+}
+#endif
#if defined(USE_THREADS)
#undef Perl_new_struct_thread
@@ -2905,7 +2932,6 @@ Perl_new_struct_thread(pTHXo_ struct perl_thread *t)
return ((CPerlObj*)pPerl)->Perl_new_struct_thread(t);
}
#endif
-#endif
#undef Perl_call_atexit
void
@@ -3476,6 +3502,13 @@ Perl_save_pptr(pTHXo_ char** pptr)
((CPerlObj*)pPerl)->Perl_save_pptr(pptr);
}
+#undef Perl_save_vptr
+void
+Perl_save_vptr(pTHXo_ void* pptr)
+{
+ ((CPerlObj*)pPerl)->Perl_save_vptr(pptr);
+}
+
#undef Perl_save_re_context
void
Perl_save_re_context(pTHXo)
@@ -4431,38 +4464,6 @@ Perl_dump_mstats(pTHXo_ char* s)
{
((CPerlObj*)pPerl)->Perl_dump_mstats(s);
}
-
-#undef Perl_malloc
-Malloc_t
-Perl_malloc(MEM_SIZE nbytes)
-{
- dTHXo;
- return ((CPerlObj*)pPerl)->Perl_malloc(nbytes);
-}
-
-#undef Perl_calloc
-Malloc_t
-Perl_calloc(MEM_SIZE elements, MEM_SIZE size)
-{
- dTHXo;
- return ((CPerlObj*)pPerl)->Perl_calloc(elements, size);
-}
-
-#undef Perl_realloc
-Malloc_t
-Perl_realloc(Malloc_t where, MEM_SIZE nbytes)
-{
- dTHXo;
- return ((CPerlObj*)pPerl)->Perl_realloc(where, nbytes);
-}
-
-#undef Perl_mfree
-Free_t
-Perl_mfree(Malloc_t where)
-{
- dTHXo;
- ((CPerlObj*)pPerl)->Perl_mfree(where);
-}
#endif
#undef Perl_safesysmalloc
@@ -4873,9 +4874,16 @@ Perl_si_dup(pTHXo_ PERL_SI* si)
#undef Perl_ss_dup
ANY*
-Perl_ss_dup(pTHXo_ ANY* ss, I32 ix, I32 max)
+Perl_ss_dup(pTHXo_ PerlInterpreter* proto_perl)
{
- return ((CPerlObj*)pPerl)->Perl_ss_dup(ss, ix, max);
+ return ((CPerlObj*)pPerl)->Perl_ss_dup(proto_perl);
+}
+
+#undef Perl_any_dup
+void*
+Perl_any_dup(pTHXo_ void* v, PerlInterpreter* proto_perl)
+{
+ return ((CPerlObj*)pPerl)->Perl_any_dup(v, proto_perl);
}
#undef Perl_he_dup
@@ -4963,24 +4971,9 @@ Perl_ptr_table_split(pTHXo_ PTR_TBL_t *tbl)
{
((CPerlObj*)pPerl)->Perl_ptr_table_split(tbl);
}
-
-#undef perl_clone
-PerlInterpreter*
-perl_clone(PerlInterpreter* interp, UV flags)
-{
- dTHXo;
- return ((CPerlObj*)pPerl)->perl_clone(flags);
-}
-
-#undef perl_clone_using
-PerlInterpreter*
-perl_clone_using(PerlInterpreter *interp, UV flags, struct IPerlMem* m, struct IPerlEnv* e, struct IPerlStdIO* io, struct IPerlLIO* lio, struct IPerlDir* d, struct IPerlSock* s, struct IPerlProc* p)
-{
- dTHXo;
- return ((CPerlObj*)pPerl)->perl_clone_using(interp, flags, m, e, io, lio, d, s, p);
-}
#endif
#if defined(PERL_OBJECT)
+#else
#endif
#if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT)
#endif
@@ -5039,6 +5032,8 @@ perl_clone_using(PerlInterpreter *interp, UV flags, struct IPerlMem* m, struct I
# if defined(LEAKTEST)
# endif
#endif
+#if defined(PERL_OBJECT)
+#endif
#undef Perl_ck_anoncode
OP *
@@ -7728,7 +7723,7 @@ Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...)
dTHXo;
va_list(arglist);
va_start(arglist, format);
- return (*pPerl->PL_StdIO->pVprintf)(pPerl->PL_StdIO, stream, format, arglist);
+ return (*PL_StdIO->pVprintf)(PL_StdIO, stream, format, arglist);
}
END_EXTERN_C
diff --git a/plan9/plan9ish.h b/plan9/plan9ish.h
index 06a30fe..bac6a92 100644
--- a/plan9/plan9ish.h
+++ b/plan9/plan9ish.h
@@ -103,7 +103,7 @@
#ifndef SIGILL
# define SIGILL 6 /* blech */
#endif
-#define ABORT() kill(getpid(),SIGABRT);
+#define ABORT() kill(PerlProc_getpid(),SIGABRT);
#define BIT_BUCKET "/dev/null"
#define PERL_SYS_INIT(c,v) MALLOC_INIT
diff --git a/pod/Makefile b/pod/Makefile
index a4b405c..3aadd9e 100644
--- a/pod/Makefile
+++ b/pod/Makefile
@@ -31,6 +31,7 @@ POD = \
perlmod.pod \
perlmodlib.pod \
perlmodinstall.pod \
+ perlfork.pod \
perlform.pod \
perllocale.pod \
perlref.pod \
@@ -92,6 +93,7 @@ MAN = \
perlmod.man \
perlmodlib.man \
perlmodinstall.man \
+ perlfork.man \
perlform.man \
perllocale.man \
perlref.man \
@@ -153,6 +155,7 @@ HTML = \
perlmod.html \
perlmodlib.html \
perlmodinstall.html \
+ perlfork.html \
perlform.html \
perllocale.html \
perlref.html \
@@ -214,6 +217,7 @@ TEX = \
perlmod.tex \
perlmodlib.tex \
perlmodinstall.tex \
+ perlfork.tex \
perlform.tex \
perllocale.tex \
perlref.tex \
diff --git a/pod/buildtoc b/pod/buildtoc
index 1a9a24b..41cb76d 100644
--- a/pod/buildtoc
+++ b/pod/buildtoc
@@ -8,7 +8,7 @@ sub output ($);
perl perlfaq perlfaq1 perlfaq2 perlfaq3 perlfaq4 perlfaq5
perlfaq6 perlfaq7 perlfaq8 perlfaq9 perldelta perldata
perlsyn perlop perlre perlrun perlfunc perlvar perlsub
- perlmod perlmodlib perlmodinstall perlform perllocale
+ perlmod perlmodlib perlmodinstall perlfork perlform perllocale
perlref perlreftut perldsc
perllol perltoot perltootc perlobj perltie perlbot perlipc
perldbmfilter perldebug
diff --git a/pod/perl.pod b/pod/perl.pod
index 6e3921e..dc97764 100644
--- a/pod/perl.pod
+++ b/pod/perl.pod
@@ -47,6 +47,7 @@ sections:
perltie Perl objects hidden behind simple variables
perlbot Perl OO tricks and examples
perlipc Perl interprocess communication
+ perlfork Perl fork() information
perlthrtut Perl threads tutorial
perldbmfilter Perl DBM Filters
diff --git a/pod/perlfork.pod b/pod/perlfork.pod
new file mode 100644
index 0000000..68a3242
--- /dev/null
+++ b/pod/perlfork.pod
@@ -0,0 +1,224 @@
+=head1 NAME
+
+perlfork - Perl's fork() emulation
+
+=head1 SYNOPSIS
+
+Perl provides a fork() keyword that corresponds to the Unix system call
+of the same name. On most Unix-like platforms where the fork() system
+call is available, Perl's fork() simply calls it.
+
+On some platforms such as Windows where the fork() system call is not
+available, Perl can be built to emulate fork() at the interpreter level.
+While the emulation is designed to be as compatible as possible with the
+real fork() at the the level of the Perl program, there are certain
+important differences that stem from the fact that all the pseudo child
+"processes" created this way live in the same real process as far as the
+operating system is concerned.
+
+This document provides a general overview of the capabilities and
+limitations of the fork() emulation. Note that the issues discussed here
+are not applicable to platforms where a real fork() is available and Perl
+has been configured to use it.
+
+=head1 DESCRIPTION
+
+The fork() emulation is implemented at the level of the Perl interpreter.
+What this means in general is that running fork() will actually clone the
+running interpreter and all its state, and run the cloned interpreter in
+a separate thread, beginning execution in the new thread just after the
+point where the fork() was called in the parent. We will refer to the
+thread that implements this child "process" as the pseudo-process.
+
+To the Perl program that called fork(), all this is designed to be
+transparent. The parent returns from the fork() with a pseudo-process
+ID that can be subsequently used in any process manipulation functions;
+the child returns from the fork() with a value of C<0> to signify that
+it is the child pseudo-process.
+
+=head2 Behavior of other Perl features in forked pseudo-processes
+
+Most Perl features behave in a natural way within pseudo-processes.
+
+=over 8
+
+=item $$ or $PROCESS_ID
+
+This special variable is correctly set to the pseudo-process ID.
+It can be used to identify pseudo-processes within a particular
+session. Note that this value is subject to recycling if any
+pseudo-processes are launched after others have been wait()-ed on.
+
+=item %ENV
+
+Each pseudo-process maintains its own virtual enviroment. Modifications
+to %ENV affect the virtual environment, and are only visible within that
+pseudo-process, and in any processes (or pseudo-processes) launched from
+it.
+
+=item chdir() and all other builtins that accept filenames
+
+Each pseudo-process maintains its own virtual idea of the current directory.
+Modifications to the current directory using chdir() are only visible within
+that pseudo-process, and in any processes (or pseudo-processes) launched from
+it. All file and directory accesses from the pseudo-process will correctly
+map the virtual working directory to the real working directory appropriately.
+
+=item wait() and waitpid()
+
+wait() and waitpid() can be passed a pseudo-process ID returned by fork().
+These calls will properly wait for the termination of the pseudo-process
+and return its status.
+
+=item kill()
+
+kill() can be used to terminate a pseudo-process by passing it the ID returned
+by fork(). This should not be used except under dire circumstances, because
+the operating system may not guarantee integrity of the process resources
+when a running thread is terminated. Note that using kill() on a
+pseudo-process() may typically cause memory leaks, because the thread that
+implements the pseudo-process does not get a chance to clean up its resources.
+
+=item exec()
+
+Calling exec() within a pseudo-process actually spawns the requested
+executable in a separate process and waits for it to complete before
+exiting with the same exit status as that process. This means that the
+process ID reported within the running executable will be different from
+what the earlier Perl fork() might have returned. Similarly, any process
+manipulation functions applied to the ID returned by fork() will affect the
+waiting pseudo-process that called exec(), not the real process it is
+waiting for after the exec().
+
+=item exit()
+
+exit() always exits just the executing pseudo-process, after automatically
+wait()-ing for any outstanding child pseudo-processes. Note that this means
+that the process as a whole will not exit unless all running pseudo-processes
+have exited.
+
+=item Open handles to files, directories and network sockets
+
+All open handles are dup()-ed in pseudo-processes, so that closing
+any handles in one process does not affect the others. See below for
+some limitations.
+
+=back
+
+=head2 Resource limits
+
+In the eyes of the operating system, pseudo-processes created via the fork()
+emulation are simply threads in the same process. This means that any
+process-level limits imposed by the operating system apply to all
+pseudo-processes taken together. This includes any limits imposed by the
+operating system on the number of open file, directory and socket handles,
+limits on disk space usage, limits on memory size, limits on CPU utilization
+etc.
+
+=head2 Killing the parent process
+
+If the parent process is killed (either using Perl's kill() builtin, or
+using some external means) all the pseudo-processes are killed as well,
+and the whole process exits.
+
+=head2 Lifetime of the parent process and pseudo-processes
+
+During the normal course of events, the parent process and every
+pseudo-process started by it will wait for their respective pseudo-children
+to complete before they exit. This means that the parent and every
+pseudo-child created by it that is also a pseudo-parent will only exit
+after their pseudo-children have exited.
+
+A way to mark a pseudo-processes as running detached from their parent (so
+that the parent would not have to wait() for them if it doesn't want to)
+will be provided in future.
+
+=head2 CAVEATS AND LIMITATIONS
+
+=over 8
+
+=item BEGIN blocks
+
+The fork() emulation will not work entirely correctly when called from
+within a BEGIN block. The forked copy will run the contents of the
+BEGIN block, but will not continue parsing the source stream after the
+BEGIN block. For example, consider the following code:
+
+ BEGIN {
+ fork and exit; # fork child and exit the parent
+ print "inner\n";
+ }
+ print "outer\n";
+
+This will print:
+
+ inner
+
+rather than the expected:
+
+ inner
+ outer
+
+This limitation arises from fundamental technical difficulties in
+cloning and restarting the stacks used by the Perl parser in the
+middle of a parse.
+
+=item Open filehandles
+
+Any filehandles open at the time of the fork() will be dup()-ed. Thus,
+the files can be closed independently in the parent and child, but beware
+that the dup()-ed handles will still share the same seek pointer. Changing
+the seek position in the parent will change it in the child and vice-versa.
+One can avoid this by opening files that need distinct seek pointers
+separately in the child.
+
+=item Global state maintained by XSUBs
+
+External subroutines (XSUBs) that maintain their own global state may
+not work correctly. Such XSUBs will either need to maintain locks to
+protect simultaneous access to global data from different pseudo-processes,
+or maintain all their state on the Perl symbol table, which is copied
+naturally when fork() is called. A callback mechanism that provides
+extensions an opportunity to clone their state will be provided in the
+near future.
+
+=item Interpreter embedded in larger application
+
+The fork() emulation may not behave as expected when it is executed in an
+application which embeds a Perl interpreter and calls Perl APIs that can
+evaluate bits of Perl code. This stems from the fact that the emulation
+only has knowledge about the Perl interpreter's own data structures and
+knows nothing about the containing application's state. For example, any
+state carried on the application's own call stack is out of reach.
+
+=back
+
+=head1 BUGS
+
+=over 8
+
+=item *
+
+Having pseudo-process IDs be negative integers breaks down for the integer
+C<-1> because the wait() and waitpid() functions treat this number as
+being special. The tacit assumption in the current implementation is that
+the system never allocates a thread ID of C<1> for user threads. A better
+representation for pseudo-process IDs will be implemented in future.
+
+=item *
+
+This document may be incomplete in some respects.
+
+=head1 AUTHOR
+
+Support for the fork() emulation was implemented by ActiveState, supported
+by funding from Microsoft Corporation.
+
+This document is authored and maintained by Gurusamy Sarathy
+E<lt>gsar@activestate.comE<gt>.
+
+=head1 SEE ALSO
+
+L<perlfunc/"fork">, L<perlipc>
+
+=cut
diff --git a/pod/roffitall b/pod/roffitall
index 9c9daeb..7ddffe7 100644
--- a/pod/roffitall
+++ b/pod/roffitall
@@ -42,6 +42,7 @@ toroff=`
$mandir/perlmod.1 \
$mandir/perlmodlib.1 \
$mandir/perlmodinstall.1 \
+ $mandir/perlfork.1 \
$mandir/perlform.1 \
$mandir/perllocale.1 \
$mandir/perlref.1 \
diff --git a/pp.c b/pp.c
index e7c966f..529fa9d 100644
--- a/pp.c
+++ b/pp.c
@@ -1789,7 +1789,7 @@ S_seed(pTHX)
u = (U32)SEED_C1 * when;
# endif
#endif
- u += SEED_C3 * (U32)getpid();
+ u += SEED_C3 * (U32)PerlProc_getpid();
u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
u += SEED_C5 * (U32)PTR2UV(&when);
diff --git a/pp_ctl.c b/pp_ctl.c
index bc2a361..b1f71a3 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -686,7 +686,7 @@ PP(pp_grepstart)
/* SAVE_DEFSV does *not* suffice here for USE_THREADS */
SAVESPTR(DEFSV);
ENTER; /* enter inner scope */
- SAVESPTR(PL_curpm);
+ SAVEVPTR(PL_curpm);
src = PL_stack_base[*PL_markstack_ptr];
SvTEMP_off(src);
@@ -756,7 +756,7 @@ PP(pp_mapwhile)
SV *src;
ENTER; /* enter inner scope */
- SAVESPTR(PL_curpm);
+ SAVEVPTR(PL_curpm);
src = PL_stack_base[PL_markstack_ptr[-1]];
SvTEMP_off(src);
@@ -785,7 +785,7 @@ PP(pp_sort)
}
ENTER;
- SAVEPPTR(PL_sortcop);
+ SAVEVPTR(PL_sortcop);
if (PL_op->op_flags & OPf_STACKED) {
if (PL_op->op_flags & OPf_SPECIAL) {
OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
@@ -813,10 +813,10 @@ PP(pp_sort)
DIE(aTHX_ "Not a CODE reference in sort");
}
PL_sortcop = CvSTART(cv);
- SAVESPTR(CvROOT(cv)->op_ppaddr);
+ SAVEVPTR(CvROOT(cv)->op_ppaddr);
CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
- SAVESPTR(PL_curpad);
+ SAVEVPTR(PL_curpad);
PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
}
}
@@ -1040,6 +1040,11 @@ S_dopoptolabel(pTHX_ char *label)
Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s",
PL_op_name[PL_op->op_type]);
break;
+ case CXt_FORMAT:
+ if (ckWARN(WARN_UNSAFE))
+ Perl_warner(aTHX_ WARN_UNSAFE, "Exiting format via %s",
+ PL_op_name[PL_op->op_type]);
+ break;
case CXt_EVAL:
if (ckWARN(WARN_UNSAFE))
Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s",
@@ -1115,6 +1120,7 @@ S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
continue;
case CXt_EVAL:
case CXt_SUB:
+ case CXt_FORMAT:
DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
return i;
}
@@ -1160,6 +1166,11 @@ S_dopoptoloop(pTHX_ I32 startingblock)
Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s",
PL_op_name[PL_op->op_type]);
break;
+ case CXt_FORMAT:
+ if (ckWARN(WARN_UNSAFE))
+ Perl_warner(aTHX_ WARN_UNSAFE, "Exiting format via %s",
+ PL_op_name[PL_op->op_type]);
+ break;
case CXt_EVAL:
if (ckWARN(WARN_UNSAFE))
Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s",
@@ -1208,6 +1219,9 @@ Perl_dounwind(pTHX_ I32 cxix)
break;
case CXt_NULL:
break;
+ case CXt_FORMAT:
+ POPFORMAT(cx);
+ break;
}
cxstack_ix--;
}
@@ -1420,7 +1434,7 @@ PP(pp_caller)
}
cx = &ccstack[cxix];
- if (CxTYPE(cx) == CXt_SUB) {
+ if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
dbcxix = dopoptosub_at(ccstack, cxix - 1);
/* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
field below is defined for any cx. */
@@ -1448,7 +1462,8 @@ PP(pp_caller)
PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
if (!MAXARG)
RETURN;
- if (CxTYPE(cx) == CXt_SUB) { /* So is ccstack[dbcxix]. */
+ if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
+ /* So is ccstack[dbcxix]. */
sv = NEWSV(49, 0);
gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
PUSHs(sv_2mortal(sv));
@@ -1563,7 +1578,7 @@ PP(pp_dbstate)
PUSHSUB(cx);
CvDEPTH(cv)++;
(void)SvREFCNT_inc(cv);
- SAVESPTR(PL_curpad);
+ SAVEVPTR(PL_curpad);
PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
RETURNOP(CvSTART(cv));
}
@@ -1582,6 +1597,10 @@ PP(pp_enteriter)
register PERL_CONTEXT *cx;
I32 gimme = GIMME_V;
SV **svp;
+ U32 cxtype = CXt_LOOP;
+#ifdef USE_ITHREADS
+ void *iterdata;
+#endif
ENTER;
SAVETMPS;
@@ -1598,17 +1617,29 @@ PP(pp_enteriter)
if (PL_op->op_targ) {
svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
SAVESPTR(*svp);
+#ifdef USE_ITHREADS
+ iterdata = (void*)PL_op->op_targ;
+ cxtype |= CXp_PADVAR;
+#endif
}
else {
- svp = &GvSV((GV*)POPs); /* symbol table variable */
+ GV *gv = (GV*)POPs;
+ svp = &GvSV(gv); /* symbol table variable */
SAVEGENERICSV(*svp);
*svp = NEWSV(0,0);
+#ifdef USE_ITHREADS
+ iterdata = (void*)gv;
+#endif
}
ENTER;
- PUSHBLOCK(cx, CXt_LOOP, SP);
+ PUSHBLOCK(cx, cxtype, SP);
+#ifdef USE_ITHREADS
+ PUSHLOOP(cx, iterdata, MARK);
+#else
PUSHLOOP(cx, svp, MARK);
+#endif
if (PL_op->op_flags & OPf_STACKED) {
cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
@@ -1703,7 +1734,9 @@ PP(pp_return)
SV *sv;
if (PL_curstackinfo->si_type == PERLSI_SORT) {
- if (cxstack_ix == PL_sortcxix || dopoptosub(cxstack_ix) <= PL_sortcxix) {
+ if (cxstack_ix == PL_sortcxix
+ || dopoptosub(cxstack_ix) <= PL_sortcxix)
+ {
if (cxstack_ix > PL_sortcxix)
dounwind(PL_sortcxix);
AvARRAY(PL_curstack)[1] = *SP;
@@ -1737,6 +1770,9 @@ PP(pp_return)
DIE(aTHX_ "%s did not return a true value", name);
}
break;
+ case CXt_FORMAT:
+ POPFORMAT(cx);
+ break;
default:
DIE(aTHX_ "panic: return");
}
@@ -1826,6 +1862,10 @@ PP(pp_last)
POPEVAL(cx);
nextop = pop_return();
break;
+ case CXt_FORMAT:
+ POPFORMAT(cx);
+ nextop = pop_return();
+ break;
default:
DIE(aTHX_ "panic: last");
}
@@ -2072,7 +2112,7 @@ PP(pp_goto)
SP[1] = SP[0];
SP--;
}
- fp3 = (I32(*)(int,int,int)))CvXSUB(cv;
+ fp3 = (I32(*)(int,int,int))CvXSUB(cv);
items = (*fp3)(CvXSUBANY(cv).any_i32,
mark - PL_stack_base + 1,
items);
@@ -2116,9 +2156,10 @@ PP(pp_goto)
AV *newpad = newAV();
SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
I32 ix = AvFILLp((AV*)svp[1]);
+ I32 names_fill = AvFILLp((AV*)svp[0]);
svp = AvARRAY(svp[0]);
for ( ;ix > 0; ix--) {
- if (svp[ix] != &PL_sv_undef) {
+ if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
char *name = SvPVX(svp[ix]);
if ((SvFLAGS(svp[ix]) & SVf_FAKE)
|| *name == '&')
@@ -2137,7 +2178,7 @@ PP(pp_goto)
SvPADMY_on(sv);
}
}
- else if (IS_PADGV(oldpad[ix])) {
+ else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
}
else {
@@ -2170,7 +2211,7 @@ PP(pp_goto)
}
}
#endif /* USE_THREADS */
- SAVESPTR(PL_curpad);
+ SAVEVPTR(PL_curpad);
PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
#ifndef USE_THREADS
if (cx->blk_sub.hasargs)
@@ -2275,6 +2316,7 @@ PP(pp_goto)
break;
}
/* FALL THROUGH */
+ case CXt_FORMAT:
case CXt_NULL:
DIE(aTHX_ "Can't \"goto\" outside a block");
default:
@@ -2506,7 +2548,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
#ifdef OP_IN_REGISTER
PL_opsave = op;
#else
- SAVEPPTR(PL_op);
+ SAVEVPTR(PL_op);
#endif
PL_hints = 0;
@@ -2549,7 +2591,7 @@ S_doeval(pTHX_ int gimme, OP** startop)
/* set up a scratch pad */
SAVEI32(PL_padix);
- SAVESPTR(PL_curpad);
+ SAVEVPTR(PL_curpad);
SAVESPTR(PL_comppad);
SAVESPTR(PL_comppad_name);
SAVEI32(PL_comppad_name_fill);
@@ -2561,7 +2603,7 @@ S_doeval(pTHX_ int gimme, OP** startop)
PERL_CONTEXT *cx = &cxstack[i];
if (CxTYPE(cx) == CXt_EVAL)
break;
- else if (CxTYPE(cx) == CXt_SUB) {
+ else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
caller = cx->blk_sub.cv;
break;
}
@@ -2970,11 +3012,9 @@ PP(pp_require)
PL_rsfp_filters = Nullav;
PL_rsfp = tryrsfp;
- name = savepv(name);
- SAVEFREEPV(name);
SAVEHINTS();
PL_hints = 0;
- SAVEPPTR(PL_compiling.cop_warnings);
+ SAVESPTR(PL_compiling.cop_warnings);
if (PL_dowarn & G_WARN_ALL_ON)
PL_compiling.cop_warnings = WARN_ALL ;
else if (PL_dowarn & G_WARN_ALL_OFF)
@@ -3049,7 +3089,7 @@ PP(pp_entereval)
SAVEDELETE(PL_defstash, safestr, strlen(safestr));
SAVEHINTS();
PL_hints = PL_op->op_targ;
- SAVEPPTR(PL_compiling.cop_warnings);
+ SAVESPTR(PL_compiling.cop_warnings);
if (!specialWARN(PL_compiling.cop_warnings)) {
PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
SAVEFREESV(PL_compiling.cop_warnings) ;
diff --git a/pp_hot.c b/pp_hot.c
index 421b099..690abea 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -40,7 +40,7 @@ static void unset_cvowner(pTHXo_ void *cvarg);
PP(pp_const)
{
djSP;
- XPUSHs(cSVOP->op_sv);
+ XPUSHs(cSVOP_sv);
RETURN;
}
@@ -1509,12 +1509,14 @@ PP(pp_iter)
register PERL_CONTEXT *cx;
SV* sv;
AV* av;
+ SV **itersvp;
EXTEND(SP, 1);
cx = &cxstack[cxstack_ix];
if (CxTYPE(cx) != CXt_LOOP)
DIE(aTHX_ "panic: pp_iter");
+ itersvp = CxITERVAR(cx);
av = cx->blk_loop.iterary;
if (SvTYPE(av) != SVt_PVAV) {
/* iterate ($min .. $max) */
@@ -1525,11 +1527,9 @@ PP(pp_iter)
char *max = SvPV((SV*)av, maxlen);
if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
#ifndef USE_THREADS /* don't risk potential race */
- if (SvREFCNT(*cx->blk_loop.itervar) == 1
- && !SvMAGICAL(*cx->blk_loop.itervar))
- {
+ if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
/* safe to reuse old SV */
- sv_setsv(*cx->blk_loop.itervar, cur);
+ sv_setsv(*itersvp, cur);
}
else
#endif
@@ -1537,8 +1537,8 @@ PP(pp_iter)
/* we need a fresh SV every time so that loop body sees a
* completely new SV for closures/references to work as
* they used to */
- SvREFCNT_dec(*cx->blk_loop.itervar);
- *cx->blk_loop.itervar = newSVsv(cur);
+ SvREFCNT_dec(*itersvp);
+ *itersvp = newSVsv(cur);
}
if (strEQ(SvPVX(cur), max))
sv_setiv(cur, 0); /* terminate next time */
@@ -1553,11 +1553,9 @@ PP(pp_iter)
RETPUSHNO;
#ifndef USE_THREADS /* don't risk potential race */
- if (SvREFCNT(*cx->blk_loop.itervar) == 1
- && !SvMAGICAL(*cx->blk_loop.itervar))
- {
+ if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
/* safe to reuse old SV */
- sv_setiv(*cx->blk_loop.itervar, cx->blk_loop.iterix++);
+ sv_setiv(*itersvp, cx->blk_loop.iterix++);
}
else
#endif
@@ -1565,8 +1563,8 @@ PP(pp_iter)
/* we need a fresh SV every time so that loop body sees a
* completely new SV for closures/references to work as they
* used to */
- SvREFCNT_dec(*cx->blk_loop.itervar);
- *cx->blk_loop.itervar = newSViv(cx->blk_loop.iterix++);
+ SvREFCNT_dec(*itersvp);
+ *itersvp = newSViv(cx->blk_loop.iterix++);
}
RETPUSHYES;
}
@@ -1575,7 +1573,7 @@ PP(pp_iter)
if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
RETPUSHNO;
- SvREFCNT_dec(*cx->blk_loop.itervar);
+ SvREFCNT_dec(*itersvp);
if (sv = (SvMAGICAL(av))
? *av_fetch(av, ++cx->blk_loop.iterix, FALSE)
@@ -1603,7 +1601,7 @@ PP(pp_iter)
sv = (SV*)lv;
}
- *cx->blk_loop.itervar = SvREFCNT_inc(sv);
+ *itersvp = SvREFCNT_inc(sv);
RETPUSHYES;
}
@@ -1900,7 +1898,7 @@ PP(pp_grepwhile)
SV *src;
ENTER; /* enter inner scope */
- SAVESPTR(PL_curpm);
+ SAVEVPTR(PL_curpm);
src = PL_stack_base[*PL_markstack_ptr];
SvTEMP_off(src);
@@ -2403,7 +2401,7 @@ try_autoload:
SP--;
}
PL_stack_sp = mark + 1;
- fp3 = (I32(*)(int,int,int)))CvXSUB(cv;
+ fp3 = (I32(*)(int,int,int))CvXSUB(cv);
items = (*fp3)(CvXSUBANY(cv).any_i32,
MARK - PL_stack_base + 1,
items);
@@ -2439,7 +2437,7 @@ try_autoload:
}
/* We assume first XSUB in &DB::sub is the called one. */
if (PL_curcopdb) {
- SAVESPTR(PL_curcop);
+ SAVEVPTR(PL_curcop);
PL_curcop = PL_curcopdb;
PL_curcopdb = NULL;
}
@@ -2481,9 +2479,10 @@ try_autoload:
AV *newpad = newAV();
SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
I32 ix = AvFILLp((AV*)svp[1]);
+ I32 names_fill = AvFILLp((AV*)svp[0]);
svp = AvARRAY(svp[0]);
for ( ;ix > 0; ix--) {
- if (svp[ix] != &PL_sv_undef) {
+ if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
char *name = SvPVX(svp[ix]);
if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
|| *name == '&') /* anonymous code? */
@@ -2500,7 +2499,7 @@ try_autoload:
SvPADMY_on(sv);
}
}
- else if (IS_PADGV(oldpad[ix])) {
+ else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
}
else {
@@ -2531,7 +2530,7 @@ try_autoload:
}
}
#endif /* USE_THREADS */
- SAVESPTR(PL_curpad);
+ SAVEVPTR(PL_curpad);
PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
#ifndef USE_THREADS
if (hasargs)
diff --git a/pp_sys.c b/pp_sys.c
index ebc5e27..48fb5e4 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -1138,9 +1138,9 @@ S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
SAVETMPS;
push_return(retop);
- PUSHBLOCK(cx, CXt_SUB, PL_stack_sp);
+ PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
PUSHFORMAT(cx);
- SAVESPTR(PL_curpad);
+ SAVEVPTR(PL_curpad);
PL_curpad = AvARRAY((AV*)svp[1]);
setdefout(gv); /* locally select filehandle so $% et al work */
@@ -2990,9 +2990,11 @@ PP(pp_fttext)
len = 512;
}
else {
- if (ckWARN(WARN_UNOPENED))
+ if (ckWARN(WARN_UNOPENED)) {
+ gv = cGVOP;
Perl_warner(aTHX_ WARN_UNOPENED, "Test on unopened file <%s>",
- GvENAME(cGVOP));
+ GvENAME(gv));
+ }
SETERRNO(EBADF,RMS$_IFI);
RETPUSHUNDEF;
}
@@ -3576,24 +3578,20 @@ PP(pp_fork)
if (!childpid) {
/*SUPPRESS 560*/
if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV))
- sv_setiv(GvSV(tmpgv), (IV)getpid());
+ sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
}
PUSHi(childpid);
RETURN;
#else
-# ifdef USE_ITHREADS
- /* XXXXXX testing */
+# if defined(USE_ITHREADS) && defined(WIN32)
djSP; dTARGET;
- /* XXX this just an approximation of what will eventually be run
- * in a different thread */
- PerlInterpreter *new_perl = perl_clone(my_perl, 0);
- Perl_pp_enter(new_perl);
- new_perl->Top = new_perl->Top->op_next; /* continue from next op */
- CALLRUNOPS(new_perl);
-
- /* parent returns with negative pseudo-pid */
- PUSHi(-1);
+ Pid_t childpid;
+
+ EXTEND(SP, 1);
+ PERL_FLUSHALL_FOR_CHILD;
+ childpid = PerlProc_fork();
+ PUSHi(childpid);
RETURN;
# else
DIE(aTHX_ PL_no_func, "Unsupported function fork");
@@ -3783,6 +3781,12 @@ PP(pp_exec)
# endif
#endif
}
+
+#ifdef USE_ITHREADS
+ if (value >= 0)
+ my_exit(value);
+#endif
+
SP = ORIGMARK;
PUSHi(value);
RETURN;
@@ -3827,7 +3831,7 @@ PP(pp_getpgrp)
#ifdef BSD_GETPGRP
pgrp = (I32)BSD_GETPGRP(pid);
#else
- if (pid != 0 && pid != getpid())
+ if (pid != 0 && pid != PerlProc_getpid())
DIE(aTHX_ "POSIX getpgrp can't take an argument");
pgrp = getpgrp();
#endif
@@ -3857,8 +3861,11 @@ PP(pp_setpgrp)
#ifdef BSD_SETPGRP
SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
#else
- if ((pgrp != 0 && pgrp != getpid()) || (pid != 0 && pid != getpid()))
+ if ((pgrp != 0 && pgrp != PerlProc_getpid())
+ || (pid != 0 && pid != PerlProc_getpid()))
+ {
DIE(aTHX_ "setpgrp can't take arguments");
+ }
SETi( setpgrp() >= 0 );
#endif /* USE_BSDPGRP */
RETURN;
diff --git a/proto.h b/proto.h
index 1204c81..5a01615 100644
--- a/proto.h
+++ b/proto.h
@@ -4,9 +4,52 @@
* and run 'make regen_headers' to effect changes.
*/
+
+
+START_EXTERN_C
+
+#if defined(PERL_IMPLICIT_SYS)
+PERL_CALLCONV PerlInterpreter* perl_alloc_using(struct IPerlMem* m, struct IPerlMem* ms, struct IPerlMem* mp, struct IPerlEnv* e, struct IPerlStdIO* io, struct IPerlLIO* lio, struct IPerlDir* d, struct IPerlSock* s, struct IPerlProc* p);
+#else
+PERL_CALLCONV PerlInterpreter* perl_alloc(void);
+#endif
+PERL_CALLCONV void perl_construct(PerlInterpreter* interp);
+PERL_CALLCONV void perl_destruct(PerlInterpreter* interp);
+PERL_CALLCONV void perl_free(PerlInterpreter* interp);
+PERL_CALLCONV int perl_run(PerlInterpreter* interp);
+PERL_CALLCONV int perl_parse(PerlInterpreter* interp, XSINIT_t xsinit, int argc, char** argv, char** env);
+#if defined(USE_ITHREADS)
+PERL_CALLCONV PerlInterpreter* perl_clone(PerlInterpreter* interp, UV flags);
+PERL_CALLCONV PerlInterpreter* perl_clone_using(PerlInterpreter *interp, UV flags, struct IPerlMem* m, struct IPerlMem* ms, struct IPerlMem* mp, struct IPerlEnv* e, struct IPerlStdIO* io, struct IPerlLIO* lio, struct IPerlDir* d, struct IPerlSock* s, struct IPerlProc* p);
+#endif
+
+#if defined(MYMALLOC)
+PERL_CALLCONV Malloc_t Perl_malloc(MEM_SIZE nbytes);
+PERL_CALLCONV Malloc_t Perl_calloc(MEM_SIZE elements, MEM_SIZE size);
+PERL_CALLCONV Malloc_t Perl_realloc(Malloc_t where, MEM_SIZE nbytes);
+PERL_CALLCONV Free_t Perl_mfree(Malloc_t where);
+PERL_CALLCONV MEM_SIZE Perl_malloced_size(void *p);
+#endif
+
+END_EXTERN_C
+
+/* functions with flag 'n' should come before here */
#if defined(PERL_OBJECT)
+class CPerlObj {
public:
+ struct interpreter interp;
+ CPerlObj(IPerlMem*, IPerlMem*, IPerlMem*, IPerlEnv*, IPerlStdIO*,
+ IPerlLIO*, IPerlDir*, IPerlSock*, IPerlProc*);
+ void* operator new(size_t nSize, IPerlMem *pvtbl);
+ static void operator delete(void* pPerl, IPerlMem *pvtbl);
+ int do_aspawn (void *vreally, void **vmark, void **vsp);
#endif
+#if defined(PERL_OBJECT)
+public:
+#else
+START_EXTERN_C
+#endif
+# include "pp_proto.h"
PERL_CALLCONV SV* Perl_amagic_call(pTHX_ SV* left, SV* right, int method, int dir);
PERL_CALLCONV bool Perl_Gv_AMupdate(pTHX_ HV* stash);
PERL_CALLCONV OP* Perl_append_elem(pTHX_ I32 optype, OP* head, OP* tail);
@@ -315,9 +358,6 @@ PERL_CALLCONV int Perl_magic_set_all_env(pTHX_ SV* sv, MAGIC* mg);
PERL_CALLCONV U32 Perl_magic_sizepack(pTHX_ SV* sv, MAGIC* mg);
PERL_CALLCONV int Perl_magic_wipepack(pTHX_ SV* sv, MAGIC* mg);
PERL_CALLCONV void Perl_magicname(pTHX_ char* sym, char* name, I32 namlen);
-#if defined(MYMALLOC)
-PERL_CALLCONV MEM_SIZE Perl_malloced_size(void *p);
-#endif
PERL_CALLCONV void Perl_markstack_grow(pTHX);
#if defined(USE_LOCALE_COLLATE)
PERL_CALLCONV char* Perl_mem_collxfrm(pTHX_ const char* s, STRLEN len, STRLEN* xlen);
@@ -415,6 +455,7 @@ PERL_CALLCONV SV* Perl_newSVrv(pTHX_ SV* rv, const char* classname);
PERL_CALLCONV SV* Perl_newSVsv(pTHX_ SV* old);
PERL_CALLCONV OP* Perl_newUNOP(pTHX_ I32 type, I32 flags, OP* first);
PERL_CALLCONV OP* Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP* loop, I32 whileline, OP* expr, OP* block, OP* cont);
+
PERL_CALLCONV PERL_SI* Perl_new_stackinfo(pTHX_ I32 stitems, I32 cxitems);
PERL_CALLCONV PerlIO* Perl_nextargv(pTHX_ GV* gv);
PERL_CALLCONV char* Perl_ninstr(pTHX_ const char* big, const char* bigend, const char* little, const char* lend);
@@ -433,22 +474,15 @@ PERL_CALLCONV void Perl_pad_reset(pTHX);
PERL_CALLCONV void Perl_pad_swipe(pTHX_ PADOFFSET po);
PERL_CALLCONV void Perl_peep(pTHX_ OP* o);
#if defined(PERL_OBJECT)
-PERL_CALLCONV void perl_construct(void);
-PERL_CALLCONV void perl_destruct(void);
-PERL_CALLCONV void perl_free(void);
-PERL_CALLCONV int perl_run(void);
-PERL_CALLCONV int perl_parse(XSINIT_t xsinit, int argc, char** argv, char** env);
-#else
-PERL_CALLCONV PerlInterpreter* perl_alloc(void);
-PERL_CALLCONV void perl_construct(PerlInterpreter* interp);
-PERL_CALLCONV void perl_destruct(PerlInterpreter* interp);
-PERL_CALLCONV void perl_free(PerlInterpreter* interp);
-PERL_CALLCONV int perl_run(PerlInterpreter* interp);
-PERL_CALLCONV int perl_parse(PerlInterpreter* interp, XSINIT_t xsinit, int argc, char** argv, char** env);
+PERL_CALLCONV void Perl_construct(pTHX);
+PERL_CALLCONV void Perl_destruct(pTHX);
+PERL_CALLCONV void Perl_free(pTHX);
+PERL_CALLCONV int Perl_run(pTHX);
+PERL_CALLCONV int Perl_parse(pTHX_ XSINIT_t xsinit, int argc, char** argv, char** env);
+#endif
#if defined(USE_THREADS)
PERL_CALLCONV struct perl_thread* Perl_new_struct_thread(pTHX_ struct perl_thread *t);
#endif
-#endif
PERL_CALLCONV void Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr);
PERL_CALLCONV I32 Perl_call_argv(pTHX_ const char* sub_name, I32 flags, char** argv);
PERL_CALLCONV I32 Perl_call_method(pTHX_ const char* methname, I32 flags);
@@ -532,6 +566,7 @@ PERL_CALLCONV void Perl_save_nogv(pTHX_ GV* gv);
PERL_CALLCONV void Perl_save_op(pTHX);
PERL_CALLCONV SV* Perl_save_scalar(pTHX_ GV* gv);
PERL_CALLCONV void Perl_save_pptr(pTHX_ char** pptr);
+PERL_CALLCONV void Perl_save_vptr(pTHX_ void* pptr);
PERL_CALLCONV void Perl_save_re_context(pTHX);
PERL_CALLCONV void Perl_save_sptr(pTHX_ SV** sptr);
PERL_CALLCONV SV* Perl_save_svref(pTHX_ SV** sptr);
@@ -677,10 +712,6 @@ PERL_CALLCONV int Perl_yyparse(pTHX);
PERL_CALLCONV int Perl_yywarn(pTHX_ char* s);
#if defined(MYMALLOC)
PERL_CALLCONV void Perl_dump_mstats(pTHX_ char* s);
-PERL_CALLCONV Malloc_t Perl_malloc(MEM_SIZE nbytes);
-PERL_CALLCONV Malloc_t Perl_calloc(MEM_SIZE elements, MEM_SIZE size);
-PERL_CALLCONV Malloc_t Perl_realloc(Malloc_t where, MEM_SIZE nbytes);
-PERL_CALLCONV Free_t Perl_mfree(Malloc_t where);
#endif
PERL_CALLCONV Malloc_t Perl_safesysmalloc(MEM_SIZE nbytes);
PERL_CALLCONV Malloc_t Perl_safesyscalloc(MEM_SIZE elements, MEM_SIZE size);
@@ -741,7 +772,8 @@ PERL_CALLCONV void Perl_boot_core_xsutils(pTHX);
#if defined(USE_ITHREADS)
PERL_CALLCONV PERL_CONTEXT* Perl_cx_dup(pTHX_ PERL_CONTEXT* cx, I32 ix, I32 max);
PERL_CALLCONV PERL_SI* Perl_si_dup(pTHX_ PERL_SI* si);
-PERL_CALLCONV ANY* Perl_ss_dup(pTHX_ ANY* ss, I32 ix, I32 max);
+PERL_CALLCONV ANY* Perl_ss_dup(pTHX_ PerlInterpreter* proto_perl);
+PERL_CALLCONV void* Perl_any_dup(pTHX_ void* v, PerlInterpreter* proto_perl);
PERL_CALLCONV HE* Perl_he_dup(pTHX_ HE* e, bool shared);
PERL_CALLCONV REGEXP* Perl_re_dup(pTHX_ REGEXP* r);
PERL_CALLCONV PerlIO* Perl_fp_dup(pTHX_ PerlIO* fp, char type);
@@ -756,15 +788,18 @@ PERL_CALLCONV PTR_TBL_t* Perl_ptr_table_new(pTHX);
PERL_CALLCONV void* Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv);
PERL_CALLCONV void Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldsv, void *newsv);
PERL_CALLCONV void Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl);
-PERL_CALLCONV PerlInterpreter* perl_clone(PerlInterpreter* interp, UV flags);
-PERL_CALLCONV PerlInterpreter* perl_clone_using(PerlInterpreter *interp, UV flags, struct IPerlMem* m, struct IPerlEnv* e, struct IPerlStdIO* io, struct IPerlLIO* lio, struct IPerlDir* d, struct IPerlSock* s, struct IPerlProc* p);
#endif
+
#if defined(PERL_OBJECT)
protected:
+#else
+END_EXTERN_C
#endif
+
#if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT)
STATIC I32 S_avhv_index_sv(pTHX_ SV* sv);
#endif
+
#if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT)
STATIC I32 S_do_trans_CC_simple(pTHX_ SV *sv);
STATIC I32 S_do_trans_CC_count(pTHX_ SV *sv);
@@ -777,9 +812,11 @@ 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_GV_C) || defined(PERL_DECL_PROT)
STATIC void S_gv_init_sv(pTHX_ GV *gv, I32 sv_type);
#endif
+
#if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT)
STATIC void S_hsplit(pTHX_ HV *hv);
STATIC void S_hfreeentries(pTHX_ HV *hv);
@@ -789,11 +826,13 @@ STATIC void S_del_he(pTHX_ HE *p);
STATIC HEK* S_save_hek(pTHX_ const char *str, I32 len, U32 hash);
STATIC void S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store);
#endif
+
#if defined(PERL_IN_MG_C) || defined(PERL_DECL_PROT)
STATIC void S_save_magic(pTHX_ I32 mgs_ix, SV *sv);
STATIC int S_magic_methpack(pTHX_ SV *sv, MAGIC *mg, char *meth);
STATIC int S_magic_methcall(pTHX_ SV *sv, MAGIC *mg, char *meth, I32 f, int n, SV *val);
#endif
+
#if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT)
STATIC I32 S_list_assignment(pTHX_ OP *o);
STATIC void S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid);
@@ -822,6 +861,7 @@ STATIC void S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs);
STATIC void* S_Slab_Alloc(pTHX_ int m, size_t sz);
# endif
#endif
+
#if defined(PERL_IN_PERL_C) || defined(PERL_DECL_PROT)
STATIC void S_find_beginning(pTHX);
STATIC void S_forbid_setid(pTHX_ char *);
@@ -850,6 +890,7 @@ STATIC void* S_call_list_body(pTHX_ va_list args);
STATIC struct perl_thread * S_init_main_thread(pTHX);
# endif
#endif
+
#if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT)
STATIC void S_doencodes(pTHX_ SV* sv, char* s, I32 len);
STATIC SV* S_refto(pTHX_ SV* sv);
@@ -858,6 +899,7 @@ STATIC SV* S_mul128(pTHX_ SV *sv, U8 m);
STATIC SV* S_is_an_int(pTHX_ char *s, STRLEN l);
STATIC int S_div128(pTHX_ SV *pnum, bool *done);
#endif
+
#if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT)
STATIC OP* S_docatch(pTHX_ OP *o);
STATIC void* S_docatch_body(pTHX_ va_list args);
@@ -874,10 +916,12 @@ STATIC OP* S_doeval(pTHX_ int gimme, OP** startop);
STATIC PerlIO * S_doopen_pmc(pTHX_ const char *name, const char *mode);
STATIC void S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t f);
#endif
+
#if defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT)
STATIC CV* S_get_db_sub(pTHX_ SV **svp, CV *cv);
STATIC SV* S_method_common(pTHX_ SV* meth, U32* hashp);
#endif
+
#if defined(PERL_IN_PP_SYS_C) || defined(PERL_DECL_PROT)
STATIC OP* S_doform(pTHX_ CV *cv, GV *gv, OP *retop);
STATIC int S_emulate_eaccess(pTHX_ const char* path, Mode_t mode);
@@ -885,6 +929,7 @@ STATIC int S_emulate_eaccess(pTHX_ const char* path, Mode_t mode);
STATIC int S_dooneliner(pTHX_ char *cmd, char *filename);
# endif
#endif
+
#if defined(PERL_IN_REGCOMP_C) || defined(PERL_DECL_PROT)
STATIC regnode* S_reg(pTHX_ I32, I32 *);
STATIC regnode* S_reganode(pTHX_ U8, U32);
@@ -909,6 +954,7 @@ STATIC void S_re_croak2(pTHX_ const char* pat1, const char* pat2, ...) __attribu
STATIC I32 S_regpposixcc(pTHX_ I32 value);
STATIC void S_checkposixcc(pTHX);
#endif
+
#if defined(PERL_IN_REGEXEC_C) || defined(PERL_DECL_PROT)
STATIC I32 S_regmatch(pTHX_ regnode *prog);
STATIC I32 S_regrepeat(pTHX_ regnode *p, I32 max);
@@ -923,12 +969,15 @@ STATIC void S_cache_re(pTHX_ regexp *prog);
STATIC U8* S_reghop(pTHX_ U8 *pos, I32 off);
STATIC U8* S_reghopmaybe(pTHX_ U8 *pos, I32 off);
#endif
+
#if defined(PERL_IN_RUN_C) || defined(PERL_DECL_PROT)
STATIC void S_debprof(pTHX_ OP *o);
#endif
+
#if defined(PERL_IN_SCOPE_C) || defined(PERL_DECL_PROT)
STATIC SV* S_save_scalar_at(pTHX_ SV **sptr);
#endif
+
#if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
STATIC IV S_asIV(pTHX_ SV* sv);
STATIC UV S_asUV(pTHX_ SV* sv);
@@ -984,6 +1033,7 @@ STATIC void S_sv_del_backref(pTHX_ SV *sv);
STATIC void S_del_sv(pTHX_ SV *p);
# endif
#endif
+
#if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT)
STATIC void S_check_uni(pTHX);
STATIC void S_force_next(pTHX_ I32 type);
@@ -1027,12 +1077,18 @@ STATIC int S_uni(pTHX_ I32 f, char *s);
STATIC I32 S_win32_textfilter(pTHX_ int idx, SV *sv, int maxlen);
# endif
#endif
+
#if defined(PERL_IN_UNIVERSAL_C) || defined(PERL_DECL_PROT)
STATIC SV* S_isa_lookup(pTHX_ HV *stash, const char *name, int len, int level);
#endif
+
#if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT)
STATIC SV* S_mess_alloc(pTHX);
# if defined(LEAKTEST)
STATIC void S_xstat(pTHX_ int);
# endif
#endif
+
+#if defined(PERL_OBJECT)
+};
+#endif
diff --git a/regcomp.c b/regcomp.c
index 49e9e26..65db009 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -3502,39 +3502,39 @@ Perl_save_re_context(pTHX)
SAVEPPTR(PL_reginput); /* String-input pointer. */
SAVEPPTR(PL_regbol); /* Beginning of input, for ^ check. */
SAVEPPTR(PL_regeol); /* End of input, for $ check. */
- SAVESPTR(PL_regstartp); /* Pointer to startp array. */
- SAVESPTR(PL_regendp); /* Ditto for endp. */
- SAVESPTR(PL_reglastparen); /* Similarly for lastparen. */
+ SAVEVPTR(PL_regstartp); /* Pointer to startp array. */
+ SAVEVPTR(PL_regendp); /* Ditto for endp. */
+ SAVEVPTR(PL_reglastparen); /* Similarly for lastparen. */
SAVEPPTR(PL_regtill); /* How far we are required to go. */
SAVEI32(PL_regprev); /* char before regbol, \n if none */
- SAVESPTR(PL_reg_start_tmp); /* from regexec.c */
+ SAVEVPTR(PL_reg_start_tmp); /* from regexec.c */
PL_reg_start_tmp = 0;
SAVEFREEPV(PL_reg_start_tmp);
SAVEI32(PL_reg_start_tmpl); /* from regexec.c */
PL_reg_start_tmpl = 0;
- SAVESPTR(PL_regdata);
+ SAVEVPTR(PL_regdata);
SAVEI32(PL_reg_flags); /* from regexec.c */
SAVEI32(PL_reg_eval_set); /* from regexec.c */
SAVEI32(PL_regnarrate); /* from regexec.c */
- SAVESPTR(PL_regprogram); /* from regexec.c */
+ SAVEVPTR(PL_regprogram); /* from regexec.c */
SAVEINT(PL_regindent); /* from regexec.c */
- SAVESPTR(PL_regcc); /* from regexec.c */
- SAVESPTR(PL_curcop);
- SAVESPTR(PL_regcomp_rx); /* from regcomp.c */
+ SAVEVPTR(PL_regcc); /* from regexec.c */
+ SAVEVPTR(PL_curcop);
+ SAVEVPTR(PL_regcomp_rx); /* from regcomp.c */
SAVEI32(PL_regseen); /* from regcomp.c */
SAVEI32(PL_regsawback); /* Did we see \1, ...? */
SAVEI32(PL_regnaughty); /* How bad is this pattern? */
- SAVESPTR(PL_regcode); /* Code-emit pointer; ®dummy = don't */
+ SAVEVPTR(PL_regcode); /* Code-emit pointer; ®dummy = don't */
SAVEPPTR(PL_regxend); /* End of input for compile */
SAVEPPTR(PL_regcomp_parse); /* Input-scan pointer. */
- SAVESPTR(PL_reg_call_cc); /* from regexec.c */
- SAVESPTR(PL_reg_re); /* from regexec.c */
+ SAVEVPTR(PL_reg_call_cc); /* from regexec.c */
+ SAVEVPTR(PL_reg_re); /* from regexec.c */
SAVEPPTR(PL_reg_ganch); /* from regexec.c */
SAVESPTR(PL_reg_sv); /* from regexec.c */
- SAVESPTR(PL_reg_magic); /* from regexec.c */
+ SAVEVPTR(PL_reg_magic); /* from regexec.c */
SAVEI32(PL_reg_oldpos); /* from regexec.c */
- SAVESPTR(PL_reg_oldcurpm); /* from regexec.c */
- SAVESPTR(PL_reg_curpm); /* from regexec.c */
+ SAVEVPTR(PL_reg_oldcurpm); /* from regexec.c */
+ SAVEVPTR(PL_reg_curpm); /* from regexec.c */
#ifdef DEBUGGING
SAVEPPTR(PL_reg_starttry); /* from regexec.c */
#endif
diff --git a/run.c b/run.c
index a5e6359..9878076 100644
--- a/run.c
+++ b/run.c
@@ -71,7 +71,7 @@ Perl_debop(pTHX_ OP *o)
Perl_deb(aTHX_ "%s", PL_op_name[o->op_type]);
switch (o->op_type) {
case OP_CONST:
- PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo->op_sv));
+ PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
break;
case OP_GVSV:
case OP_GV:
diff --git a/scope.c b/scope.c
index 0fd3692..c0559da 100644
--- a/scope.c
+++ b/scope.c
@@ -428,6 +428,16 @@ Perl_save_pptr(pTHX_ char **pptr)
}
void
+Perl_save_vptr(pTHX_ void *ptr)
+{
+ dTHR;
+ SSCHECK(3);
+ SSPUSHPTR(*(char**)ptr);
+ SSPUSHPTR(ptr);
+ SSPUSHINT(SAVEt_VPTR);
+}
+
+void
Perl_save_sptr(pTHX_ SV **sptr)
{
dTHR;
@@ -749,6 +759,7 @@ Perl_leave_scope(pTHX_ I32 base)
ptr = SSPOPPTR;
*(SV**)ptr = (SV*)SSPOPPTR;
break;
+ case SAVEt_VPTR: /* random* reference */
case SAVEt_PPTR: /* char* reference */
ptr = SSPOPPTR;
*(char**)ptr = (char*)SSPOPPTR;
@@ -936,17 +947,25 @@ Perl_cx_dump(pTHX_ PERL_CONTEXT *cx)
case CXt_NULL:
case CXt_BLOCK:
break;
- case CXt_SUB:
+ case CXt_FORMAT:
PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%"UVxf"\n",
PTR2UV(cx->blk_sub.cv));
PerlIO_printf(Perl_debug_log, "BLK_SUB.GV = 0x%"UVxf"\n",
PTR2UV(cx->blk_sub.gv));
PerlIO_printf(Perl_debug_log, "BLK_SUB.DFOUTGV = 0x%"UVxf"\n",
PTR2UV(cx->blk_sub.dfoutgv));
+ PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n",
+ (int)cx->blk_sub.hasargs);
+ break;
+ case CXt_SUB:
+ PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%"UVxf"\n",
+ PTR2UV(cx->blk_sub.cv));
PerlIO_printf(Perl_debug_log, "BLK_SUB.OLDDEPTH = %ld\n",
(long)cx->blk_sub.olddepth);
PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n",
(int)cx->blk_sub.hasargs);
+ PerlIO_printf(Perl_debug_log, "BLK_SUB.LVAL = %d\n",
+ (int)cx->blk_sub.lval);
break;
case CXt_EVAL:
PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_IN_EVAL = %ld\n",
@@ -976,8 +995,8 @@ Perl_cx_dump(pTHX_ PERL_CONTEXT *cx)
PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%"UVxf"\n",
PTR2UV(cx->blk_loop.iterary));
PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERVAR = 0x%"UVxf"\n",
- PTR2UV(cx->blk_loop.itervar));
- if (cx->blk_loop.itervar)
+ PTR2UV(CxITERVAR(cx)));
+ if (CxITERVAR(cx))
PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERSAVE = 0x%"UVxf"\n",
PTR2UV(cx->blk_loop.itersave));
PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERLVAL = 0x%"UVxf"\n",
diff --git a/scope.h b/scope.h
index 6aca9ea..6d6b013 100644
--- a/scope.h
+++ b/scope.h
@@ -29,6 +29,7 @@
#define SAVEt_ALLOC 28
#define SAVEt_GENERIC_SVREF 29
#define SAVEt_DESTRUCTOR_X 30
+#define SAVEt_VPTR 31
#define SSCHECK(need) if (PL_savestack_ix + need > PL_savestack_max) savestack_grow()
#define SSPUSHINT(i) (PL_savestack[PL_savestack_ix++].any_i32 = (I32)(i))
@@ -77,6 +78,7 @@
#define SAVELONG(l) save_long(SOFT_CAST(long*)&(l))
#define SAVESPTR(s) save_sptr((SV**)&(s))
#define SAVEPPTR(s) save_pptr(SOFT_CAST(char**)&(s))
+#define SAVEVPTR(s) save_vptr(&(s))
#define SAVEFREESV(s) save_freesv((SV*)(s))
#define SAVEFREEOP(o) save_freeop(SOFT_CAST(OP*)(o))
#define SAVEFREEPV(p) save_freepv(SOFT_CAST(char*)(p))
diff --git a/sv.c b/sv.c
index 746f929..1c6ac83 100644
--- a/sv.c
+++ b/sv.c
@@ -5642,11 +5642,19 @@ Perl_re_dup(pTHX_ REGEXP *r)
PerlIO *
Perl_fp_dup(pTHX_ PerlIO *fp, char type)
{
+ PerlIO *ret;
if (!fp)
return (PerlIO*)NULL;
- return fp; /* XXX */
- /* return PerlIO_fdopen(PerlIO_fileno(fp),
- type == '<' ? "r" : type == '>' ? "w" : "rw"); */
+
+ /* look for it in the table first */
+ ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
+ if (ret)
+ return ret;
+
+ /* create anew and remember what it is */
+ ret = PerlIO_fdupopen(fp);
+ ptr_table_store(PL_ptr_table, fp, ret);
+ return ret;
}
DIR *
@@ -5665,7 +5673,7 @@ Perl_gp_dup(pTHX_ GP *gp)
if (!gp)
return (GP*)NULL;
/* look for it in the table first */
- ret = ptr_table_fetch(PL_ptr_table, gp);
+ ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
if (ret)
return ret;
@@ -5696,7 +5704,10 @@ Perl_mg_dup(pTHX_ MAGIC *mg)
MAGIC *mgprev;
if (!mg)
return (MAGIC*)NULL;
- /* XXX need to handle aliases here? */
+ /* look for it in the table first */
+ mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
+ if (mgret)
+ return mgret;
for (; mg; mg = mg->mg_moremagic) {
MAGIC *nmg;
@@ -5765,27 +5776,27 @@ Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
}
void
-Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *old, void *new)
+Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
{
PTR_TBL_ENT_t *tblent, **otblent;
/* XXX this may be pessimal on platforms where pointers aren't good
* hash values e.g. if they grow faster in the most significant
* bits */
- UV hash = (UV)old;
+ UV hash = (UV)oldv;
bool i = 1;
assert(tbl);
otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
- if (tblent->oldval == old) {
- tblent->newval = new;
+ if (tblent->oldval == oldv) {
+ tblent->newval = newv;
tbl->tbl_items++;
return;
}
}
Newz(0, tblent, 1, PTR_TBL_ENT_t);
- tblent->oldval = old;
- tblent->newval = new;
+ tblent->oldval = oldv;
+ tblent->newval = newv;
tblent->next = *otblent;
*otblent = tblent;
tbl->tbl_items++;
@@ -5824,7 +5835,7 @@ Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
}
#ifdef DEBUGGING
-DllExport char *PL_watch_pvx;
+char *PL_watch_pvx;
#endif
SV *
@@ -5838,7 +5849,7 @@ Perl_sv_dup(pTHX_ SV *sstr)
if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
return Nullsv;
/* look for it in the table first */
- dstr = ptr_table_fetch(PL_ptr_table, sstr);
+ dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
if (dstr)
return dstr;
@@ -5996,11 +6007,11 @@ Perl_sv_dup(pTHX_ SV *sstr)
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
- IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
+ IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
if (IoOFP(sstr) == IoIFP(sstr))
IoOFP(dstr) = IoIFP(dstr);
else
- IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
+ IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
/* PL_rsfp_filters entries have fake IoDIRP() */
if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
@@ -6036,6 +6047,7 @@ Perl_sv_dup(pTHX_ SV *sstr)
src_ary = AvARRAY((AV*)sstr);
Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
+ ptr_table_store(PL_ptr_table, src_ary, dst_ary);
SvPVX(dstr) = (char*)dst_ary;
AvALLOC((AV*)dstr) = dst_ary;
if (AvREAL((AV*)sstr)) {
@@ -6073,26 +6085,11 @@ Perl_sv_dup(pTHX_ SV *sstr)
Newz(0, dxhv->xhv_array,
PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
while (i <= sxhv->xhv_max) {
- HE *dentry, *oentry;
- entry = ((HE**)sxhv->xhv_array)[i];
- dentry = he_dup(entry, !!HvSHAREKEYS(sstr));
- ((HE**)dxhv->xhv_array)[i] = dentry;
- while (entry) {
- entry = HeNEXT(entry);
- oentry = dentry;
- dentry = he_dup(entry, !!HvSHAREKEYS(sstr));
- HeNEXT(oentry) = dentry;
- }
+ ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
+ !!HvSHAREKEYS(sstr));
++i;
}
- if (sxhv->xhv_riter >= 0 && sxhv->xhv_eiter) {
- entry = ((HE**)sxhv->xhv_array)[sxhv->xhv_riter];
- while (entry && entry != sxhv->xhv_eiter)
- entry = HeNEXT(entry);
- dxhv->xhv_eiter = entry;
- }
- else
- dxhv->xhv_eiter = (HE*)NULL;
+ dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
}
else {
SvPVX(dstr) = Nullch;
@@ -6150,26 +6147,86 @@ dup_pvcv:
}
PERL_CONTEXT *
-Perl_cx_dup(pTHX_ PERL_CONTEXT *cx, I32 ix, I32 max)
+Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
{
- PERL_CONTEXT *ncx;
+ PERL_CONTEXT *ncxs;
- if (!cx)
+ if (!cxs)
return (PERL_CONTEXT*)NULL;
/* look for it in the table first */
- ncx = ptr_table_fetch(PL_ptr_table, cx);
- if (ncx)
- return ncx;
+ ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
+ if (ncxs)
+ return ncxs;
/* create anew and remember what it is */
- Newz(56, ncx, max + 1, PERL_CONTEXT);
- ptr_table_store(PL_ptr_table, cx, ncx);
+ Newz(56, ncxs, max + 1, PERL_CONTEXT);
+ ptr_table_store(PL_ptr_table, cxs, ncxs);
- /* XXX todo */
- /* ... */
-
- return ncx;
+ while (ix >= 0) {
+ PERL_CONTEXT *cx = &cxs[ix];
+ PERL_CONTEXT *ncx = &ncxs[ix];
+ ncx->cx_type = cx->cx_type;
+ if (CxTYPE(cx) == CXt_SUBST) {
+ Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
+ }
+ else {
+ ncx->blk_oldsp = cx->blk_oldsp;
+ ncx->blk_oldcop = cx->blk_oldcop;
+ ncx->blk_oldretsp = cx->blk_oldretsp;
+ ncx->blk_oldmarksp = cx->blk_oldmarksp;
+ ncx->blk_oldscopesp = cx->blk_oldscopesp;
+ ncx->blk_oldpm = cx->blk_oldpm;
+ ncx->blk_gimme = cx->blk_gimme;
+ switch (CxTYPE(cx)) {
+ case CXt_SUB:
+ ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
+ ? cv_dup_inc(cx->blk_sub.cv)
+ : cv_dup(cx->blk_sub.cv));
+ ncx->blk_sub.argarray = (cx->blk_sub.hasargs
+ ? av_dup_inc(cx->blk_sub.argarray)
+ : Nullav);
+ ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
+ ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
+ ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
+ ncx->blk_sub.lval = cx->blk_sub.lval;
+ break;
+ case CXt_EVAL:
+ ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
+ ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
+ ncx->blk_eval.old_name = SAVEPV(cx->blk_eval.old_name);
+ ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
+ ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
+ break;
+ case CXt_LOOP:
+ ncx->blk_loop.label = cx->blk_loop.label;
+ ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
+ ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
+ ncx->blk_loop.next_op = cx->blk_loop.next_op;
+ ncx->blk_loop.last_op = cx->blk_loop.last_op;
+ ncx->blk_loop.iterdata = (CxPADLOOP(cx)
+ ? cx->blk_loop.iterdata
+ : gv_dup((GV*)cx->blk_loop.iterdata));
+ ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
+ ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
+ ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
+ ncx->blk_loop.iterix = cx->blk_loop.iterix;
+ ncx->blk_loop.itermax = cx->blk_loop.itermax;
+ break;
+ case CXt_FORMAT:
+ ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
+ ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
+ ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
+ ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
+ break;
+ case CXt_BLOCK:
+ case CXt_NULL:
+ break;
+ }
+ }
+ --ix;
+ }
+ return ncxs;
}
PERL_SI *
@@ -6181,7 +6238,7 @@ Perl_si_dup(pTHX_ PERL_SI *si)
return (PERL_SI*)NULL;
/* look for it in the table first */
- nsi = ptr_table_fetch(PL_ptr_table, si);
+ nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
if (nsi)
return nsi;
@@ -6201,51 +6258,317 @@ Perl_si_dup(pTHX_ PERL_SI *si)
return nsi;
}
+#define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
+#define TOPINT(ss,ix) ((ss)[ix].any_i32)
+#define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
+#define TOPLONG(ss,ix) ((ss)[ix].any_long)
+#define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
+#define TOPIV(ss,ix) ((ss)[ix].any_iv)
+#define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
+#define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
+#define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
+#define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
+#define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
+#define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
+
+/* XXXXX todo */
+#define pv_dup_inc(p) SAVEPV(p)
+#define pv_dup(p) SAVEPV(p)
+#define svp_dup_inc(p,pp) any_dup(p,pp)
+
+void *
+Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
+{
+ void *ret;
+
+ if (!v)
+ return (void*)NULL;
+
+ /* look for it in the table first */
+ ret = ptr_table_fetch(PL_ptr_table, v);
+ if (ret)
+ return ret;
+
+ /* see if it is part of the interpreter structure */
+ if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
+ ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
+ else
+ ret = v;
+
+ return ret;
+}
+
ANY *
-Perl_ss_dup(pTHX_ ANY *ss, I32 ix, I32 max)
+Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
+{
+ ANY *ss = proto_perl->Tsavestack;
+ I32 ix = proto_perl->Tsavestack_ix;
+ I32 max = proto_perl->Tsavestack_max;
+ ANY *nss;
+ SV *sv;
+ GV *gv;
+ AV *av;
+ HV *hv;
+ void* ptr;
+ int intval;
+ long longval;
+ GP *gp;
+ IV iv;
+ I32 i;
+ char *c;
+ void (*dptr) (void*);
+ void (*dxptr) (pTHXo_ void*);
+
+ Newz(54, nss, max, ANY);
+
+ while (ix > 0) {
+ i = POPINT(ss,ix);
+ TOPINT(nss,ix) = i;
+ switch (i) {
+ case SAVEt_ITEM: /* normal string */
+ sv = (SV*)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = sv_dup_inc(sv);
+ sv = (SV*)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = sv_dup_inc(sv);
+ break;
+ case SAVEt_SV: /* scalar reference */
+ sv = (SV*)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = sv_dup_inc(sv);
+ gv = (GV*)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = gv_dup_inc(gv);
+ break;
+ case SAVEt_GENERIC_SVREF: /* generic sv */
+ case SAVEt_SVREF: /* scalar reference */
+ sv = (SV*)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = sv_dup_inc(sv);
+ ptr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
+ break;
+ case SAVEt_AV: /* array reference */
+ av = (AV*)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = av_dup_inc(av);
+ gv = (GV*)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = gv_dup(gv);
+ break;
+ case SAVEt_HV: /* hash reference */
+ hv = (HV*)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = hv_dup_inc(hv);
+ gv = (GV*)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = gv_dup(gv);
+ break;
+ case SAVEt_INT: /* int reference */
+ ptr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
+ intval = (int)POPINT(ss,ix);
+ TOPINT(nss,ix) = intval;
+ break;
+ case SAVEt_LONG: /* long reference */
+ ptr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
+ longval = (long)POPLONG(ss,ix);
+ TOPLONG(nss,ix) = longval;
+ break;
+ case SAVEt_I32: /* I32 reference */
+ ptr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
+ i = POPINT(ss,ix);
+ TOPINT(nss,ix) = i;
+ break;
+ case SAVEt_I16: /* I16 reference */
+ ptr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
+ i = POPINT(ss,ix);
+ TOPINT(nss,ix) = i;
+ break;
+ case SAVEt_IV: /* IV reference */
+ ptr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
+ iv = POPIV(ss,ix);
+ TOPIV(nss,ix) = iv;
+ break;
+ case SAVEt_SPTR: /* SV* reference */
+ ptr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
+ sv = (SV*)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = sv_dup(sv);
+ break;
+ case SAVEt_VPTR: /* random* reference */
+ ptr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
+ ptr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
+ break;
+ case SAVEt_PPTR: /* char* reference */
+ ptr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
+ c = (char*)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = pv_dup(c);
+ break;
+ case SAVEt_HPTR: /* HV* reference */
+ ptr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
+ hv = (HV*)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = hv_dup(hv);
+ break;
+ case SAVEt_APTR: /* AV* reference */
+ ptr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
+ av = (AV*)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = av_dup(av);
+ break;
+ case SAVEt_NSTAB:
+ gv = (GV*)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = gv_dup(gv);
+ break;
+ case SAVEt_GP: /* scalar reference */
+ gp = (GP*)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = gp = gp_dup(gp);
+ (void)GpREFCNT_inc(gp);
+ gv = (GV*)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = gv_dup_inc(c);
+ c = (char*)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = pv_dup(c);
+ iv = POPIV(ss,ix);
+ TOPIV(nss,ix) = iv;
+ iv = POPIV(ss,ix);
+ TOPIV(nss,ix) = iv;
+ break;
+ case SAVEt_FREESV:
+ sv = (SV*)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = sv_dup_inc(sv);
+ break;
+ case SAVEt_FREEOP:
+ ptr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = ptr;
+ break;
+ case SAVEt_FREEPV:
+ c = (char*)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = pv_dup_inc(c);
+ break;
+ case SAVEt_CLEARSV:
+ longval = POPLONG(ss,ix);
+ TOPLONG(nss,ix) = longval;
+ break;
+ case SAVEt_DELETE:
+ hv = (HV*)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = hv_dup_inc(hv);
+ c = (char*)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = pv_dup_inc(c);
+ i = POPINT(ss,ix);
+ TOPINT(nss,ix) = i;
+ break;
+ case SAVEt_DESTRUCTOR:
+ ptr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
+ dptr = POPDPTR(ss,ix);
+ TOPDPTR(nss,ix) = (void (*)(void*))any_dup(dptr, proto_perl);
+ break;
+ case SAVEt_DESTRUCTOR_X:
+ ptr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
+ dxptr = POPDXPTR(ss,ix);
+ TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup(dxptr, proto_perl);
+ break;
+ case SAVEt_REGCONTEXT:
+ case SAVEt_ALLOC:
+ i = POPINT(ss,ix);
+ TOPINT(nss,ix) = i;
+ ix -= i;
+ break;
+ case SAVEt_STACK_POS: /* Position on Perl stack */
+ i = POPINT(ss,ix);
+ TOPINT(nss,ix) = i;
+ break;
+ case SAVEt_AELEM: /* array element */
+ sv = (SV*)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = sv_dup_inc(sv);
+ i = POPINT(ss,ix);
+ TOPINT(nss,ix) = i;
+ av = (AV*)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = av_dup_inc(av);
+ break;
+ case SAVEt_HELEM: /* hash element */
+ sv = (SV*)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = sv_dup_inc(sv);
+ sv = (SV*)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = sv_dup_inc(sv);
+ hv = (HV*)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = hv_dup_inc(hv);
+ break;
+ case SAVEt_OP:
+ ptr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = ptr;
+ break;
+ case SAVEt_HINTS:
+ i = POPINT(ss,ix);
+ TOPINT(nss,ix) = i;
+ break;
+ default:
+ Perl_croak(aTHX_ "panic: ss_dup inconsistency");
+ }
+ }
+
+ return nss;
+}
+
+#ifdef PERL_OBJECT
+#include "XSUB.h"
+#endif
+
+PerlInterpreter *
+perl_clone(PerlInterpreter *my_perl, UV flags)
{
- /* XXX todo */
- return NULL;
+#ifdef PERL_OBJECT
+ CPerlObj *pPerl = (CPerlObj*)my_perl;
+#endif
+ return perl_clone_using(my_perl, flags, PL_Mem, PL_MemShared, PL_MemParse,
+ PL_Env, PL_StdIO, PL_LIO, PL_Dir, PL_Sock, PL_Proc);
}
PerlInterpreter *
perl_clone_using(PerlInterpreter *proto_perl, UV flags,
- struct IPerlMem* ipM, struct IPerlEnv* ipE,
+ struct IPerlMem* ipM, struct IPerlMem* ipMS,
+ struct IPerlMem* ipMP, struct IPerlEnv* ipE,
struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
struct IPerlDir* ipD, struct IPerlSock* ipS,
struct IPerlProc* ipP)
{
+ /* XXX many of the string copies here can be optimized if they're
+ * constants; they need to be allocated as common memory and just
+ * their pointers copied. */
+
IV i;
SV *sv;
SV **svp;
+#ifdef PERL_OBJECT
+ CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
+ ipD, ipS, ipP);
+ PERL_SET_INTERP(pPerl);
+#else
PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
PERL_SET_INTERP(my_perl);
-#ifdef DEBUGGING
+# ifdef DEBUGGING
memset(my_perl, 0xab, sizeof(PerlInterpreter));
PL_markstack = 0;
PL_scopestack = 0;
PL_savestack = 0;
PL_retstack = 0;
-#else
+# else
Zero(my_perl, 1, PerlInterpreter);
-# if 0
- Copy(proto_perl, my_perl, 1, PerlInterpreter);
# endif
-#endif
-
- /* XXX many of the string copies here can be optimized if they're
- * constants; they need to be allocated as common memory and just
- * their pointers copied. */
/* host pointers */
PL_Mem = ipM;
+ PL_MemShared = ipMS;
+ PL_MemParse = ipMP;
PL_Env = ipE;
PL_StdIO = ipStd;
PL_LIO = ipLIO;
PL_Dir = ipD;
PL_Sock = ipS;
PL_Proc = ipP;
+#endif
/* arena roots */
PL_xiv_arenaroot = NULL;
@@ -6280,7 +6603,11 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
+#ifdef PERL_OBJECT
+ SvUPGRADE(&PL_sv_no, SVt_PVNV);
+#else
SvANY(&PL_sv_no) = new_XPVNV();
+#endif
SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
@@ -6289,7 +6616,11 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
SvNVX(&PL_sv_no) = 0;
ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
+#ifdef PERL_OBJECT
+ SvUPGRADE(&PL_sv_yes, SVt_PVNV);
+#else
SvANY(&PL_sv_yes) = new_XPVNV();
+#endif
SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
@@ -6307,12 +6638,10 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
PL_compiling = proto_perl->Icompiling;
PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
+ ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
if (!specialWARN(PL_compiling.cop_warnings))
PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
- if (proto_perl->Tcurcop == &proto_perl->Icompiling)
- PL_curcop = &PL_compiling;
- else
- PL_curcop = proto_perl->Tcurcop;
+ PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
/* pseudo environmental stuff */
PL_origargc = proto_perl->Iorigargc;
@@ -6418,14 +6747,11 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
PL_main_start = proto_perl->Imain_start;
- PL_eval_root = proto_perl->Ieval_root;
+ PL_eval_root = OpREFCNT_inc(proto_perl->Ieval_root);
PL_eval_start = proto_perl->Ieval_start;
/* runtime control stuff */
- if (proto_perl->Icurcopdb == &proto_perl->Icompiling)
- PL_curcopdb = &PL_compiling;
- else
- PL_curcopdb = proto_perl->Icurcopdb;
+ PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
PL_copline = proto_perl->Icopline;
PL_filemode = proto_perl->Ifilemode;
@@ -6464,7 +6790,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
PL_comppad_name = av_dup(proto_perl->Icomppad_name);
PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
- PL_curpad = PL_comppad ? AvARRAY(PL_comppad) : (SV**)NULL;
+ PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
+ proto_perl->Tcurpad);
#ifdef HAVE_INTERP_INTERN
sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
@@ -6610,7 +6937,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
PL_last_swash_hv = Nullhv; /* reinits on demand */
PL_last_swash_klen = 0;
PL_last_swash_key[0]= '\0';
- PL_last_swash_tmps = Nullch;
+ PL_last_swash_tmps = (U8*)NULL;
PL_last_swash_slen = 0;
/* perly.c globals */
@@ -6626,6 +6953,19 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
PL_uudmap['M'] = 0; /* reinits on demand */
PL_bitcount = Nullch; /* reinits on demand */
+ if (proto_perl->Ipsig_ptr) {
+ int sig_num[] = { SIG_NUM };
+ Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
+ Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
+ for (i = 1; PL_sig_name[i]; i++) {
+ PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
+ PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
+ }
+ }
+ else {
+ PL_psig_ptr = (SV**)NULL;
+ PL_psig_name = (SV**)NULL;
+ }
/* thrdvar.h stuff */
@@ -6658,15 +6998,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
Newz(54, PL_scopestack, PL_scopestack_max, I32);
Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
- /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
- * NOTE: unlike the others! */
- PL_savestack_ix = proto_perl->Tsavestack_ix;
- PL_savestack_max = proto_perl->Tsavestack_max;
- /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
- PL_savestack = ss_dup(proto_perl->Tsavestack,
- PL_savestack_ix,
- PL_savestack_max);
-
/* next push_return() sets PL_retstack[PL_retstack_ix]
* NOTE: unlike the others! */
PL_retstack_ix = proto_perl->Tretstack_ix;
@@ -6686,6 +7017,13 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
- proto_perl->Tstack_base);
PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
+
+ /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
+ * NOTE: unlike the others! */
+ PL_savestack_ix = proto_perl->Tsavestack_ix;
+ PL_savestack_max = proto_perl->Tsavestack_max;
+ /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
+ PL_savestack = ss_dup(proto_perl);
}
else {
init_stacks();
@@ -6736,10 +7074,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
PL_lastgotoprobe = Nullop;
PL_dumpindent = proto_perl->Tdumpindent;
- if (proto_perl->Tsortcop == (OP*)&proto_perl->Icompiling)
- PL_sortcop = (OP*)&PL_compiling;
- else
- PL_sortcop = proto_perl->Tsortcop;
+ PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
PL_sortstash = hv_dup(proto_perl->Tsortstash);
PL_firstgv = gv_dup(proto_perl->Tfirstgv);
PL_secondgv = gv_dup(proto_perl->Tsecondgv);
@@ -6818,22 +7153,21 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
PL_reginterp_cnt = 0;
PL_reg_starttry = 0;
+#ifdef PERL_OBJECT
+ return (PerlInterpreter*)pPerl;
+#else
return my_perl;
+#endif
}
-PerlInterpreter *
-perl_clone(pTHXx_ UV flags)
-{
- return perl_clone_using(aTHXx_ flags, PL_Mem, PL_Env, PL_StdIO, PL_LIO,
- PL_Dir, PL_Sock, PL_Proc);
-}
-
-#endif /* USE_ITHREADS */
+#else /* !USE_ITHREADS */
#ifdef PERL_OBJECT
#include "XSUB.h"
#endif
+#endif /* USE_ITHREADS */
+
static void
do_report_used(pTHXo_ SV *sv)
{
diff --git a/t/op/fork.t b/t/op/fork.t
index 20c8747..be95653 100755
--- a/t/op/fork.t
+++ b/t/op/fork.t
@@ -1,26 +1,315 @@
#!./perl
-# $RCSfile: fork.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:53 $
+# tests for both real and emulated fork()
BEGIN {
chdir 't' if -d 't';
unshift @INC, '../lib';
require Config; import Config;
- unless ($Config{'d_fork'}) {
+ unless ($Config{'d_fork'} || $Config{ccflags} =~ /-DUSE_ITHREADS\b/) {
print "1..0 # Skip: no fork\n";
exit 0;
}
+ $ENV{PERL5LIB} = "../lib";
}
-$| = 1;
-print "1..2\n";
+$|=1;
+
+undef $/;
+@prgs = split "\n########\n", <DATA>;
+print "1..", scalar @prgs, "\n";
+
+$tmpfile = "forktmp000";
+1 while -f ++$tmpfile;
+END { unlink $tmpfile if $tmpfile; }
+
+$CAT = (($^O eq 'MSWin32') ? '.\perl -e "print <>"' : 'cat');
+for (@prgs){
+ my $switch;
+ if (s/^\s*(-\w.*)//){
+ $switch = $1;
+ }
+ my($prog,$expected) = split(/\nEXPECT\n/, $_);
+ $expected =~ s/\n+$//;
+ # results can be in any order, so sort 'em
+ my @expected = sort split /\n/, $expected;
+ open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!";
+ print TEST $prog, "\n";
+ close TEST or die "Cannot close $tmpfile: $!";
+ my $results;
+ if ($^O eq 'MSWin32') {
+ $results = `.\\perl -I../lib $switch $tmpfile 2>&1`;
+ }
+ else {
+ $results = `./perl $switch $tmpfile 2>&1`;
+ }
+ $status = $?;
+ $results =~ s/\n+$//;
+ $results =~ s/at\s+forktmp\d+\s+line/at - line/g;
+ $results =~ s/of\s+forktmp\d+\s+aborted/of - aborted/g;
+# bison says 'parse error' instead of 'syntax error',
+# various yaccs may or may not capitalize 'syntax'.
+ $results =~ s/^(syntax|parse) error/syntax error/mig;
+ my @results = sort split /\n/, $results;
+ if ( "@results" ne "@expected" ) {
+ print STDERR "PROG: $switch\n$prog\n";
+ print STDERR "EXPECTED:\n$expected\n";
+ print STDERR "GOT:\n$results\n";
+ print "not ";
+ }
+ print "ok ", ++$i, "\n";
+}
+
+__END__
+$| = 1;
if ($cid = fork) {
- sleep 2;
- if ($result = (kill 9, $cid)) {print "ok 2\n";} else {print "not ok 2 $result\n";}
+ sleep 1;
+ if ($result = (kill 9, $cid)) {
+ print "ok 2\n";
+ }
+ else {
+ print "not ok 2 $result\n";
+ }
+ sleep 1 if $^O eq 'MSWin32'; # avoid WinNT race bug
}
else {
- $| = 1;
print "ok 1\n";
sleep 10;
}
+EXPECT
+ok 1
+ok 2
+########
+$| = 1;
+sub forkit {
+ print "iteration $i start\n";
+ my $x = fork;
+ if (defined $x) {
+ if ($x) {
+ print "iteration $i parent\n";
+ }
+ else {
+ print "iteration $i child\n";
+ }
+ }
+ else {
+ print "pid $$ failed to fork\n";
+ }
+}
+while ($i++ < 3) { do { forkit(); }; }
+EXPECT
+iteration 1 start
+iteration 1 parent
+iteration 1 child
+iteration 2 start
+iteration 2 parent
+iteration 2 child
+iteration 2 start
+iteration 2 parent
+iteration 2 child
+iteration 3 start
+iteration 3 parent
+iteration 3 child
+iteration 3 start
+iteration 3 parent
+iteration 3 child
+iteration 3 start
+iteration 3 parent
+iteration 3 child
+iteration 3 start
+iteration 3 parent
+iteration 3 child
+########
+$| = 1;
+fork()
+ ? (print("parent\n"),sleep(1))
+ : (print("child\n"),exit) ;
+EXPECT
+parent
+child
+########
+$| = 1;
+fork()
+ ? (print("parent\n"),exit)
+ : (print("child\n"),sleep(1)) ;
+EXPECT
+parent
+child
+########
+$| = 1;
+@a = (1..3);
+for (@a) {
+ if (fork) {
+ print "parent $_\n";
+ $_ = "[$_]";
+ }
+ else {
+ print "child $_\n";
+ $_ = "-$_-";
+ }
+}
+print "@a\n";
+EXPECT
+parent 1
+child 1
+parent 2
+child 2
+parent 2
+child 2
+parent 3
+child 3
+parent 3
+child 3
+parent 3
+child 3
+parent 3
+child 3
+[1] [2] [3]
+-1- [2] [3]
+[1] -2- [3]
+[1] [2] -3-
+-1- -2- [3]
+-1- [2] -3-
+[1] -2- -3-
+-1- -2- -3-
+########
+use Config;
+$| = 1;
+$\ = "\n";
+fork()
+ ? print($Config{osname} eq $^O)
+ : print($Config{osname} eq $^O) ;
+EXPECT
+1
+1
+########
+$| = 1;
+$\ = "\n";
+fork()
+ ? do { require Config; print($Config::Config{osname} eq $^O); }
+ : do { require Config; print($Config::Config{osname} eq $^O); }
+EXPECT
+1
+1
+########
+$| = 1;
+use Cwd;
+$\ = "\n";
+my $dir;
+if (fork) {
+ $dir = "f$$.tst";
+ mkdir $dir, 0755;
+ chdir $dir;
+ print cwd() =~ /\Q$dir/i ? "ok 1 parent" : "not ok 1 parent";
+ chdir "..";
+ rmdir $dir;
+}
+else {
+ sleep 2;
+ $dir = "f$$.tst";
+ mkdir $dir, 0755;
+ chdir $dir;
+ print cwd() =~ /\Q$dir/i ? "ok 1 child" : "not ok 1 child";
+ chdir "..";
+ rmdir $dir;
+}
+EXPECT
+ok 1 parent
+ok 1 child
+########
+$| = 1;
+$\ = "\n";
+my $getenv;
+if ($^O eq 'MSWin32') {
+ $getenv = qq[$^X -e "print \$ENV{TST}"];
+}
+else {
+ $getenv = qq[$^X -e 'print \$ENV{TST}'];
+}
+if (fork) {
+ sleep 1;
+ $ENV{TST} = 'foo';
+ print "parent: " . `$getenv`;
+}
+else {
+ $ENV{TST} = 'bar';
+ print "child: " . `$getenv`;
+ sleep 1;
+}
+EXPECT
+parent: foo
+child: bar
+########
+$| = 1;
+$\ = "\n";
+if ($pid = fork) {
+ waitpid($pid,0);
+ print "parent got $?"
+}
+else {
+ exit(42);
+}
+EXPECT
+parent got 10752
+########
+$| = 1;
+$\ = "\n";
+my $echo = 'echo';
+if ($pid = fork) {
+ waitpid($pid,0);
+ print "parent got $?"
+}
+else {
+ exec("$echo foo");
+}
+EXPECT
+foo
+parent got 0
+########
+if (fork) {
+ die "parent died";
+}
+else {
+ die "child died";
+}
+EXPECT
+parent died at - line 2.
+child died at - line 5.
+########
+if ($pid = fork) {
+ eval { die "parent died" };
+ print $@;
+}
+else {
+ eval { die "child died" };
+ print $@;
+}
+EXPECT
+parent died at - line 2.
+child died at - line 6.
+########
+if (eval q{$pid = fork}) {
+ eval q{ die "parent died" };
+ print $@;
+}
+else {
+ eval q{ die "child died" };
+ print $@;
+}
+EXPECT
+parent died at (eval 2) line 1.
+child died at (eval 2) line 1.
+########
+BEGIN {
+ $| = 1;
+ fork and exit;
+ print "inner\n";
+}
+# XXX In emulated fork(), the child will not execute anything after
+# the BEGIN block, due to difficulties in recreating the parse stacks
+# and restarting yyparse() midstream in the child. This can potentially
+# be overcome by treating what's after the BEGIN{} as a brand new parse.
+#print "outer\n"
+EXPECT
+inner
diff --git a/toke.c b/toke.c
index 4053c81..b4377d1 100644
--- a/toke.c
+++ b/toke.c
@@ -364,7 +364,7 @@ Perl_lex_start(pTHX_ SV *line)
SAVEI32(PL_lex_casemods);
SAVEI32(PL_lex_starts);
SAVEI32(PL_lex_state);
- SAVESPTR(PL_lex_inpat);
+ SAVEVPTR(PL_lex_inpat);
SAVEI32(PL_lex_inwhat);
SAVECOPLINE(PL_curcop);
SAVEPPTR(PL_bufptr);
@@ -967,7 +967,7 @@ S_sublex_push(pTHX)
SAVEI32(PL_lex_casemods);
SAVEI32(PL_lex_starts);
SAVEI32(PL_lex_state);
- SAVESPTR(PL_lex_inpat);
+ SAVEVPTR(PL_lex_inpat);
SAVEI32(PL_lex_inwhat);
SAVECOPLINE(PL_curcop);
SAVEPPTR(PL_bufptr);
@@ -6886,10 +6886,10 @@ Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
if (PL_compcv) {
assert(SvTYPE(PL_compcv) == SVt_PVCV);
}
- save_I32(&PL_subline);
+ SAVEI32(PL_subline);
save_item(PL_subname);
SAVEI32(PL_padix);
- SAVESPTR(PL_curpad);
+ SAVEVPTR(PL_curpad);
SAVESPTR(PL_comppad);
SAVESPTR(PL_comppad_name);
SAVESPTR(PL_compcv);
diff --git a/unixish.h b/unixish.h
index 2d37fbe..f4fe177 100644
--- a/unixish.h
+++ b/unixish.h
@@ -99,7 +99,7 @@
#ifndef SIGILL
# define SIGILL 6 /* blech */
#endif
-#define ABORT() kill(getpid(),SIGABRT);
+#define ABORT() kill(PerlProc_getpid(),SIGABRT);
/*
* fwrite1() should be a routine with the same calling sequence as fwrite(),
diff --git a/util.c b/util.c
index e131a5b..5eb6471 100644
--- a/util.c
+++ b/util.c
@@ -2302,7 +2302,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode)
#endif /* defined OS2 */
/*SUPPRESS 560*/
if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
- sv_setiv(GvSV(tmpgv), getpid());
+ sv_setiv(GvSV(tmpgv), PerlProc_getpid());
PL_forkprocess = 0;
hv_clear(PL_pidstatus); /* we have no children */
return Nullfp;
@@ -2497,7 +2497,7 @@ Perl_rsignal_state(pTHX_ int signo)
oldsig = PerlProc_signal(signo, sig_trap);
PerlProc_signal(signo, oldsig);
if (sig_trapped)
- PerlProc_kill(getpid(), signo);
+ PerlProc_kill(PerlProc_getpid(), signo);
return oldsig;
}
diff --git a/vos/vosish.h b/vos/vosish.h
index fc53dc1..1648702 100644
--- a/vos/vosish.h
+++ b/vos/vosish.h
@@ -99,7 +99,7 @@
#ifndef SIGILL
# define SIGILL 6 /* blech */
#endif
-#define ABORT() kill(getpid(),SIGABRT);
+#define ABORT() kill(PerlProc_getpid(),SIGABRT);
/*
* fwrite1() should be a routine with the same calling sequence as fwrite(),
diff --git a/win32/Makefile b/win32/Makefile
index c4bb568..fe38d99 100644
--- a/win32/Makefile
+++ b/win32/Makefile
@@ -65,6 +65,21 @@ INST_ARCH = \$(ARCHNAME)
#USE_OBJECT = define
#
+# XXX WARNING! This option currently undergoing changes. May be broken.
+#
+# Beginnings of interpreter cloning/threads: still rather rough, fails
+# tests. This should be enabled to get the fork() emulation. Do not
+# enable unless you know what you're doing!
+#
+USE_ITHREADS = define
+
+#
+# uncomment to enable the implicit "host" layer for all system calls
+# made by perl. This is needed and auto-enabled by USE_OBJECT above.
+#
+USE_IMP_SYS = define
+
+#
# uncomment one of the following lines if you are using either
# Visual C++ 2.x or Visual C++ 6.x (aka Visual Studio 98)
#
@@ -84,6 +99,7 @@ INST_ARCH = \$(ARCHNAME)
# and follow the directions in the package to install.
#
#USE_PERLCRT = define
+#BUILD_FOR_WIN95 = define
#
# uncomment to enable linking with setargv.obj under the Visual C
@@ -145,10 +161,8 @@ CCLIBDIR = $(CCHOME)\lib
#
#BUILDOPT = $(BUILDOPT) -DPERL_INTERNAL_GLOB
-# Beginnings of interpreter cloning/threads: still rather rough, fails
-# many tests. Do not enable unless you know what you're doing!
-#
-#BUILDOPT = $(BUILDOPT) -DUSE_ITHREADS
+# Enabling this runs a cloned toplevel interpreter (fails tests)
+#BUILDOPT = $(BUILDOPT) -DTOP_CLONE
# specify semicolon-separated list of extra directories that modules will
# look for libraries (spaces in path names need not be quoted)
@@ -178,6 +192,7 @@ CRYPT_FLAG = -DHAVE_DES_FCRYPT
PERL_MALLOC = undef
USE_THREADS = undef
USE_MULTI = undef
+USE_IMP_SYS = define
!ENDIF
!IF "$(PERL_MALLOC)" == ""
@@ -188,6 +203,10 @@ PERL_MALLOC = undef
USE_THREADS = undef
!ENDIF
+!IF "$(USE_THREADS)" == "define"
+USE_ITHREADS = undef
+!ENDIF
+
!IF "$(USE_MULTI)" == ""
USE_MULTI = undef
!ENDIF
@@ -196,10 +215,26 @@ USE_MULTI = undef
USE_OBJECT = undef
!ENDIF
+!IF "$(USE_ITHREADS)" == ""
+USE_ITHREADS = undef
+!ENDIF
+
+!IF "$(USE_IMP_SYS)" == ""
+USE_IMP_SYS = undef
+!ENDIF
+
!IF "$(USE_MULTI)$(USE_THREADS)$(USE_OBJECT)" != "undefundefundef"
BUILDOPT = $(BUILDOPT) -DPERL_IMPLICIT_CONTEXT
!ENDIF
+!IF "$(USE_ITHREADS)" != "undef"
+BUILDOPT = $(BUILDOPT) -DUSE_ITHREADS
+!ENDIF
+
+!IF "$(USE_IMP_SYS)" != "undef"
+BUILDOPT = $(BUILDOPT) -DPERL_IMPLICIT_SYS
+!ENDIF
+
!IF "$(PROCESSOR_ARCHITECTURE)" == ""
PROCESSOR_ARCHITECTURE = x86
!ENDIF
@@ -365,6 +400,7 @@ PERLDLL = ..\perl.dll
MINIPERL = ..\miniperl.exe
MINIDIR = .\mini
PERLEXE = ..\perl.exe
+WPERLEXE = ..\wperl.exe
GLOBEXE = ..\perlglob.exe
CONFIGPM = ..\lib\Config.pm
MINIMOD = ..\lib\ExtUtils\Miniperl.pm
@@ -404,7 +440,7 @@ MAKE = nmake -nologo
CFGSH_TMPL = config.vc
CFGH_TMPL = config_H.vc
-!IF "$(USE_PERLCRT)" == ""
+!IF "$(BUILD_FOR_WIN95)" == "define"
PERL95EXE = ..\perl95.exe
!ENDIF
@@ -527,7 +563,10 @@ CORE_NOCFG_H = \
.\include\dirent.h \
.\include\netdb.h \
.\include\sys\socket.h \
- .\win32.h
+ .\win32.h \
+ .\perlhost.h \
+ .\vdir.h \
+ .\vmem.h
CORE_H = $(CORE_NOCFG_H) .\config.h
@@ -727,6 +766,12 @@ $(MINICORE_OBJ) : $(CORE_NOCFG_H)
$(MINIWIN32_OBJ) : $(CORE_NOCFG_H)
$(CC) -c $(CFLAGS) $(OBJOUT_FLAG)$@ $(*F).c
+# -DPERL_IMPLICIT_SYS needs C++ for perllib.c
+!IF "$(USE_IMP_SYS)$(USE_OBJECT)" == "defineundef"
+perllib$(o) : perllib.c
+ $(CC) -c -I. $(CFLAGS_O) $(CXX_FLAG) $(OBJOUT_FLAG)$@ perllib.c
+!ENDIF
+
# 1. we don't want to rebuild miniperl.exe when config.h changes
# 2. we don't want to rebuild miniperl.exe with non-default config.h
$(MINI_OBJ) : $(CORE_NOCFG_H)
@@ -781,10 +826,12 @@ perlmain$(o) : perlmain.c
$(PERLEXE): $(PERLDLL) $(CONFIGPM) $(PERLEXE_OBJ)
$(LINK32) -subsystem:console -out:$@ $(LINK_FLAGS) $(LIBFILES) \
$(PERLEXE_OBJ) $(SETARGV_OBJ) $(PERLIMPLIB)
+ copy $(PERLEXE) $(WPERLEXE)
+ editbin /subsystem:windows $(WPERLEXE)
copy splittree.pl ..
$(MINIPERL) -I..\lib ..\splittree.pl "../LIB" $(AUTODIR)
-!IF "$(USE_PERLCRT)" == ""
+!IF "$(BUILD_FOR_WIN95)" == "define"
perl95.c : runperl.c
copy runperl.c perl95.c
@@ -977,9 +1024,10 @@ install : all installbare installhtml
installbare : utils
$(PERLEXE) ..\installperl
-!IF "$(USE_PERLCRT)" == ""
+!IF "$(BUILD_FOR_WIN95)" == "define"
$(XCOPY) $(PERL95EXE) $(INST_BIN)\*.*
!ENDIF
+ if exist $(WPERLEXE) $(XCOPY) $(WPERLEXE) $(INST_BIN)\*.*
$(XCOPY) $(GLOBEXE) $(INST_BIN)\*.*
$(XCOPY) bin\*.bat $(INST_SCRIPT)\*.*
@@ -1025,6 +1073,7 @@ clean :
-@erase /f config.h
-@erase $(GLOBEXE)
-@erase $(PERLEXE)
+ -@erase $(WPERLEXE)
-@erase $(PERLDLL)
-@erase $(CORE_OBJ)
-rmdir /s /q $(MINIDIR) || rmdir /s $(MINIDIR)
diff --git a/win32/makefile.mk b/win32/makefile.mk
index 2550611..b5e1d19 100644
--- a/win32/makefile.mk
+++ b/win32/makefile.mk
@@ -70,6 +70,21 @@ INST_ARCH *= \$(ARCHNAME)
#USE_OBJECT *= define
#
+# XXX WARNING! This option currently undergoing changes. May be broken.
+#
+# Beginnings of interpreter cloning/threads: still rather rough, fails
+# tests. This should be enabled to get the fork() emulation. Do not
+# enable unless you know what you're doing!
+#
+USE_ITHREADS *= define
+
+#
+# uncomment to enable the implicit "host" layer for all system calls
+# made by perl. This is needed and auto-enabled by USE_OBJECT above.
+#
+USE_IMP_SYS *= define
+
+#
# uncomment exactly one of the following
#
# Visual C++ 2.x
@@ -165,6 +180,9 @@ CCLIBDIR *= $(CCHOME)\lib
#
#BUILDOPT += -DPERL_INTERNAL_GLOB
+# Enabling this runs a cloned toplevel interpreter (fails tests)
+#BUILDOPT += -DTOP_CLONE
+
#
# specify semicolon-separated list of extra directories that modules will
# look for libraries (spaces in path names need not be quoted)
@@ -200,18 +218,33 @@ CRYPT_FLAG = -DHAVE_DES_FCRYPT
PERL_MALLOC != undef
USE_THREADS != undef
USE_MULTI != undef
+USE_IMP_SYS != define
.ENDIF
PERL_MALLOC *= undef
USE_THREADS *= undef
+
+.IF "$(USE_THREADS)" == "define"
+USE_ITHREADS != undef
+.ENDIF
+
USE_MULTI *= undef
USE_OBJECT *= undef
+USE_ITHREADS *= undef
+USE_IMP_SYS *= undef
.IF "$(USE_MULTI)$(USE_THREADS)$(USE_OBJECT)" != "undefundefundef"
BUILDOPT += -DPERL_IMPLICIT_CONTEXT
.ENDIF
+.IF "$(USE_ITHREADS)" != "undef"
+BUILDOPT += -DUSE_ITHREADS
+.ENDIF
+
+.IF "$(USE_IMP_SYS)" != "undef"
+BUILDOPT += -DPERL_IMPLICIT_SYS
+.ENDIF
.IMPORT .IGNORE : PROCESSOR_ARCHITECTURE
@@ -459,6 +492,7 @@ $(o).dll:
MINIPERL = ..\miniperl.exe
MINIDIR = .\mini
PERLEXE = ..\perl.exe
+WPERLEXE = ..\wperl.exe
GLOBEXE = ..\perlglob.exe
CONFIGPM = ..\lib\Config.pm
MINIMOD = ..\lib\ExtUtils\Miniperl.pm
@@ -644,7 +678,10 @@ CORE_NOCFG_H = \
.\include\dirent.h \
.\include\netdb.h \
.\include\sys\socket.h \
- .\win32.h
+ .\win32.h \
+ .\perlhost.h \
+ .\vdir.h \
+ .\vmem.h
CORE_H = $(CORE_NOCFG_H) .\config.h
@@ -870,6 +907,12 @@ $(MINICORE_OBJ) : $(CORE_NOCFG_H)
$(MINIWIN32_OBJ) : $(CORE_NOCFG_H)
$(CC) -c $(CFLAGS) $(OBJOUT_FLAG)$@ $(*B).c
+# -DPERL_IMPLICIT_SYS needs C++ for perllib.c
+.IF "$(USE_IMP_SYS)$(USE_OBJECT)" == "defineundef"
+perllib$(o) : perllib.c
+ $(CC) -c -I. $(CFLAGS_O) $(CXX_FLAG) $(OBJOUT_FLAG)$@ perllib.c
+.ENDIF
+
# 1. we don't want to rebuild miniperl.exe when config.h changes
# 2. we don't want to rebuild miniperl.exe with non-default config.h
$(MINI_OBJ) : $(CORE_NOCFG_H)
@@ -959,6 +1002,8 @@ $(PERLEXE): $(PERLDLL) $(CONFIGPM) $(PERLEXE_OBJ)
.ELSE
$(LINK32) -subsystem:console -out:$@ $(LINK_FLAGS) $(LIBFILES) \
$(PERLEXE_OBJ) $(SETARGV_OBJ) $(PERLIMPLIB)
+ copy $(PERLEXE) $(WPERLEXE)
+ editbin /subsystem:windows $(WPERLEXE)
.ENDIF
copy splittree.pl ..
$(MINIPERL) -I..\lib ..\splittree.pl "../LIB" $(AUTODIR)
@@ -1137,6 +1182,7 @@ installbare : utils
.IF "$(PERL95EXE)" != ""
$(XCOPY) $(PERL95EXE) $(INST_BIN)\*.*
.ENDIF
+ if exist $(WPERLEXE) $(XCOPY) $(WPERLEXE) $(INST_BIN)\*.*
$(XCOPY) $(GLOBEXE) $(INST_BIN)\*.*
$(XCOPY) bin\*.bat $(INST_SCRIPT)\*.*
@@ -1185,6 +1231,7 @@ clean :
-@erase /f config.h
-@erase $(GLOBEXE)
-@erase $(PERLEXE)
+ -@erase $(WPERLEXE)
-@erase $(PERLDLL)
-@erase $(CORE_OBJ)
-rmdir /s /q $(MINIDIR) || rmdir /s $(MINIDIR)
diff --git a/win32/perlhost.h b/win32/perlhost.h
new file mode 100644
index 0000000..236a97c
--- /dev/null
+++ b/win32/perlhost.h
@@ -0,0 +1,2283 @@
+/* perlhost.h
+ *
+ * (c) 1999 Microsoft Corporation. All rights reserved.
+ * Portions (c) 1999 ActiveState Tool Corp, http://www.ActiveState.com/
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ */
+
+#ifndef ___PerlHost_H___
+#define ___PerlHost_H___
+
+#include "iperlsys.h"
+#include "vmem.h"
+#include "vdir.h"
+
+#if !defined(PERL_OBJECT)
+START_EXTERN_C
+#endif
+extern char * g_win32_get_privlib(char *pl);
+extern char * g_win32_get_sitelib(char *pl);
+extern char * g_getlogin(void);
+extern int do_spawn2(char *cmd, int exectype);
+#if !defined(PERL_OBJECT)
+END_EXTERN_C
+#endif
+
+#ifdef PERL_OBJECT
+extern int g_do_aspawn(void *vreally, void **vmark, void **vsp);
+#define do_aspawn g_do_aspawn
+#endif
+
+class CPerlHost
+{
+public:
+ CPerlHost(void);
+ CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared,
+ struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv,
+ struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO,
+ struct IPerlDir** ppDir, struct IPerlSock** ppSock,
+ struct IPerlProc** ppProc);
+ CPerlHost(CPerlHost& host);
+ ~CPerlHost(void);
+
+ static CPerlHost* IPerlMem2Host(struct IPerlMem* piPerl);
+ static CPerlHost* IPerlMemShared2Host(struct IPerlMem* piPerl);
+ static CPerlHost* IPerlMemParse2Host(struct IPerlMem* piPerl);
+ static CPerlHost* IPerlEnv2Host(struct IPerlEnv* piPerl);
+ static CPerlHost* IPerlStdIO2Host(struct IPerlStdIO* piPerl);
+ static CPerlHost* IPerlLIO2Host(struct IPerlLIO* piPerl);
+ static CPerlHost* IPerlDir2Host(struct IPerlDir* piPerl);
+ static CPerlHost* IPerlSock2Host(struct IPerlSock* piPerl);
+ static CPerlHost* IPerlProc2Host(struct IPerlProc* piPerl);
+
+ BOOL PerlCreate(void);
+ int PerlParse(int argc, char** argv, char** env);
+ int PerlRun(void);
+ void PerlDestroy(void);
+
+/* IPerlMem */
+ inline void* Malloc(size_t size) { return m_pVMem->Malloc(size); };
+ inline void* Realloc(void* ptr, size_t size) { return m_pVMem->Realloc(ptr, size); };
+ inline void Free(void* ptr) { m_pVMem->Free(ptr); };
+ inline void* Calloc(size_t num, size_t size)
+ {
+ size_t count = num*size;
+ void* lpVoid = Malloc(count);
+ if (lpVoid)
+ ZeroMemory(lpVoid, count);
+ return lpVoid;
+ };
+ inline void GetLock(void) { m_pVMem->GetLock(); };
+ inline void FreeLock(void) { m_pVMem->FreeLock(); };
+ inline int IsLocked(void) { return m_pVMem->IsLocked(); };
+
+/* IPerlMemShared */
+ inline void* MallocShared(size_t size)
+ {
+ return m_pVMemShared->Malloc(size);
+ };
+ inline void* ReallocShared(void* ptr, size_t size) { return m_pVMemShared->Realloc(ptr, size); };
+ inline void FreeShared(void* ptr) { m_pVMemShared->Free(ptr); };
+ inline void* CallocShared(size_t num, size_t size)
+ {
+ size_t count = num*size;
+ void* lpVoid = MallocShared(count);
+ if (lpVoid)
+ ZeroMemory(lpVoid, count);
+ return lpVoid;
+ };
+ inline void GetLockShared(void) { m_pVMem->GetLock(); };
+ inline void FreeLockShared(void) { m_pVMem->FreeLock(); };
+ inline int IsLockedShared(void) { return m_pVMem->IsLocked(); };
+
+/* IPerlMemParse */
+ inline void* MallocParse(size_t size) { return m_pVMemParse->Malloc(size); };
+ inline void* ReallocParse(void* ptr, size_t size) { return m_pVMemParse->Realloc(ptr, size); };
+ inline void FreeParse(void* ptr) { m_pVMemParse->Free(ptr); };
+ inline void* CallocParse(size_t num, size_t size)
+ {
+ size_t count = num*size;
+ void* lpVoid = MallocParse(count);
+ if (lpVoid)
+ ZeroMemory(lpVoid, count);
+ return lpVoid;
+ };
+ inline void GetLockParse(void) { m_pVMem->GetLock(); };
+ inline void FreeLockParse(void) { m_pVMem->FreeLock(); };
+ inline int IsLockedParse(void) { return m_pVMem->IsLocked(); };
+
+/* IPerlEnv */
+ char *Getenv(const char *varname);
+ int Putenv(const char *envstring);
+ inline char *Getenv(const char *varname, unsigned long *len)
+ {
+ *len = 0;
+ char *e = Getenv(varname);
+ if (e)
+ *len = strlen(e);
+ return e;
+ }
+ void* CreateChildEnv(void) { return CreateLocalEnvironmentStrings(*m_pvDir); };
+ void FreeChildEnv(void* pStr) { FreeLocalEnvironmentStrings((char*)pStr); };
+ char* GetChildDir(void);
+ void FreeChildDir(char* pStr);
+ void Reset(void);
+ void Clearenv(void);
+
+ inline LPSTR GetIndex(DWORD &dwIndex)
+ {
+ if(dwIndex < m_dwEnvCount)
+ {
+ ++dwIndex;
+ return m_lppEnvList[dwIndex-1];
+ }
+ return NULL;
+ };
+
+protected:
+ LPSTR Find(LPCSTR lpStr);
+ void Add(LPCSTR lpStr);
+
+ LPSTR CreateLocalEnvironmentStrings(VDir &vDir);
+ void FreeLocalEnvironmentStrings(LPSTR lpStr);
+ LPSTR* Lookup(LPCSTR lpStr);
+ DWORD CalculateEnvironmentSpace(void);
+
+public:
+
+/* IPerlDIR */
+ virtual int Chdir(const char *dirname);
+
+/* IPerllProc */
+ void Abort(void);
+ void Exit(int status);
+ void _Exit(int status);
+ int Execl(const char *cmdname, const char *arg0, const char *arg1, const char *arg2, const char *arg3);
+ int Execv(const char *cmdname, const char *const *argv);
+ int Execvp(const char *cmdname, const char *const *argv);
+
+ inline VMem* GetMemShared(void) { m_pVMemShared->AddRef(); return m_pVMemShared; };
+ inline VMem* GetMemParse(void) { m_pVMemParse->AddRef(); return m_pVMemParse; };
+ inline VDir* GetDir(void) { return m_pvDir; };
+
+public:
+
+ struct IPerlMem m_hostperlMem;
+ struct IPerlMem m_hostperlMemShared;
+ struct IPerlMem m_hostperlMemParse;
+ struct IPerlEnv m_hostperlEnv;
+ struct IPerlStdIO m_hostperlStdIO;
+ struct IPerlLIO m_hostperlLIO;
+ struct IPerlDir m_hostperlDir;
+ struct IPerlSock m_hostperlSock;
+ struct IPerlProc m_hostperlProc;
+
+ struct IPerlMem* m_pHostperlMem;
+ struct IPerlMem* m_pHostperlMemShared;
+ struct IPerlMem* m_pHostperlMemParse;
+ struct IPerlEnv* m_pHostperlEnv;
+ struct IPerlStdIO* m_pHostperlStdIO;
+ struct IPerlLIO* m_pHostperlLIO;
+ struct IPerlDir* m_pHostperlDir;
+ struct IPerlSock* m_pHostperlSock;
+ struct IPerlProc* m_pHostperlProc;
+
+ inline char* MapPathA(const char *pInName) { return m_pvDir->MapPathA(pInName); };
+ inline WCHAR* MapPathW(const WCHAR *pInName) { return m_pvDir->MapPathW(pInName); };
+protected:
+
+ VDir* m_pvDir;
+ VMem* m_pVMem;
+ VMem* m_pVMemShared;
+ VMem* m_pVMemParse;
+
+ DWORD m_dwEnvCount;
+ LPSTR* m_lppEnvList;
+};
+
+
+#define STRUCT2PTR(x, y) (CPerlHost*)(((LPBYTE)x)-offsetof(CPerlHost, y))
+
+inline CPerlHost* IPerlMem2Host(struct IPerlMem* piPerl)
+{
+ return STRUCT2PTR(piPerl, m_hostperlMem);
+}
+
+inline CPerlHost* IPerlMemShared2Host(struct IPerlMem* piPerl)
+{
+ return STRUCT2PTR(piPerl, m_hostperlMemShared);
+}
+
+inline CPerlHost* IPerlMemParse2Host(struct IPerlMem* piPerl)
+{
+ return STRUCT2PTR(piPerl, m_hostperlMemParse);
+}
+
+inline CPerlHost* IPerlEnv2Host(struct IPerlEnv* piPerl)
+{
+ return STRUCT2PTR(piPerl, m_hostperlEnv);
+}
+
+inline CPerlHost* IPerlStdIO2Host(struct IPerlStdIO* piPerl)
+{
+ return STRUCT2PTR(piPerl, m_hostperlStdIO);
+}
+
+inline CPerlHost* IPerlLIO2Host(struct IPerlLIO* piPerl)
+{
+ return STRUCT2PTR(piPerl, m_hostperlLIO);
+}
+
+inline CPerlHost* IPerlDir2Host(struct IPerlDir* piPerl)
+{
+ return STRUCT2PTR(piPerl, m_hostperlDir);
+}
+
+inline CPerlHost* IPerlSock2Host(struct IPerlSock* piPerl)
+{
+ return STRUCT2PTR(piPerl, m_hostperlSock);
+}
+
+inline CPerlHost* IPerlProc2Host(struct IPerlProc* piPerl)
+{
+ return STRUCT2PTR(piPerl, m_hostperlProc);
+}
+
+
+
+#undef IPERL2HOST
+#define IPERL2HOST(x) IPerlMem2Host(x)
+
+/* IPerlMem */
+void*
+PerlMemMalloc(struct IPerlMem* piPerl, size_t size)
+{
+ return IPERL2HOST(piPerl)->Malloc(size);
+}
+void*
+PerlMemRealloc(struct IPerlMem* piPerl, void* ptr, size_t size)
+{
+ return IPERL2HOST(piPerl)->Realloc(ptr, size);
+}
+void
+PerlMemFree(struct IPerlMem* piPerl, void* ptr)
+{
+ IPERL2HOST(piPerl)->Free(ptr);
+}
+void*
+PerlMemCalloc(struct IPerlMem* piPerl, size_t num, size_t size)
+{
+ return IPERL2HOST(piPerl)->Calloc(num, size);
+}
+
+void
+PerlMemGetLock(struct IPerlMem* piPerl)
+{
+ IPERL2HOST(piPerl)->GetLock();
+}
+
+void
+PerlMemFreeLock(struct IPerlMem* piPerl)
+{
+ IPERL2HOST(piPerl)->FreeLock();
+}
+
+int
+PerlMemIsLocked(struct IPerlMem* piPerl)
+{
+ return IPERL2HOST(piPerl)->IsLocked();
+}
+
+struct IPerlMem perlMem =
+{
+ PerlMemMalloc,
+ PerlMemRealloc,
+ PerlMemFree,
+ PerlMemCalloc,
+ PerlMemGetLock,
+ PerlMemFreeLock,
+ PerlMemIsLocked,
+};
+
+#undef IPERL2HOST
+#define IPERL2HOST(x) IPerlMemShared2Host(x)
+
+/* IPerlMemShared */
+void*
+PerlMemSharedMalloc(struct IPerlMem* piPerl, size_t size)
+{
+ return IPERL2HOST(piPerl)->MallocShared(size);
+}
+void*
+PerlMemSharedRealloc(struct IPerlMem* piPerl, void* ptr, size_t size)
+{
+ return IPERL2HOST(piPerl)->ReallocShared(ptr, size);
+}
+void
+PerlMemSharedFree(struct IPerlMem* piPerl, void* ptr)
+{
+ IPERL2HOST(piPerl)->FreeShared(ptr);
+}
+void*
+PerlMemSharedCalloc(struct IPerlMem* piPerl, size_t num, size_t size)
+{
+ return IPERL2HOST(piPerl)->CallocShared(num, size);
+}
+
+void
+PerlMemSharedGetLock(struct IPerlMem* piPerl)
+{
+ IPERL2HOST(piPerl)->GetLockShared();
+}
+
+void
+PerlMemSharedFreeLock(struct IPerlMem* piPerl)
+{
+ IPERL2HOST(piPerl)->FreeLockShared();
+}
+
+int
+PerlMemSharedIsLocked(struct IPerlMem* piPerl)
+{
+ return IPERL2HOST(piPerl)->IsLockedShared();
+}
+
+struct IPerlMem perlMemShared =
+{
+ PerlMemSharedMalloc,
+ PerlMemSharedRealloc,
+ PerlMemSharedFree,
+ PerlMemSharedCalloc,
+ PerlMemSharedGetLock,
+ PerlMemSharedFreeLock,
+ PerlMemSharedIsLocked,
+};
+
+#undef IPERL2HOST
+#define IPERL2HOST(x) IPerlMemParse2Host(x)
+
+/* IPerlMemParse */
+void*
+PerlMemParseMalloc(struct IPerlMem* piPerl, size_t size)
+{
+ return IPERL2HOST(piPerl)->MallocParse(size);
+}
+void*
+PerlMemParseRealloc(struct IPerlMem* piPerl, void* ptr, size_t size)
+{
+ return IPERL2HOST(piPerl)->ReallocParse(ptr, size);
+}
+void
+PerlMemParseFree(struct IPerlMem* piPerl, void* ptr)
+{
+ IPERL2HOST(piPerl)->FreeParse(ptr);
+}
+void*
+PerlMemParseCalloc(struct IPerlMem* piPerl, size_t num, size_t size)
+{
+ return IPERL2HOST(piPerl)->CallocParse(num, size);
+}
+
+void
+PerlMemParseGetLock(struct IPerlMem* piPerl)
+{
+ IPERL2HOST(piPerl)->GetLockParse();
+}
+
+void
+PerlMemParseFreeLock(struct IPerlMem* piPerl)
+{
+ IPERL2HOST(piPerl)->FreeLockParse();
+}
+
+int
+PerlMemParseIsLocked(struct IPerlMem* piPerl)
+{
+ return IPERL2HOST(piPerl)->IsLockedParse();
+}
+
+struct IPerlMem perlMemParse =
+{
+ PerlMemParseMalloc,
+ PerlMemParseRealloc,
+ PerlMemParseFree,
+ PerlMemParseCalloc,
+ PerlMemParseGetLock,
+ PerlMemParseFreeLock,
+ PerlMemParseIsLocked,
+};
+
+
+#undef IPERL2HOST
+#define IPERL2HOST(x) IPerlEnv2Host(x)
+
+/* IPerlEnv */
+char*
+PerlEnvGetenv(struct IPerlEnv* piPerl, const char *varname)
+{
+ return IPERL2HOST(piPerl)->Getenv(varname);
+};
+
+int
+PerlEnvPutenv(struct IPerlEnv* piPerl, const char *envstring)
+{
+ return IPERL2HOST(piPerl)->Putenv(envstring);
+};
+
+char*
+PerlEnvGetenv_len(struct IPerlEnv* piPerl, const char* varname, unsigned long* len)
+{
+ return IPERL2HOST(piPerl)->Getenv(varname, len);
+}
+
+int
+PerlEnvUname(struct IPerlEnv* piPerl, struct utsname *name)
+{
+ return win32_uname(name);
+}
+
+void
+PerlEnvClearenv(struct IPerlEnv* piPerl)
+{
+ IPERL2HOST(piPerl)->Clearenv();
+}
+
+void*
+PerlEnvGetChildenv(struct IPerlEnv* piPerl)
+{
+ return IPERL2HOST(piPerl)->CreateChildEnv();
+}
+
+void
+PerlEnvFreeChildenv(struct IPerlEnv* piPerl, void* childEnv)
+{
+ IPERL2HOST(piPerl)->FreeChildEnv(childEnv);
+}
+
+char*
+PerlEnvGetChilddir(struct IPerlEnv* piPerl)
+{
+ return IPERL2HOST(piPerl)->GetChildDir();
+}
+
+void
+PerlEnvFreeChilddir(struct IPerlEnv* piPerl, char* childDir)
+{
+ IPERL2HOST(piPerl)->FreeChildDir(childDir);
+}
+
+unsigned long
+PerlEnvOsId(struct IPerlEnv* piPerl)
+{
+ return win32_os_id();
+}
+
+char*
+PerlEnvLibPath(struct IPerlEnv* piPerl, char *pl)
+{
+ return g_win32_get_privlib(pl);
+}
+
+char*
+PerlEnvSiteLibPath(struct IPerlEnv* piPerl, char *pl)
+{
+ return g_win32_get_sitelib(pl);
+}
+
+struct IPerlEnv perlEnv =
+{
+ PerlEnvGetenv,
+ PerlEnvPutenv,
+ PerlEnvGetenv_len,
+ PerlEnvUname,
+ PerlEnvClearenv,
+ PerlEnvGetChildenv,
+ PerlEnvFreeChildenv,
+ PerlEnvGetChilddir,
+ PerlEnvFreeChilddir,
+ PerlEnvOsId,
+ PerlEnvLibPath,
+ PerlEnvSiteLibPath,
+};
+
+#undef IPERL2HOST
+#define IPERL2HOST(x) IPerlStdIO2Host(x)
+
+/* PerlStdIO */
+PerlIO*
+PerlStdIOStdin(struct IPerlStdIO* piPerl)
+{
+ return (PerlIO*)win32_stdin();
+}
+
+PerlIO*
+PerlStdIOStdout(struct IPerlStdIO* piPerl)
+{
+ return (PerlIO*)win32_stdout();
+}
+
+PerlIO*
+PerlStdIOStderr(struct IPerlStdIO* piPerl)
+{
+ return (PerlIO*)win32_stderr();
+}
+
+PerlIO*
+PerlStdIOOpen(struct IPerlStdIO* piPerl, const char *path, const char *mode)
+{
+ return (PerlIO*)win32_fopen(path, mode);
+}
+
+int
+PerlStdIOClose(struct IPerlStdIO* piPerl, PerlIO* pf)
+{
+ return win32_fclose(((FILE*)pf));
+}
+
+int
+PerlStdIOEof(struct IPerlStdIO* piPerl, PerlIO* pf)
+{
+ return win32_feof((FILE*)pf);
+}
+
+int
+PerlStdIOError(struct IPerlStdIO* piPerl, PerlIO* pf)
+{
+ return win32_ferror((FILE*)pf);
+}
+
+void
+PerlStdIOClearerr(struct IPerlStdIO* piPerl, PerlIO* pf)
+{
+ win32_clearerr((FILE*)pf);
+}
+
+int
+PerlStdIOGetc(struct IPerlStdIO* piPerl, PerlIO* pf)
+{
+ return win32_getc((FILE*)pf);
+}
+
+char*
+PerlStdIOGetBase(struct IPerlStdIO* piPerl, PerlIO* pf)
+{
+#ifdef FILE_base
+ FILE *f = (FILE*)pf;
+ return FILE_base(f);
+#else
+ return Nullch;
+#endif
+}
+
+int
+PerlStdIOGetBufsiz(struct IPerlStdIO* piPerl, PerlIO* pf)
+{
+#ifdef FILE_bufsiz
+ FILE *f = (FILE*)pf;
+ return FILE_bufsiz(f);
+#else
+ return (-1);
+#endif
+}
+
+int
+PerlStdIOGetCnt(struct IPerlStdIO* piPerl, PerlIO* pf)
+{
+#ifdef USE_STDIO_PTR
+ FILE *f = (FILE*)pf;
+ return FILE_cnt(f);
+#else
+ return (-1);
+#endif
+}
+
+char*
+PerlStdIOGetPtr(struct IPerlStdIO* piPerl, PerlIO* pf)
+{
+#ifdef USE_STDIO_PTR
+ FILE *f = (FILE*)pf;
+ return FILE_ptr(f);
+#else
+ return Nullch;
+#endif
+}
+
+char*
+PerlStdIOGets(struct IPerlStdIO* piPerl, PerlIO* pf, char* s, int n)
+{
+ return win32_fgets(s, n, (FILE*)pf);
+}
+
+int
+PerlStdIOPutc(struct IPerlStdIO* piPerl, PerlIO* pf, int c)
+{
+ return win32_fputc(c, (FILE*)pf);
+}
+
+int
+PerlStdIOPuts(struct IPerlStdIO* piPerl, PerlIO* pf, const char *s)
+{
+ return win32_fputs(s, (FILE*)pf);
+}
+
+int
+PerlStdIOFlush(struct IPerlStdIO* piPerl, PerlIO* pf)
+{
+ return win32_fflush((FILE*)pf);
+}
+
+int
+PerlStdIOUngetc(struct IPerlStdIO* piPerl, PerlIO* pf,int c)
+{
+ return win32_ungetc(c, (FILE*)pf);
+}
+
+int
+PerlStdIOFileno(struct IPerlStdIO* piPerl, PerlIO* pf)
+{
+ return win32_fileno((FILE*)pf);
+}
+
+PerlIO*
+PerlStdIOFdopen(struct IPerlStdIO* piPerl, int fd, const char *mode)
+{
+ return (PerlIO*)win32_fdopen(fd, mode);
+}
+
+PerlIO*
+PerlStdIOReopen(struct IPerlStdIO* piPerl, const char*path, const char*mode, PerlIO* pf)
+{
+ return (PerlIO*)win32_freopen(path, mode, (FILE*)pf);
+}
+
+SSize_t
+PerlStdIORead(struct IPerlStdIO* piPerl, PerlIO* pf, void *buffer, Size_t size)
+{
+ return win32_fread(buffer, 1, size, (FILE*)pf);
+}
+
+SSize_t
+PerlStdIOWrite(struct IPerlStdIO* piPerl, PerlIO* pf, const void *buffer, Size_t size)
+{
+ return win32_fwrite(buffer, 1, size, (FILE*)pf);
+}
+
+void
+PerlStdIOSetBuf(struct IPerlStdIO* piPerl, PerlIO* pf, char* buffer)
+{
+ win32_setbuf((FILE*)pf, buffer);
+}
+
+int
+PerlStdIOSetVBuf(struct IPerlStdIO* piPerl, PerlIO* pf, char* buffer, int type, Size_t size)
+{
+ return win32_setvbuf((FILE*)pf, buffer, type, size);
+}
+
+void
+PerlStdIOSetCnt(struct IPerlStdIO* piPerl, PerlIO* pf, int n)
+{
+#ifdef STDIO_CNT_LVALUE
+ FILE *f = (FILE*)pf;
+ FILE_cnt(f) = n;
+#endif
+}
+
+void
+PerlStdIOSetPtrCnt(struct IPerlStdIO* piPerl, PerlIO* pf, char * ptr, int n)
+{
+#ifdef STDIO_PTR_LVALUE
+ FILE *f = (FILE*)pf;
+ FILE_ptr(f) = ptr;
+ FILE_cnt(f) = n;
+#endif
+}
+
+void
+PerlStdIOSetlinebuf(struct IPerlStdIO* piPerl, PerlIO* pf)
+{
+ win32_setvbuf((FILE*)pf, NULL, _IOLBF, 0);
+}
+
+int
+PerlStdIOPrintf(struct IPerlStdIO* piPerl, PerlIO* pf, const char *format,...)
+{
+ va_list(arglist);
+ va_start(arglist, format);
+ return win32_vfprintf((FILE*)pf, format, arglist);
+}
+
+int
+PerlStdIOVprintf(struct IPerlStdIO* piPerl, PerlIO* pf, const char *format, va_list arglist)
+{
+ return win32_vfprintf((FILE*)pf, format, arglist);
+}
+
+long
+PerlStdIOTell(struct IPerlStdIO* piPerl, PerlIO* pf)
+{
+ return win32_ftell((FILE*)pf);
+}
+
+int
+PerlStdIOSeek(struct IPerlStdIO* piPerl, PerlIO* pf, off_t offset, int origin)
+{
+ return win32_fseek((FILE*)pf, offset, origin);
+}
+
+void
+PerlStdIORewind(struct IPerlStdIO* piPerl, PerlIO* pf)
+{
+ win32_rewind((FILE*)pf);
+}
+
+PerlIO*
+PerlStdIOTmpfile(struct IPerlStdIO* piPerl)
+{
+ return (PerlIO*)win32_tmpfile();
+}
+
+int
+PerlStdIOGetpos(struct IPerlStdIO* piPerl, PerlIO* pf, Fpos_t *p)
+{
+ return win32_fgetpos((FILE*)pf, p);
+}
+
+int
+PerlStdIOSetpos(struct IPerlStdIO* piPerl, PerlIO* pf, const Fpos_t *p)
+{
+ return win32_fsetpos((FILE*)pf, p);
+}
+void
+PerlStdIOInit(struct IPerlStdIO* piPerl)
+{
+}
+
+void
+PerlStdIOInitOSExtras(struct IPerlStdIO* piPerl)
+{
+ Perl_init_os_extras();
+}
+
+int
+PerlStdIOOpenOSfhandle(struct IPerlStdIO* piPerl, long osfhandle, int flags)
+{
+ return win32_open_osfhandle(osfhandle, flags);
+}
+
+int
+PerlStdIOGetOSfhandle(struct IPerlStdIO* piPerl, int filenum)
+{
+ return win32_get_osfhandle(filenum);
+}
+
+PerlIO*
+PerlStdIOFdupopen(struct IPerlStdIO* piPerl, PerlIO* pf)
+{
+ PerlIO* pfdup;
+ fpos_t pos;
+ char mode[3];
+ int fileno = win32_dup(win32_fileno((FILE*)pf));
+
+ /* open the file in the same mode */
+ if(((FILE*)pf)->_flag & _IOREAD) {
+ mode[0] = 'r';
+ mode[1] = 0;
+ }
+ else if(((FILE*)pf)->_flag & _IOWRT) {
+ mode[0] = 'a';
+ mode[1] = 0;
+ }
+ else if(((FILE*)pf)->_flag & _IORW) {
+ mode[0] = 'r';
+ mode[1] = '+';
+ mode[2] = 0;
+ }
+
+ /* it appears that the binmode is attached to the
+ * file descriptor so binmode files will be handled
+ * correctly
+ */
+ pfdup = (PerlIO*)win32_fdopen(fileno, mode);
+
+ /* move the file pointer to the same position */
+ if (!fgetpos((FILE*)pf, &pos)) {
+ fsetpos((FILE*)pfdup, &pos);
+ }
+ return pfdup;
+}
+
+struct IPerlStdIO perlStdIO =
+{
+ PerlStdIOStdin,
+ PerlStdIOStdout,
+ PerlStdIOStderr,
+ PerlStdIOOpen,
+ PerlStdIOClose,
+ PerlStdIOEof,
+ PerlStdIOError,
+ PerlStdIOClearerr,
+ PerlStdIOGetc,
+ PerlStdIOGetBase,
+ PerlStdIOGetBufsiz,
+ PerlStdIOGetCnt,
+ PerlStdIOGetPtr,
+ PerlStdIOGets,
+ PerlStdIOPutc,
+ PerlStdIOPuts,
+ PerlStdIOFlush,
+ PerlStdIOUngetc,
+ PerlStdIOFileno,
+ PerlStdIOFdopen,
+ PerlStdIOReopen,
+ PerlStdIORead,
+ PerlStdIOWrite,
+ PerlStdIOSetBuf,
+ PerlStdIOSetVBuf,
+ PerlStdIOSetCnt,
+ PerlStdIOSetPtrCnt,
+ PerlStdIOSetlinebuf,
+ PerlStdIOPrintf,
+ PerlStdIOVprintf,
+ PerlStdIOTell,
+ PerlStdIOSeek,
+ PerlStdIORewind,
+ PerlStdIOTmpfile,
+ PerlStdIOGetpos,
+ PerlStdIOSetpos,
+ PerlStdIOInit,
+ PerlStdIOInitOSExtras,
+ PerlStdIOFdupopen,
+};
+
+
+#undef IPERL2HOST
+#define IPERL2HOST(x) IPerlLIO2Host(x)
+
+/* IPerlLIO */
+int
+PerlLIOAccess(struct IPerlLIO* piPerl, const char *path, int mode)
+{
+ return win32_access(path, mode);
+}
+
+int
+PerlLIOChmod(struct IPerlLIO* piPerl, const char *filename, int pmode)
+{
+ return win32_chmod(filename, pmode);
+}
+
+int
+PerlLIOChown(struct IPerlLIO* piPerl, const char *filename, uid_t owner, gid_t group)
+{
+ return chown(filename, owner, group);
+}
+
+int
+PerlLIOChsize(struct IPerlLIO* piPerl, int handle, long size)
+{
+ return chsize(handle, size);
+}
+
+int
+PerlLIOClose(struct IPerlLIO* piPerl, int handle)
+{
+ return win32_close(handle);
+}
+
+int
+PerlLIODup(struct IPerlLIO* piPerl, int handle)
+{
+ return win32_dup(handle);
+}
+
+int
+PerlLIODup2(struct IPerlLIO* piPerl, int handle1, int handle2)
+{
+ return win32_dup2(handle1, handle2);
+}
+
+int
+PerlLIOFlock(struct IPerlLIO* piPerl, int fd, int oper)
+{
+ return win32_flock(fd, oper);
+}
+
+int
+PerlLIOFileStat(struct IPerlLIO* piPerl, int handle, struct stat *buffer)
+{
+ return fstat(handle, buffer);
+}
+
+int
+PerlLIOIOCtl(struct IPerlLIO* piPerl, int i, unsigned int u, char *data)
+{
+ return win32_ioctlsocket((SOCKET)i, (long)u, (u_long*)data);
+}
+
+int
+PerlLIOIsatty(struct IPerlLIO* piPerl, int fd)
+{
+ return isatty(fd);
+}
+
+int
+PerlLIOLink(struct IPerlLIO* piPerl, const char*oldname, const char *newname)
+{
+ return win32_link(oldname, newname);
+}
+
+long
+PerlLIOLseek(struct IPerlLIO* piPerl, int handle, long offset, int origin)
+{
+ return win32_lseek(handle, offset, origin);
+}
+
+int
+PerlLIOLstat(struct IPerlLIO* piPerl, const char *path, struct stat *buffer)
+{
+ return win32_stat(path, buffer);
+}
+
+char*
+PerlLIOMktemp(struct IPerlLIO* piPerl, char *Template)
+{
+ return mktemp(Template);
+}
+
+int
+PerlLIOOpen(struct IPerlLIO* piPerl, const char *filename, int oflag)
+{
+ return win32_open(filename, oflag);
+}
+
+int
+PerlLIOOpen3(struct IPerlLIO* piPerl, const char *filename, int oflag, int pmode)
+{
+ return win32_open(filename, oflag, pmode);
+}
+
+int
+PerlLIORead(struct IPerlLIO* piPerl, int handle, void *buffer, unsigned int count)
+{
+ return win32_read(handle, buffer, count);
+}
+
+int
+PerlLIORename(struct IPerlLIO* piPerl, const char *OldFileName, const char *newname)
+{
+ return win32_rename(OldFileName, newname);
+}
+
+int
+PerlLIOSetmode(struct IPerlLIO* piPerl, int handle, int mode)
+{
+ return win32_setmode(handle, mode);
+}
+
+int
+PerlLIONameStat(struct IPerlLIO* piPerl, const char *path, struct stat *buffer)
+{
+ return win32_stat(path, buffer);
+}
+
+char*
+PerlLIOTmpnam(struct IPerlLIO* piPerl, char *string)
+{
+ return tmpnam(string);
+}
+
+int
+PerlLIOUmask(struct IPerlLIO* piPerl, int pmode)
+{
+ return umask(pmode);
+}
+
+int
+PerlLIOUnlink(struct IPerlLIO* piPerl, const char *filename)
+{
+ return win32_unlink(filename);
+}
+
+int
+PerlLIOUtime(struct IPerlLIO* piPerl, char *filename, struct utimbuf *times)
+{
+ return win32_utime(filename, times);
+}
+
+int
+PerlLIOWrite(struct IPerlLIO* piPerl, int handle, const void *buffer, unsigned int count)
+{
+ return win32_write(handle, buffer, count);
+}
+
+struct IPerlLIO perlLIO =
+{
+ PerlLIOAccess,
+ PerlLIOChmod,
+ PerlLIOChown,
+ PerlLIOChsize,
+ PerlLIOClose,
+ PerlLIODup,
+ PerlLIODup2,
+ PerlLIOFlock,
+ PerlLIOFileStat,
+ PerlLIOIOCtl,
+ PerlLIOIsatty,
+ PerlLIOLink,
+ PerlLIOLseek,
+ PerlLIOLstat,
+ PerlLIOMktemp,
+ PerlLIOOpen,
+ PerlLIOOpen3,
+ PerlLIORead,
+ PerlLIORename,
+ PerlLIOSetmode,
+ PerlLIONameStat,
+ PerlLIOTmpnam,
+ PerlLIOUmask,
+ PerlLIOUnlink,
+ PerlLIOUtime,
+ PerlLIOWrite,
+};
+
+
+#undef IPERL2HOST
+#define IPERL2HOST(x) IPerlDir2Host(x)
+
+/* IPerlDIR */
+int
+PerlDirMakedir(struct IPerlDir* piPerl, const char *dirname, int mode)
+{
+ return win32_mkdir(dirname, mode);
+}
+
+int
+PerlDirChdir(struct IPerlDir* piPerl, const char *dirname)
+{
+ return IPERL2HOST(piPerl)->Chdir(dirname);
+}
+
+int
+PerlDirRmdir(struct IPerlDir* piPerl, const char *dirname)
+{
+ return win32_rmdir(dirname);
+}
+
+int
+PerlDirClose(struct IPerlDir* piPerl, DIR *dirp)
+{
+ return win32_closedir(dirp);
+}
+
+DIR*
+PerlDirOpen(struct IPerlDir* piPerl, char *filename)
+{
+ return win32_opendir(filename);
+}
+
+struct direct *
+PerlDirRead(struct IPerlDir* piPerl, DIR *dirp)
+{
+ return win32_readdir(dirp);
+}
+
+void
+PerlDirRewind(struct IPerlDir* piPerl, DIR *dirp)
+{
+ win32_rewinddir(dirp);
+}
+
+void
+PerlDirSeek(struct IPerlDir* piPerl, DIR *dirp, long loc)
+{
+ win32_seekdir(dirp, loc);
+}
+
+long
+PerlDirTell(struct IPerlDir* piPerl, DIR *dirp)
+{
+ return win32_telldir(dirp);
+}
+
+char*
+PerlDirMapPathA(struct IPerlDir* piPerl, const char* path)
+{
+ return IPERL2HOST(piPerl)->MapPathA(path);
+}
+
+WCHAR*
+PerlDirMapPathW(struct IPerlDir* piPerl, const WCHAR* path)
+{
+ return IPERL2HOST(piPerl)->MapPathW(path);
+}
+
+struct IPerlDir perlDir =
+{
+ PerlDirMakedir,
+ PerlDirChdir,
+ PerlDirRmdir,
+ PerlDirClose,
+ PerlDirOpen,
+ PerlDirRead,
+ PerlDirRewind,
+ PerlDirSeek,
+ PerlDirTell,
+ PerlDirMapPathA,
+ PerlDirMapPathW,
+};
+
+
+/* IPerlSock */
+u_long
+PerlSockHtonl(struct IPerlSock* piPerl, u_long hostlong)
+{
+ return win32_htonl(hostlong);
+}
+
+u_short
+PerlSockHtons(struct IPerlSock* piPerl, u_short hostshort)
+{
+ return win32_htons(hostshort);
+}
+
+u_long
+PerlSockNtohl(struct IPerlSock* piPerl, u_long netlong)
+{
+ return win32_ntohl(netlong);
+}
+
+u_short
+PerlSockNtohs(struct IPerlSock* piPerl, u_short netshort)
+{
+ return win32_ntohs(netshort);
+}
+
+SOCKET PerlSockAccept(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* addr, int* addrlen)
+{
+ return win32_accept(s, addr, addrlen);
+}
+
+int
+PerlSockBind(struct IPerlSock* piPerl, SOCKET s, const struct sockaddr* name, int namelen)
+{
+ return win32_bind(s, name, namelen);
+}
+
+int
+PerlSockConnect(struct IPerlSock* piPerl, SOCKET s, const struct sockaddr* name, int namelen)
+{
+ return win32_connect(s, name, namelen);
+}
+
+void
+PerlSockEndhostent(struct IPerlSock* piPerl)
+{
+ win32_endhostent();
+}
+
+void
+PerlSockEndnetent(struct IPerlSock* piPerl)
+{
+ win32_endnetent();
+}
+
+void
+PerlSockEndprotoent(struct IPerlSock* piPerl)
+{
+ win32_endprotoent();
+}
+
+void
+PerlSockEndservent(struct IPerlSock* piPerl)
+{
+ win32_endservent();
+}
+
+struct hostent*
+PerlSockGethostbyaddr(struct IPerlSock* piPerl, const char* addr, int len, int type)
+{
+ return win32_gethostbyaddr(addr, len, type);
+}
+
+struct hostent*
+PerlSockGethostbyname(struct IPerlSock* piPerl, const char* name)
+{
+ return win32_gethostbyname(name);
+}
+
+struct hostent*
+PerlSockGethostent(struct IPerlSock* piPerl)
+{
+ dTHXo;
+ Perl_croak(aTHX_ "gethostent not implemented!\n");
+ return NULL;
+}
+
+int
+PerlSockGethostname(struct IPerlSock* piPerl, char* name, int namelen)
+{
+ return win32_gethostname(name, namelen);
+}
+
+struct netent *
+PerlSockGetnetbyaddr(struct IPerlSock* piPerl, long net, int type)
+{
+ return win32_getnetbyaddr(net, type);
+}
+
+struct netent *
+PerlSockGetnetbyname(struct IPerlSock* piPerl, const char *name)
+{
+ return win32_getnetbyname((char*)name);
+}
+
+struct netent *
+PerlSockGetnetent(struct IPerlSock* piPerl)
+{
+ return win32_getnetent();
+}
+
+int PerlSockGetpeername(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* name, int* namelen)
+{
+ return win32_getpeername(s, name, namelen);
+}
+
+struct protoent*
+PerlSockGetprotobyname(struct IPerlSock* piPerl, const char* name)
+{
+ return win32_getprotobyname(name);
+}
+
+struct protoent*
+PerlSockGetprotobynumber(struct IPerlSock* piPerl, int number)
+{
+ return win32_getprotobynumber(number);
+}
+
+struct protoent*
+PerlSockGetprotoent(struct IPerlSock* piPerl)
+{
+ return win32_getprotoent();
+}
+
+struct servent*
+PerlSockGetservbyname(struct IPerlSock* piPerl, const char* name, const char* proto)
+{
+ return win32_getservbyname(name, proto);
+}
+
+struct servent*
+PerlSockGetservbyport(struct IPerlSock* piPerl, int port, const char* proto)
+{
+ return win32_getservbyport(port, proto);
+}
+
+struct servent*
+PerlSockGetservent(struct IPerlSock* piPerl)
+{
+ return win32_getservent();
+}
+
+int
+PerlSockGetsockname(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* name, int* namelen)
+{
+ return win32_getsockname(s, name, namelen);
+}
+
+int
+PerlSockGetsockopt(struct IPerlSock* piPerl, SOCKET s, int level, int optname, char* optval, int* optlen)
+{
+ return win32_getsockopt(s, level, optname, optval, optlen);
+}
+
+unsigned long
+PerlSockInetAddr(struct IPerlSock* piPerl, const char* cp)
+{
+ return win32_inet_addr(cp);
+}
+
+char*
+PerlSockInetNtoa(struct IPerlSock* piPerl, struct in_addr in)
+{
+ return win32_inet_ntoa(in);
+}
+
+int
+PerlSockListen(struct IPerlSock* piPerl, SOCKET s, int backlog)
+{
+ return win32_listen(s, backlog);
+}
+
+int
+PerlSockRecv(struct IPerlSock* piPerl, SOCKET s, char* buffer, int len, int flags)
+{
+ return win32_recv(s, buffer, len, flags);
+}
+
+int
+PerlSockRecvfrom(struct IPerlSock* piPerl, SOCKET s, char* buffer, int len, int flags, struct sockaddr* from, int* fromlen)
+{
+ return win32_recvfrom(s, buffer, len, flags, from, fromlen);
+}
+
+int
+PerlSockSelect(struct IPerlSock* piPerl, int nfds, char* readfds, char* writefds, char* exceptfds, const struct timeval* timeout)
+{
+ return win32_select(nfds, (Perl_fd_set*)readfds, (Perl_fd_set*)writefds, (Perl_fd_set*)exceptfds, timeout);
+}
+
+int
+PerlSockSend(struct IPerlSock* piPerl, SOCKET s, const char* buffer, int len, int flags)
+{
+ return win32_send(s, buffer, len, flags);
+}
+
+int
+PerlSockSendto(struct IPerlSock* piPerl, SOCKET s, const char* buffer, int len, int flags, const struct sockaddr* to, int tolen)
+{
+ return win32_sendto(s, buffer, len, flags, to, tolen);
+}
+
+void
+PerlSockSethostent(struct IPerlSock* piPerl, int stayopen)
+{
+ win32_sethostent(stayopen);
+}
+
+void
+PerlSockSetnetent(struct IPerlSock* piPerl, int stayopen)
+{
+ win32_setnetent(stayopen);
+}
+
+void
+PerlSockSetprotoent(struct IPerlSock* piPerl, int stayopen)
+{
+ win32_setprotoent(stayopen);
+}
+
+void
+PerlSockSetservent(struct IPerlSock* piPerl, int stayopen)
+{
+ win32_setservent(stayopen);
+}
+
+int
+PerlSockSetsockopt(struct IPerlSock* piPerl, SOCKET s, int level, int optname, const char* optval, int optlen)
+{
+ return win32_setsockopt(s, level, optname, optval, optlen);
+}
+
+int
+PerlSockShutdown(struct IPerlSock* piPerl, SOCKET s, int how)
+{
+ return win32_shutdown(s, how);
+}
+
+SOCKET
+PerlSockSocket(struct IPerlSock* piPerl, int af, int type, int protocol)
+{
+ return win32_socket(af, type, protocol);
+}
+
+int
+PerlSockSocketpair(struct IPerlSock* piPerl, int domain, int type, int protocol, int* fds)
+{
+ dTHXo;
+ Perl_croak(aTHX_ "socketpair not implemented!\n");
+ return 0;
+}
+
+int
+PerlSockClosesocket(struct IPerlSock* piPerl, SOCKET s)
+{
+ return win32_closesocket(s);
+}
+
+int
+PerlSockIoctlsocket(struct IPerlSock* piPerl, SOCKET s, long cmd, u_long *argp)
+{
+ return win32_ioctlsocket(s, cmd, argp);
+}
+
+struct IPerlSock perlSock =
+{
+ PerlSockHtonl,
+ PerlSockHtons,
+ PerlSockNtohl,
+ PerlSockNtohs,
+ PerlSockAccept,
+ PerlSockBind,
+ PerlSockConnect,
+ PerlSockEndhostent,
+ PerlSockEndnetent,
+ PerlSockEndprotoent,
+ PerlSockEndservent,
+ PerlSockGethostname,
+ PerlSockGetpeername,
+ PerlSockGethostbyaddr,
+ PerlSockGethostbyname,
+ PerlSockGethostent,
+ PerlSockGetnetbyaddr,
+ PerlSockGetnetbyname,
+ PerlSockGetnetent,
+ PerlSockGetprotobyname,
+ PerlSockGetprotobynumber,
+ PerlSockGetprotoent,
+ PerlSockGetservbyname,
+ PerlSockGetservbyport,
+ PerlSockGetservent,
+ PerlSockGetsockname,
+ PerlSockGetsockopt,
+ PerlSockInetAddr,
+ PerlSockInetNtoa,
+ PerlSockListen,
+ PerlSockRecv,
+ PerlSockRecvfrom,
+ PerlSockSelect,
+ PerlSockSend,
+ PerlSockSendto,
+ PerlSockSethostent,
+ PerlSockSetnetent,
+ PerlSockSetprotoent,
+ PerlSockSetservent,
+ PerlSockSetsockopt,
+ PerlSockShutdown,
+ PerlSockSocket,
+ PerlSockSocketpair,
+ PerlSockClosesocket,
+};
+
+
+/* IPerlProc */
+
+#define EXECF_EXEC 1
+#define EXECF_SPAWN 2
+
+void
+PerlProcAbort(struct IPerlProc* piPerl)
+{
+ win32_abort();
+}
+
+char *
+PerlProcCrypt(struct IPerlProc* piPerl, const char* clear, const char* salt)
+{
+ return win32_crypt(clear, salt);
+}
+
+void
+PerlProcExit(struct IPerlProc* piPerl, int status)
+{
+ exit(status);
+}
+
+void
+PerlProc_Exit(struct IPerlProc* piPerl, int status)
+{
+ _exit(status);
+}
+
+int
+PerlProcExecl(struct IPerlProc* piPerl, const char *cmdname, const char *arg0, const char *arg1, const char *arg2, const char *arg3)
+{
+ return execl(cmdname, arg0, arg1, arg2, arg3);
+}
+
+int
+PerlProcExecv(struct IPerlProc* piPerl, const char *cmdname, const char *const *argv)
+{
+ return win32_execvp(cmdname, argv);
+}
+
+int
+PerlProcExecvp(struct IPerlProc* piPerl, const char *cmdname, const char *const *argv)
+{
+ return win32_execvp(cmdname, argv);
+}
+
+uid_t
+PerlProcGetuid(struct IPerlProc* piPerl)
+{
+ return getuid();
+}
+
+uid_t
+PerlProcGeteuid(struct IPerlProc* piPerl)
+{
+ return geteuid();
+}
+
+gid_t
+PerlProcGetgid(struct IPerlProc* piPerl)
+{
+ return getgid();
+}
+
+gid_t
+PerlProcGetegid(struct IPerlProc* piPerl)
+{
+ return getegid();
+}
+
+char *
+PerlProcGetlogin(struct IPerlProc* piPerl)
+{
+ return g_getlogin();
+}
+
+int
+PerlProcKill(struct IPerlProc* piPerl, int pid, int sig)
+{
+ return win32_kill(pid, sig);
+}
+
+int
+PerlProcKillpg(struct IPerlProc* piPerl, int pid, int sig)
+{
+ dTHXo;
+ Perl_croak(aTHX_ "killpg not implemented!\n");
+ return 0;
+}
+
+int
+PerlProcPauseProc(struct IPerlProc* piPerl)
+{
+ return win32_sleep((32767L << 16) + 32767);
+}
+
+PerlIO*
+PerlProcPopen(struct IPerlProc* piPerl, const char *command, const char *mode)
+{
+ dTHXo;
+ PERL_FLUSHALL_FOR_CHILD;
+ return (PerlIO*)win32_popen(command, mode);
+}
+
+int
+PerlProcPclose(struct IPerlProc* piPerl, PerlIO *stream)
+{
+ return win32_pclose((FILE*)stream);
+}
+
+int
+PerlProcPipe(struct IPerlProc* piPerl, int *phandles)
+{
+ return win32_pipe(phandles, 512, O_BINARY);
+}
+
+int
+PerlProcSetuid(struct IPerlProc* piPerl, uid_t u)
+{
+ return setuid(u);
+}
+
+int
+PerlProcSetgid(struct IPerlProc* piPerl, gid_t g)
+{
+ return setgid(g);
+}
+
+int
+PerlProcSleep(struct IPerlProc* piPerl, unsigned int s)
+{
+ return win32_sleep(s);
+}
+
+int
+PerlProcTimes(struct IPerlProc* piPerl, struct tms *timebuf)
+{
+ return win32_times(timebuf);
+}
+
+int
+PerlProcWait(struct IPerlProc* piPerl, int *status)
+{
+ return win32_wait(status);
+}
+
+int
+PerlProcWaitpid(struct IPerlProc* piPerl, int pid, int *status, int flags)
+{
+ return win32_waitpid(pid, status, flags);
+}
+
+Sighandler_t
+PerlProcSignal(struct IPerlProc* piPerl, int sig, Sighandler_t subcode)
+{
+ return 0;
+}
+
+static DWORD WINAPI
+win32_start_child(LPVOID arg)
+{
+ PerlInterpreter *my_perl = (PerlInterpreter*)arg;
+ GV *tmpgv;
+ int status;
+#ifdef PERL_OBJECT
+ CPerlObj *pPerl = (CPerlObj*)my_perl;
+#endif
+#ifdef PERL_SYNC_FORK
+ static long sync_fork_id = 0;
+ long id = ++sync_fork_id;
+#endif
+
+
+ PERL_SET_INTERP(my_perl);
+
+ /* set $$ to pseudo id */
+#ifdef PERL_SYNC_FORK
+ w32_pseudo_id = id;
+#else
+ w32_pseudo_id = GetCurrentThreadId();
+#endif
+ if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV))
+ sv_setiv(GvSV(tmpgv), -(IV)w32_pseudo_id);
+ hv_clear(PL_pidstatus);
+
+ /* push a zero on the stack (we are the child) */
+ {
+ djSP;
+ dTARGET;
+ PUSHi(0);
+ PUTBACK;
+ }
+
+ /* continue from next op */
+ PL_op = PL_op->op_next;
+
+ {
+ dJMPENV;
+ volatile oldscope = PL_scopestack_ix;
+
+restart:
+ JMPENV_PUSH(status);
+ switch (status) {
+ case 0:
+ CALLRUNOPS(aTHX);
+ status = 0;
+ break;
+ case 2:
+ while (PL_scopestack_ix > oldscope)
+ LEAVE;
+ FREETMPS;
+ PL_curstash = PL_defstash;
+ if (PL_endav && !PL_minus_c)
+ call_list(oldscope, PL_endav);
+ status = STATUS_NATIVE_EXPORT;
+ break;
+ case 3:
+ if (PL_restartop) {
+ POPSTACK_TO(PL_mainstack);
+ PL_op = PL_restartop;
+ PL_restartop = Nullop;
+ goto restart;
+ }
+ PerlIO_printf(Perl_error_log, "panic: restartop\n");
+ FREETMPS;
+ status = 1;
+ break;
+ }
+ JMPENV_POP;
+
+ /* XXX hack to avoid perl_destruct() freeing optree */
+ PL_main_root = Nullop;
+ }
+
+ /* destroy everything (waits for any pseudo-forked children) */
+ perl_destruct(my_perl);
+ perl_free(my_perl);
+
+#ifdef PERL_SYNC_FORK
+ return id;
+#else
+ return (DWORD)status;
+#endif
+}
+
+int
+PerlProcFork(struct IPerlProc* piPerl)
+{
+ dTHXo;
+ DWORD id;
+ HANDLE handle;
+ CPerlHost *h = new CPerlHost();
+ PerlInterpreter *new_perl = perl_clone_using((PerlInterpreter*)aTHXo, 1,
+ h->m_pHostperlMem,
+ h->m_pHostperlMemShared,
+ h->m_pHostperlMemParse,
+ h->m_pHostperlEnv,
+ h->m_pHostperlStdIO,
+ h->m_pHostperlLIO,
+ h->m_pHostperlDir,
+ h->m_pHostperlSock,
+ h->m_pHostperlProc
+ );
+#ifdef PERL_SYNC_FORK
+ id = win32_start_child((LPVOID)new_perl);
+ PERL_SET_INTERP(aTHXo);
+#else
+ handle = CreateThread(NULL, 0, win32_start_child,
+ (LPVOID)new_perl, 0, &id);
+ PERL_SET_INTERP(aTHXo);
+ if (!handle)
+ Perl_croak(aTHX_ "panic: pseudo fork() failed");
+ w32_pseudo_child_handles[w32_num_pseudo_children] = handle;
+ w32_pseudo_child_pids[w32_num_pseudo_children] = id;
+ ++w32_num_pseudo_children;
+#endif
+ return -(int)id;
+}
+
+int
+PerlProcGetpid(struct IPerlProc* piPerl)
+{
+ return win32_getpid();
+}
+
+void*
+PerlProcDynaLoader(struct IPerlProc* piPerl, const char* filename)
+{
+ return win32_dynaload(filename);
+}
+
+void
+PerlProcGetOSError(struct IPerlProc* piPerl, SV* sv, DWORD dwErr)
+{
+ win32_str_os_error(sv, dwErr);
+}
+
+BOOL
+PerlProcDoCmd(struct IPerlProc* piPerl, char *cmd)
+{
+ do_spawn2(cmd, EXECF_EXEC);
+ return FALSE;
+}
+
+int
+PerlProcSpawn(struct IPerlProc* piPerl, char* cmds)
+{
+ return do_spawn2(cmds, EXECF_SPAWN);
+}
+
+int
+PerlProcSpawnvp(struct IPerlProc* piPerl, int mode, const char *cmdname, const char *const *argv)
+{
+ return win32_spawnvp(mode, cmdname, argv);
+}
+
+int
+PerlProcASpawn(struct IPerlProc* piPerl, void *vreally, void **vmark, void **vsp)
+{
+ return do_aspawn(vreally, vmark, vsp);
+}
+
+struct IPerlProc perlProc =
+{
+ PerlProcAbort,
+ PerlProcCrypt,
+ PerlProcExit,
+ PerlProc_Exit,
+ PerlProcExecl,
+ PerlProcExecv,
+ PerlProcExecvp,
+ PerlProcGetuid,
+ PerlProcGeteuid,
+ PerlProcGetgid,
+ PerlProcGetegid,
+ PerlProcGetlogin,
+ PerlProcKill,
+ PerlProcKillpg,
+ PerlProcPauseProc,
+ PerlProcPopen,
+ PerlProcPclose,
+ PerlProcPipe,
+ PerlProcSetuid,
+ PerlProcSetgid,
+ PerlProcSleep,
+ PerlProcTimes,
+ PerlProcWait,
+ PerlProcWaitpid,
+ PerlProcSignal,
+ PerlProcFork,
+ PerlProcGetpid,
+ PerlProcDynaLoader,
+ PerlProcGetOSError,
+ PerlProcDoCmd,
+ PerlProcSpawn,
+ PerlProcSpawnvp,
+ PerlProcASpawn,
+};
+
+
+/*
+ * CPerlHost
+ */
+
+CPerlHost::CPerlHost(void)
+{
+ m_pvDir = new VDir();
+ m_pVMem = new VMem();
+ m_pVMemShared = new VMem();
+ m_pVMemParse = new VMem();
+
+ m_pvDir->Init(NULL, m_pVMem);
+
+ m_dwEnvCount = 0;
+ m_lppEnvList = NULL;
+
+ CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem));
+ CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared));
+ CopyMemory(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse));
+ CopyMemory(&m_hostperlEnv, &perlEnv, sizeof(perlEnv));
+ CopyMemory(&m_hostperlStdIO, &perlStdIO, sizeof(perlStdIO));
+ CopyMemory(&m_hostperlLIO, &perlLIO, sizeof(perlLIO));
+ CopyMemory(&m_hostperlDir, &perlDir, sizeof(perlDir));
+ CopyMemory(&m_hostperlSock, &perlSock, sizeof(perlSock));
+ CopyMemory(&m_hostperlProc, &perlProc, sizeof(perlProc));
+
+ m_pHostperlMem = &m_hostperlMem;
+ m_pHostperlMemShared = &m_hostperlMemShared;
+ m_pHostperlMemParse = &m_hostperlMemParse;
+ m_pHostperlEnv = &m_hostperlEnv;
+ m_pHostperlStdIO = &m_hostperlStdIO;
+ m_pHostperlLIO = &m_hostperlLIO;
+ m_pHostperlDir = &m_hostperlDir;
+ m_pHostperlSock = &m_hostperlSock;
+ m_pHostperlProc = &m_hostperlProc;
+}
+
+#define SETUPEXCHANGE(xptr, iptr, table) \
+ STMT_START { \
+ if (xptr) { \
+ iptr = *xptr; \
+ *xptr = &table; \
+ } \
+ else { \
+ iptr = &table; \
+ } \
+ } STMT_END
+
+CPerlHost::CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared,
+ struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv,
+ struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO,
+ struct IPerlDir** ppDir, struct IPerlSock** ppSock,
+ struct IPerlProc** ppProc)
+{
+ m_pvDir = new VDir();
+ m_pVMem = new VMem();
+ m_pVMemShared = new VMem();
+ m_pVMemParse = new VMem();
+
+ m_pvDir->Init(NULL, m_pVMem);
+
+ m_dwEnvCount = 0;
+ m_lppEnvList = NULL;
+
+ CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem));
+ CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared));
+ CopyMemory(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse));
+ CopyMemory(&m_hostperlEnv, &perlEnv, sizeof(perlEnv));
+ CopyMemory(&m_hostperlStdIO, &perlStdIO, sizeof(perlStdIO));
+ CopyMemory(&m_hostperlLIO, &perlLIO, sizeof(perlLIO));
+ CopyMemory(&m_hostperlDir, &perlDir, sizeof(perlDir));
+ CopyMemory(&m_hostperlSock, &perlSock, sizeof(perlSock));
+ CopyMemory(&m_hostperlProc, &perlProc, sizeof(perlProc));
+
+ SETUPEXCHANGE(ppMem, m_pHostperlMem, m_hostperlMem);
+ SETUPEXCHANGE(ppMemShared, m_pHostperlMemShared, m_hostperlMemShared);
+ SETUPEXCHANGE(ppMemParse, m_pHostperlMemParse, m_hostperlMemParse);
+ SETUPEXCHANGE(ppEnv, m_pHostperlEnv, m_hostperlEnv);
+ SETUPEXCHANGE(ppStdIO, m_pHostperlStdIO, m_hostperlStdIO);
+ SETUPEXCHANGE(ppLIO, m_pHostperlLIO, m_hostperlLIO);
+ SETUPEXCHANGE(ppDir, m_pHostperlDir, m_hostperlDir);
+ SETUPEXCHANGE(ppSock, m_pHostperlSock, m_hostperlSock);
+ SETUPEXCHANGE(ppProc, m_pHostperlProc, m_hostperlProc);
+}
+#undef SETUPEXCHANGE
+
+CPerlHost::CPerlHost(CPerlHost& host)
+{
+ m_pVMem = new VMem();
+ m_pVMemShared = host.GetMemShared();
+ m_pVMemParse = host.GetMemParse();
+
+ /* duplicate directory info */
+ m_pvDir = new VDir();
+ m_pvDir->Init(host.GetDir(), m_pVMem);
+
+ CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem));
+ CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared));
+ CopyMemory(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse));
+ CopyMemory(&m_hostperlEnv, &perlEnv, sizeof(perlEnv));
+ CopyMemory(&m_hostperlStdIO, &perlStdIO, sizeof(perlStdIO));
+ CopyMemory(&m_hostperlLIO, &perlLIO, sizeof(perlLIO));
+ CopyMemory(&m_hostperlDir, &perlDir, sizeof(perlDir));
+ CopyMemory(&m_hostperlSock, &perlSock, sizeof(perlSock));
+ CopyMemory(&m_hostperlProc, &perlProc, sizeof(perlProc));
+ m_pHostperlMem = &host.m_hostperlMem;
+ m_pHostperlMemShared = &host.m_hostperlMemShared;
+ m_pHostperlMemParse = &host.m_hostperlMemParse;
+ m_pHostperlEnv = &host.m_hostperlEnv;
+ m_pHostperlStdIO = &host.m_hostperlStdIO;
+ m_pHostperlLIO = &host.m_hostperlLIO;
+ m_pHostperlDir = &host.m_hostperlDir;
+ m_pHostperlSock = &host.m_hostperlSock;
+ m_pHostperlProc = &host.m_hostperlProc;
+
+ m_dwEnvCount = 0;
+ m_lppEnvList = NULL;
+
+ /* duplicate environment info */
+ LPSTR lpPtr;
+ DWORD dwIndex = 0;
+ while(lpPtr = host.GetIndex(dwIndex))
+ Add(lpPtr);
+}
+
+CPerlHost::~CPerlHost(void)
+{
+// Reset();
+ delete m_pvDir;
+ m_pVMemParse->Release();
+ m_pVMemShared->Release();
+ m_pVMem->Release();
+}
+
+LPSTR
+CPerlHost::Find(LPCSTR lpStr)
+{
+ LPSTR lpPtr;
+ LPSTR* lppPtr = Lookup(lpStr);
+ if(lppPtr != NULL) {
+ for(lpPtr = *lppPtr; *lpPtr != '\0' && *lpPtr != '='; ++lpPtr)
+ ;
+
+ if(*lpPtr == '=')
+ ++lpPtr;
+
+ return lpPtr;
+ }
+ return NULL;
+}
+
+int
+lookup(const void *arg1, const void *arg2)
+{ // Compare strings
+ char*ptr1, *ptr2;
+ char c1,c2;
+
+ ptr1 = *(char**)arg1;
+ ptr2 = *(char**)arg2;
+ for(;;) {
+ c1 = *ptr1++;
+ c2 = *ptr2++;
+ if(c1 == '\0' || c1 == '=') {
+ if(c2 == '\0' || c2 == '=')
+ break;
+
+ return -1; // string 1 < string 2
+ }
+ else if(c2 == '\0' || c2 == '=')
+ return 1; // string 1 > string 2
+ else if(c1 != c2) {
+ c1 = toupper(c1);
+ c2 = toupper(c2);
+ if(c1 != c2) {
+ if(c1 < c2)
+ return -1; // string 1 < string 2
+
+ return 1; // string 1 > string 2
+ }
+ }
+ }
+ return 0;
+}
+
+LPSTR*
+CPerlHost::Lookup(LPCSTR lpStr)
+{
+ return (LPSTR*)bsearch(&lpStr, m_lppEnvList, m_dwEnvCount, sizeof(LPSTR), lookup);
+}
+
+int
+compare(const void *arg1, const void *arg2)
+{ // Compare strings
+ char*ptr1, *ptr2;
+ char c1,c2;
+
+ ptr1 = *(char**)arg1;
+ ptr2 = *(char**)arg2;
+ for(;;) {
+ c1 = *ptr1++;
+ c2 = *ptr2++;
+ if(c1 == '\0' || c1 == '=') {
+ if(c1 == c2)
+ break;
+
+ return -1; // string 1 < string 2
+ }
+ else if(c2 == '\0' || c2 == '=')
+ return 1; // string 1 > string 2
+ else if(c1 != c2) {
+ c1 = toupper(c1);
+ c2 = toupper(c2);
+ if(c1 != c2) {
+ if(c1 < c2)
+ return -1; // string 1 < string 2
+
+ return 1; // string 1 > string 2
+ }
+ }
+ }
+ return 0;
+}
+
+void
+CPerlHost::Add(LPCSTR lpStr)
+{
+ dTHXo;
+ char szBuffer[1024];
+ LPSTR *lpPtr;
+ int index, length = strlen(lpStr)+1;
+
+ for(index = 0; lpStr[index] != '\0' && lpStr[index] != '='; ++index)
+ szBuffer[index] = lpStr[index];
+
+ szBuffer[index] = '\0';
+
+ // replacing ?
+ lpPtr = Lookup(szBuffer);
+ if(lpPtr != NULL) {
+ Renew(*lpPtr, length, char);
+ strcpy(*lpPtr, lpStr);
+ }
+ else {
+ ++m_dwEnvCount;
+ Renew(m_lppEnvList, m_dwEnvCount, LPSTR);
+ New(1, m_lppEnvList[m_dwEnvCount-1], length, char);
+ if(m_lppEnvList[m_dwEnvCount-1] != NULL) {
+ strcpy(m_lppEnvList[m_dwEnvCount-1], lpStr);
+ qsort(m_lppEnvList, m_dwEnvCount, sizeof(LPSTR), compare);
+ }
+ else
+ --m_dwEnvCount;
+ }
+}
+
+DWORD
+CPerlHost::CalculateEnvironmentSpace(void)
+{
+ DWORD index;
+ DWORD dwSize = 0;
+ for(index = 0; index < m_dwEnvCount; ++index)
+ dwSize += strlen(m_lppEnvList[index]) + 1;
+
+ return dwSize;
+}
+
+void
+CPerlHost::FreeLocalEnvironmentStrings(LPSTR lpStr)
+{
+ dTHXo;
+ Safefree(lpStr);
+}
+
+char*
+CPerlHost::GetChildDir(void)
+{
+ dTHXo;
+ int length;
+ char* ptr;
+ New(0, ptr, MAX_PATH+1, char);
+ if(ptr) {
+ m_pvDir->GetCurrentDirectoryA(MAX_PATH+1, ptr);
+ length = strlen(ptr)-1;
+ if(length > 0) {
+ if((ptr[length] == '\\') || (ptr[length] == '/'))
+ ptr[length] = 0;
+ }
+ }
+ return ptr;
+}
+
+void
+CPerlHost::FreeChildDir(char* pStr)
+{
+ dTHXo;
+ Safefree(pStr);
+}
+
+LPSTR
+CPerlHost::CreateLocalEnvironmentStrings(VDir &vDir)
+{
+ dTHXo;
+ LPSTR lpStr, lpPtr, lpEnvPtr, lpTmp, lpLocalEnv, lpAllocPtr;
+ DWORD dwSize, dwEnvIndex;
+ int nLength, compVal;
+
+ // get the process environment strings
+ lpAllocPtr = lpTmp = (LPSTR)GetEnvironmentStrings();
+
+ // step over current directory stuff
+ while(*lpTmp == '=')
+ lpTmp += strlen(lpTmp) + 1;
+
+ // save the start of the environment strings
+ lpEnvPtr = lpTmp;
+ for(dwSize = 1; *lpTmp != '\0'; lpTmp += strlen(lpTmp) + 1) {
+ // calculate the size of the environment strings
+ dwSize += strlen(lpTmp) + 1;
+ }
+
+ // add the size of current directories
+ dwSize += vDir.CalculateEnvironmentSpace();
+
+ // add the additional space used by changes made to the environment
+ dwSize += CalculateEnvironmentSpace();
+
+ New(1, lpStr, dwSize, char);
+ lpPtr = lpStr;
+ if(lpStr != NULL) {
+ // build the local environment
+ lpStr = vDir.BuildEnvironmentSpace(lpStr);
+
+ dwEnvIndex = 0;
+ lpLocalEnv = GetIndex(dwEnvIndex);
+ while(*lpEnvPtr != '\0') {
+ if(lpLocalEnv == NULL) {
+ // all environment overrides have been added
+ // so copy string into place
+ strcpy(lpStr, lpEnvPtr);
+ nLength = strlen(lpEnvPtr) + 1;
+ lpStr += nLength;
+ lpEnvPtr += nLength;
+ }
+ else {
+ // determine which string to copy next
+ compVal = compare(&lpEnvPtr, &lpLocalEnv);
+ if(compVal < 0) {
+ strcpy(lpStr, lpEnvPtr);
+ nLength = strlen(lpEnvPtr) + 1;
+ lpStr += nLength;
+ lpEnvPtr += nLength;
+ }
+ else {
+ char *ptr = strchr(lpLocalEnv, '=');
+ if(ptr && ptr[1]) {
+ strcpy(lpStr, lpLocalEnv);
+ lpStr += strlen(lpLocalEnv) + 1;
+ }
+ lpLocalEnv = GetIndex(dwEnvIndex);
+ if(compVal == 0) {
+ // this string was replaced
+ lpEnvPtr += strlen(lpEnvPtr) + 1;
+ }
+ }
+ }
+ }
+
+ // add final NULL
+ *lpStr = '\0';
+ }
+
+ // release the process environment strings
+ FreeEnvironmentStrings(lpAllocPtr);
+
+ return lpPtr;
+}
+
+void
+CPerlHost::Reset(void)
+{
+ dTHXo;
+ if(m_lppEnvList != NULL) {
+ for(DWORD index = 0; index < m_dwEnvCount; ++index) {
+ Safefree(m_lppEnvList[index]);
+ m_lppEnvList[index] = NULL;
+ }
+ }
+ m_dwEnvCount = 0;
+}
+
+void
+CPerlHost::Clearenv(void)
+{
+ char ch;
+ LPSTR lpPtr, lpStr, lpEnvPtr;
+ if(m_lppEnvList != NULL) {
+ /* set every entry to an empty string */
+ for(DWORD index = 0; index < m_dwEnvCount; ++index) {
+ char* ptr = strchr(m_lppEnvList[index], '=');
+ if(ptr) {
+ *++ptr = 0;
+ }
+ }
+ }
+
+ /* get the process environment strings */
+ lpStr = lpEnvPtr = (LPSTR)GetEnvironmentStrings();
+
+ /* step over current directory stuff */
+ while(*lpStr == '=')
+ lpStr += strlen(lpStr) + 1;
+
+ while(*lpStr) {
+ lpPtr = strchr(lpStr, '=');
+ if(lpPtr) {
+ ch = *++lpPtr;
+ *lpPtr = 0;
+ Add(lpStr);
+ *lpPtr = ch;
+ }
+ lpStr += strlen(lpStr) + 1;
+ }
+
+ FreeEnvironmentStrings(lpEnvPtr);
+}
+
+
+char*
+CPerlHost::Getenv(const char *varname)
+{
+ char* pEnv = Find(varname);
+ if(pEnv == NULL) {
+ pEnv = win32_getenv(varname);
+ }
+ else {
+ if(!*pEnv)
+ pEnv = 0;
+ }
+
+ return pEnv;
+}
+
+int
+CPerlHost::Putenv(const char *envstring)
+{
+ Add(envstring);
+ return 0;
+}
+
+int
+CPerlHost::Chdir(const char *dirname)
+{
+ dTHXo;
+ int ret;
+ if (USING_WIDE()) {
+ WCHAR wBuffer[MAX_PATH];
+ A2WHELPER(dirname, wBuffer, sizeof(wBuffer));
+ ret = m_pvDir->SetCurrentDirectoryW(wBuffer);
+ }
+ else
+ ret = m_pvDir->SetCurrentDirectoryA((char*)dirname);
+ if(ret < 0) {
+ errno = ENOENT;
+ }
+ return ret;
+}
+
+#endif /* ___PerlHost_H___ */
diff --git a/win32/perllib.c b/win32/perllib.c
index 9cd542b..717b902 100644
--- a/win32/perllib.c
+++ b/win32/perllib.c
@@ -15,1304 +15,33 @@
#ifdef PERL_IMPLICIT_SYS
#include "win32iop.h"
#include <fcntl.h>
-#endif
-
-
-/* Register any extra external extensions */
-char *staticlinkmodules[] = {
- "DynaLoader",
- NULL,
-};
-
-EXTERN_C void boot_DynaLoader (pTHXo_ CV* cv);
-
-static void
-xs_init(pTHXo)
-{
- char *file = __FILE__;
- dXSUB_SYS;
- newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
-}
-
-#ifdef PERL_IMPLICIT_SYS
-/* IPerlMem */
-void*
-PerlMemMalloc(struct IPerlMem *I, size_t size)
-{
- return win32_malloc(size);
-}
-void*
-PerlMemRealloc(struct IPerlMem *I, void* ptr, size_t size)
-{
- return win32_realloc(ptr, size);
-}
-void
-PerlMemFree(struct IPerlMem *I, void* ptr)
-{
- win32_free(ptr);
-}
-
-struct IPerlMem perlMem =
-{
- PerlMemMalloc,
- PerlMemRealloc,
- PerlMemFree,
-};
-
-
-/* IPerlEnv */
-extern char * g_win32_get_privlib(char *pl);
-extern char * g_win32_get_sitelib(char *pl);
-
-
-char*
-PerlEnvGetenv(struct IPerlEnv *I, const char *varname)
-{
- return win32_getenv(varname);
-};
-int
-PerlEnvPutenv(struct IPerlEnv *I, const char *envstring)
-{
- return win32_putenv(envstring);
-};
-
-char*
-PerlEnvGetenv_len(struct IPerlEnv *I, const char* varname, unsigned long* len)
-{
- char *e = win32_getenv(varname);
- if (e)
- *len = strlen(e);
- return e;
-}
-
-int
-PerlEnvUname(struct IPerlEnv *I, struct utsname *name)
-{
- return win32_uname(name);
-}
-
-void
-PerlEnvClearenv(struct IPerlEnv *I)
-{
- dTHXo;
- char *envv = GetEnvironmentStrings();
- char *cur = envv;
- STRLEN len;
- while (*cur) {
- char *end = strchr(cur,'=');
- if (end && end != cur) {
- *end = '\0';
- my_setenv(cur,Nullch);
- *end = '=';
- cur = end + strlen(end+1)+2;
- }
- else if ((len = strlen(cur)))
- cur += len+1;
- }
- FreeEnvironmentStrings(envv);
-}
-
-void*
-PerlEnvGetChildEnv(struct IPerlEnv *I)
-{
- return NULL;
-}
-
-void
-PerlEnvFreeChildEnv(struct IPerlEnv *I, void* env)
-{
-}
-
-char*
-PerlEnvGetChildDir(struct IPerlEnv *I)
-{
- return NULL;
-}
-
-void
-PerlEnvFreeChildDir(struct IPerlEnv *I, char* dir)
-{
-}
-
-unsigned long
-PerlEnvOsId(struct IPerlEnv *I)
-{
- return win32_os_id();
-}
-
-char*
-PerlEnvLibPath(struct IPerlEnv *I, char *pl)
-{
- return g_win32_get_privlib(pl);
-}
-
-char*
-PerlEnvSiteLibPath(struct IPerlEnv *I, char *pl)
-{
- return g_win32_get_sitelib(pl);
-}
-
-struct IPerlEnv perlEnv =
-{
- PerlEnvGetenv,
- PerlEnvPutenv,
- PerlEnvGetenv_len,
- PerlEnvUname,
- PerlEnvClearenv,
- PerlEnvGetChildEnv,
- PerlEnvFreeChildEnv,
- PerlEnvGetChildDir,
- PerlEnvFreeChildDir,
- PerlEnvOsId,
- PerlEnvLibPath,
- PerlEnvSiteLibPath,
-};
-
-
-/* PerlStdIO */
-PerlIO*
-PerlStdIOStdin(struct IPerlStdIO *I)
-{
- return (PerlIO*)win32_stdin();
-}
-
-PerlIO*
-PerlStdIOStdout(struct IPerlStdIO *I)
-{
- return (PerlIO*)win32_stdout();
-}
-
-PerlIO*
-PerlStdIOStderr(struct IPerlStdIO *I)
-{
- return (PerlIO*)win32_stderr();
-}
-
-PerlIO*
-PerlStdIOOpen(struct IPerlStdIO *I, const char *path, const char *mode)
-{
- return (PerlIO*)win32_fopen(path, mode);
-}
-
-int
-PerlStdIOClose(struct IPerlStdIO *I, PerlIO* pf)
-{
- return win32_fclose(((FILE*)pf));
-}
-
-int
-PerlStdIOEof(struct IPerlStdIO *I, PerlIO* pf)
-{
- return win32_feof((FILE*)pf);
-}
-
-int
-PerlStdIOError(struct IPerlStdIO *I, PerlIO* pf)
-{
- return win32_ferror((FILE*)pf);
-}
-
-void
-PerlStdIOClearerr(struct IPerlStdIO *I, PerlIO* pf)
-{
- win32_clearerr((FILE*)pf);
-}
-
-int
-PerlStdIOGetc(struct IPerlStdIO *I, PerlIO* pf)
-{
- return win32_getc((FILE*)pf);
-}
-
-char*
-PerlStdIOGetBase(struct IPerlStdIO *I, PerlIO* pf)
-{
-#ifdef FILE_base
- FILE *f = (FILE*)pf;
- return FILE_base(f);
-#else
- return Nullch;
-#endif
-}
-
-int
-PerlStdIOGetBufsiz(struct IPerlStdIO *I, PerlIO* pf)
-{
-#ifdef FILE_bufsiz
- FILE *f = (FILE*)pf;
- return FILE_bufsiz(f);
-#else
- return (-1);
-#endif
-}
-
-int
-PerlStdIOGetCnt(struct IPerlStdIO *I, PerlIO* pf)
-{
-#ifdef USE_STDIO_PTR
- FILE *f = (FILE*)pf;
- return FILE_cnt(f);
-#else
- return (-1);
-#endif
-}
-
-char*
-PerlStdIOGetPtr(struct IPerlStdIO *I, PerlIO* pf)
-{
-#ifdef USE_STDIO_PTR
- FILE *f = (FILE*)pf;
- return FILE_ptr(f);
-#else
- return Nullch;
-#endif
-}
-
-char*
-PerlStdIOGets(struct IPerlStdIO *I, PerlIO* pf, char* s, int n)
-{
- return win32_fgets(s, n, (FILE*)pf);
-}
-
-int
-PerlStdIOPutc(struct IPerlStdIO *I, PerlIO* pf, int c)
-{
- return win32_fputc(c, (FILE*)pf);
-}
-
-int
-PerlStdIOPuts(struct IPerlStdIO *I, PerlIO* pf, const char *s)
-{
- return win32_fputs(s, (FILE*)pf);
-}
-
-int
-PerlStdIOFlush(struct IPerlStdIO *I, PerlIO* pf)
-{
- return win32_fflush((FILE*)pf);
-}
-
-int
-PerlStdIOUngetc(struct IPerlStdIO *I, PerlIO* pf,int c)
-{
- return win32_ungetc(c, (FILE*)pf);
-}
-
-int
-PerlStdIOFileno(struct IPerlStdIO *I, PerlIO* pf)
-{
- return win32_fileno((FILE*)pf);
-}
-
-PerlIO*
-PerlStdIOFdopen(struct IPerlStdIO *I, int fd, const char *mode)
-{
- return (PerlIO*)win32_fdopen(fd, mode);
-}
-
-PerlIO*
-PerlStdIOReopen(struct IPerlStdIO *I, const char*path, const char*mode, PerlIO* pf)
-{
- return (PerlIO*)win32_freopen(path, mode, (FILE*)pf);
-}
-
-SSize_t
-PerlStdIORead(struct IPerlStdIO *I, PerlIO* pf, void *buffer, Size_t size)
-{
- return win32_fread(buffer, 1, size, (FILE*)pf);
-}
-
-SSize_t
-PerlStdIOWrite(struct IPerlStdIO *I, PerlIO* pf, const void *buffer, Size_t size)
-{
- return win32_fwrite(buffer, 1, size, (FILE*)pf);
-}
-
-void
-PerlStdIOSetBuf(struct IPerlStdIO *I, PerlIO* pf, char* buffer)
-{
- win32_setbuf((FILE*)pf, buffer);
-}
-
-int
-PerlStdIOSetVBuf(struct IPerlStdIO *I, PerlIO* pf, char* buffer, int type, Size_t size)
-{
- return win32_setvbuf((FILE*)pf, buffer, type, size);
-}
-
-void
-PerlStdIOSetCnt(struct IPerlStdIO *I, PerlIO* pf, int n)
-{
-#ifdef STDIO_CNT_LVALUE
- FILE *f = (FILE*)pf;
- FILE_cnt(f) = n;
-#endif
-}
-
-void
-PerlStdIOSetPtrCnt(struct IPerlStdIO *I, PerlIO* pf, char * ptr, int n)
-{
-#ifdef STDIO_PTR_LVALUE
- FILE *f = (FILE*)pf;
- FILE_ptr(f) = ptr;
- FILE_cnt(f) = n;
-#endif
-}
-
-void
-PerlStdIOSetlinebuf(struct IPerlStdIO *I, PerlIO* pf)
-{
- win32_setvbuf((FILE*)pf, NULL, _IOLBF, 0);
-}
-
-int
-PerlStdIOPrintf(struct IPerlStdIO *I, PerlIO* pf, const char *format,...)
-{
- va_list(arglist);
- va_start(arglist, format);
- return win32_vfprintf((FILE*)pf, format, arglist);
-}
-
-int
-PerlStdIOVprintf(struct IPerlStdIO *I, PerlIO* pf, const char *format, va_list arglist)
-{
- return win32_vfprintf((FILE*)pf, format, arglist);
-}
-
-long
-PerlStdIOTell(struct IPerlStdIO *I, PerlIO* pf)
-{
- return win32_ftell((FILE*)pf);
-}
-
-int
-PerlStdIOSeek(struct IPerlStdIO *I, PerlIO* pf, off_t offset, int origin)
-{
- return win32_fseek((FILE*)pf, offset, origin);
-}
-
-void
-PerlStdIORewind(struct IPerlStdIO *I, PerlIO* pf)
-{
- win32_rewind((FILE*)pf);
-}
-
-PerlIO*
-PerlStdIOTmpfile(struct IPerlStdIO *I)
-{
- return (PerlIO*)win32_tmpfile();
-}
-
-int
-PerlStdIOGetpos(struct IPerlStdIO *I, PerlIO* pf, Fpos_t *p)
-{
- return win32_fgetpos((FILE*)pf, p);
-}
-
-int
-PerlStdIOSetpos(struct IPerlStdIO *I, PerlIO* pf, const Fpos_t *p)
-{
- return win32_fsetpos((FILE*)pf, p);
-}
-void
-PerlStdIOInit(struct IPerlStdIO *I)
-{
-}
-
-void
-PerlStdIOInitOSExtras(struct IPerlStdIO *I)
-{
- Perl_init_os_extras();
-}
-
-int
-PerlStdIOOpenOSfhandle(struct IPerlStdIO *I, long osfhandle, int flags)
-{
- return win32_open_osfhandle(osfhandle, flags);
-}
-
-int
-PerlStdIOGetOSfhandle(struct IPerlStdIO *I, int filenum)
-{
- return win32_get_osfhandle(filenum);
-}
-
-
-struct IPerlStdIO perlStdIO =
-{
- PerlStdIOStdin,
- PerlStdIOStdout,
- PerlStdIOStderr,
- PerlStdIOOpen,
- PerlStdIOClose,
- PerlStdIOEof,
- PerlStdIOError,
- PerlStdIOClearerr,
- PerlStdIOGetc,
- PerlStdIOGetBase,
- PerlStdIOGetBufsiz,
- PerlStdIOGetCnt,
- PerlStdIOGetPtr,
- PerlStdIOGets,
- PerlStdIOPutc,
- PerlStdIOPuts,
- PerlStdIOFlush,
- PerlStdIOUngetc,
- PerlStdIOFileno,
- PerlStdIOFdopen,
- PerlStdIOReopen,
- PerlStdIORead,
- PerlStdIOWrite,
- PerlStdIOSetBuf,
- PerlStdIOSetVBuf,
- PerlStdIOSetCnt,
- PerlStdIOSetPtrCnt,
- PerlStdIOSetlinebuf,
- PerlStdIOPrintf,
- PerlStdIOVprintf,
- PerlStdIOTell,
- PerlStdIOSeek,
- PerlStdIORewind,
- PerlStdIOTmpfile,
- PerlStdIOGetpos,
- PerlStdIOSetpos,
- PerlStdIOInit,
- PerlStdIOInitOSExtras,
-};
-
-
-/* IPerlLIO */
-int
-PerlLIOAccess(struct IPerlLIO *I, const char *path, int mode)
-{
- return access(path, mode);
-}
-
-int
-PerlLIOChmod(struct IPerlLIO *I, const char *filename, int pmode)
-{
- return chmod(filename, pmode);
-}
-
-int
-PerlLIOChown(struct IPerlLIO *I, const char *filename, uid_t owner, gid_t group)
-{
- return chown(filename, owner, group);
-}
-
-int
-PerlLIOChsize(struct IPerlLIO *I, int handle, long size)
-{
- return chsize(handle, size);
-}
-
-int
-PerlLIOClose(struct IPerlLIO *I, int handle)
-{
- return win32_close(handle);
-}
-
-int
-PerlLIODup(struct IPerlLIO *I, int handle)
-{
- return win32_dup(handle);
-}
-
-int
-PerlLIODup2(struct IPerlLIO *I, int handle1, int handle2)
-{
- return win32_dup2(handle1, handle2);
-}
-
-int
-PerlLIOFlock(struct IPerlLIO *I, int fd, int oper)
-{
- return win32_flock(fd, oper);
-}
-
-int
-PerlLIOFileStat(struct IPerlLIO *I, int handle, struct stat *buffer)
-{
- return fstat(handle, buffer);
-}
-
-int
-PerlLIOIOCtl(struct IPerlLIO *I, int i, unsigned int u, char *data)
-{
- return win32_ioctlsocket((SOCKET)i, (long)u, (u_long*)data);
-}
-
-int
-PerlLIOIsatty(struct IPerlLIO *I, int fd)
-{
- return isatty(fd);
-}
-
-int
-PerlLIOLink(struct IPerlLIO *I, const char*oldname, const char *newname)
-{
- return win32_link(oldname, newname);
-}
-
-long
-PerlLIOLseek(struct IPerlLIO *I, int handle, long offset, int origin)
-{
- return win32_lseek(handle, offset, origin);
-}
-
-int
-PerlLIOLstat(struct IPerlLIO* p, const char *path, struct stat *buffer)
-{
- return win32_stat(path, buffer);
-}
-
-char*
-PerlLIOMktemp(struct IPerlLIO *I, char *Template)
-{
- return mktemp(Template);
-}
-
-int
-PerlLIOOpen(struct IPerlLIO *I, const char *filename, int oflag)
-{
- return win32_open(filename, oflag);
-}
-
-int
-PerlLIOOpen3(struct IPerlLIO *I, const char *filename, int oflag, int pmode)
-{
- int ret;
- if(stricmp(filename, "/dev/null") == 0)
- ret = open("NUL", oflag, pmode);
- else
- ret = open(filename, oflag, pmode);
-
- return ret;
-}
-
-int
-PerlLIORead(struct IPerlLIO *I, int handle, void *buffer, unsigned int count)
-{
- return win32_read(handle, buffer, count);
-}
-
-int
-PerlLIORename(struct IPerlLIO *I, const char *OldFileName, const char *newname)
-{
- return win32_rename(OldFileName, newname);
-}
-
-int
-PerlLIOSetmode(struct IPerlLIO *I, int handle, int mode)
-{
- return win32_setmode(handle, mode);
-}
-
-int
-PerlLIONameStat(struct IPerlLIO *I, const char *path, struct stat *buffer)
-{
- return win32_stat(path, buffer);
-}
-
-char*
-PerlLIOTmpnam(struct IPerlLIO *I, char *string)
-{
- return tmpnam(string);
-}
-
-int
-PerlLIOUmask(struct IPerlLIO *I, int pmode)
-{
- return umask(pmode);
-}
-
-int
-PerlLIOUnlink(struct IPerlLIO *I, const char *filename)
-{
- chmod(filename, S_IREAD | S_IWRITE);
- return unlink(filename);
-}
-
-int
-PerlLIOUtime(struct IPerlLIO *I, char *filename, struct utimbuf *times)
-{
- return win32_utime(filename, times);
-}
-
-int
-PerlLIOWrite(struct IPerlLIO *I, int handle, const void *buffer, unsigned int count)
-{
- return win32_write(handle, buffer, count);
-}
-
-struct IPerlLIO perlLIO =
-{
- PerlLIOAccess,
- PerlLIOChmod,
- PerlLIOChown,
- PerlLIOChsize,
- PerlLIOClose,
- PerlLIODup,
- PerlLIODup2,
- PerlLIOFlock,
- PerlLIOFileStat,
- PerlLIOIOCtl,
- PerlLIOIsatty,
- PerlLIOLink,
- PerlLIOLseek,
- PerlLIOLstat,
- PerlLIOMktemp,
- PerlLIOOpen,
- PerlLIOOpen3,
- PerlLIORead,
- PerlLIORename,
- PerlLIOSetmode,
- PerlLIONameStat,
- PerlLIOTmpnam,
- PerlLIOUmask,
- PerlLIOUnlink,
- PerlLIOUtime,
- PerlLIOWrite,
-};
-
-/* IPerlDIR */
-int
-PerlDirMakedir(struct IPerlDir *I, const char *dirname, int mode)
-{
- return win32_mkdir(dirname, mode);
-}
-
-int
-PerlDirChdir(struct IPerlDir *I, const char *dirname)
-{
- return win32_chdir(dirname);
-}
-
-int
-PerlDirRmdir(struct IPerlDir *I, const char *dirname)
-{
- return win32_rmdir(dirname);
-}
-
-int
-PerlDirClose(struct IPerlDir *I, DIR *dirp)
-{
- return win32_closedir(dirp);
-}
-
-DIR*
-PerlDirOpen(struct IPerlDir *I, char *filename)
-{
- return win32_opendir(filename);
-}
-
-struct direct *
-PerlDirRead(struct IPerlDir *I, DIR *dirp)
-{
- return win32_readdir(dirp);
-}
-
-void
-PerlDirRewind(struct IPerlDir *I, DIR *dirp)
-{
- win32_rewinddir(dirp);
-}
-
-void
-PerlDirSeek(struct IPerlDir *I, DIR *dirp, long loc)
-{
- win32_seekdir(dirp, loc);
-}
-
-long
-PerlDirTell(struct IPerlDir *I, DIR *dirp)
-{
- return win32_telldir(dirp);
-}
-
-struct IPerlDir perlDir =
-{
- PerlDirMakedir,
- PerlDirChdir,
- PerlDirRmdir,
- PerlDirClose,
- PerlDirOpen,
- PerlDirRead,
- PerlDirRewind,
- PerlDirSeek,
- PerlDirTell,
-};
-
-
-/* IPerlSock */
-u_long
-PerlSockHtonl(struct IPerlSock *I, u_long hostlong)
-{
- return win32_htonl(hostlong);
-}
-
-u_short
-PerlSockHtons(struct IPerlSock *I, u_short hostshort)
-{
- return win32_htons(hostshort);
-}
-
-u_long
-PerlSockNtohl(struct IPerlSock *I, u_long netlong)
-{
- return win32_ntohl(netlong);
-}
-
-u_short
-PerlSockNtohs(struct IPerlSock *I, u_short netshort)
-{
- return win32_ntohs(netshort);
-}
-
-SOCKET PerlSockAccept(struct IPerlSock *I, SOCKET s, struct sockaddr* addr, int* addrlen)
-{
- return win32_accept(s, addr, addrlen);
-}
-
-int
-PerlSockBind(struct IPerlSock *I, SOCKET s, const struct sockaddr* name, int namelen)
-{
- return win32_bind(s, name, namelen);
-}
-
-int
-PerlSockConnect(struct IPerlSock *I, SOCKET s, const struct sockaddr* name, int namelen)
-{
- return win32_connect(s, name, namelen);
-}
-
-void
-PerlSockEndhostent(struct IPerlSock *I)
-{
- win32_endhostent();
-}
-
-void
-PerlSockEndnetent(struct IPerlSock *I)
-{
- win32_endnetent();
-}
-
-void
-PerlSockEndprotoent(struct IPerlSock *I)
-{
- win32_endprotoent();
-}
-
-void
-PerlSockEndservent(struct IPerlSock *I)
-{
- win32_endservent();
-}
-
-struct hostent*
-PerlSockGethostbyaddr(struct IPerlSock *I, const char* addr, int len, int type)
-{
- return win32_gethostbyaddr(addr, len, type);
-}
-
-struct hostent*
-PerlSockGethostbyname(struct IPerlSock *I, const char* name)
-{
- return win32_gethostbyname(name);
-}
-
-struct hostent*
-PerlSockGethostent(struct IPerlSock *I)
-{
- dTHXo;
- Perl_croak(aTHX_ "gethostent not implemented!\n");
- return NULL;
-}
-
-int
-PerlSockGethostname(struct IPerlSock *I, char* name, int namelen)
-{
- return win32_gethostname(name, namelen);
-}
-
-struct netent *
-PerlSockGetnetbyaddr(struct IPerlSock *I, long net, int type)
-{
- return win32_getnetbyaddr(net, type);
-}
-
-struct netent *
-PerlSockGetnetbyname(struct IPerlSock *I, const char *name)
-{
- return win32_getnetbyname((char*)name);
-}
-
-struct netent *
-PerlSockGetnetent(struct IPerlSock *I)
-{
- return win32_getnetent();
-}
-
-int PerlSockGetpeername(struct IPerlSock *I, SOCKET s, struct sockaddr* name, int* namelen)
-{
- return win32_getpeername(s, name, namelen);
-}
-
-struct protoent*
-PerlSockGetprotobyname(struct IPerlSock *I, const char* name)
-{
- return win32_getprotobyname(name);
-}
-
-struct protoent*
-PerlSockGetprotobynumber(struct IPerlSock *I, int number)
-{
- return win32_getprotobynumber(number);
-}
-
-struct protoent*
-PerlSockGetprotoent(struct IPerlSock *I)
-{
- return win32_getprotoent();
-}
-
-struct servent*
-PerlSockGetservbyname(struct IPerlSock *I, const char* name, const char* proto)
-{
- return win32_getservbyname(name, proto);
-}
-
-struct servent*
-PerlSockGetservbyport(struct IPerlSock *I, int port, const char* proto)
-{
- return win32_getservbyport(port, proto);
-}
-
-struct servent*
-PerlSockGetservent(struct IPerlSock *I)
-{
- return win32_getservent();
-}
-
-int
-PerlSockGetsockname(struct IPerlSock *I, SOCKET s, struct sockaddr* name, int* namelen)
-{
- return win32_getsockname(s, name, namelen);
-}
-
-int
-PerlSockGetsockopt(struct IPerlSock *I, SOCKET s, int level, int optname, char* optval, int* optlen)
-{
- return win32_getsockopt(s, level, optname, optval, optlen);
-}
-
-unsigned long
-PerlSockInetAddr(struct IPerlSock *I, const char* cp)
-{
- return win32_inet_addr(cp);
-}
-
-char*
-PerlSockInetNtoa(struct IPerlSock *I, struct in_addr in)
-{
- return win32_inet_ntoa(in);
-}
-
-int
-PerlSockListen(struct IPerlSock *I, SOCKET s, int backlog)
-{
- return win32_listen(s, backlog);
-}
-
-int
-PerlSockRecv(struct IPerlSock *I, SOCKET s, char* buffer, int len, int flags)
-{
- return win32_recv(s, buffer, len, flags);
-}
-
-int
-PerlSockRecvfrom(struct IPerlSock *I, SOCKET s, char* buffer, int len, int flags, struct sockaddr* from, int* fromlen)
-{
- return win32_recvfrom(s, buffer, len, flags, from, fromlen);
-}
-
-int
-PerlSockSelect(struct IPerlSock *I, int nfds, char* readfds, char* writefds, char* exceptfds, const struct timeval* timeout)
-{
- return win32_select(nfds, (Perl_fd_set*)readfds, (Perl_fd_set*)writefds, (Perl_fd_set*)exceptfds, timeout);
-}
-
-int
-PerlSockSend(struct IPerlSock *I, SOCKET s, const char* buffer, int len, int flags)
-{
- return win32_send(s, buffer, len, flags);
-}
-
-int
-PerlSockSendto(struct IPerlSock *I, SOCKET s, const char* buffer, int len, int flags, const struct sockaddr* to, int tolen)
-{
- return win32_sendto(s, buffer, len, flags, to, tolen);
-}
-
-void
-PerlSockSethostent(struct IPerlSock *I, int stayopen)
-{
- win32_sethostent(stayopen);
-}
-
-void
-PerlSockSetnetent(struct IPerlSock *I, int stayopen)
-{
- win32_setnetent(stayopen);
-}
-
-void
-PerlSockSetprotoent(struct IPerlSock *I, int stayopen)
-{
- win32_setprotoent(stayopen);
-}
-
-void
-PerlSockSetservent(struct IPerlSock *I, int stayopen)
-{
- win32_setservent(stayopen);
-}
-
-int
-PerlSockSetsockopt(struct IPerlSock *I, SOCKET s, int level, int optname, const char* optval, int optlen)
-{
- return win32_setsockopt(s, level, optname, optval, optlen);
-}
-
-int
-PerlSockShutdown(struct IPerlSock *I, SOCKET s, int how)
-{
- return win32_shutdown(s, how);
-}
-
-SOCKET
-PerlSockSocket(struct IPerlSock *I, int af, int type, int protocol)
-{
- return win32_socket(af, type, protocol);
-}
-
-int
-PerlSockSocketpair(struct IPerlSock *I, int domain, int type, int protocol, int* fds)
-{
- dTHXo;
- Perl_croak(aTHX_ "socketpair not implemented!\n");
- return 0;
-}
-
-int
-PerlSockClosesocket(struct IPerlSock *I, SOCKET s)
-{
- return win32_closesocket(s);
-}
+#endif /* PERL_IMPLICIT_SYS */
-int
-PerlSockIoctlsocket(struct IPerlSock *I, SOCKET s, long cmd, u_long *argp)
-{
- return win32_ioctlsocket(s, cmd, argp);
-}
-struct IPerlSock perlSock =
-{
- PerlSockHtonl,
- PerlSockHtons,
- PerlSockNtohl,
- PerlSockNtohs,
- PerlSockAccept,
- PerlSockBind,
- PerlSockConnect,
- PerlSockEndhostent,
- PerlSockEndnetent,
- PerlSockEndprotoent,
- PerlSockEndservent,
- PerlSockGethostname,
- PerlSockGetpeername,
- PerlSockGethostbyaddr,
- PerlSockGethostbyname,
- PerlSockGethostent,
- PerlSockGetnetbyaddr,
- PerlSockGetnetbyname,
- PerlSockGetnetent,
- PerlSockGetprotobyname,
- PerlSockGetprotobynumber,
- PerlSockGetprotoent,
- PerlSockGetservbyname,
- PerlSockGetservbyport,
- PerlSockGetservent,
- PerlSockGetsockname,
- PerlSockGetsockopt,
- PerlSockInetAddr,
- PerlSockInetNtoa,
- PerlSockListen,
- PerlSockRecv,
- PerlSockRecvfrom,
- PerlSockSelect,
- PerlSockSend,
- PerlSockSendto,
- PerlSockSethostent,
- PerlSockSetnetent,
- PerlSockSetprotoent,
- PerlSockSetservent,
- PerlSockSetsockopt,
- PerlSockShutdown,
- PerlSockSocket,
- PerlSockSocketpair,
- PerlSockClosesocket,
+/* Register any extra external extensions */
+char *staticlinkmodules[] = {
+ "DynaLoader",
+ NULL,
};
+EXTERN_C void boot_DynaLoader (pTHXo_ CV* cv);
-/* IPerlProc */
-
-#define EXECF_EXEC 1
-#define EXECF_SPAWN 2
-
-extern char * g_getlogin(void);
-extern int do_spawn2(char *cmd, int exectype);
-#ifdef PERL_OBJECT
-extern int g_do_aspawn(void *vreally, void **vmark, void **vsp);
-#define do_aspawn g_do_aspawn
-#endif
-EXTERN_C PerlInterpreter* perl_alloc_using(struct IPerlMem* pMem,
- struct IPerlEnv* pEnv, struct IPerlStdIO* pStdIO,
- struct IPerlLIO* pLIO, struct IPerlDir* pDir,
- struct IPerlSock* pSock, struct IPerlProc* pProc);
-
-void
-PerlProcAbort(struct IPerlProc *I)
-{
- win32_abort();
-}
-
-char *
-PerlProcCrypt(struct IPerlProc *I, const char* clear, const char* salt)
-{
- return win32_crypt(clear, salt);
-}
-
-void
-PerlProcExit(struct IPerlProc *I, int status)
-{
- exit(status);
-}
-
-void
-PerlProc_Exit(struct IPerlProc *I, int status)
-{
- _exit(status);
-}
-
-int
-PerlProcExecl(struct IPerlProc *I, const char *cmdname, const char *arg0, const char *arg1, const char *arg2, const char *arg3)
-{
- return execl(cmdname, arg0, arg1, arg2, arg3);
-}
-
-int
-PerlProcExecv(struct IPerlProc *I, const char *cmdname, const char *const *argv)
-{
- return win32_execvp(cmdname, argv);
-}
-
-int
-PerlProcExecvp(struct IPerlProc *I, const char *cmdname, const char *const *argv)
-{
- return win32_execvp(cmdname, argv);
-}
-
-uid_t
-PerlProcGetuid(struct IPerlProc *I)
-{
- return getuid();
-}
-
-uid_t
-PerlProcGeteuid(struct IPerlProc *I)
-{
- return geteuid();
-}
-
-gid_t
-PerlProcGetgid(struct IPerlProc *I)
-{
- return getgid();
-}
-
-gid_t
-PerlProcGetegid(struct IPerlProc *I)
-{
- return getegid();
-}
-
-char *
-PerlProcGetlogin(struct IPerlProc *I)
-{
- return g_getlogin();
-}
-
-int
-PerlProcKill(struct IPerlProc *I, int pid, int sig)
-{
- return win32_kill(pid, sig);
-}
-
-int
-PerlProcKillpg(struct IPerlProc *I, int pid, int sig)
-{
- dTHXo;
- Perl_croak(aTHX_ "killpg not implemented!\n");
- return 0;
-}
-
-int
-PerlProcPauseProc(struct IPerlProc *I)
-{
- return win32_sleep((32767L << 16) + 32767);
-}
-
-PerlIO*
-PerlProcPopen(struct IPerlProc *I, const char *command, const char *mode)
-{
- dTHXo;
- PERL_FLUSHALL_FOR_CHILD;
- return (PerlIO*)win32_popen(command, mode);
-}
-
-int
-PerlProcPclose(struct IPerlProc *I, PerlIO *stream)
-{
- return win32_pclose((FILE*)stream);
-}
-
-int
-PerlProcPipe(struct IPerlProc *I, int *phandles)
-{
- return win32_pipe(phandles, 512, O_BINARY);
-}
-
-int
-PerlProcSetuid(struct IPerlProc *I, uid_t u)
-{
- return setuid(u);
-}
-
-int
-PerlProcSetgid(struct IPerlProc *I, gid_t g)
-{
- return setgid(g);
-}
-
-int
-PerlProcSleep(struct IPerlProc *I, unsigned int s)
-{
- return win32_sleep(s);
-}
-
-int
-PerlProcTimes(struct IPerlProc *I, struct tms *timebuf)
-{
- return win32_times(timebuf);
-}
-
-int
-PerlProcWait(struct IPerlProc *I, int *status)
-{
- return win32_wait(status);
-}
-
-int
-PerlProcWaitpid(struct IPerlProc *I, int pid, int *status, int flags)
-{
- return win32_waitpid(pid, status, flags);
-}
-
-Sighandler_t
-PerlProcSignal(struct IPerlProc *I, int sig, Sighandler_t subcode)
-{
- return 0;
-}
-
-void*
-PerlProcDynaLoader(struct IPerlProc *I, const char* filename)
-{
- return win32_dynaload(filename);
-}
-
-void
-PerlProcGetOSError(struct IPerlProc *I, SV* sv, DWORD dwErr)
-{
- win32_str_os_error(sv, dwErr);
-}
-
-BOOL
-PerlProcDoCmd(struct IPerlProc *I, char *cmd)
-{
- do_spawn2(cmd, EXECF_EXEC);
- return FALSE;
-}
-
-int
-PerlProcSpawn(struct IPerlProc *I, char* cmds)
-{
- return do_spawn2(cmds, EXECF_SPAWN);
-}
-
-int
-PerlProcSpawnvp(struct IPerlProc *I, int mode, const char *cmdname, const char *const *argv)
-{
- return win32_spawnvp(mode, cmdname, argv);
-}
-
-int
-PerlProcASpawn(struct IPerlProc *I, void *vreally, void **vmark, void **vsp)
+static void
+xs_init(pTHXo)
{
- return do_aspawn(vreally, vmark, vsp);
+ char *file = __FILE__;
+ dXSUB_SYS;
+ newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
}
-struct IPerlProc perlProc =
-{
- PerlProcAbort,
- PerlProcCrypt,
- PerlProcExit,
- PerlProc_Exit,
- PerlProcExecl,
- PerlProcExecv,
- PerlProcExecvp,
- PerlProcGetuid,
- PerlProcGeteuid,
- PerlProcGetgid,
- PerlProcGetegid,
- PerlProcGetlogin,
- PerlProcKill,
- PerlProcKillpg,
- PerlProcPauseProc,
- PerlProcPopen,
- PerlProcPclose,
- PerlProcPipe,
- PerlProcSetuid,
- PerlProcSetgid,
- PerlProcSleep,
- PerlProcTimes,
- PerlProcWait,
- PerlProcWaitpid,
- PerlProcSignal,
- PerlProcDynaLoader,
- PerlProcGetOSError,
- PerlProcDoCmd,
- PerlProcSpawn,
- PerlProcSpawnvp,
- PerlProcASpawn,
-};
-
-/*#include "perlhost.h" */
+#ifdef PERL_IMPLICIT_SYS
+#include "perlhost.h"
EXTERN_C void
perl_get_host_info(struct IPerlMemInfo* perlMemInfo,
+ struct IPerlMemInfo* perlMemSharedInfo,
+ struct IPerlMemInfo* perlMemParseInfo,
struct IPerlEnvInfo* perlEnvInfo,
struct IPerlStdIOInfo* perlStdIOInfo,
struct IPerlLIOInfo* perlLIOInfo,
@@ -1320,31 +49,39 @@ perl_get_host_info(struct IPerlMemInfo* perlMemInfo,
struct IPerlSockInfo* perlSockInfo,
struct IPerlProcInfo* perlProcInfo)
{
- if(perlMemInfo) {
+ if (perlMemInfo) {
Copy(&perlMem, &perlMemInfo->perlMemList, perlMemInfo->nCount, void*);
perlMemInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
}
- if(perlEnvInfo) {
+ if (perlMemSharedInfo) {
+ Copy(&perlMem, &perlMemSharedInfo->perlMemList, perlMemSharedInfo->nCount, void*);
+ perlMemSharedInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
+ }
+ if (perlMemParseInfo) {
+ Copy(&perlMem, &perlMemParseInfo->perlMemList, perlMemParseInfo->nCount, void*);
+ perlMemParseInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
+ }
+ if (perlEnvInfo) {
Copy(&perlEnv, &perlEnvInfo->perlEnvList, perlEnvInfo->nCount, void*);
perlEnvInfo->nCount = (sizeof(struct IPerlEnv)/sizeof(void*));
}
- if(perlStdIOInfo) {
+ if (perlStdIOInfo) {
Copy(&perlStdIO, &perlStdIOInfo->perlStdIOList, perlStdIOInfo->nCount, void*);
perlStdIOInfo->nCount = (sizeof(struct IPerlStdIO)/sizeof(void*));
}
- if(perlLIOInfo) {
+ if (perlLIOInfo) {
Copy(&perlLIO, &perlLIOInfo->perlLIOList, perlLIOInfo->nCount, void*);
perlLIOInfo->nCount = (sizeof(struct IPerlLIO)/sizeof(void*));
}
- if(perlDirInfo) {
+ if (perlDirInfo) {
Copy(&perlDir, &perlDirInfo->perlDirList, perlDirInfo->nCount, void*);
perlDirInfo->nCount = (sizeof(struct IPerlDir)/sizeof(void*));
}
- if(perlSockInfo) {
+ if (perlSockInfo) {
Copy(&perlSock, &perlSockInfo->perlSockList, perlSockInfo->nCount, void*);
perlSockInfo->nCount = (sizeof(struct IPerlSock)/sizeof(void*));
}
- if(perlProcInfo) {
+ if (perlProcInfo) {
Copy(&perlProc, &perlProcInfo->perlProcList, perlProcInfo->nCount, void*);
perlProcInfo->nCount = (sizeof(struct IPerlProc)/sizeof(void*));
}
@@ -1352,142 +89,173 @@ perl_get_host_info(struct IPerlMemInfo* perlMemInfo,
#ifdef PERL_OBJECT
-EXTERN_C PerlInterpreter* perl_alloc_using(struct IPerlMem* pMem,
- struct IPerlEnv* pEnv, struct IPerlStdIO* pStdIO,
- struct IPerlLIO* pLIO, struct IPerlDir* pDir,
- struct IPerlSock* pSock, struct IPerlProc* pProc)
+EXTERN_C PerlInterpreter*
+perl_alloc_override(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared,
+ struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv,
+ struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO,
+ struct IPerlDir** ppDir, struct IPerlSock** ppSock,
+ struct IPerlProc** ppProc)
{
- CPerlObj* pPerl = NULL;
+ PerlInterpreter *my_perl = NULL;
try
{
- pPerl = Perl_alloc(pMem, pEnv, pStdIO, pLIO, pDir, pSock, pProc);
+ CPerlHost* pHost = new CPerlHost(ppMem, ppMemShared, ppMemParse, ppEnv,
+ ppStdIO, ppLIO, ppDir, ppSock, ppProc);
+
+ if (pHost) {
+ my_perl = perl_alloc_using(pHost->m_pHostperlMem,
+ pHost->m_pHostperlMemShared,
+ pHost->m_pHostperlMemParse,
+ pHost->m_pHostperlEnv,
+ pHost->m_pHostperlStdIO,
+ pHost->m_pHostperlLIO,
+ pHost->m_pHostperlDir,
+ pHost->m_pHostperlSock,
+ pHost->m_pHostperlProc);
+ if (my_perl) {
+ CPerlObj* pPerl = (CPerlObj*)my_perl;
+ w32_internal_host = pHost;
+ }
+ }
}
catch(...)
{
win32_fprintf(stderr, "%s\n", "Error: Unable to allocate memory");
- pPerl = NULL;
- }
- if(pPerl)
- {
- SetPerlInterpreter(pPerl);
- return (PerlInterpreter*)pPerl;
+ my_perl = NULL;
}
- SetPerlInterpreter(NULL);
- return NULL;
+
+ return my_perl;
}
-#undef perl_alloc
-#undef perl_construct
-#undef perl_destruct
-#undef perl_free
-#undef perl_run
-#undef perl_parse
-EXTERN_C PerlInterpreter* perl_alloc(void)
+EXTERN_C PerlInterpreter*
+perl_alloc(void)
{
- CPerlObj* pPerl = NULL;
+ PerlInterpreter* my_perl = NULL;
try
{
- pPerl = Perl_alloc(&perlMem, &perlEnv, &perlStdIO, &perlLIO,
- &perlDir, &perlSock, &perlProc);
+ CPerlHost* pHost = new CPerlHost();
+ if (pHost) {
+ my_perl = perl_alloc_using(pHost->m_pHostperlMem,
+ pHost->m_pHostperlMemShared,
+ pHost->m_pHostperlMemParse,
+ pHost->m_pHostperlEnv,
+ pHost->m_pHostperlStdIO,
+ pHost->m_pHostperlLIO,
+ pHost->m_pHostperlDir,
+ pHost->m_pHostperlSock,
+ pHost->m_pHostperlProc);
+ if (my_perl) {
+ CPerlObj* pPerl = (CPerlObj*)my_perl;
+ w32_internal_host = pHost;
+ }
+ }
}
catch(...)
{
win32_fprintf(stderr, "%s\n", "Error: Unable to allocate memory");
- pPerl = NULL;
- }
- if(pPerl)
- {
- SetPerlInterpreter(pPerl);
- return (PerlInterpreter*)pPerl;
+ my_perl = NULL;
}
- SetPerlInterpreter(NULL);
- return NULL;
+
+ return my_perl;
}
-EXTERN_C void perl_construct(PerlInterpreter* sv_interp)
+EXTERN_C void
+perl_construct(PerlInterpreter* my_perl)
{
- CPerlObj* pPerl = (CPerlObj*)sv_interp;
+ CPerlObj* pPerl = (CPerlObj*)my_perl;
try
{
- pPerl->perl_construct();
+ Perl_construct();
}
catch(...)
{
win32_fprintf(stderr, "%s\n",
"Error: Unable to construct data structures");
- pPerl->perl_free();
+ CPerlHost* pHost = (CPerlHost*)w32_internal_host;
+ Perl_free();
+ delete pHost;
SetPerlInterpreter(NULL);
}
}
-EXTERN_C void perl_destruct(PerlInterpreter* sv_interp)
+EXTERN_C void
+perl_destruct(PerlInterpreter* my_perl)
{
- CPerlObj* pPerl = (CPerlObj*)sv_interp;
+ CPerlObj* pPerl = (CPerlObj*)my_perl;
+#ifdef DEBUGGING
+ Perl_destruct();
+#else
try
{
- pPerl->perl_destruct();
+ Perl_destruct();
}
catch(...)
{
}
+#endif
}
-EXTERN_C void perl_free(PerlInterpreter* sv_interp)
+EXTERN_C void
+perl_free(PerlInterpreter* my_perl)
{
- CPerlObj* pPerl = (CPerlObj*)sv_interp;
+ CPerlObj* pPerl = (CPerlObj*)my_perl;
+#ifdef DEBUGGING
+ CPerlHost* pHost = (CPerlHost*)w32_internal_host;
+ Perl_free();
+ delete pHost;
+#else
try
{
- pPerl->perl_free();
+ CPerlHost* pHost = (CPerlHost*)w32_internal_host;
+ Perl_free();
+ delete pHost;
}
catch(...)
{
}
+#endif
SetPerlInterpreter(NULL);
}
-EXTERN_C int perl_run(PerlInterpreter* sv_interp)
+EXTERN_C int
+perl_run(PerlInterpreter* my_perl)
{
- CPerlObj* pPerl = (CPerlObj*)sv_interp;
+ CPerlObj* pPerl = (CPerlObj*)my_perl;
+#ifdef DEBUGGING
+ return Perl_run();
+#else
int retVal;
try
{
- retVal = pPerl->perl_run();
- }
-/*
- catch(int x)
- {
- // this is where exit() should arrive
- retVal = x;
+ retVal = Perl_run();
}
-*/
catch(...)
{
win32_fprintf(stderr, "Error: Runtime exception\n");
retVal = -1;
}
return retVal;
+#endif
}
-EXTERN_C int perl_parse(PerlInterpreter* sv_interp, void (*xsinit)(CPerlObj*), int argc, char** argv, char** env)
+EXTERN_C int
+perl_parse(PerlInterpreter* my_perl, void (*xsinit)(CPerlObj*), int argc, char** argv, char** env)
{
int retVal;
- CPerlObj* pPerl = (CPerlObj*)sv_interp;
+ CPerlObj* pPerl = (CPerlObj*)my_perl;
+#ifdef DEBUGGING
+ retVal = Perl_parse(xsinit, argc, argv, env);
+#else
try
{
- retVal = pPerl->perl_parse(xsinit, argc, argv, env);
- }
-/*
- catch(int x)
- {
- // this is where exit() should arrive
- retVal = x;
+ retVal = Perl_parse(xsinit, argc, argv, env);
}
-*/
catch(...)
{
win32_fprintf(stderr, "Error: Parse exception\n");
retVal = -1;
}
+#endif
*win32_errno() = 0;
return retVal;
}
@@ -1500,15 +268,31 @@ EXTERN_C int perl_parse(PerlInterpreter* sv_interp, void (*xsinit)(CPerlObj*), i
EXTERN_C PerlInterpreter*
perl_alloc(void)
{
- return perl_alloc_using(&perlMem, &perlEnv, &perlStdIO, &perlLIO,
- &perlDir, &perlSock, &perlProc);
+ PerlInterpreter *my_perl = NULL;
+ CPerlHost* pHost = new CPerlHost();
+ if (pHost) {
+ my_perl = perl_alloc_using(pHost->m_pHostperlMem,
+ pHost->m_pHostperlMemShared,
+ pHost->m_pHostperlMemParse,
+ pHost->m_pHostperlEnv,
+ pHost->m_pHostperlStdIO,
+ pHost->m_pHostperlLIO,
+ pHost->m_pHostperlDir,
+ pHost->m_pHostperlSock,
+ pHost->m_pHostperlProc);
+ if (my_perl) {
+ CPerlObj* pPerl = (CPerlObj*)my_perl;
+ w32_internal_host = pHost;
+ }
+ }
+ return my_perl;
}
#endif /* PERL_OBJECT */
-
#endif /* PERL_IMPLICIT_SYS */
-extern HANDLE w32_perldll_handle;
+EXTERN_C HANDLE w32_perldll_handle;
+
static DWORD g_TlsAllocIndex;
EXTERN_C DllExport bool
@@ -1563,9 +347,24 @@ RunPerl(int argc, char **argv, char **env)
exitstatus = perl_parse(my_perl, xs_init, argc, argv, env);
if (!exitstatus) {
-#ifdef USE_ITHREADS /* XXXXXX testing */
- new_perl = perl_clone(my_perl, 0);
- Perl_push_scope(new_perl); /* ENTER; (hack in lieu of perl_destruct()) */
+#if defined(TOP_CLONE) && defined(USE_ITHREADS) /* XXXXXX testing */
+# ifdef PERL_OBJECT
+ CPerlHost *h = new CPerlHost();
+ new_perl = perl_clone_using(my_perl, 1,
+ h->m_pHostperlMem,
+ h->m_pHostperlMemShared,
+ h->m_pHostperlMemParse,
+ h->m_pHostperlEnv,
+ h->m_pHostperlStdIO,
+ h->m_pHostperlLIO,
+ h->m_pHostperlDir,
+ h->m_pHostperlSock,
+ h->m_pHostperlProc
+ );
+ CPerlObj *pPerl = (CPerlObj*)new_perl;
+# else
+ new_perl = perl_clone(my_perl, 1);
+# endif
exitstatus = perl_run( new_perl );
SetPerlInterpreter(my_perl);
#else
@@ -1630,4 +429,3 @@ DllMain(HANDLE hModule, /* DLL module handle */
}
return TRUE;
}
-
diff --git a/win32/vdir.h b/win32/vdir.h
new file mode 100644
index 0000000..0d21616
--- /dev/null
+++ b/win32/vdir.h
@@ -0,0 +1,467 @@
+/* vdir.h
+ *
+ * (c) 1999 Microsoft Corporation. All rights reserved.
+ * Portions (c) 1999 ActiveState Tool Corp, http://www.ActiveState.com/
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ */
+
+#ifndef ___VDir_H___
+#define ___VDir_H___
+
+const int driveCount = 30;
+
+class VDir
+{
+public:
+ VDir();
+ ~VDir() {};
+
+ void Init(VDir* pDir, VMem *pMem);
+ void SetDefaultA(char const *pDefault);
+ void SetDefaultW(WCHAR const *pDefault);
+ char* MapPathA(const char *pInName);
+ WCHAR* MapPathW(const WCHAR *pInName);
+ int SetCurrentDirectoryA(char *lpBuffer);
+ int SetCurrentDirectoryW(WCHAR *lpBuffer);
+ inline const char *GetDirA(int index)
+ {
+ return dirTableA[index];
+ };
+ inline const WCHAR *GetDirW(int index)
+ {
+ return dirTableW[index];
+ };
+ inline int GetDefault(void) { return nDefault; };
+
+ inline char* GetCurrentDirectoryA(int dwBufSize, char *lpBuffer)
+ {
+ char* ptr = dirTableA[nDefault];
+ while (dwBufSize--)
+ {
+ if ((*lpBuffer++ = *ptr++) == '\0')
+ break;
+ }
+ return lpBuffer;
+ };
+ inline WCHAR* GetCurrentDirectoryW(int dwBufSize, WCHAR *lpBuffer)
+ {
+ WCHAR* ptr = dirTableW[nDefault];
+ while (dwBufSize--)
+ {
+ if ((*lpBuffer++ = *ptr++) == '\0')
+ break;
+ }
+ return lpBuffer;
+ };
+
+
+ DWORD CalculateEnvironmentSpace(void);
+ LPSTR BuildEnvironmentSpace(LPSTR lpStr);
+
+protected:
+ int SetDirA(char const *pPath, int index);
+ void FromEnvA(char *pEnv, int index);
+ inline const char *GetDefaultDirA(void)
+ {
+ return dirTableA[nDefault];
+ };
+
+ inline void SetDefaultDirA(char const *pPath, int index)
+ {
+ SetDirA(pPath, index);
+ nDefault = index;
+ };
+ int SetDirW(WCHAR const *pPath, int index);
+ inline const WCHAR *GetDefaultDirW(void)
+ {
+ return dirTableW[nDefault];
+ };
+
+ inline void SetDefaultDirW(WCHAR const *pPath, int index)
+ {
+ SetDirW(pPath, index);
+ nDefault = index;
+ };
+
+ inline int DriveIndex(char chr)
+ {
+ return (chr | 0x20)-'a';
+ };
+
+ VMem *pMem;
+ int nDefault;
+ char *dirTableA[driveCount];
+ char szLocalBufferA[MAX_PATH+1];
+ WCHAR *dirTableW[driveCount];
+ WCHAR szLocalBufferW[MAX_PATH+1];
+};
+
+
+VDir::VDir()
+{
+ nDefault = 0;
+ memset(dirTableA, 0, sizeof(dirTableA));
+ memset(dirTableW, 0, sizeof(dirTableW));
+}
+
+void VDir::Init(VDir* pDir, VMem *p)
+{
+ int index;
+ DWORD driveBits;
+ char szBuffer[MAX_PATH*driveCount];
+
+ pMem = p;
+ if (pDir) {
+ for (index = 0; index < driveCount; ++index) {
+ SetDirW(pDir->GetDirW(index), index);
+ }
+ nDefault = pDir->GetDefault();
+ }
+ else {
+ driveBits = GetLogicalDrives();
+ if (GetLogicalDriveStrings(sizeof(szBuffer), szBuffer)) {
+ char* pEnv = GetEnvironmentStrings();
+ char* ptr = szBuffer;
+ for (index = 0; index < driveCount; ++index) {
+ if (driveBits & (1<<index)) {
+ ptr += SetDirA(ptr, index) + 1;
+ FromEnvA(pEnv, index);
+ }
+ }
+ FreeEnvironmentStrings(pEnv);
+ }
+ SetDefaultA(".");
+ }
+}
+
+int VDir::SetDirA(char const *pPath, int index)
+{
+ char chr, *ptr;
+ int length = 0;
+ WCHAR wBuffer[MAX_PATH+1];
+ if (index < driveCount && pPath != NULL) {
+ length = strlen(pPath);
+ pMem->Free(dirTableA[index]);
+ ptr = dirTableA[index] = (char*)pMem->Malloc(length+2);
+ if (ptr != NULL) {
+ strcpy(ptr, pPath);
+ ptr += length-1;
+ chr = *ptr++;
+ if (chr != '\\' && chr != '/') {
+ *ptr++ = '\\';
+ *ptr = '\0';
+ }
+ MultiByteToWideChar(CP_ACP, 0, dirTableA[index], -1,
+ wBuffer, (sizeof(wBuffer)/sizeof(WCHAR)));
+ length = wcslen(wBuffer);
+ pMem->Free(dirTableW[index]);
+ dirTableW[index] = (WCHAR*)pMem->Malloc((length+1)*2);
+ if (dirTableW[index] != NULL) {
+ wcscpy(dirTableW[index], wBuffer);
+ }
+ }
+ }
+ return length;
+}
+
+void VDir::FromEnvA(char *pEnv, int index)
+{ /* gets the directory for index from the environment variable. */
+ while (*pEnv != '\0') {
+ if ((pEnv[0] == '=') && (DriveIndex(pEnv[1]) == index)) {
+ SetDirA(&pEnv[4], index);
+ break;
+ }
+ else
+ pEnv += strlen(pEnv)+1;
+ }
+}
+
+void VDir::SetDefaultA(char const *pDefault)
+{
+ char szBuffer[MAX_PATH+1];
+ char *pPtr;
+
+ if (GetFullPathNameA(pDefault, sizeof(szBuffer), szBuffer, &pPtr)) {
+ if (*pDefault != '.' && pPtr != NULL)
+ *pPtr = '\0';
+
+ SetDefaultDirA(szBuffer, DriveIndex(szBuffer[0]));
+ }
+}
+
+int VDir::SetDirW(WCHAR const *pPath, int index)
+{
+ WCHAR chr, *ptr;
+ char szBuffer[MAX_PATH+1];
+ int length = 0;
+ if (index < driveCount && pPath != NULL) {
+ length = wcslen(pPath);
+ pMem->Free(dirTableW[index]);
+ ptr = dirTableW[index] = (WCHAR*)pMem->Malloc((length+2)*2);
+ if (ptr != NULL) {
+ wcscpy(ptr, pPath);
+ ptr += length-1;
+ chr = *ptr++;
+ if (chr != '\\' && chr != '/') {
+ *ptr++ = '\\';
+ *ptr = '\0';
+ }
+ WideCharToMultiByte(CP_ACP, 0, dirTableW[index], -1, szBuffer, sizeof(szBuffer), NULL, NULL);
+ length = strlen(szBuffer);
+ pMem->Free(dirTableA[index]);
+ dirTableA[index] = (char*)pMem->Malloc(length+1);
+ if (dirTableA[index] != NULL) {
+ strcpy(dirTableA[index], szBuffer);
+ }
+ }
+ }
+ return length;
+}
+
+void VDir::SetDefaultW(WCHAR const *pDefault)
+{
+ WCHAR szBuffer[MAX_PATH+1];
+ WCHAR *pPtr;
+
+ if (GetFullPathNameW(pDefault, (sizeof(szBuffer)/sizeof(WCHAR)), szBuffer, &pPtr)) {
+ if (*pDefault != '.' && pPtr != NULL)
+ *pPtr = '\0';
+
+ SetDefaultDirW(szBuffer, DriveIndex((char)szBuffer[0]));
+ }
+}
+
+inline BOOL IsPathSep(char ch)
+{
+ return (ch == '\\' || ch == '/');
+}
+
+inline void DoGetFullPathNameA(char* lpBuffer, DWORD dwSize, char* Dest)
+{
+ char *pPtr;
+
+ /*
+ * On WinNT GetFullPathName does not fail, (or at least always
+ * succeeds when the drive is valid) WinNT does set *Dest to Nullch
+ * On Win98 GetFullPathName will set last error if it fails, but
+ * does not touch *Dest
+ */
+ *Dest = '\0';
+ GetFullPathNameA(lpBuffer, dwSize, Dest, &pPtr);
+}
+
+char *VDir::MapPathA(const char *pInName)
+{ /*
+ * possiblities -- relative path or absolute path with or without drive letter
+ * OR UNC name
+ */
+ char szBuffer[(MAX_PATH+1)*2];
+ char szlBuf[MAX_PATH+1];
+
+ if (strlen(pInName) > MAX_PATH) {
+ strncpy(szlBuf, pInName, MAX_PATH);
+ if (IsPathSep(pInName[0]) && !IsPathSep(pInName[1])) {
+ /* absolute path - reduce length by 2 for drive specifier */
+ szlBuf[MAX_PATH-2] = '\0';
+ }
+ else
+ szlBuf[MAX_PATH] = '\0';
+ pInName = szlBuf;
+ }
+ /* strlen(pInName) is now <= MAX_PATH */
+
+ if (pInName[1] == ':') {
+ /* has drive letter */
+ if (IsPathSep(pInName[2])) {
+ /* absolute with drive letter */
+ strcpy(szLocalBufferA, pInName);
+ }
+ else {
+ /* relative path with drive letter */
+ strcpy(szBuffer, GetDirA(DriveIndex(*pInName)));
+ strcat(szBuffer, &pInName[2]);
+ if(strlen(szBuffer) > MAX_PATH)
+ szBuffer[MAX_PATH] = '\0';
+
+ DoGetFullPathNameA(szBuffer, sizeof(szLocalBufferA), szLocalBufferA);
+ }
+ }
+ else {
+ /* no drive letter */
+ if (IsPathSep(pInName[1]) && IsPathSep(pInName[0])) {
+ /* UNC name */
+ strcpy(szLocalBufferA, pInName);
+ }
+ else {
+ strcpy(szBuffer, GetDefaultDirA());
+ if (IsPathSep(pInName[0])) {
+ /* absolute path */
+ szLocalBufferA[0] = szBuffer[0];
+ szLocalBufferA[1] = szBuffer[1];
+ strcpy(&szLocalBufferA[2], pInName);
+ }
+ else {
+ /* relative path */
+ strcat(szBuffer, pInName);
+ if (strlen(szBuffer) > MAX_PATH)
+ szBuffer[MAX_PATH] = '\0';
+
+ DoGetFullPathNameA(szBuffer, sizeof(szLocalBufferA), szLocalBufferA);
+ }
+ }
+ }
+
+ return szLocalBufferA;
+}
+
+int VDir::SetCurrentDirectoryA(char *lpBuffer)
+{
+ HANDLE hHandle;
+ WIN32_FIND_DATA win32FD;
+ char szBuffer[MAX_PATH+1], *pPtr;
+ int nRet = -1;
+
+ GetFullPathNameA(MapPathA(lpBuffer), sizeof(szBuffer), szBuffer, &pPtr);
+
+ hHandle = FindFirstFile(szBuffer, &win32FD);
+ if (hHandle != INVALID_HANDLE_VALUE) {
+ FindClose(hHandle);
+ SetDefaultDirA(szBuffer, DriveIndex(szBuffer[0]));
+ nRet = 0;
+ }
+ return nRet;
+}
+
+int VDir::SetCurrentDirectoryW(WCHAR *lpBuffer)
+{
+ HANDLE hHandle;
+ WIN32_FIND_DATAW win32FD;
+ WCHAR szBuffer[MAX_PATH+1], *pPtr;
+ int nRet = -1;
+
+ GetFullPathNameW(MapPathW(lpBuffer), (sizeof(szBuffer)/sizeof(WCHAR)), szBuffer, &pPtr);
+
+ hHandle = FindFirstFileW(szBuffer, &win32FD);
+ if (hHandle != INVALID_HANDLE_VALUE) {
+ FindClose(hHandle);
+ SetDefaultDirW(szBuffer, DriveIndex((char)szBuffer[0]));
+ nRet = 0;
+ }
+ return nRet;
+}
+
+DWORD VDir::CalculateEnvironmentSpace(void)
+{ /* the current directory environment strings are stored as '=d=d:\path' */
+ int index;
+ DWORD dwSize = 0;
+ for (index = 0; index < driveCount; ++index) {
+ if (dirTableA[index] != NULL) {
+ dwSize += strlen(dirTableA[index]) + 4; /* add 1 for trailing NULL and 3 for '=d=' */
+ }
+ }
+ return dwSize;
+}
+
+LPSTR VDir::BuildEnvironmentSpace(LPSTR lpStr)
+{ /* store the current directory environment strings as '=d=d:\path' */
+ int index;
+ LPSTR lpDirStr;
+ for (index = 0; index < driveCount; ++index) {
+ lpDirStr = dirTableA[index];
+ if (lpDirStr != NULL) {
+ lpStr[0] = '=';
+ lpStr[1] = lpDirStr[0];
+ lpStr[2] = '=';
+ strcpy(&lpStr[3], lpDirStr);
+ lpStr += strlen(lpDirStr) + 4; /* add 1 for trailing NULL and 3 for '=d=' */
+ }
+ }
+ return lpStr;
+}
+
+inline BOOL IsPathSep(WCHAR ch)
+{
+ return (ch == '\\' || ch == '/');
+}
+
+inline void DoGetFullPathNameW(WCHAR* lpBuffer, DWORD dwSize, WCHAR* Dest)
+{
+ WCHAR *pPtr;
+
+ /*
+ * On WinNT GetFullPathName does not fail, (or at least always
+ * succeeds when the drive is valid) WinNT does set *Dest to Nullch
+ * On Win98 GetFullPathName will set last error if it fails, but
+ * does not touch *Dest
+ */
+ *Dest = '\0';
+ GetFullPathNameW(lpBuffer, dwSize, Dest, &pPtr);
+}
+
+WCHAR* VDir::MapPathW(const WCHAR *pInName)
+{ /*
+ * possiblities -- relative path or absolute path with or without drive letter
+ * OR UNC name
+ */
+ WCHAR szBuffer[(MAX_PATH+1)*2];
+ WCHAR szlBuf[MAX_PATH+1];
+
+ if (wcslen(pInName) > MAX_PATH) {
+ wcsncpy(szlBuf, pInName, MAX_PATH);
+ if (IsPathSep(pInName[0]) && !IsPathSep(pInName[1])) {
+ /* absolute path - reduce length by 2 for drive specifier */
+ szlBuf[MAX_PATH-2] = '\0';
+ }
+ else
+ szlBuf[MAX_PATH] = '\0';
+ pInName = szlBuf;
+ }
+ /* strlen(pInName) is now <= MAX_PATH */
+
+ if (pInName[1] == ':') {
+ /* has drive letter */
+ if (IsPathSep(pInName[2])) {
+ /* absolute with drive letter */
+ wcscpy(szLocalBufferW, pInName);
+ }
+ else {
+ /* relative path with drive letter */
+ wcscpy(szBuffer, GetDirW(DriveIndex((char)*pInName)));
+ wcscat(szBuffer, &pInName[2]);
+ if(wcslen(szBuffer) > MAX_PATH)
+ szBuffer[MAX_PATH] = '\0';
+
+ DoGetFullPathNameW(szBuffer, (sizeof(szLocalBufferW)/sizeof(WCHAR)), szLocalBufferW);
+ }
+ }
+ else {
+ /* no drive letter */
+ if (IsPathSep(pInName[1]) && IsPathSep(pInName[0])) {
+ /* UNC name */
+ wcscpy(szLocalBufferW, pInName);
+ }
+ else {
+ wcscpy(szBuffer, GetDefaultDirW());
+ if (IsPathSep(pInName[0])) {
+ /* absolute path */
+ szLocalBufferW[0] = szBuffer[0];
+ szLocalBufferW[1] = szBuffer[1];
+ wcscpy(&szLocalBufferW[2], pInName);
+ }
+ else {
+ /* relative path */
+ wcscat(szBuffer, pInName);
+ if (wcslen(szBuffer) > MAX_PATH)
+ szBuffer[MAX_PATH] = '\0';
+
+ DoGetFullPathNameW(szBuffer, (sizeof(szLocalBufferW)/sizeof(WCHAR)), szLocalBufferW);
+ }
+ }
+ }
+ return szLocalBufferW;
+}
+
+
+#endif /* ___VDir_H___ */
diff --git a/win32/vmem.h b/win32/vmem.h
new file mode 100644
index 0000000..cf3f502
--- /dev/null
+++ b/win32/vmem.h
@@ -0,0 +1,703 @@
+/* vmem.h
+ *
+ * (c) 1999 Microsoft Corporation. All rights reserved.
+ * Portions (c) 1999 ActiveState Tool Corp, http://www.ActiveState.com/
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ *
+ * Knuth's boundary tag algorithm Vol #1, Page 440.
+ *
+ * Each block in the heap has tag words before and after it,
+ * TAG
+ * block
+ * TAG
+ * The size is stored in these tags as a long word, and includes the 8 bytes
+ * of overhead that the boundary tags consume. Blocks are allocated on long
+ * word boundaries, so the size is always multiples of long words. When the
+ * block is allocated, bit 0, (the tag bit), of the size is set to 1. When
+ * a block is freed, it is merged with adjacent free blocks, and the tag bit
+ * is set to 0.
+ *
+ * A linked list is used to manage the free list. The first two long words of
+ * the block contain double links. These links are only valid when the block
+ * is freed, therefore space needs to be reserved for them. Thus, the minimum
+ * block size (not counting the tags) is 8 bytes.
+ *
+ * Since memory allocation may occur on a single threaded, explict locks are
+ * provided.
+ *
+ */
+
+#ifndef ___VMEM_H_INC___
+#define ___VMEM_H_INC___
+
+const long lAllocStart = 0x00010000; /* start at 64K */
+const long minBlockSize = sizeof(void*)*2;
+const long sizeofTag = sizeof(long);
+const long blockOverhead = sizeofTag*2;
+const long minAllocSize = minBlockSize+blockOverhead;
+
+typedef BYTE* PBLOCK; /* pointer to a memory block */
+
+/*
+ * Macros for accessing hidden fields in a memory block:
+ *
+ * SIZE size of this block (tag bit 0 is 1 if block is allocated)
+ * PSIZE size of previous physical block
+ */
+
+#define SIZE(block) (*(ULONG*)(((PBLOCK)(block))-sizeofTag))
+#define PSIZE(block) (*(ULONG*)(((PBLOCK)(block))-(sizeofTag*2)))
+inline void SetTags(PBLOCK block, long size)
+{
+ SIZE(block) = size;
+ PSIZE(block+(size&~1)) = size;
+}
+
+/*
+ * Free list pointers
+ * PREV pointer to previous block
+ * NEXT pointer to next block
+ */
+
+#define PREV(block) (*(PBLOCK*)(block))
+#define NEXT(block) (*(PBLOCK*)((block)+sizeof(PBLOCK)))
+inline void SetLink(PBLOCK block, PBLOCK prev, PBLOCK next)
+{
+ PREV(block) = prev;
+ NEXT(block) = next;
+}
+inline void Unlink(PBLOCK p)
+{
+ PBLOCK next = NEXT(p);
+ PBLOCK prev = PREV(p);
+ NEXT(prev) = next;
+ PREV(next) = prev;
+}
+inline void AddToFreeList(PBLOCK block, PBLOCK pInList)
+{
+ PBLOCK next = NEXT(pInList);
+ NEXT(pInList) = block;
+ SetLink(block, pInList, next);
+ PREV(next) = block;
+}
+
+
+/* Macro for rounding up to the next sizeof(long) */
+#define ROUND_UP(n) (((ULONG)(n)+sizeof(long)-1)&~(sizeof(long)-1))
+#define ROUND_UP64K(n) (((ULONG)(n)+0x10000-1)&~(0x10000-1))
+#define ROUND_DOWN(n) ((ULONG)(n)&~(sizeof(long)-1))
+
+/*
+ * HeapRec - a list of all non-contiguous heap areas
+ *
+ * Each record in this array contains information about a non-contiguous heap area.
+ */
+
+const int maxHeaps = 64;
+const long lAllocMax = 0x80000000; /* max size of allocation */
+
+typedef struct _HeapRec
+{
+ PBLOCK base; /* base of heap area */
+ ULONG len; /* size of heap area */
+} HeapRec;
+
+
+class VMem
+{
+public:
+ VMem();
+ ~VMem();
+ virtual void* Malloc(size_t size);
+ virtual void* Realloc(void* pMem, size_t size);
+ virtual void Free(void* pMem);
+ virtual void GetLock(void);
+ virtual void FreeLock(void);
+ virtual int IsLocked(void);
+ virtual long Release(void);
+ virtual long AddRef(void);
+
+ inline BOOL CreateOk(void)
+ {
+ return m_hHeap != NULL;
+ };
+
+ void ReInit(void);
+
+protected:
+ void Init(void);
+ int Getmem(size_t size);
+ int HeapAdd(void* ptr, size_t size);
+ void* Expand(void* block, size_t size);
+ void WalkHeap(void);
+
+ HANDLE m_hHeap; // memory heap for this script
+ char m_FreeDummy[minAllocSize]; // dummy free block
+ PBLOCK m_pFreeList; // pointer to first block on free list
+ PBLOCK m_pRover; // roving pointer into the free list
+ HeapRec m_heaps[maxHeaps]; // list of all non-contiguous heap areas
+ int m_nHeaps; // no. of heaps in m_heaps
+ long m_lAllocSize; // current alloc size
+ long m_lRefCount; // number of current users
+ CRITICAL_SECTION m_cs; // access lock
+};
+
+// #define _DEBUG_MEM
+#ifdef _DEBUG_MEM
+#define ASSERT(f) if(!(f)) DebugBreak();
+
+inline void MEMODS(char *str)
+{
+ OutputDebugString(str);
+ OutputDebugString("\n");
+}
+
+inline void MEMODSlx(char *str, long x)
+{
+ char szBuffer[512];
+ sprintf(szBuffer, "%s %lx\n", str, x);
+ OutputDebugString(szBuffer);
+}
+
+#define WALKHEAP() WalkHeap()
+#define WALKHEAPTRACE() m_pRover = NULL; WalkHeap()
+
+#else
+
+#define ASSERT(f)
+#define MEMODS(x)
+#define MEMODSlx(x, y)
+#define WALKHEAP()
+#define WALKHEAPTRACE()
+
+#endif
+
+
+VMem::VMem()
+{
+ m_lRefCount = 1;
+ BOOL bRet = (NULL != (m_hHeap = HeapCreate(HEAP_NO_SERIALIZE,
+ lAllocStart, /* initial size of heap */
+ 0))); /* no upper limit on size of heap */
+ ASSERT(bRet);
+
+ InitializeCriticalSection(&m_cs);
+
+ Init();
+}
+
+VMem::~VMem(void)
+{
+ ASSERT(HeapValidate(m_hHeap, HEAP_NO_SERIALIZE, NULL));
+ WALKHEAPTRACE();
+ DeleteCriticalSection(&m_cs);
+ BOOL bRet = HeapDestroy(m_hHeap);
+ ASSERT(bRet);
+}
+
+void VMem::ReInit(void)
+{
+ for(int index = 0; index < m_nHeaps; ++index)
+ HeapFree(m_hHeap, HEAP_NO_SERIALIZE, m_heaps[index].base);
+
+ Init();
+}
+
+void VMem::Init(void)
+{ /*
+ * Initialize the free list by placing a dummy zero-length block on it.
+ * Set the number of non-contiguous heaps to zero.
+ */
+ m_pFreeList = m_pRover = (PBLOCK)(&m_FreeDummy[minBlockSize]);
+ PSIZE(m_pFreeList) = SIZE(m_pFreeList) = 0;
+ PREV(m_pFreeList) = NEXT(m_pFreeList) = m_pFreeList;
+
+ m_nHeaps = 0;
+ m_lAllocSize = lAllocStart;
+}
+
+void* VMem::Malloc(size_t size)
+{
+ WALKHEAP();
+
+ /*
+ * Adjust the real size of the block to be a multiple of sizeof(long), and add
+ * the overhead for the boundary tags. Disallow negative or zero sizes.
+ */
+ size_t realsize = (size < blockOverhead) ? minAllocSize : (size_t)ROUND_UP(size) + minBlockSize;
+ if((int)realsize < minAllocSize || size == 0)
+ return NULL;
+
+ /*
+ * Start searching the free list at the rover. If we arrive back at rover without
+ * finding anything, allocate some memory from the heap and try again.
+ */
+ PBLOCK ptr = m_pRover; /* start searching at rover */
+ int loops = 2; /* allow two times through the loop */
+ for(;;) {
+ size_t lsize = SIZE(ptr);
+ ASSERT((lsize&1)==0);
+ /* is block big enough? */
+ if(lsize >= realsize) {
+ /* if the remainder is too small, don't bother splitting the block. */
+ size_t rem = lsize - realsize;
+ if(rem < minAllocSize) {
+ if(m_pRover == ptr)
+ m_pRover = NEXT(ptr);
+
+ /* Unlink the block from the free list. */
+ Unlink(ptr);
+ }
+ else {
+ /*
+ * split the block
+ * The remainder is big enough to split off into a new block.
+ * Use the end of the block, resize the beginning of the block
+ * no need to change the free list.
+ */
+ SetTags(ptr, rem);
+ ptr += SIZE(ptr);
+ lsize = realsize;
+ }
+ /* Set the boundary tags to mark it as allocated. */
+ SetTags(ptr, lsize | 1);
+ return ((void *)ptr);
+ }
+
+ /*
+ * This block was unsuitable. If we've gone through this list once already without
+ * finding anything, allocate some new memory from the heap and try again.
+ */
+ ptr = NEXT(ptr);
+ if(ptr == m_pRover) {
+ if(!(loops-- && Getmem(realsize))) {
+ return NULL;
+ }
+ ptr = m_pRover;
+ }
+ }
+}
+
+void* VMem::Realloc(void* block, size_t size)
+{
+ WALKHEAP();
+
+ /* if size is zero, free the block. */
+ if(size == 0) {
+ Free(block);
+ return (NULL);
+ }
+
+ /* if block pointer is NULL, do a Malloc(). */
+ if(block == NULL)
+ return Malloc(size);
+
+ /*
+ * Grow or shrink the block in place.
+ * if the block grows then the next block will be used if free
+ */
+ if(Expand(block, size) != NULL)
+ return block;
+
+ /*
+ * adjust the real size of the block to be a multiple of sizeof(long), and add the
+ * overhead for the boundary tags. Disallow negative or zero sizes.
+ */
+ size_t realsize = (size < blockOverhead) ? minAllocSize : (size_t)ROUND_UP(size) + minBlockSize;
+ if((int)realsize < minAllocSize)
+ return NULL;
+
+ /*
+ * see if the previous block is free, and is it big enough to cover the new size
+ * if merged with the current block.
+ */
+ PBLOCK ptr = (PBLOCK)block;
+ size_t cursize = SIZE(ptr) & ~1;
+ size_t psize = PSIZE(ptr);
+ if((psize&1) == 0 && (psize + cursize) >= realsize) {
+ PBLOCK prev = ptr - psize;
+ if(m_pRover == prev)
+ m_pRover = NEXT(prev);
+
+ /* Unlink the next block from the free list. */
+ Unlink(prev);
+
+ /* Copy contents of old block to new location, make it the current block. */
+ memmove(prev, ptr, cursize);
+ cursize += psize; /* combine sizes */
+ ptr = prev;
+
+ size_t rem = cursize - realsize;
+ if(rem >= minAllocSize) {
+ /*
+ * The remainder is big enough to be a new block. Set boundary
+ * tags for the resized block and the new block.
+ */
+ prev = ptr + realsize;
+ /*
+ * add the new block to the free list.
+ * next block cannot be free
+ */
+ SetTags(prev, rem);
+ AddToFreeList(prev, m_pFreeList);
+ cursize = realsize;
+ }
+ /* Set the boundary tags to mark it as allocated. */
+ SetTags(ptr, cursize | 1);
+ return ((void *)ptr);
+ }
+
+ /* Allocate a new block, copy the old to the new, and free the old. */
+ if((ptr = (PBLOCK)Malloc(size)) != NULL) {
+ memmove(ptr, block, cursize-minBlockSize);
+ Free(block);
+ }
+ return ((void *)ptr);
+}
+
+void VMem::Free(void* p)
+{
+ WALKHEAP();
+
+ /* Ignore null pointer. */
+ if(p == NULL)
+ return;
+
+ PBLOCK ptr = (PBLOCK)p;
+
+ /* Check for attempt to free a block that's already free. */
+ size_t size = SIZE(ptr);
+ if((size&1) == 0) {
+ MEMODSlx("Attempt to free previously freed block", (long)p);
+ return;
+ }
+ size &= ~1; /* remove allocated tag */
+
+ /* if previous block is free, add this block to it. */
+ int linked = FALSE;
+ size_t psize = PSIZE(ptr);
+ if((psize&1) == 0) {
+ ptr -= psize; /* point to previous block */
+ size += psize; /* merge the sizes of the two blocks */
+ linked = TRUE; /* it's already on the free list */
+ }
+
+ /* if the next physical block is free, merge it with this block. */
+ PBLOCK next = ptr + size; /* point to next physical block */
+ size_t nsize = SIZE(next);
+ if((nsize&1) == 0) {
+ /* block is free move rover if needed */
+ if(m_pRover == next)
+ m_pRover = NEXT(next);
+
+ /* unlink the next block from the free list. */
+ Unlink(next);
+
+ /* merge the sizes of this block and the next block. */
+ size += nsize;
+ }
+
+ /* Set the boundary tags for the block; */
+ SetTags(ptr, size);
+
+ /* Link the block to the head of the free list. */
+ if(!linked) {
+ AddToFreeList(ptr, m_pFreeList);
+ }
+}
+
+void VMem::GetLock(void)
+{
+ EnterCriticalSection(&m_cs);
+}
+
+void VMem::FreeLock(void)
+{
+ LeaveCriticalSection(&m_cs);
+}
+
+int VMem::IsLocked(void)
+{
+ BOOL bAccessed = TryEnterCriticalSection(&m_cs);
+ if(bAccessed) {
+ LeaveCriticalSection(&m_cs);
+ }
+ return !bAccessed;
+}
+
+
+long VMem::Release(void)
+{
+ long lCount = InterlockedDecrement(&m_lRefCount);
+ if(!lCount)
+ delete this;
+ return lCount;
+}
+
+long VMem::AddRef(void)
+{
+ long lCount = InterlockedIncrement(&m_lRefCount);
+ return lCount;
+}
+
+
+int VMem::Getmem(size_t requestSize)
+{ /* returns -1 is successful 0 if not */
+ void *ptr;
+
+ /* Round up size to next multiple of 64K. */
+ size_t size = (size_t)ROUND_UP64K(requestSize);
+
+ /*
+ * if the size requested is smaller than our current allocation size
+ * adjust up
+ */
+ if(size < (unsigned long)m_lAllocSize)
+ size = m_lAllocSize;
+
+ /* Update the size to allocate on the next request */
+ if(m_lAllocSize != lAllocMax)
+ m_lAllocSize <<= 1;
+
+ if(m_nHeaps != 0) {
+ /* Expand the last allocated heap */
+ ptr = HeapReAlloc(m_hHeap, HEAP_REALLOC_IN_PLACE_ONLY|HEAP_ZERO_MEMORY|HEAP_NO_SERIALIZE,
+ m_heaps[m_nHeaps-1].base,
+ m_heaps[m_nHeaps-1].len + size);
+ if(ptr != 0) {
+ HeapAdd(((char*)ptr) + m_heaps[m_nHeaps-1].len, size);
+ return -1;
+ }
+ }
+
+ /*
+ * if we didn't expand a block to cover the requested size
+ * allocate a new Heap
+ * the size of this block must include the additional dummy tags at either end
+ * the above ROUND_UP64K may not have added any memory to include this.
+ */
+ if(size == requestSize)
+ size = (size_t)ROUND_UP64K(requestSize+(sizeofTag*2));
+
+ ptr = HeapAlloc(m_hHeap, HEAP_ZERO_MEMORY|HEAP_NO_SERIALIZE, size);
+ if(ptr == 0) {
+ MEMODSlx("HeapAlloc failed on size!!!", size);
+ return 0;
+ }
+
+ HeapAdd(ptr, size);
+ return -1;
+}
+
+int VMem::HeapAdd(void *p, size_t size)
+{ /* if the block can be succesfully added to the heap, returns 0; otherwise -1. */
+ int index;
+
+ /* Check size, then round size down to next long word boundary. */
+ if(size < minAllocSize)
+ return -1;
+
+ size = (size_t)ROUND_DOWN(size);
+ PBLOCK ptr = (PBLOCK)p;
+
+ /*
+ * Search for another heap area that's contiguous with the bottom of this new area.
+ * (It should be extremely unusual to find one that's contiguous with the top).
+ */
+ for(index = 0; index < m_nHeaps; ++index) {
+ if(ptr == m_heaps[index].base + (int)m_heaps[index].len) {
+ /*
+ * The new block is contiguous with a previously allocated heap area. Add its
+ * length to that of the previous heap. Merge it with the the dummy end-of-heap
+ * area marker of the previous heap.
+ */
+ m_heaps[index].len += size;
+ break;
+ }
+ }
+
+ if(index == m_nHeaps) {
+ /* The new block is not contiguous. Add it to the heap list. */
+ if(m_nHeaps == maxHeaps) {
+ return -1; /* too many non-contiguous heaps */
+ }
+ m_heaps[m_nHeaps].base = ptr;
+ m_heaps[m_nHeaps].len = size;
+ m_nHeaps++;
+
+ /*
+ * Reserve the first LONG in the block for the ending boundary tag of a dummy
+ * block at the start of the heap area.
+ */
+ size -= minBlockSize;
+ ptr += minBlockSize;
+ PSIZE(ptr) = 1; /* mark the dummy previous block as allocated */
+ }
+
+ /*
+ * Convert the heap to one large block. Set up its boundary tags, and those of
+ * marker block after it. The marker block before the heap will already have
+ * been set up if this heap is not contiguous with the end of another heap.
+ */
+ SetTags(ptr, size | 1);
+ PBLOCK next = ptr + size; /* point to dummy end block */
+ SIZE(next) = 1; /* mark the dummy end block as allocated */
+
+ /*
+ * Link the block to the start of the free list by calling free().
+ * This will merge the block with any adjacent free blocks.
+ */
+ Free(ptr);
+ return 0;
+}
+
+
+void* VMem::Expand(void* block, size_t size)
+{
+ /*
+ * Adjust the size of the block to be a multiple of sizeof(long), and add the
+ * overhead for the boundary tags. Disallow negative or zero sizes.
+ */
+ size_t realsize = (size < blockOverhead) ? minAllocSize : (size_t)ROUND_UP(size) + minBlockSize;
+ if((int)realsize < minAllocSize || size == 0)
+ return NULL;
+
+ PBLOCK ptr = (PBLOCK)block;
+
+ /* if the current size is the same as requested, do nothing. */
+ size_t cursize = SIZE(ptr) & ~1;
+ if(cursize == realsize) {
+ return block;
+ }
+
+ /* if the block is being shrunk, convert the remainder of the block into a new free block. */
+ if(realsize <= cursize) {
+ size_t nextsize = cursize - realsize; /* size of new remainder block */
+ if(nextsize >= minAllocSize) {
+ /*
+ * Split the block
+ * Set boundary tags for the resized block and the new block.
+ */
+ SetTags(ptr, realsize | 1);
+ ptr += realsize;
+
+ /*
+ * add the new block to the free list.
+ * call Free to merge this block with next block if free
+ */
+ SetTags(ptr, nextsize | 1);
+ Free(ptr);
+ }
+
+ return block;
+ }
+
+ PBLOCK next = ptr + cursize;
+ size_t nextsize = SIZE(next);
+
+ /* Check the next block for consistency.*/
+ if((nextsize&1) == 0 && (nextsize + cursize) >= realsize) {
+ /*
+ * The next block is free and big enough. Add the part that's needed
+ * to our block, and split the remainder off into a new block.
+ */
+ if(m_pRover == next)
+ m_pRover = NEXT(next);
+
+ /* Unlink the next block from the free list. */
+ Unlink(next);
+ cursize += nextsize; /* combine sizes */
+
+ size_t rem = cursize - realsize; /* size of remainder */
+ if(rem >= minAllocSize) {
+ /*
+ * The remainder is big enough to be a new block.
+ * Set boundary tags for the resized block and the new block.
+ */
+ next = ptr + realsize;
+ /*
+ * add the new block to the free list.
+ * next block cannot be free
+ */
+ SetTags(next, rem);
+ AddToFreeList(next, m_pFreeList);
+ cursize = realsize;
+ }
+ /* Set the boundary tags to mark it as allocated. */
+ SetTags(ptr, cursize | 1);
+ return ((void *)ptr);
+ }
+ return NULL;
+}
+
+#ifdef _DEBUG_MEM
+#define LOG_FILENAME "P:\\Apps\\Perl\\Result.txt"
+
+void MemoryUsageMessage(char *str, long x, long y, int c)
+{
+ static FILE* fp = NULL;
+ char szBuffer[512];
+ if(str) {
+ if(!fp)
+ fp = fopen(LOG_FILENAME, "w");
+ sprintf(szBuffer, str, x, y, c);
+ fputs(szBuffer, fp);
+ }
+ else {
+ fflush(fp);
+ fclose(fp);
+ }
+}
+
+void VMem::WalkHeap(void)
+{
+ if(!m_pRover) {
+ MemoryUsageMessage("VMem heaps used %d\n", m_nHeaps, 0, 0);
+ }
+
+ /* Walk all the heaps - verify structures */
+ for(int index = 0; index < m_nHeaps; ++index) {
+ PBLOCK ptr = m_heaps[index].base;
+ size_t size = m_heaps[index].len;
+ ASSERT(HeapValidate(m_hHeap, HEAP_NO_SERIALIZE, p));
+
+ /* set over reserved header block */
+ size -= minBlockSize;
+ ptr += minBlockSize;
+ PBLOCK pLast = ptr + size;
+ ASSERT(PSIZE(ptr) == 1); /* dummy previous block is allocated */
+ ASSERT(SIZE(pLast) == 1); /* dummy next block is allocated */
+ while(ptr < pLast) {
+ ASSERT(ptr > m_heaps[index].base);
+ size_t cursize = SIZE(ptr) & ~1;
+ ASSERT((PSIZE(ptr+cursize) & ~1) == cursize);
+ if(!m_pRover) {
+ MemoryUsageMessage("Memory Block %08x: Size %08x %c\n", (long)ptr, cursize, (SIZE(p)&1) ? 'x' : ' ');
+ }
+ if(!(SIZE(ptr)&1)) {
+ /* this block is on the free list */
+ PBLOCK tmp = NEXT(ptr);
+ while(tmp != ptr) {
+ ASSERT((SIZE(tmp)&1)==0);
+ if(tmp == m_pFreeList)
+ break;
+ ASSERT(NEXT(tmp));
+ tmp = NEXT(tmp);
+ }
+ if(tmp == ptr) {
+ MemoryUsageMessage("Memory Block %08x: Size %08x free but not in free list\n", (long)ptr, cursize, 0);
+ }
+ }
+ ptr += cursize;
+ }
+ }
+ if(!m_pRover) {
+ MemoryUsageMessage(NULL, 0, 0, 0);
+ }
+}
+#endif
+
+#endif /* ___VMEM_H_INC___ */
diff --git a/win32/win32.c b/win32/win32.c
index 6566f9a..4c13d4a 100644
--- a/win32/win32.c
+++ b/win32/win32.c
@@ -95,11 +95,20 @@ static char * get_emd_part(SV **leading, char *trailing, ...);
static void remove_dead_process(long deceased);
static long find_pid(int pid);
static char * qualified_path(const char *cmd);
+#ifdef USE_ITHREADS
+static void remove_dead_pseudo_process(long child);
+static long find_pseudo_pid(int pid);
+#endif
+START_EXTERN_C
HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
char w32_module_name[MAX_PATH+1];
+END_EXTERN_C
+
static DWORD w32_platform = (DWORD)-1;
+#define ONE_K_BUFSIZE 1024
+
int
IsWin95(void)
{
@@ -349,17 +358,17 @@ PerlIO *
Perl_my_popen(pTHX_ char *cmd, char *mode)
{
#ifdef FIXCMD
-#define fixcmd(x) { \
- char *pspace = strchr((x),' '); \
- if (pspace) { \
- char *p = (x); \
- while (p < pspace) { \
- if (*p == '/') \
- *p = '\\'; \
- p++; \
- } \
- } \
- }
+#define fixcmd(x) { \
+ char *pspace = strchr((x),' '); \
+ if (pspace) { \
+ char *p = (x); \
+ while (p < pspace) { \
+ if (*p == '/') \
+ *p = '\\'; \
+ p++; \
+ } \
+ } \
+ }
#else
#define fixcmd(x)
#endif
@@ -389,6 +398,17 @@ win32_os_id(void)
return (unsigned long)w32_platform;
}
+DllExport int
+win32_getpid(void)
+{
+#ifdef USE_ITHREADS
+ dTHXo;
+ if (w32_pseudo_id)
+ return -((int)w32_pseudo_id);
+#endif
+ return _getpid();
+}
+
/* Tokenize a string. Words are null-separated, and the list
* ends with a doubled null. Any character (except null and
* including backslash) may be escaped by preceding it with a
@@ -685,10 +705,10 @@ win32_opendir(char *filename)
/* do the FindFirstFile call */
if (USING_WIDE()) {
A2WHELPER(scanname, wbuffer, sizeof(wbuffer));
- fh = FindFirstFileW(wbuffer, &wFindData);
+ fh = FindFirstFileW(PerlDir_mapW(wbuffer), &wFindData);
}
else {
- fh = FindFirstFileA(scanname, &aFindData);
+ fh = FindFirstFileA(PerlDir_mapA(scanname), &aFindData);
}
dirp->handle = fh;
if (fh == INVALID_HANDLE_VALUE) {
@@ -911,8 +931,8 @@ static long
find_pid(int pid)
{
dTHXo;
- long child;
- for (child = 0 ; child < w32_num_children ; ++child) {
+ long child = w32_num_children;
+ while (--child >= 0) {
if (w32_child_pids[child] == pid)
return child;
}
@@ -933,18 +953,72 @@ remove_dead_process(long child)
}
}
+#ifdef USE_ITHREADS
+static long
+find_pseudo_pid(int pid)
+{
+ dTHXo;
+ long child = w32_num_pseudo_children;
+ while (--child >= 0) {
+ if (w32_pseudo_child_pids[child] == pid)
+ return child;
+ }
+ return -1;
+}
+
+static void
+remove_dead_pseudo_process(long child)
+{
+ if (child >= 0) {
+ dTHXo;
+ CloseHandle(w32_pseudo_child_handles[child]);
+ Copy(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child],
+ (w32_num_pseudo_children-child-1), HANDLE);
+ Copy(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child],
+ (w32_num_pseudo_children-child-1), DWORD);
+ w32_num_pseudo_children--;
+ }
+}
+#endif
+
DllExport int
win32_kill(int pid, int sig)
{
+ dTHXo;
HANDLE hProcess;
- hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE, pid);
- if (hProcess && TerminateProcess(hProcess, sig))
- CloseHandle(hProcess);
- else {
- errno = EINVAL;
- return -1;
+#ifdef USE_ITHREADS
+ if (pid < 0) {
+ /* it is a pseudo-forked child */
+ long child = find_pseudo_pid(-pid);
+ if (child >= 0) {
+ hProcess = w32_pseudo_child_handles[child];
+ if (TerminateThread(hProcess, sig)) {
+ remove_dead_pseudo_process(child);
+ return 0;
+ }
+ }
}
- return 0;
+ else
+#endif
+ {
+ long child = find_pid(pid);
+ if (child >= 0) {
+ hProcess = w32_child_handles[child];
+ if (TerminateProcess(hProcess, sig)) {
+ remove_dead_process(child);
+ return 0;
+ }
+ }
+ else {
+ hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE, pid);
+ if (hProcess && TerminateProcess(hProcess, sig)) {
+ CloseHandle(hProcess);
+ return 0;
+ }
+ }
+ }
+ errno = EINVAL;
+ return -1;
}
/*
@@ -995,9 +1069,11 @@ win32_stat(const char *path, struct stat *buffer)
/* This also gives us an opportunity to determine the number of links. */
if (USING_WIDE()) {
A2WHELPER(path, wbuffer, sizeof(wbuffer));
+ wcscpy(wbuffer, PerlDir_mapW(wbuffer));
handle = CreateFileW(wbuffer, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
}
else {
+ path = PerlDir_mapA(path);
handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
}
if (handle != INVALID_HANDLE_VALUE) {
@@ -1007,10 +1083,13 @@ win32_stat(const char *path, struct stat *buffer)
CloseHandle(handle);
}
- if (USING_WIDE())
+ /* wbuffer or path will be mapped correctly above */
+ if (USING_WIDE()) {
res = _wstat(wbuffer, (struct _stat *)buffer);
- else
+ }
+ else {
res = stat(path, buffer);
+ }
buffer->st_nlink = nlink;
if (res < 0) {
@@ -1213,9 +1292,9 @@ win32_putenv(const char *name)
New(1309,wCuritem,length,WCHAR);
A2WHELPER(name, wCuritem, length*sizeof(WCHAR));
wVal = wcschr(wCuritem, '=');
- if(wVal) {
+ if (wVal) {
*wVal++ = '\0';
- if(SetEnvironmentVariableW(wCuritem, *wVal ? wVal : NULL))
+ if (SetEnvironmentVariableW(wCuritem, *wVal ? wVal : NULL))
relval = 0;
}
Safefree(wCuritem);
@@ -1224,7 +1303,7 @@ win32_putenv(const char *name)
New(1309,curitem,strlen(name)+1,char);
strcpy(curitem, name);
val = strchr(curitem, '=');
- if(val) {
+ if (val) {
/* The sane way to deal with the environment.
* Has these advantages over putenv() & co.:
* * enables us to store a truly empty value in the
@@ -1240,7 +1319,7 @@ win32_putenv(const char *name)
* GSAR 97-06-07
*/
*val++ = '\0';
- if(SetEnvironmentVariableA(curitem, *val ? val : NULL))
+ if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
relval = 0;
}
Safefree(curitem);
@@ -1254,11 +1333,11 @@ win32_putenv(const char *name)
static long
filetime_to_clock(PFILETIME ft)
{
- __int64 qw = ft->dwHighDateTime;
- qw <<= 32;
- qw |= ft->dwLowDateTime;
- qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
- return (long) qw;
+ __int64 qw = ft->dwHighDateTime;
+ qw <<= 32;
+ qw |= ft->dwLowDateTime;
+ qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
+ return (long) qw;
}
DllExport int
@@ -1309,6 +1388,43 @@ filetime_from_time(PFILETIME pFileTime, time_t Time)
}
DllExport int
+win32_unlink(const char *filename)
+{
+ dTHXo;
+ int ret;
+ DWORD attrs;
+
+ if (USING_WIDE()) {
+ WCHAR wBuffer[MAX_PATH];
+
+ A2WHELPER(filename, wBuffer, sizeof(wBuffer));
+ wcscpy(wBuffer, PerlDir_mapW(wBuffer));
+ attrs = GetFileAttributesW(wBuffer);
+ if (attrs & FILE_ATTRIBUTE_READONLY) {
+ (void)SetFileAttributesW(wBuffer, attrs & ~FILE_ATTRIBUTE_READONLY);
+ ret = _wunlink(wBuffer);
+ if (ret == -1)
+ (void)SetFileAttributesW(wBuffer, attrs);
+ }
+ else
+ ret = _wunlink(wBuffer);
+ }
+ else {
+ filename = PerlDir_mapA(filename);
+ attrs = GetFileAttributesA(filename);
+ if (attrs & FILE_ATTRIBUTE_READONLY) {
+ (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
+ ret = unlink(filename);
+ if (ret == -1)
+ (void)SetFileAttributesA(filename, attrs);
+ }
+ else
+ ret = unlink(filename);
+ }
+ return ret;
+}
+
+DllExport int
win32_utime(const char *filename, struct utimbuf *times)
{
dTHXo;
@@ -1322,9 +1438,11 @@ win32_utime(const char *filename, struct utimbuf *times)
int rc;
if (USING_WIDE()) {
A2WHELPER(filename, wbuffer, sizeof(wbuffer));
+ wcscpy(wbuffer, PerlDir_mapW(wbuffer));
rc = _wutime(wbuffer, (struct _utimbuf*)times);
}
else {
+ filename = PerlDir_mapA(filename);
rc = utime(filename, times);
}
/* EACCES: path specifies directory or readonly file */
@@ -1458,8 +1576,27 @@ win32_waitpid(int pid, int *status, int flags)
{
dTHXo;
int retval = -1;
- if (pid == -1)
+ if (pid == -1) /* XXX threadid == 1 ? */
return win32_wait(status);
+#ifdef USE_ITHREADS
+ else if (pid < 0) {
+ long child = find_pseudo_pid(-pid);
+ if (child >= 0) {
+ HANDLE hThread = w32_pseudo_child_handles[child];
+ DWORD waitcode = WaitForSingleObject(hThread, INFINITE);
+ if (waitcode != WAIT_FAILED) {
+ if (GetExitCodeThread(hThread, &waitcode)) {
+ *status = (int)((waitcode & 0xff) << 8);
+ retval = (int)w32_pseudo_child_pids[child];
+ remove_dead_pseudo_process(child);
+ return retval;
+ }
+ }
+ else
+ errno = ECHILD;
+ }
+ }
+#endif
else {
long child = find_pid(pid);
if (child >= 0) {
@@ -1498,6 +1635,28 @@ win32_wait(int *status)
int i, retval;
DWORD exitcode, waitcode;
+#ifdef USE_ITHREADS
+ if (w32_num_pseudo_children) {
+ waitcode = WaitForMultipleObjects(w32_num_pseudo_children,
+ w32_pseudo_child_handles,
+ FALSE,
+ INFINITE);
+ if (waitcode != WAIT_FAILED) {
+ if (waitcode >= WAIT_ABANDONED_0
+ && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
+ i = waitcode - WAIT_ABANDONED_0;
+ else
+ i = waitcode - WAIT_OBJECT_0;
+ if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
+ *status = (int)((exitcode & 0xff) << 8);
+ retval = (int)w32_pseudo_child_pids[i];
+ remove_dead_pseudo_process(i);
+ return retval;
+ }
+ }
+ }
+#endif
+
if (!w32_num_children) {
errno = ECHILD;
return -1;
@@ -1903,9 +2062,9 @@ win32_fopen(const char *filename, const char *mode)
if (USING_WIDE()) {
A2WHELPER(mode, wMode, sizeof(wMode));
A2WHELPER(filename, wBuffer, sizeof(wBuffer));
- return _wfopen(wBuffer, wMode);
+ return _wfopen(PerlDir_mapW(wBuffer), wMode);
}
- return fopen(filename, mode);
+ return fopen(PerlDir_mapA(filename), mode);
}
#ifndef USE_SOCKETS_AS_HANDLES
@@ -1936,9 +2095,9 @@ win32_freopen(const char *path, const char *mode, FILE *stream)
if (USING_WIDE()) {
A2WHELPER(mode, wMode, sizeof(wMode));
A2WHELPER(path, wBuffer, sizeof(wBuffer));
- return _wfreopen(wBuffer, wMode, stream);
+ return _wfreopen(PerlDir_mapW(wBuffer), wMode, stream);
}
- return freopen(path, mode, stream);
+ return freopen(PerlDir_mapA(path), mode, stream);
}
DllExport int
@@ -2244,7 +2403,8 @@ win32_link(const char *oldname, const char *newname)
if ((A2WHELPER(oldname, wOldName, sizeof(wOldName))) &&
(A2WHELPER(newname, wNewName, sizeof(wNewName))) &&
- pfnCreateHardLinkW(wNewName, wOldName, NULL))
+ (wcscpy(wOldName, PerlDir_mapW(wOldName)),
+ pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
{
return 0;
}
@@ -2257,6 +2417,7 @@ win32_rename(const char *oname, const char *newname)
{
WCHAR wOldName[MAX_PATH];
WCHAR wNewName[MAX_PATH];
+ char szOldName[MAX_PATH];
BOOL bResult;
/* XXX despite what the documentation says about MoveFileEx(),
* it doesn't work under Windows95!
@@ -2266,11 +2427,13 @@ win32_rename(const char *oname, const char *newname)
if (USING_WIDE()) {
A2WHELPER(oname, wOldName, sizeof(wOldName));
A2WHELPER(newname, wNewName, sizeof(wNewName));
- bResult = MoveFileExW(wOldName,wNewName,
+ wcscpy(wOldName, PerlDir_mapW(wOldName));
+ bResult = MoveFileExW(wOldName,PerlDir_mapW(wNewName),
MOVEFILE_COPY_ALLOWED|MOVEFILE_REPLACE_EXISTING);
}
else {
- bResult = MoveFileExA(oname,newname,
+ strcpy(szOldName, PerlDir_mapA(szOldName));
+ bResult = MoveFileExA(szOldName,PerlDir_mapA(newname),
MOVEFILE_COPY_ALLOWED|MOVEFILE_REPLACE_EXISTING);
}
if (!bResult) {
@@ -2401,9 +2564,9 @@ win32_open(const char *path, int flag, ...)
if (USING_WIDE()) {
A2WHELPER(path, wBuffer, sizeof(wBuffer));
- return _wopen(wBuffer, flag, pmode);
+ return _wopen(PerlDir_mapW(wBuffer), flag, pmode);
}
- return open(path,flag,pmode);
+ return open(PerlDir_mapA(path), flag, pmode);
}
DllExport int
@@ -2445,21 +2608,64 @@ win32_write(int fd, const void *buf, unsigned int cnt)
DllExport int
win32_mkdir(const char *dir, int mode)
{
- return mkdir(dir); /* just ignore mode */
+ dTHXo;
+ if (USING_WIDE()) {
+ WCHAR wBuffer[MAX_PATH];
+ A2WHELPER(dir, wBuffer, sizeof(wBuffer));
+ return _wmkdir(PerlDir_mapW(wBuffer));
+ }
+ return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
}
DllExport int
win32_rmdir(const char *dir)
{
- return rmdir(dir);
+ dTHXo;
+ if (USING_WIDE()) {
+ WCHAR wBuffer[MAX_PATH];
+ A2WHELPER(dir, wBuffer, sizeof(wBuffer));
+ return _wrmdir(PerlDir_mapW(wBuffer));
+ }
+ return rmdir(PerlDir_mapA(dir));
}
DllExport int
win32_chdir(const char *dir)
{
+ dTHXo;
+ if (USING_WIDE()) {
+ WCHAR wBuffer[MAX_PATH];
+ A2WHELPER(dir, wBuffer, sizeof(wBuffer));
+ return _wchdir(wBuffer);
+ }
return chdir(dir);
}
+DllExport int
+win32_access(const char *path, int mode)
+{
+ dTHXo;
+ if (USING_WIDE()) {
+ WCHAR wBuffer[MAX_PATH];
+ A2WHELPER(path, wBuffer, sizeof(wBuffer));
+ return _waccess(PerlDir_mapW(wBuffer), mode);
+ }
+ return access(PerlDir_mapA(path), mode);
+}
+
+DllExport int
+win32_chmod(const char *path, int mode)
+{
+ dTHXo;
+ if (USING_WIDE()) {
+ WCHAR wBuffer[MAX_PATH];
+ A2WHELPER(path, wBuffer, sizeof(wBuffer));
+ return _wchmod(PerlDir_mapW(wBuffer), mode);
+ }
+ return chmod(PerlDir_mapA(path), mode);
+}
+
+
static char *
create_command_line(const char* command, const char * const *args)
{
@@ -2592,12 +2798,28 @@ free_childenv(void* d)
char*
get_childdir(void)
{
- return NULL;
+ dTHXo;
+ char* ptr;
+ char szfilename[(MAX_PATH+1)*2];
+ if (USING_WIDE()) {
+ WCHAR wfilename[MAX_PATH+1];
+ GetCurrentDirectoryW(MAX_PATH+1, wfilename);
+ W2AHELPER(wfilename, szfilename, sizeof(szfilename));
+ }
+ else {
+ GetCurrentDirectoryA(MAX_PATH+1, szfilename);
+ }
+
+ New(0, ptr, strlen(szfilename)+1, char);
+ strcpy(ptr, szfilename);
+ return ptr;
}
void
free_childdir(char* d)
{
+ dTHXo;
+ Safefree(d);
}
@@ -2722,12 +2944,26 @@ RETVAL:
DllExport int
win32_execv(const char *cmdname, const char *const *argv)
{
+#ifdef USE_ITHREADS
+ dTHXo;
+ /* if this is a pseudo-forked child, we just want to spawn
+ * the new program, and return */
+ if (w32_pseudo_id)
+ return spawnv(P_WAIT, cmdname, (char *const *)argv);
+#endif
return execv(cmdname, (char *const *)argv);
}
DllExport int
win32_execvp(const char *cmdname, const char *const *argv)
{
+#ifdef USE_ITHREADS
+ dTHXo;
+ /* if this is a pseudo-forked child, we just want to spawn
+ * the new program, and return */
+ if (w32_pseudo_id)
+ return win32_spawnvp(P_WAIT, cmdname, (char *const *)argv);
+#endif
return execvp(cmdname, (char *const *)argv);
}
@@ -2927,44 +3163,14 @@ win32_dynaload(const char* filename)
if (USING_WIDE()) {
WCHAR wfilename[MAX_PATH];
A2WHELPER(filename, wfilename, sizeof(wfilename));
- hModule = LoadLibraryExW(wfilename, NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
+ hModule = LoadLibraryExW(PerlDir_mapW(wfilename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
}
else {
- hModule = LoadLibraryExA(filename, NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
+ hModule = LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
}
return hModule;
}
-DllExport int
-win32_add_host(char *nameId, void *data)
-{
- /*
- * This must be called before the script is parsed,
- * therefore no locking of threads is needed
- */
- dTHXo;
- struct host_link *link;
- New(1314, link, 1, struct host_link);
- link->host_data = data;
- link->nameId = nameId;
- link->next = w32_host_link;
- w32_host_link = link;
- return 1;
-}
-
-DllExport void *
-win32_get_host_data(char *nameId)
-{
- dTHXo;
- struct host_link *link = w32_host_link;
- while(link) {
- if(strEQ(link->nameId, nameId))
- return link->host_data;
- link = link->next;
- }
- return Nullch;
-}
-
/*
* Extras.
*/
@@ -2973,19 +3179,19 @@ static
XS(w32_GetCwd)
{
dXSARGS;
- SV *sv = sv_newmortal();
- /* Make one call with zero size - return value is required size */
- DWORD len = GetCurrentDirectory((DWORD)0,NULL);
- SvUPGRADE(sv,SVt_PV);
- SvGROW(sv,len);
- SvCUR(sv) = GetCurrentDirectory((DWORD) SvLEN(sv), SvPVX(sv));
+ /* Make the host for current directory */
+ char* ptr = PerlEnv_get_childdir();
/*
- * If result != 0
+ * If ptr != Nullch
* then it worked, set PV valid,
- * else leave it 'undef'
+ * else return 'undef'
*/
- EXTEND(SP,1);
- if (SvCUR(sv)) {
+ if (ptr) {
+ SV *sv = sv_newmortal();
+ sv_setpv(sv, ptr);
+ PerlEnv_free_childdir(ptr);
+
+ EXTEND(SP,1);
SvPOK_on(sv);
ST(0) = sv;
XSRETURN(1);
@@ -2999,7 +3205,7 @@ XS(w32_SetCwd)
dXSARGS;
if (items != 1)
Perl_croak(aTHX_ "usage: Win32::SetCurrentDirectory($cwd)");
- if (SetCurrentDirectory(SvPV_nolen(ST(0))))
+ if (!PerlDir_chdir(SvPV_nolen(ST(0))))
XSRETURN_YES;
XSRETURN_NO;
@@ -3122,7 +3328,7 @@ XS(w32_DomainName)
if (hNetApi32)
FreeLibrary(hNetApi32);
if (GetUserName(name,&size)) {
- char sid[1024];
+ char sid[ONE_K_BUFSIZE];
DWORD sidlen = sizeof(sid);
char dname[256];
DWORD dnamelen = sizeof(dname);
@@ -3161,19 +3367,34 @@ static
XS(w32_GetOSVersion)
{
dXSARGS;
- OSVERSIONINFO osver;
+ OSVERSIONINFOA osver;
- osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
- if (GetVersionEx(&osver)) {
+ if (USING_WIDE()) {
+ OSVERSIONINFOW osverw;
+ char szCSDVersion[sizeof(osverw.szCSDVersion)];
+ osverw.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
+ if (!GetVersionExW(&osverw)) {
+ XSRETURN_EMPTY;
+ }
+ W2AHELPER(osverw.szCSDVersion, szCSDVersion, sizeof(szCSDVersion));
+ XPUSHs(newSVpvn(szCSDVersion, strlen(szCSDVersion)));
+ osver.dwMajorVersion = osverw.dwMajorVersion;
+ osver.dwMinorVersion = osverw.dwMinorVersion;
+ osver.dwBuildNumber = osverw.dwBuildNumber;
+ osver.dwPlatformId = osverw.dwPlatformId;
+ }
+ else {
+ osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
+ if (!GetVersionExA(&osver)) {
+ XSRETURN_EMPTY;
+ }
XPUSHs(newSVpvn(osver.szCSDVersion, strlen(osver.szCSDVersion)));
- XPUSHs(newSViv(osver.dwMajorVersion));
- XPUSHs(newSViv(osver.dwMinorVersion));
- XPUSHs(newSViv(osver.dwBuildNumber));
- XPUSHs(newSViv(osver.dwPlatformId));
- PUTBACK;
- return;
}
- XSRETURN_EMPTY;
+ XPUSHs(newSViv(osver.dwMajorVersion));
+ XPUSHs(newSViv(osver.dwMinorVersion));
+ XPUSHs(newSViv(osver.dwBuildNumber));
+ XPUSHs(newSViv(osver.dwPlatformId));
+ PUTBACK;
}
static
@@ -3197,15 +3418,27 @@ XS(w32_FormatMessage)
{
dXSARGS;
DWORD source = 0;
- char msgbuf[1024];
+ char msgbuf[ONE_K_BUFSIZE];
if (items != 1)
Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)");
- if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM,
- &source, SvIV(ST(0)), 0,
- msgbuf, sizeof(msgbuf)-1, NULL))
- XSRETURN_PV(msgbuf);
+ if (USING_WIDE()) {
+ WCHAR wmsgbuf[ONE_K_BUFSIZE];
+ if (FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM,
+ &source, SvIV(ST(0)), 0,
+ wmsgbuf, ONE_K_BUFSIZE-1, NULL))
+ {
+ W2AHELPER(wmsgbuf, msgbuf, sizeof(msgbuf));
+ XSRETURN_PV(msgbuf);
+ }
+ }
+ else {
+ if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,
+ &source, SvIV(ST(0)), 0,
+ msgbuf, sizeof(msgbuf)-1, NULL))
+ XSRETURN_PV(msgbuf);
+ }
XSRETURN_UNDEF;
}
@@ -3358,9 +3591,24 @@ static
XS(w32_CopyFile)
{
dXSARGS;
+ BOOL bResult;
if (items != 3)
Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)");
- if (CopyFile(SvPV_nolen(ST(0)), SvPV_nolen(ST(1)), !SvTRUE(ST(2))))
+ if (USING_WIDE()) {
+ WCHAR wSourceFile[MAX_PATH];
+ WCHAR wDestFile[MAX_PATH];
+ A2WHELPER(SvPV_nolen(ST(0)), wSourceFile, sizeof(wSourceFile));
+ wcscpy(wSourceFile, PerlDir_mapW(wSourceFile));
+ A2WHELPER(SvPV_nolen(ST(1)), wDestFile, sizeof(wDestFile));
+ bResult = CopyFileW(wSourceFile, PerlDir_mapW(wDestFile), !SvTRUE(ST(2)));
+ }
+ else {
+ char szSourceFile[MAX_PATH];
+ strcpy(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(0))));
+ bResult = CopyFileA(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(1))), !SvTRUE(ST(2)));
+ }
+
+ if (bResult)
XSRETURN_YES;
XSRETURN_NO;
}
@@ -3377,6 +3625,12 @@ Perl_init_os_extras(void)
w32_fdpid = newAV(); /* XXX needs to be in Perl_win32_init()? */
New(1313, w32_children, 1, child_tab);
w32_num_children = 0;
+ w32_init_socktype = 0;
+#ifdef USE_ITHREADS
+ w32_pseudo_id = 0;
+ New(1313, w32_pseudo_children, 1, child_tab);
+ w32_num_pseudo_children = 0;
+#endif
/* these names are Activeware compatible */
newXS("Win32::GetCwd", w32_GetCwd, file);
@@ -3427,21 +3681,6 @@ Perl_win32_init(int *argcp, char ***argvp)
MALLOC_INIT;
}
-#ifdef USE_ITHREADS
-void
-Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
-{
- dst->perlshell_tokens = Nullch;
- dst->perlshell_vec = (char**)NULL;
- dst->perlshell_items = 0;
- dst->fdpid = newAV();
- New(1313, dst->children, 1, child_tab);
- dst->children->num = 0;
- dst->hostlist = src->hostlist; /* XXX */
- dst->thr_intern.Winit_socktype = src->thr_intern.Winit_socktype;
-}
-#endif
-
#ifdef USE_BINMODE_SCRIPTS
void
@@ -3466,3 +3705,27 @@ win32_strip_return(SV *sv)
}
#endif
+
+#ifdef USE_ITHREADS
+
+# ifdef PERL_OBJECT
+# undef Perl_sys_intern_dup
+# define Perl_sys_intern_dup CPerlObj::Perl_sys_intern_dup
+# define pPerl this
+# endif
+
+void
+Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
+{
+ dst->perlshell_tokens = Nullch;
+ dst->perlshell_vec = (char**)NULL;
+ dst->perlshell_items = 0;
+ dst->fdpid = newAV();
+ Newz(1313, dst->children, 1, child_tab);
+ Newz(1313, dst->pseudo_children, 1, child_tab);
+ dst->pseudo_id = 0;
+ dst->children->num = 0;
+ dst->thr_intern.Winit_socktype = src->thr_intern.Winit_socktype;
+}
+#endif
+
diff --git a/win32/win32.h b/win32/win32.h
index 9eaf76a..856232a 100644
--- a/win32/win32.h
+++ b/win32/win32.h
@@ -378,22 +378,20 @@ struct thread_intern {
typedef struct {
long num;
DWORD pids[MAXIMUM_WAIT_OBJECTS];
+ HANDLE handles[MAXIMUM_WAIT_OBJECTS];
} child_tab;
-struct host_link {
- char * nameId;
- void * host_data;
- struct host_link * next;
-};
-
struct interp_intern {
char * perlshell_tokens;
char ** perlshell_vec;
long perlshell_items;
struct av * fdpid;
child_tab * children;
- HANDLE child_handles[MAXIMUM_WAIT_OBJECTS];
- struct host_link * hostlist;
+#ifdef USE_ITHREADS
+ DWORD pseudo_id;
+ child_tab * pseudo_children;
+#endif
+ void * internal_host;
#ifndef USE_THREADS
struct thread_intern thr_intern;
#endif
@@ -407,8 +405,13 @@ struct interp_intern {
#define w32_children (PL_sys_intern.children)
#define w32_num_children (w32_children->num)
#define w32_child_pids (w32_children->pids)
-#define w32_child_handles (PL_sys_intern.child_handles)
-#define w32_host_link (PL_sys_intern.hostlist)
+#define w32_child_handles (w32_children->handles)
+#define w32_pseudo_id (PL_sys_intern.pseudo_id)
+#define w32_pseudo_children (PL_sys_intern.pseudo_children)
+#define w32_num_pseudo_children (w32_pseudo_children->num)
+#define w32_pseudo_child_pids (w32_pseudo_children->pids)
+#define w32_pseudo_child_handles (w32_pseudo_children->handles)
+#define w32_internal_host (PL_sys_intern.internal_host)
#ifdef USE_THREADS
# define w32_strerror_buffer (thr->i.Wstrerror_buffer)
# define w32_getlogin_buffer (thr->i.Wgetlogin_buffer)
@@ -435,6 +438,20 @@ struct interp_intern {
#define USING_WIDE() (PerlEnv_os_id() == VER_PLATFORM_WIN32_NT)
+#ifdef USE_ITHREADS
+# define PERL_WAIT_FOR_CHILDREN \
+ STMT_START { \
+ if (w32_pseudo_children && w32_num_pseudo_children) { \
+ long children = w32_num_pseudo_children; \
+ WaitForMultipleObjects(children, \
+ w32_pseudo_child_handles, \
+ TRUE, INFINITE); \
+ while (children) \
+ CloseHandle(w32_pseudo_child_handles[--children]); \
+ } \
+ } STMT_END
+#endif
+
/*
* This provides a layer of functions and macros to ensure extensions will
* get to use the same RTL functions as the core.
diff --git a/win32/win32iop.h b/win32/win32iop.h
index 566ed57..d7c2ac4 100644
--- a/win32/win32iop.h
+++ b/win32/win32iop.h
@@ -132,6 +132,7 @@ DllExport int win32_stat(const char *path, struct stat *buf);
DllExport char* win32_longpath(char *path);
DllExport int win32_ioctl(int i, unsigned int u, char *data);
DllExport int win32_link(const char *oldname, const char *newname);
+DllExport int win32_unlink(const char *f);
DllExport int win32_utime(const char *f, struct utimbuf *t);
DllExport int win32_uname(struct utsname *n);
DllExport int win32_wait(int *status);
@@ -139,6 +140,9 @@ DllExport int win32_waitpid(int pid, int *status, int flags);
DllExport int win32_kill(int pid, int sig);
DllExport unsigned long win32_os_id(void);
DllExport void* win32_dynaload(const char*filename);
+DllExport int win32_access(const char *path, int mode);
+DllExport int win32_chmod(const char *path, int mode);
+DllExport int win32_getpid(void);
DllExport char * win32_crypt(const char *txt, const char *salt);
@@ -162,6 +166,7 @@ END_EXTERN_C
#undef times
#undef alarm
#undef ioctl
+#undef unlink
#undef utime
#undef uname
#undef wait
@@ -254,6 +259,9 @@ END_EXTERN_C
#define getchar win32_getchar
#undef putchar
#define putchar win32_putchar
+#define access(p,m) win32_access(p,m)
+#define chmod(p,m) win32_chmod(p,m)
+
#if !defined(MYMALLOC) || !defined(PERL_CORE)
#undef malloc
@@ -273,6 +281,7 @@ END_EXTERN_C
#define alarm win32_alarm
#define ioctl win32_ioctl
#define link win32_link
+#define unlink win32_unlink
#define utime win32_utime
#define uname win32_uname
#define wait win32_wait
@@ -286,6 +295,7 @@ END_EXTERN_C
#define rewinddir win32_rewinddir
#define closedir win32_closedir
#define os_id win32_os_id
+#define getpid win32_getpid
#undef crypt
#define crypt(t,s) win32_crypt(t,s)
diff --git a/win32/win32thread.h b/win32/win32thread.h
index 4fa3e2f..d4f8ee4 100644
--- a/win32/win32thread.h
+++ b/win32/win32thread.h
@@ -1,8 +1,7 @@
#ifndef _WIN32THREAD_H
#define _WIN32THREAD_H
-#define WIN32_LEAN_AND_MEAN
-#include <windows.h>
+#include "win32.h"
typedef struct win32_cond { LONG waiters; HANDLE sem; } perl_cond;
typedef DWORD perl_key;
@@ -193,7 +192,7 @@ END_EXTERN_C
if ((WaitForSingleObject((t)->self,INFINITE) == WAIT_FAILED) \
|| (GetExitCodeThread((t)->self,(LPDWORD)(avp)) == 0) \
|| (CloseHandle((t)->self) == 0)) \
- Perl_croak(aTHX_ "panic: JOIN"); \
+ Perl_croak(aTHX_ "panic: JOIN"); \
} STMT_END
#endif /* !USE_RTL_THREAD_API || _MSC_VER */