This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
more complete pseudo-fork() support for Windows
authorGurusamy Sarathy <gsar@cpan.org>
Wed, 1 Dec 1999 01:00:09 +0000 (01:00 +0000)
committerGurusamy Sarathy <gsar@cpan.org>
Wed, 1 Dec 1999 01:00:09 +0000 (01:00 +0000)
p4raw-id: //depot/perl@4602

57 files changed:
MANIFEST
XSUB.h
cop.h
dump.c
embed.h
embed.pl
embedvar.h
ext/B/B/CC.pm
ext/Opcode/Opcode.xs
global.sym
globals.c
globvar.sym
gv.c
hv.c
intrpvar.h
iperlsys.h
makedef.pl
mg.c
mpeix/mpeixish.h
objXSUB.h
op.c
op.h
os2/os2ish.h
perl.c
perl.h
perlapi.c
plan9/plan9ish.h
pod/Makefile
pod/buildtoc
pod/perl.pod
pod/perlfork.pod [new file with mode: 0644]
pod/roffitall
pp.c
pp_ctl.c
pp_hot.c
pp_sys.c
proto.h
regcomp.c
run.c
scope.c
scope.h
sv.c
t/op/fork.t
toke.c
unixish.h
util.c
vos/vosish.h
win32/Makefile
win32/makefile.mk
win32/perlhost.h [new file with mode: 0644]
win32/perllib.c
win32/vdir.h [new file with mode: 0644]
win32/vmem.h [new file with mode: 0644]
win32/win32.c
win32/win32.h
win32/win32iop.h
win32/win32thread.h

index db6f5d6..483b3bb 100644 (file)
--- 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 (file)
--- a/XSUB.h
+++ b/XSUB.h
 #    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 (file)
--- 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 (file)
--- 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 (file)
--- a/embed.h
+++ b/embed.h
 #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
 #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
 #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
 #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
 #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
 #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
 #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
 
 #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)
 #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)
 #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)
 #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)
 #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)
 #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)
 #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)
 #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
 #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)
 #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
 #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
 #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
 #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
 #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
 #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
index fff791e..b21f21f 100755 (executable)
--- 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
index 610f266..2ceb49e 100644 (file)
 #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)
 #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)
 #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)
 #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)
 #  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
 #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
 #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
 #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)
 #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
 #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)
index 0fe5e7d..cf0e81f 100644 (file)
@@ -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);
index 63ff8aa..581cbc9 100644 (file)
@@ -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
index e219030..796ab64 100644 (file)
@@ -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
index 8e19d22..80c659e 100644 (file)
--- 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)
index 3cb8ccc..0d76888 100644 (file)
@@ -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 (file)
--- 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 (file)
--- 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)
index c772d79..d7a669c 100644 (file)
@@ -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*)
index 9404d18..222d88b 100644 (file)
@@ -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);
index 40c9be3..4b1b84f 100644 (file)
@@ -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 (file)
--- 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);
index 2311171..b5e4fa4 100644 (file)
@@ -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(),
index e8b1ffb..0884936 100644 (file)
--- a/objXSUB.h
+++ b/objXSUB.h
 #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
 #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
 
 /* 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
 #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
 #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
 #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
 #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
 #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
 #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
 #  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 (file)
--- 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 (file)
--- 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 */
index 3d7a6fd..f254b5c 100644 (file)
@@ -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 (file)
--- 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 (file)
--- a/perl.h
+++ b/perl.h
 #  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"
index 02795ad..2f902f8 100644 (file)
--- 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
index 06a30fe..bac6a92 100644 (file)
 #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
index a4b405c..3aadd9e 100644 (file)
@@ -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     \
index 1a9a24b..41cb76d 100644 (file)
@@ -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
index 6e3921e..dc97764 100644 (file)
@@ -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 (file)
index 0000000..68a3242
--- /dev/null
@@ -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
index 9c9daeb..7ddffe7 100644 (file)
@@ -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 (file)
--- 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);
index bc2a361..b1f71a3 100644 (file)
--- 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) ;
index 421b099..690abea 100644 (file)
--- 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)
index ebc5e27..48fb5e4 100644 (file)
--- 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 (file)
--- 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
index 49e9e26..65db009 100644 (file)
--- 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; &regdummy = don't */
+    SAVEVPTR(PL_regcode);              /* Code-emit pointer; &regdummy = 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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)
 {
index 20c8747..be95653 100755 (executable)
 #!./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 (file)
--- 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);
index 2d37fbe..f4fe177 100644 (file)
--- 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 (file)
--- 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;
 }
 
index fc53dc1..1648702 100644 (file)
@@ -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(),
index c4bb568..fe38d99 100644 (file)
@@ -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)
index 2550611..b5e1d19 100644 (file)
@@ -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 (file)
index 0000000..236a97c
--- /dev/null
@@ -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