This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
avoid leaking static local_patches unless patchlevel.h is
[perl5.git] / perl.c
diff --git a/perl.c b/perl.c
index b654404..ed88bc3 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -14,6 +14,7 @@
 #include "EXTERN.h"
 #define PERL_IN_PERL_C
 #include "perl.h"
+#include "patchlevel.h"                        /* for local_patches */
 
 /* XXX If this causes problems, set i_unistd=undef in the hint file.  */
 #ifdef I_UNISTD
@@ -61,10 +62,9 @@ perl_alloc(void)
 {
     PerlInterpreter *my_perl;
 
-#if !defined(PERL_IMPLICIT_CONTEXT)
-    PL_curinterp = 0;
-#endif
-    New(53, my_perl, 1, PerlInterpreter);
+    /* New() needs interpreter, so call malloc() instead */
+    my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
+    PERL_SET_INTERP(my_perl);
     return my_perl;
 }
 #endif /* PERL_OBJECT */
@@ -79,13 +79,16 @@ perl_construct(pTHXx)
 #endif /* FAKE_THREADS */
 #endif /* USE_THREADS */
     
-#ifndef PERL_OBJECT
-    if (!(PL_curinterp = my_perl))
-       return;
+#ifdef MULTIPLICITY
+    Zero(my_perl, 1, PerlInterpreter);
 #endif
 
 #ifdef MULTIPLICITY
-    Zero(my_perl, 1, PerlInterpreter);
+    init_interp();
+    PL_perl_destruct_level = 1; 
+#else
+   if (PL_perl_destruct_level > 0)
+       init_interp();
 #endif
 
    /* Init the real globals (and main thread)? */
@@ -117,7 +120,7 @@ perl_construct(pTHXx)
        thr = init_main_thread();
 #endif /* USE_THREADS */
 
-       PL_protect = FUNC_NAME_TO_PTR(Perl_default_protect); /* for exceptions */
+       PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
 
        PL_curcop = &PL_compiling;      /* needed by ckWARN, right away */
 
@@ -165,13 +168,6 @@ perl_construct(pTHXx)
     PL_rs = SvREFCNT_inc(PL_nrs);
 
     init_stacks();
-#ifdef MULTIPLICITY
-    init_interp();
-    PL_perl_destruct_level = 1; 
-#else
-   if (PL_perl_destruct_level > 0)
-       init_interp();
-#endif
 
     init_ids();
     PL_lex_state = LEX_NOTPARSING;
@@ -219,11 +215,6 @@ perl_destruct(pTHXx)
     dTHX;
 #endif /* USE_THREADS */
 
-#if !defined(PERL_OBJECT) && !defined(PERL_IMPLICIT_CONTEXT)
-    if (!(PL_curinterp = my_perl))
-       return;
-#endif
-
 #ifdef USE_THREADS
 #ifndef FAKE_THREADS
     /* Pass 1 on any remaining threads: detach joinables, join zombies */
@@ -519,6 +510,7 @@ perl_destruct(pTHXx)
     Safefree(PL_reg_start_tmp);
     if (PL_reg_curpm)
        Safefree(PL_reg_curpm);
+    Safefree(PL_reg_poscache);
     Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
     Safefree(PL_op_mask);
     nuke_stacks();
@@ -568,14 +560,10 @@ perl_destruct(pTHXx)
 void
 perl_free(pTHXx)
 {
-#ifdef PERL_OBJECT
-       Safefree(this);
+#if defined(PERL_OBJECT)
+    PerlMem_free(this);
 #else
-#  if !defined(PERL_IMPLICIT_CONTEXT)
-    if (!(PL_curinterp = my_perl))
-       return;
-#  endif
-    Safefree(my_perl);
+    PerlMem_free(aTHXx);
 #endif
 }
 
@@ -606,11 +594,6 @@ setuid perl scripts securely.\n");
 #endif
 #endif
 
