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