X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=c67134378b428530584cff916ef7d72d6c5c26ff;hb=be708cc0141c68546a70e3d19f68ad41bef15add;hp=820f65d3bde0e11c8403699a8b3615e357dec65c;hpb=1cc8b4c566f7901a54e4b576f09608beb4c81f86;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index 820f65d..c671343 100644 --- a/perl.c +++ b/perl.c @@ -25,7 +25,7 @@ char *getenv (char *); /* Usually in */ #endif -static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen); +static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen); #ifdef IAMSUID #ifndef DOSUID @@ -39,14 +39,6 @@ static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen); #endif #endif -#ifdef PERL_OBJECT -#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 - #if defined(USE_5005THREADS) # define INIT_TLS_AND_INTERP \ STMT_START { \ @@ -91,11 +83,6 @@ perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS, struct IPerlProc* ipP) { PerlInterpreter *my_perl; -#ifdef PERL_OBJECT - my_perl = (PerlInterpreter*)new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, - ipLIO, ipD, ipS, ipP); - INIT_TLS_AND_INTERP; -#else /* New() needs interpreter, so call malloc() instead */ my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter)); INIT_TLS_AND_INTERP; @@ -109,7 +96,6 @@ perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS, PL_Dir = ipD; PL_Sock = ipS; PL_Proc = ipP; -#endif return my_perl; } @@ -212,12 +198,7 @@ perl_construct(pTHXx) SvREFCNT(&PL_sv_yes) = (~(U32)0)/2; } -#ifdef PERL_OBJECT - /* TODO: */ - /* PL_sighandlerp = sighandler; */ -#else PL_sighandlerp = Perl_sighandler; -#endif PL_pidstatus = newHV(); #ifdef MSDOS @@ -231,8 +212,7 @@ perl_construct(pTHXx) #endif } - PL_nrs = newSVpvn("\n", 1); - PL_rs = SvREFCNT_inc(PL_nrs); + PL_rs = newSVpvn("\n", 1); init_stacks(); @@ -292,6 +272,27 @@ perl_construct(pTHXx) New(31337, PL_reentrant_buffer,1, REBUF); New(31337, PL_reentrant_buffer->tmbuff,1, struct tm); #endif + + /* Note that strtab is a rather special HV. Assumptions are made + about not iterating on it, and not adding tie magic to it. + It is properly deallocated in perl_destruct() */ + PL_strtab = newHV(); + +#ifdef USE_5005THREADS + MUTEX_INIT(&PL_strtab_mutex); +#endif + HvSHAREKEYS_off(PL_strtab); /* mandatory */ + hv_ksplit(PL_strtab, 512); + +#if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__)) + _dyld_lookup_and_bind + ("__environ", (unsigned long *) &environ_pointer, NULL); +#endif /* environ */ + +#ifdef USE_ENVIRON_ARRAY + PL_origenviron = environ; +#endif + ENTER; } @@ -306,7 +307,7 @@ Shuts down a Perl interpreter. See L. int perl_destruct(pTHXx) { - int destruct_level; /* 0=none, 1=full, 2=full with checks */ + volatile int destruct_level; /* 0=none, 1=full, 2=full with checks */ HV *hv; #ifdef USE_5005THREADS Thread t; @@ -450,7 +451,7 @@ perl_destruct(pTHXx) /* call exit list functions */ while (PL_exitlistlen-- > 0) - PL_exitlist[PL_exitlistlen].fn(aTHXo_ PL_exitlist[PL_exitlistlen].ptr); + PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr); Safefree(PL_exitlist); @@ -470,6 +471,7 @@ perl_destruct(pTHXx) for (i = 0; environ[i]; i++) safesysfree(environ[i]); + /* Must use safesysfree() when working with environ. */ safesysfree(environ); @@ -489,7 +491,7 @@ perl_destruct(pTHXx) while (i) { SV *resv = ary[--i]; - REGEXP *re = (REGEXP *)SvIVX(resv); + REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv)); if (SvFLAGS(resv) & SVf_BREAK) { /* this is PL_reg_curpm, already freed @@ -559,9 +561,6 @@ perl_destruct(pTHXx) SvREFCNT_dec(PL_rs); /* $/ */ PL_rs = Nullsv; - SvREFCNT_dec(PL_nrs); /* $/ helper */ - PL_nrs = Nullsv; - PL_multiline = 0; /* $* */ Safefree(PL_osname); /* $^O */ PL_osname = Nullch; @@ -587,10 +586,12 @@ perl_destruct(pTHXx) /* startup and shutdown function lists */ SvREFCNT_dec(PL_beginav); + SvREFCNT_dec(PL_beginav_save); SvREFCNT_dec(PL_endav); SvREFCNT_dec(PL_checkav); SvREFCNT_dec(PL_initav); PL_beginav = Nullav; + PL_beginav_save = Nullav; PL_endav = Nullav; PL_checkav = Nullav; PL_initav = Nullav; @@ -874,34 +875,34 @@ Releases a Perl interpreter. See L. void perl_free(pTHXx) { -#if defined(PERL_OBJECT) - PerlMem_free(this); -#else -# if defined(WIN32) || defined(NETWARE) +#if defined(WIN32) || defined(NETWARE) # if defined(PERL_IMPLICIT_SYS) - #ifdef NETWARE - void *host = nw_internal_host; - #else - void *host = w32_internal_host; - #endif - #ifndef NETWARE - if (PerlProc_lasthost()) { +# ifdef NETWARE + void *host = nw_internal_host; +# else + void *host = w32_internal_host; +# endif +# ifndef NETWARE + if (PerlProc_lasthost()) { +# ifdef USE_PERLIO PerlIO_cleanup(); - } - #endif - PerlMem_free(aTHXx); - #ifdef NETWARE - nw5_delete_internal_host(host); - #else - win32_delete_internal_host(host); - #endif -#else - PerlIO_cleanup(); +# endif + } +# endif PerlMem_free(aTHXx); -#endif +# ifdef NETWARE + nw5_delete_internal_host(host); +# else + win32_delete_internal_host(host); +# endif # else +# ifdef USE_PERLIO + PerlIO_cleanup(); +# endif PerlMem_free(aTHXx); # endif +#else + PerlMem_free(aTHXx); #endif } @@ -940,11 +941,6 @@ setuid perl scripts securely.\n"); #endif #endif -#if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__)) - _dyld_lookup_and_bind - ("__environ", (unsigned long *) &environ_pointer, NULL); -#endif /* environ */ - PL_origargc = argc; { /* we copy rather than point to argv @@ -960,9 +956,7 @@ setuid perl scripts securely.\n"); } } -#ifdef USE_ENVIRON_ARRAY - PL_origenviron = environ; -#endif + if (PL_do_undump) { @@ -1195,9 +1189,6 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) # ifdef USE_SOCKS sv_catpv(PL_Sv," USE_SOCKS"); # endif -# ifdef PERL_OBJECT - sv_catpv(PL_Sv," PERL_OBJECT"); -# endif # ifdef PERL_IMPLICIT_CONTEXT sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT"); # endif @@ -1398,7 +1389,7 @@ print \" \\@INC:\\n @INC\\n\";"); #endif if (xsinit) - (*xsinit)(aTHXo); /* in case linked C routines want magical variables */ + (*xsinit)(aTHX); /* in case linked C routines want magical variables */ #ifndef PERL_MICRO #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC) init_os_extras(); @@ -1453,10 +1444,12 @@ print \" \\@INC:\\n @INC\\n\";"); PL_e_script = Nullsv; } - /* now that script is parsed, we can modify record separator */ - SvREFCNT_dec(PL_rs); - PL_rs = SvREFCNT_inc(PL_nrs); +/* + Not sure that this is still the right place to do this now that we + no longer use PL_nrs. HVDS 2001/09/09 +*/ sv_setsv(get_sv("/", TRUE), PL_rs); + if (PL_do_undump) my_unexec(); @@ -1569,7 +1562,7 @@ S_run_body(pTHX_ I32 oldscope) if (PL_minus_c) { #ifdef MACOS_TRADITIONAL - PerlIO_printf(Perl_error_log, "%s syntax OK\n", MacPerl_MPWFileName(PL_origfilename)); + PerlIO_printf(Perl_error_log, "# %s syntax OK\n", MacPerl_MPWFileName(PL_origfilename)); #else PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename); #endif @@ -2170,16 +2163,17 @@ Perl_moreswitches(pTHX_ char *s) switch (*s) { case '0': { - numlen = 0; /* disallow underscores */ - rschar = (U32)scan_oct(s, 4, &numlen); - SvREFCNT_dec(PL_nrs); + I32 flags = 0; + numlen = 4; + rschar = (U32)grok_oct(s, &numlen, &flags, NULL); + SvREFCNT_dec(PL_rs); if (rschar & ~((U8)~0)) - PL_nrs = &PL_sv_undef; + PL_rs = &PL_sv_undef; else if (!rschar && numlen >= 2) - PL_nrs = newSVpvn("", 0); + PL_rs = newSVpvn("", 0); else { char ch = rschar; - PL_nrs = newSVpvn(&ch, 1); + PL_rs = newSVpvn(&ch, 1); } return s + numlen; } @@ -2302,17 +2296,18 @@ Perl_moreswitches(pTHX_ char *s) PL_ors_sv = Nullsv; } if (isDIGIT(*s)) { + I32 flags = 0; PL_ors_sv = newSVpvn("\n",1); - numlen = 0; /* disallow underscores */ - *SvPVX(PL_ors_sv) = (char)scan_oct(s, 3 + (*s == '0'), &numlen); + numlen = 3 + (*s == '0'); + *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL); s += numlen; } else { - if (RsPARA(PL_nrs)) { + if (RsPARA(PL_rs)) { PL_ors_sv = newSVpvn("\n\n",2); } else { - PL_ors_sv = newSVsv(PL_nrs); + PL_ors_sv = newSVsv(PL_rs); } } return s; @@ -2561,77 +2556,42 @@ STATIC void S_init_interp(pTHX) { -#ifdef PERL_OBJECT /* XXX kludge */ -#define I_REINIT \ - STMT_START { \ - PL_chopset = " \n-"; \ - PL_copline = NOLINE; \ - PL_curcop = &PL_compiling;\ - PL_curcopdb = NULL; \ - PL_dbargs = 0; \ - PL_dumpindent = 4; \ - PL_laststatval = -1; \ - PL_laststype = OP_STAT; \ - PL_maxscream = -1; \ - PL_maxsysfd = MAXSYSFD; \ - PL_statname = Nullsv; \ - PL_tmps_floor = -1; \ - PL_tmps_ix = -1; \ - PL_op_mask = NULL; \ - PL_laststatval = -1; \ - PL_laststype = OP_STAT; \ - PL_mess_sv = Nullsv; \ - PL_splitstr = " "; \ - PL_generation = 100; \ - PL_exitlist = NULL; \ - PL_exitlistlen = 0; \ - PL_regindent = 0; \ - PL_in_clean_objs = FALSE; \ - PL_in_clean_all = FALSE; \ - PL_profiledata = NULL; \ - PL_rsfp = Nullfp; \ - PL_rsfp_filters = Nullav; \ - PL_dirty = FALSE; \ - } STMT_END - I_REINIT; -#else -# ifdef MULTIPLICITY -# define PERLVAR(var,type) -# define PERLVARA(var,n,type) -# if defined(PERL_IMPLICIT_CONTEXT) -# if defined(USE_5005THREADS) -# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init; -# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init; -# else /* !USE_5005THREADS */ -# define PERLVARI(var,type,init) aTHX->var = init; -# define PERLVARIC(var,type,init) aTHX->var = init; -# endif /* USE_5005THREADS */ -# else -# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init; +#ifdef MULTIPLICITY +# define PERLVAR(var,type) +# define PERLVARA(var,n,type) +# if defined(PERL_IMPLICIT_CONTEXT) +# if defined(USE_5005THREADS) +# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init; # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init; -# endif -# include "intrpvar.h" -# ifndef USE_5005THREADS -# include "thrdvar.h" -# endif -# undef PERLVAR -# undef PERLVARA -# undef PERLVARI -# undef PERLVARIC +# else /* !USE_5005THREADS */ +# define PERLVARI(var,type,init) aTHX->var = init; +# define PERLVARIC(var,type,init) aTHX->var = init; +# endif /* USE_5005THREADS */ # else -# define PERLVAR(var,type) -# define PERLVARA(var,n,type) -# define PERLVARI(var,type,init) PL_##var = init; -# define PERLVARIC(var,type,init) PL_##var = init; -# include "intrpvar.h" -# ifndef USE_5005THREADS -# include "thrdvar.h" -# endif -# undef PERLVAR -# undef PERLVARA -# undef PERLVARI -# undef PERLVARIC +# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init; +# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init; +# endif +# include "intrpvar.h" +# ifndef USE_5005THREADS +# include "thrdvar.h" +# endif +# undef PERLVAR +# undef PERLVARA +# undef PERLVARI +# undef PERLVARIC +#else +# define PERLVAR(var,type) +# define PERLVARA(var,n,type) +# define PERLVARI(var,type,init) PL_##var = init; +# define PERLVARIC(var,type,init) PL_##var = init; +# include "intrpvar.h" +# ifndef USE_5005THREADS +# include "thrdvar.h" # endif +# undef PERLVAR +# undef PERLVARA +# undef PERLVARI +# undef PERLVARIC #endif } @@ -2641,15 +2601,7 @@ S_init_main_stash(pTHX) { GV *gv; - /* Note that strtab is a rather special HV. Assumptions are made - about not iterating on it, and not adding tie magic to it. - It is properly deallocated in perl_destruct() */ - PL_strtab = newHV(); -#ifdef USE_5005THREADS - MUTEX_INIT(&PL_strtab_mutex); -#endif - HvSHAREKEYS_off(PL_strtab); /* mandatory */ - hv_ksplit(PL_strtab, 512); + PL_curstash = PL_defstash = newHV(); PL_curstname = newSVpvn("main",4); @@ -3358,16 +3310,10 @@ S_nuke_stacks(pTHX) Safefree(PL_retstack); } -#ifndef PERL_OBJECT -static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */ -#endif - STATIC void S_init_lexer(pTHX) { -#ifdef PERL_OBJECT - PerlIO *tmpfp; -#endif + PerlIO *tmpfp; tmpfp = PL_rsfp; PL_rsfp = Nullfp; lex_start(PL_linestr); @@ -4045,12 +3991,8 @@ S_my_exit_jump(pTHX) JMPENV_JUMP(2); } -#ifdef PERL_OBJECT -#include "XSUB.h" -#endif - static I32 -read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen) +read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen) { char *p, *nl; p = SvPVX(PL_e_script);