-#if !defined(PERL_OBJECT) && !defined(PERL_IMPLICIT_CONTEXT)
-    if (!(PL_curinterp = my_perl))
-       return 255;
-#endif
-
 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
     _dyld_lookup_and_bind
        ("__environ", (unsigned long *) &environ_pointer, NULL);
@@ -647,7 +630,7 @@ setuid perl scripts securely.\n");
     oldscope = PL_scopestack_ix;
     PL_dowarn = G_WARN_OFF;
 
-    CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_parse_body), env, xsinit);
+    CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_parse_body), env, xsinit);
     switch (ret) {
     case 0:
        return 0;
@@ -944,11 +927,12 @@ print \"  \\@INC:\\n    @INC\\n\";");
     CvPADLIST(PL_compcv) = comppadlist;
 
     boot_core_UNIVERSAL();
+    boot_core_xsutils();
 
     if (xsinit)
        (*xsinit)(aTHXo);       /* in case linked C routines want magical variables */
 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
-    init_os_extras(aTHX);
+    init_os_extras();
 #endif
 
 #ifdef USE_SOCKS
@@ -1017,15 +1001,10 @@ perl_run(pTHXx)
     dTHX;
 #endif
 
-#if !defined(PERL_OBJECT) && !defined(PERL_IMPLICIT_CONTEXT)
-    if (!(PL_curinterp = my_perl))
-       return 255;
-#endif
-
     oldscope = PL_scopestack_ix;
 
  redo_body:
-    CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_run_body), oldscope);
+    CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
     switch (ret) {
     case 1:
        cxstack_ix = -1;                /* start context stack again */
@@ -1250,10 +1229,16 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
        PL_op->op_private |= OPpENTERSUB_DB;
 
     if (!(flags & G_EVAL)) {
-       CATCH_SET(TRUE);
+        /* G_NOCATCH is a hack for perl_vdie using this path to call
+          a __DIE__ handler */
+        if (!(flags & G_NOCATCH)) {
+           CATCH_SET(TRUE);
+       }
        call_xbody((OP*)&myop, FALSE);
        retval = PL_stack_sp - (PL_stack_base + oldmark);
-       CATCH_SET(FALSE);
+        if (!(flags & G_NOCATCH)) {
+           CATCH_SET(FALSE);
+       }
     }
     else {
        cLOGOP->op_other = PL_op;
@@ -1280,7 +1265,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
        PL_markstack_ptr++;
 
   redo_body:
-       CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_call_body), (OP*)&myop, FALSE);
+       CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_body), (OP*)&myop, FALSE);
        switch (ret) {
        case 0:
            retval = PL_stack_sp - (PL_stack_base + oldmark);
@@ -1402,7 +1387,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags)
        myop.op_flags |= OPf_SPECIAL;
 
  redo_body:
-    CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_call_body), (OP*)&myop, TRUE);
+    CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_body), (OP*)&myop, TRUE);
     switch (ret) {
     case 0:
        retval = PL_stack_sp - (PL_stack_base + oldmark);
@@ -1904,11 +1889,16 @@ S_init_interp(pTHX)
 #    define PERLVAR(var,type)
 #    define PERLVARA(var,n,type)
 #    if defined(PERL_IMPLICIT_CONTEXT)
-#      define PERLVARI(var,type,init)  my_perl->var = init;
-#      define PERLVARIC(var,type,init) my_perl->var = init;
+#      if defined(USE_THREADS)
+#        define PERLVARI(var,type,init)                PERL_GET_INTERP->var = init;
+#        define PERLVARIC(var,type,init)       PERL_GET_INTERP->var = init;
+#      else /* !USE_THREADS */
+#        define PERLVARI(var,type,init)                aTHX->var = init;
+#        define PERLVARIC(var,type,init)       aTHX->var = init;
+#      endif /* USE_THREADS */
 #    else
-#      define PERLVARI(var,type,init)  PL_curinterp->var = init;
-#      define PERLVARIC(var,type,init) PL_curinterp->var = init;
+#      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_THREADS
@@ -2484,10 +2474,10 @@ S_find_beginning(pTHX)
 STATIC void
 S_init_ids(pTHX)
 {
-    PL_uid = (int)PerlProc_getuid();
-    PL_euid = (int)PerlProc_geteuid();
-    PL_gid = (int)PerlProc_getgid();
-    PL_egid = (int)PerlProc_getegid();
+    PL_uid = PerlProc_getuid();
+    PL_euid = PerlProc_geteuid();
+    PL_gid = PerlProc_getgid();
+    PL_egid = PerlProc_getegid();
 #ifdef VMS
     PL_uid |= PL_gid << 16;
     PL_euid |= PL_egid << 16;
@@ -2504,23 +2494,26 @@ S_forbid_setid(pTHX_ char *s)
         Perl_croak(aTHX_ "No %s allowed while running setgid", s);
 }
 
-STATIC void
-S_init_debugger(pTHX)
+void
+Perl_init_debugger(pTHX)
 {
     dTHR;
+    HV *ostash = PL_curstash;
+
     PL_curstash = PL_debstash;
     PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
     AvREAL_off(PL_dbargs);
     PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
     PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
     PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
+    sv_upgrade(GvSV(PL_DBsub), SVt_IV);        /* IVX accessed if PERLDB_SUB_NN */
     PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
     sv_setiv(PL_DBsingle, 0); 
     PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
     sv_setiv(PL_DBtrace, 0); 
     PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
     sv_setiv(PL_DBsignal, 0); 
-    PL_curstash = PL_defstash;
+    PL_curstash = ostash;
 }
 
 #ifndef STRESS_REALLOC
@@ -2792,6 +2785,13 @@ S_init_perllib(pTHX)
     incpush(SITELIB_EXP, FALSE);
 #endif
 #endif
+#if defined(PERL_VENDORLIB_EXP)
+#if defined(WIN32) 
+    incpush(PERL_VENDORLIB_EXP, TRUE);
+#else
+    incpush(PERL_VENDORLIB_EXP, FALSE);
+#endif
+#endif
     if (!PL_tainting)
        incpush(".", FALSE);
 }
@@ -2900,13 +2900,14 @@ S_incpush(pTHX_ char *p, int addsubdirs)
 STATIC struct perl_thread *
 S_init_main_thread(pTHX)
 {
-#ifndef PERL_IMPLICIT_CONTEXT
+#if !defined(PERL_IMPLICIT_CONTEXT)
     struct perl_thread *thr;
 #endif
     XPV *xpv;
 
     Newz(53, thr, 1, struct perl_thread);
     PL_curcop = &PL_compiling;
+    thr->interp = PERL_GET_INTERP;
     thr->cvcache = newHV();
     thr->threadsv = newAV();
     /* thr->threadsvp is set when find_threadsv is called */
@@ -2961,11 +2962,11 @@ S_init_main_thread(pTHX)
     (void) find_threadsv("@"); /* Ensure $@ is initialised early */
 
     PL_maxscream = -1;
-    PL_regcompp = FUNC_NAME_TO_PTR(Perl_pregcomp);
-    PL_regexecp = FUNC_NAME_TO_PTR(Perl_regexec_flags);
-    PL_regint_start = FUNC_NAME_TO_PTR(Perl_re_intuit_start);
-    PL_regint_string = FUNC_NAME_TO_PTR(Perl_re_intuit_string);
-    PL_regfree = FUNC_NAME_TO_PTR(Perl_pregfree);
+    PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
+    PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
+    PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
+    PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
+    PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
     PL_regindent = 0;
     PL_reginterp_cnt = 0;
 
@@ -2986,7 +2987,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
     while (AvFILL(paramList) >= 0) {
        cv = (CV*)av_shift(paramList);
        SAVEFREESV(cv);
-       CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_call_list_body), cv);
+       CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
        switch (ret) {
        case 0:
            (void)SvPV(atsv, len);
Unnamed repository; edit this file 'description' to name the repository.