home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / perl.c < prev    next >
C/C++ Source or Header  |  2000-03-17  |  92KB  |  3,697 lines
  1. /*    perl.c
  2.  *
  3.  *    Copyright (c) 1987-2000 Larry Wall
  4.  *
  5.  *    You may distribute under the terms of either the GNU General Public
  6.  *    License or the Artistic License, as specified in the README file.
  7.  *
  8.  */
  9.  
  10. /*
  11.  * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
  12.  */
  13.  
  14. #include "EXTERN.h"
  15. #define PERL_IN_PERL_C
  16. #include "perl.h"
  17. #include "patchlevel.h"            /* for local_patches */
  18.  
  19. /* XXX If this causes problems, set i_unistd=undef in the hint file.  */
  20. #ifdef I_UNISTD
  21. #include <unistd.h>
  22. #endif
  23.  
  24. #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
  25. char *getenv (char *); /* Usually in <stdlib.h> */
  26. #endif
  27.  
  28. static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen);
  29.  
  30. #ifdef IAMSUID
  31. #ifndef DOSUID
  32. #define DOSUID
  33. #endif
  34. #endif
  35.  
  36. #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  37. #ifdef DOSUID
  38. #undef DOSUID
  39. #endif
  40. #endif
  41.  
  42. #ifdef PERL_OBJECT
  43. #define perl_construct    Perl_construct
  44. #define perl_parse    Perl_parse
  45. #define perl_run    Perl_run
  46. #define perl_destruct    Perl_destruct
  47. #define perl_free    Perl_free
  48. #endif
  49.  
  50. #if defined(USE_THREADS)
  51. #  define INIT_TLS_AND_INTERP \
  52.     STMT_START {                \
  53.     if (!PL_curinterp) {            \
  54.         PERL_SET_INTERP(my_perl);        \
  55.         INIT_THREADS;            \
  56.         ALLOC_THREAD_KEY;            \
  57.     }                    \
  58.     } STMT_END
  59. #else
  60. #  if defined(USE_ITHREADS)
  61. #  define INIT_TLS_AND_INTERP \
  62.     STMT_START {                \
  63.     if (!PL_curinterp) {            \
  64.         PERL_SET_INTERP(my_perl);        \
  65.         INIT_THREADS;            \
  66.         ALLOC_THREAD_KEY;            \
  67.         PERL_SET_THX(my_perl);        \
  68.         OP_REFCNT_INIT;            \
  69.     }                    \
  70.     else {                    \
  71.         PERL_SET_THX(my_perl);        \
  72.     }                    \
  73.     } STMT_END
  74. #  else
  75. #  define INIT_TLS_AND_INTERP \
  76.     STMT_START {                \
  77.     if (!PL_curinterp) {            \
  78.         PERL_SET_INTERP(my_perl);        \
  79.     }                    \
  80.     PERL_SET_THX(my_perl);            \
  81.     } STMT_END
  82. #  endif
  83. #endif
  84.  
  85. #ifdef PERL_IMPLICIT_SYS
  86. PerlInterpreter *
  87. perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
  88.          struct IPerlMem* ipMP, struct IPerlEnv* ipE,
  89.          struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
  90.          struct IPerlDir* ipD, struct IPerlSock* ipS,
  91.          struct IPerlProc* ipP)
  92. {
  93.     PerlInterpreter *my_perl;
  94. #ifdef PERL_OBJECT
  95.     my_perl = (PerlInterpreter*)new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd,
  96.                           ipLIO, ipD, ipS, ipP);
  97.     INIT_TLS_AND_INTERP;
  98. #else
  99.     /* New() needs interpreter, so call malloc() instead */
  100.     my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
  101.     INIT_TLS_AND_INTERP;
  102.     Zero(my_perl, 1, PerlInterpreter);
  103.     PL_Mem = ipM;
  104.     PL_MemShared = ipMS;
  105.     PL_MemParse = ipMP;
  106.     PL_Env = ipE;
  107.     PL_StdIO = ipStd;
  108.     PL_LIO = ipLIO;
  109.     PL_Dir = ipD;
  110.     PL_Sock = ipS;
  111.     PL_Proc = ipP;
  112. #endif
  113.  
  114.     return my_perl;
  115. }
  116. #else
  117.  
  118. /*
  119. =for apidoc perl_alloc
  120.  
  121. Allocates a new Perl interpreter.  See L<perlembed>.
  122.  
  123. =cut
  124. */
  125.  
  126. PerlInterpreter *
  127. perl_alloc(void)
  128. {
  129.     PerlInterpreter *my_perl;
  130.  
  131.     /* New() needs interpreter, so call malloc() instead */
  132.     my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
  133.  
  134.     INIT_TLS_AND_INTERP;
  135.     Zero(my_perl, 1, PerlInterpreter);
  136.     return my_perl;
  137. }
  138. #endif /* PERL_IMPLICIT_SYS */
  139.  
  140. /*
  141. =for apidoc perl_construct
  142.  
  143. Initializes a new Perl interpreter.  See L<perlembed>.
  144.  
  145. =cut
  146. */
  147.  
  148. void
  149. perl_construct(pTHXx)
  150. {
  151. #ifdef USE_THREADS
  152.     int i;
  153. #ifndef FAKE_THREADS
  154.     struct perl_thread *thr = NULL;
  155. #endif /* FAKE_THREADS */
  156. #endif /* USE_THREADS */
  157.  
  158. #ifdef MULTIPLICITY
  159.     init_interp();
  160.     PL_perl_destruct_level = 1; 
  161. #else
  162.    if (PL_perl_destruct_level > 0)
  163.        init_interp();
  164. #endif
  165.  
  166.    /* Init the real globals (and main thread)? */
  167.     if (!PL_linestr) {
  168. #ifdef USE_THREADS
  169.     MUTEX_INIT(&PL_sv_mutex);
  170.     /*
  171.      * Safe to use basic SV functions from now on (though
  172.      * not things like mortals or tainting yet).
  173.      */
  174.     MUTEX_INIT(&PL_eval_mutex);
  175.     COND_INIT(&PL_eval_cond);
  176.     MUTEX_INIT(&PL_threads_mutex);
  177.     COND_INIT(&PL_nthreads_cond);
  178. #  ifdef EMULATE_ATOMIC_REFCOUNTS
  179.     MUTEX_INIT(&PL_svref_mutex);
  180. #  endif /* EMULATE_ATOMIC_REFCOUNTS */
  181.     
  182.     MUTEX_INIT(&PL_cred_mutex);
  183.  
  184.     thr = init_main_thread();
  185. #endif /* USE_THREADS */
  186.  
  187. #ifdef PERL_FLEXIBLE_EXCEPTIONS
  188.     PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
  189. #endif
  190.  
  191.     PL_curcop = &PL_compiling;    /* needed by ckWARN, right away */
  192.  
  193.     PL_linestr = NEWSV(65,79);
  194.     sv_upgrade(PL_linestr,SVt_PVIV);
  195.  
  196.     if (!SvREADONLY(&PL_sv_undef)) {
  197.         /* set read-only and try to insure than we wont see REFCNT==0
  198.            very often */
  199.  
  200.         SvREADONLY_on(&PL_sv_undef);
  201.         SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
  202.  
  203.         sv_setpv(&PL_sv_no,PL_No);
  204.         SvNV(&PL_sv_no);
  205.         SvREADONLY_on(&PL_sv_no);
  206.         SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
  207.  
  208.         sv_setpv(&PL_sv_yes,PL_Yes);
  209.         SvNV(&PL_sv_yes);
  210.         SvREADONLY_on(&PL_sv_yes);
  211.         SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
  212.     }
  213.  
  214. #ifdef PERL_OBJECT
  215.     /* TODO: */
  216.     /* PL_sighandlerp = sighandler; */
  217. #else
  218.     PL_sighandlerp = Perl_sighandler;
  219. #endif
  220.     PL_pidstatus = newHV();
  221.  
  222. #ifdef MSDOS
  223.     /*
  224.      * There is no way we can refer to them from Perl so close them to save
  225.      * space.  The other alternative would be to provide STDAUX and STDPRN
  226.      * filehandles.
  227.      */
  228.     (void)fclose(stdaux);
  229.     (void)fclose(stdprn);
  230. #endif
  231.     }
  232.  
  233.     PL_nrs = newSVpvn("\n", 1);
  234.     PL_rs = SvREFCNT_inc(PL_nrs);
  235.  
  236.     init_stacks();
  237.  
  238.     init_ids();
  239.     PL_lex_state = LEX_NOTPARSING;
  240.  
  241.     JMPENV_BOOTSTRAP;
  242.     STATUS_ALL_SUCCESS;
  243.  
  244.     init_i18nl10n(1);
  245.     SET_NUMERIC_STANDARD();
  246.  
  247.     {
  248.     U8 *s;
  249.     PL_patchlevel = NEWSV(0,4);
  250.     (void)SvUPGRADE(PL_patchlevel, SVt_PVNV);
  251.     if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
  252.         SvGROW(PL_patchlevel, UTF8_MAXLEN*3+1);
  253.     s = (U8*)SvPVX(PL_patchlevel);
  254.     s = uv_to_utf8(s, (UV)PERL_REVISION);
  255.     s = uv_to_utf8(s, (UV)PERL_VERSION);
  256.     s = uv_to_utf8(s, (UV)PERL_SUBVERSION);
  257.     *s = '\0';
  258.     SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel));
  259.     SvPOK_on(PL_patchlevel);
  260.     SvNVX(PL_patchlevel) = (NV)PERL_REVISION
  261.                 + ((NV)PERL_VERSION / (NV)1000)
  262. #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
  263.                 + ((NV)PERL_SUBVERSION / (NV)1000000)
  264. #endif
  265.                 ;
  266.     SvNOK_on(PL_patchlevel);    /* dual valued */
  267.     SvUTF8_on(PL_patchlevel);
  268.     SvREADONLY_on(PL_patchlevel);
  269.     }
  270.  
  271. #if defined(LOCAL_PATCH_COUNT)
  272.     PL_localpatches = local_patches;    /* For possible -v */
  273. #endif
  274.  
  275.     PerlIO_init();            /* Hook to IO system */
  276.  
  277.     PL_fdpid = newAV();            /* for remembering popen pids by fd */
  278.     PL_modglobal = newHV();        /* pointers to per-interpreter module globals */
  279.  
  280.     ENTER;
  281. }
  282.  
  283. /*
  284. =for apidoc perl_destruct
  285.  
  286. Shuts down a Perl interpreter.  See L<perlembed>.
  287.  
  288. =cut
  289. */
  290.  
  291. void
  292. perl_destruct(pTHXx)
  293. {
  294.     dTHR;
  295.     int destruct_level;  /* 0=none, 1=full, 2=full with checks */
  296.     I32 last_sv_count;
  297.     HV *hv;
  298. #ifdef USE_THREADS
  299.     Thread t;
  300.     dTHX;
  301. #endif /* USE_THREADS */
  302.  
  303.     /* wait for all pseudo-forked children to finish */
  304.     PERL_WAIT_FOR_CHILDREN;
  305.  
  306. #ifdef USE_THREADS
  307. #ifndef FAKE_THREADS
  308.     /* Pass 1 on any remaining threads: detach joinables, join zombies */
  309.   retry_cleanup:
  310.     MUTEX_LOCK(&PL_threads_mutex);
  311.     DEBUG_S(PerlIO_printf(Perl_debug_log,
  312.               "perl_destruct: waiting for %d threads...\n",
  313.               PL_nthreads - 1));
  314.     for (t = thr->next; t != thr; t = t->next) {
  315.     MUTEX_LOCK(&t->mutex);
  316.     switch (ThrSTATE(t)) {
  317.         AV *av;
  318.     case THRf_ZOMBIE:
  319.         DEBUG_S(PerlIO_printf(Perl_debug_log,
  320.                   "perl_destruct: joining zombie %p\n", t));
  321.         ThrSETSTATE(t, THRf_DEAD);
  322.         MUTEX_UNLOCK(&t->mutex);
  323.         PL_nthreads--;
  324.         /*
  325.          * The SvREFCNT_dec below may take a long time (e.g. av
  326.          * may contain an object scalar whose destructor gets
  327.          * called) so we have to unlock threads_mutex and start
  328.          * all over again.
  329.          */
  330.         MUTEX_UNLOCK(&PL_threads_mutex);
  331.         JOIN(t, &av);
  332.         SvREFCNT_dec((SV*)av);
  333.         DEBUG_S(PerlIO_printf(Perl_debug_log,
  334.                   "perl_destruct: joined zombie %p OK\n", t));
  335.         goto retry_cleanup;
  336.     case THRf_R_JOINABLE:
  337.         DEBUG_S(PerlIO_printf(Perl_debug_log,
  338.                   "perl_destruct: detaching thread %p\n", t));
  339.         ThrSETSTATE(t, THRf_R_DETACHED);
  340.         /* 
  341.          * We unlock threads_mutex and t->mutex in the opposite order
  342.          * from which we locked them just so that DETACH won't
  343.          * deadlock if it panics. It's only a breach of good style
  344.          * not a bug since they are unlocks not locks.
  345.          */
  346.         MUTEX_UNLOCK(&PL_threads_mutex);
  347.         DETACH(t);
  348.         MUTEX_UNLOCK(&t->mutex);
  349.         goto retry_cleanup;
  350.     default:
  351.         DEBUG_S(PerlIO_printf(Perl_debug_log,
  352.                   "perl_destruct: ignoring %p (state %u)\n",
  353.                   t, ThrSTATE(t)));
  354.         MUTEX_UNLOCK(&t->mutex);
  355.         /* fall through and out */
  356.     }
  357.     }
  358.     /* We leave the above "Pass 1" loop with threads_mutex still locked */
  359.  
  360.     /* Pass 2 on remaining threads: wait for the thread count to drop to one */
  361.     while (PL_nthreads > 1)
  362.     {
  363.     DEBUG_S(PerlIO_printf(Perl_debug_log,
  364.                   "perl_destruct: final wait for %d threads\n",
  365.                   PL_nthreads - 1));
  366.     COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
  367.     }
  368.     /* At this point, we're the last thread */
  369.     MUTEX_UNLOCK(&PL_threads_mutex);
  370.     DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
  371.     MUTEX_DESTROY(&PL_threads_mutex);
  372.     COND_DESTROY(&PL_nthreads_cond);
  373. #endif /* !defined(FAKE_THREADS) */
  374. #endif /* USE_THREADS */
  375.  
  376.     destruct_level = PL_perl_destruct_level;
  377. #ifdef DEBUGGING
  378.     {
  379.     char *s;
  380.     if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) {
  381.         int i = atoi(s);
  382.         if (destruct_level < i)
  383.         destruct_level = i;
  384.     }
  385.     }
  386. #endif
  387.  
  388.     LEAVE;
  389.     FREETMPS;
  390.  
  391.     /* We must account for everything.  */
  392.  
  393.     /* Destroy the main CV and syntax tree */
  394.     if (PL_main_root) {
  395.     PL_curpad = AvARRAY(PL_comppad);
  396.     op_free(PL_main_root);
  397.     PL_main_root = Nullop;
  398.     }
  399.     PL_curcop = &PL_compiling;
  400.     PL_main_start = Nullop;
  401.     SvREFCNT_dec(PL_main_cv);
  402.     PL_main_cv = Nullcv;
  403.     PL_dirty = TRUE;
  404.  
  405.     if (PL_sv_objcount) {
  406.     /*
  407.      * Try to destruct global references.  We do this first so that the
  408.      * destructors and destructees still exist.  Some sv's might remain.
  409.      * Non-referenced objects are on their own.
  410.      */
  411.     sv_clean_objs();
  412.     }
  413.  
  414.     /* unhook hooks which will soon be, or use, destroyed data */
  415.     SvREFCNT_dec(PL_warnhook);
  416.     PL_warnhook = Nullsv;
  417.     SvREFCNT_dec(PL_diehook);
  418.     PL_diehook = Nullsv;
  419.  
  420.     /* call exit list functions */
  421.     while (PL_exitlistlen-- > 0)
  422.     PL_exitlist[PL_exitlistlen].fn(aTHXo_ PL_exitlist[PL_exitlistlen].ptr);
  423.  
  424.     Safefree(PL_exitlist);
  425.  
  426.     if (destruct_level == 0){
  427.  
  428.     DEBUG_P(debprofdump());
  429.     
  430.     /* The exit() function will do everything that needs doing. */
  431.     return;
  432.     }
  433.  
  434.     /* loosen bonds of global variables */
  435.  
  436.     if(PL_rsfp) {
  437.     (void)PerlIO_close(PL_rsfp);
  438.     PL_rsfp = Nullfp;
  439.     }
  440.  
  441.     /* Filters for program text */
  442.     SvREFCNT_dec(PL_rsfp_filters);
  443.     PL_rsfp_filters = Nullav;
  444.  
  445.     /* switches */
  446.     PL_preprocess   = FALSE;
  447.     PL_minus_n      = FALSE;
  448.     PL_minus_p      = FALSE;
  449.     PL_minus_l      = FALSE;
  450.     PL_minus_a      = FALSE;
  451.     PL_minus_F      = FALSE;
  452.     PL_doswitches   = FALSE;
  453.     PL_dowarn       = G_WARN_OFF;
  454.     PL_doextract    = FALSE;
  455.     PL_sawampersand = FALSE;    /* must save all match strings */
  456.     PL_unsafe       = FALSE;
  457.  
  458.     Safefree(PL_inplace);
  459.     PL_inplace = Nullch;
  460.     SvREFCNT_dec(PL_patchlevel);
  461.  
  462.     if (PL_e_script) {
  463.     SvREFCNT_dec(PL_e_script);
  464.     PL_e_script = Nullsv;
  465.     }
  466.  
  467.     /* magical thingies */
  468.  
  469.     Safefree(PL_ofs);        /* $, */
  470.     PL_ofs = Nullch;
  471.  
  472.     Safefree(PL_ors);        /* $\ */
  473.     PL_ors = Nullch;
  474.  
  475.     SvREFCNT_dec(PL_rs);    /* $/ */
  476.     PL_rs = Nullsv;
  477.  
  478.     SvREFCNT_dec(PL_nrs);    /* $/ helper */
  479.     PL_nrs = Nullsv;
  480.  
  481.     PL_multiline = 0;        /* $* */
  482.     Safefree(PL_osname);    /* $^O */
  483.     PL_osname = Nullch;
  484.  
  485.     SvREFCNT_dec(PL_statname);
  486.     PL_statname = Nullsv;
  487.     PL_statgv = Nullgv;
  488.  
  489.     /* defgv, aka *_ should be taken care of elsewhere */
  490.  
  491.     /* clean up after study() */
  492.     SvREFCNT_dec(PL_lastscream);
  493.     PL_lastscream = Nullsv;
  494.     Safefree(PL_screamfirst);
  495.     PL_screamfirst = 0;
  496.     Safefree(PL_screamnext);
  497.     PL_screamnext  = 0;
  498.  
  499.     /* float buffer */
  500.     Safefree(PL_efloatbuf);
  501.     PL_efloatbuf = Nullch;
  502.     PL_efloatsize = 0;
  503.  
  504.     /* startup and shutdown function lists */
  505.     SvREFCNT_dec(PL_beginav);
  506.     SvREFCNT_dec(PL_endav);
  507.     SvREFCNT_dec(PL_checkav);
  508.     SvREFCNT_dec(PL_initav);
  509.     PL_beginav = Nullav;
  510.     PL_endav = Nullav;
  511.     PL_checkav = Nullav;
  512.     PL_initav = Nullav;
  513.  
  514.     /* shortcuts just get cleared */
  515.     PL_envgv = Nullgv;
  516.     PL_incgv = Nullgv;
  517.     PL_hintgv = Nullgv;
  518.     PL_errgv = Nullgv;
  519.     PL_argvgv = Nullgv;
  520.     PL_argvoutgv = Nullgv;
  521.     PL_stdingv = Nullgv;
  522.     PL_stderrgv = Nullgv;
  523.     PL_last_in_gv = Nullgv;
  524.     PL_replgv = Nullgv;
  525.     PL_debstash = Nullhv;
  526.  
  527.     /* reset so print() ends up where we expect */
  528.     setdefout(Nullgv);
  529.  
  530.     SvREFCNT_dec(PL_argvout_stack);
  531.     PL_argvout_stack = Nullav;
  532.  
  533.     SvREFCNT_dec(PL_modglobal);
  534.     PL_modglobal = Nullhv;
  535.     SvREFCNT_dec(PL_preambleav);
  536.     PL_preambleav = Nullav;
  537.     SvREFCNT_dec(PL_subname);
  538.     PL_subname = Nullsv;
  539.     SvREFCNT_dec(PL_linestr);
  540.     PL_linestr = Nullsv;
  541.     SvREFCNT_dec(PL_pidstatus);
  542.     PL_pidstatus = Nullhv;
  543.     SvREFCNT_dec(PL_toptarget);
  544.     PL_toptarget = Nullsv;
  545.     SvREFCNT_dec(PL_bodytarget);
  546.     PL_bodytarget = Nullsv;
  547.     PL_formtarget = Nullsv;
  548.  
  549.     /* free locale stuff */
  550. #ifdef USE_LOCALE_COLLATE
  551.     Safefree(PL_collation_name);
  552.     PL_collation_name = Nullch;
  553. #endif
  554.  
  555. #ifdef USE_LOCALE_NUMERIC
  556.     Safefree(PL_numeric_name);
  557.     PL_numeric_name = Nullch;
  558. #endif
  559.  
  560.     /* clear utf8 character classes */
  561.     SvREFCNT_dec(PL_utf8_alnum);
  562.     SvREFCNT_dec(PL_utf8_alnumc);
  563.     SvREFCNT_dec(PL_utf8_ascii);
  564.     SvREFCNT_dec(PL_utf8_alpha);
  565.     SvREFCNT_dec(PL_utf8_space);
  566.     SvREFCNT_dec(PL_utf8_cntrl);
  567.     SvREFCNT_dec(PL_utf8_graph);
  568.     SvREFCNT_dec(PL_utf8_digit);
  569.     SvREFCNT_dec(PL_utf8_upper);
  570.     SvREFCNT_dec(PL_utf8_lower);
  571.     SvREFCNT_dec(PL_utf8_print);
  572.     SvREFCNT_dec(PL_utf8_punct);
  573.     SvREFCNT_dec(PL_utf8_xdigit);
  574.     SvREFCNT_dec(PL_utf8_mark);
  575.     SvREFCNT_dec(PL_utf8_toupper);
  576.     SvREFCNT_dec(PL_utf8_tolower);
  577.     PL_utf8_alnum    = Nullsv;
  578.     PL_utf8_alnumc    = Nullsv;
  579.     PL_utf8_ascii    = Nullsv;
  580.     PL_utf8_alpha    = Nullsv;
  581.     PL_utf8_space    = Nullsv;
  582.     PL_utf8_cntrl    = Nullsv;
  583.     PL_utf8_graph    = Nullsv;
  584.     PL_utf8_digit    = Nullsv;
  585.     PL_utf8_upper    = Nullsv;
  586.     PL_utf8_lower    = Nullsv;
  587.     PL_utf8_print    = Nullsv;
  588.     PL_utf8_punct    = Nullsv;
  589.     PL_utf8_xdigit    = Nullsv;
  590.     PL_utf8_mark    = Nullsv;
  591.     PL_utf8_toupper    = Nullsv;
  592.     PL_utf8_totitle    = Nullsv;
  593.     PL_utf8_tolower    = Nullsv;
  594.  
  595.     if (!specialWARN(PL_compiling.cop_warnings))
  596.     SvREFCNT_dec(PL_compiling.cop_warnings);
  597.     PL_compiling.cop_warnings = Nullsv;
  598. #ifndef USE_ITHREADS
  599.     SvREFCNT_dec(CopFILEGV(&PL_compiling));
  600.     CopFILEGV_set(&PL_compiling, Nullgv);
  601. #endif
  602.  
  603.     /* Prepare to destruct main symbol table.  */
  604.  
  605.     hv = PL_defstash;
  606.     PL_defstash = 0;
  607.     SvREFCNT_dec(hv);
  608.     SvREFCNT_dec(PL_curstname);
  609.     PL_curstname = Nullsv;
  610.  
  611.     /* clear queued errors */
  612.     SvREFCNT_dec(PL_errors);
  613.     PL_errors = Nullsv;
  614.  
  615.     FREETMPS;
  616.     if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
  617.     if (PL_scopestack_ix != 0)
  618.         Perl_warner(aTHX_ WARN_INTERNAL,
  619.              "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
  620.          (long)PL_scopestack_ix);
  621.     if (PL_savestack_ix != 0)
  622.         Perl_warner(aTHX_ WARN_INTERNAL,
  623.          "Unbalanced saves: %ld more saves than restores\n",
  624.          (long)PL_savestack_ix);
  625.     if (PL_tmps_floor != -1)
  626.         Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
  627.          (long)PL_tmps_floor + 1);
  628.     if (cxstack_ix != -1)
  629.         Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
  630.          (long)cxstack_ix + 1);
  631.     }
  632.  
  633.     /* Now absolutely destruct everything, somehow or other, loops or no. */
  634.     last_sv_count = 0;
  635.     SvFLAGS(PL_fdpid) |= SVTYPEMASK;        /* don't clean out pid table now */
  636.     SvFLAGS(PL_strtab) |= SVTYPEMASK;        /* don't clean out strtab now */
  637.     while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
  638.     last_sv_count = PL_sv_count;
  639.     sv_clean_all();
  640.     }
  641.     SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
  642.     SvFLAGS(PL_fdpid) |= SVt_PVAV;
  643.     SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
  644.     SvFLAGS(PL_strtab) |= SVt_PVHV;
  645.  
  646.     AvREAL_off(PL_fdpid);        /* no surviving entries */
  647.     SvREFCNT_dec(PL_fdpid);        /* needed in io_close() */
  648.     PL_fdpid = Nullav;
  649.  
  650.     /* Destruct the global string table. */
  651.     {
  652.     /* Yell and reset the HeVAL() slots that are still holding refcounts,
  653.      * so that sv_free() won't fail on them.
  654.      */
  655.     I32 riter;
  656.     I32 max;
  657.     HE *hent;
  658.     HE **array;
  659.  
  660.     riter = 0;
  661.     max = HvMAX(PL_strtab);
  662.     array = HvARRAY(PL_strtab);
  663.     hent = array[0];
  664.     for (;;) {
  665.         if (hent && ckWARN_d(WARN_INTERNAL)) {
  666.         Perl_warner(aTHX_ WARN_INTERNAL,
  667.              "Unbalanced string table refcount: (%d) for \"%s\"",
  668.              HeVAL(hent) - Nullsv, HeKEY(hent));
  669.         HeVAL(hent) = Nullsv;
  670.         hent = HeNEXT(hent);
  671.         }
  672.         if (!hent) {
  673.         if (++riter > max)
  674.             break;
  675.         hent = array[riter];
  676.         }
  677.     }
  678.     }
  679.     SvREFCNT_dec(PL_strtab);
  680.  
  681.     /* free special SVs */
  682.  
  683.     SvREFCNT(&PL_sv_yes) = 0;
  684.     sv_clear(&PL_sv_yes);
  685.     SvANY(&PL_sv_yes) = NULL;
  686.     SvFLAGS(&PL_sv_yes) = 0;
  687.  
  688.     SvREFCNT(&PL_sv_no) = 0;
  689.     sv_clear(&PL_sv_no);
  690.     SvANY(&PL_sv_no) = NULL;
  691.     SvFLAGS(&PL_sv_no) = 0;
  692.  
  693.     SvREFCNT(&PL_sv_undef) = 0;
  694.     SvREADONLY_off(&PL_sv_undef);
  695.  
  696.     if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
  697.     Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
  698.  
  699.     sv_free_arenas();
  700.  
  701.     /* No SVs have survived, need to clean out */
  702.     Safefree(PL_origfilename);
  703.     Safefree(PL_reg_start_tmp);
  704.     if (PL_reg_curpm)
  705.     Safefree(PL_reg_curpm);
  706.     Safefree(PL_reg_poscache);
  707.     Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
  708.     Safefree(PL_op_mask);
  709.     nuke_stacks();
  710.     PL_hints = 0;        /* Reset hints. Should hints be per-interpreter ? */
  711.     
  712.     DEBUG_P(debprofdump());
  713. #ifdef USE_THREADS
  714.     MUTEX_DESTROY(&PL_strtab_mutex);
  715.     MUTEX_DESTROY(&PL_sv_mutex);
  716.     MUTEX_DESTROY(&PL_eval_mutex);
  717.     MUTEX_DESTROY(&PL_cred_mutex);
  718.     COND_DESTROY(&PL_eval_cond);
  719. #ifdef EMULATE_ATOMIC_REFCOUNTS
  720.     MUTEX_DESTROY(&PL_svref_mutex);
  721. #endif /* EMULATE_ATOMIC_REFCOUNTS */
  722.  
  723.     /* As the penultimate thing, free the non-arena SV for thrsv */
  724.     Safefree(SvPVX(PL_thrsv));
  725.     Safefree(SvANY(PL_thrsv));
  726.     Safefree(PL_thrsv);
  727.     PL_thrsv = Nullsv;
  728. #endif /* USE_THREADS */
  729.  
  730.     /* As the absolutely last thing, free the non-arena SV for mess() */
  731.  
  732.     if (PL_mess_sv) {
  733.     /* it could have accumulated taint magic */
  734.     if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
  735.         MAGIC* mg;
  736.         MAGIC* moremagic;
  737.         for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
  738.         moremagic = mg->mg_moremagic;
  739.         if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
  740.             Safefree(mg->mg_ptr);
  741.         Safefree(mg);
  742.         }
  743.     }
  744.     /* we know that type >= SVt_PV */
  745.     (void)SvOOK_off(PL_mess_sv);
  746.     Safefree(SvPVX(PL_mess_sv));
  747.     Safefree(SvANY(PL_mess_sv));
  748.     Safefree(PL_mess_sv);
  749.     PL_mess_sv = Nullsv;
  750.     }
  751. }
  752.  
  753. /*
  754. =for apidoc perl_free
  755.  
  756. Releases a Perl interpreter.  See L<perlembed>.
  757.  
  758. =cut
  759. */
  760.  
  761. void
  762. perl_free(pTHXx)
  763. {
  764. #if defined(PERL_OBJECT)
  765.     PerlMem_free(this);
  766. #else
  767. #  if defined(PERL_IMPLICIT_SYS) && defined(WIN32)
  768.     void *host = w32_internal_host;
  769.     PerlMem_free(aTHXx);
  770.     win32_delete_internal_host(host);
  771. #  else
  772.     PerlMem_free(aTHXx);
  773. #  endif
  774. #endif
  775. }
  776.  
  777. void
  778. Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
  779. {
  780.     Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
  781.     PL_exitlist[PL_exitlistlen].fn = fn;
  782.     PL_exitlist[PL_exitlistlen].ptr = ptr;
  783.     ++PL_exitlistlen;
  784. }
  785.  
  786. /*
  787. =for apidoc perl_parse
  788.  
  789. Tells a Perl interpreter to parse a Perl script.  See L<perlembed>.
  790.  
  791. =cut
  792. */
  793.  
  794. int
  795. perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
  796. {
  797.     dTHR;
  798.     I32 oldscope;
  799.     int ret;
  800.     dJMPENV;
  801. #ifdef USE_THREADS
  802.     dTHX;
  803. #endif
  804.  
  805. #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  806. #ifdef IAMSUID
  807. #undef IAMSUID
  808.     Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
  809. setuid perl scripts securely.\n");
  810. #endif
  811. #endif
  812.  
  813. #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
  814.     _dyld_lookup_and_bind
  815.     ("__environ", (unsigned long *) &environ_pointer, NULL);
  816. #endif /* environ */
  817.  
  818.     PL_origargv = argv;
  819.     PL_origargc = argc;
  820. #ifndef VMS  /* VMS doesn't have environ array */
  821.     PL_origenviron = environ;
  822. #endif
  823.  
  824.     if (PL_do_undump) {
  825.  
  826.     /* Come here if running an undumped a.out. */
  827.  
  828.     PL_origfilename = savepv(argv[0]);
  829.     PL_do_undump = FALSE;
  830.     cxstack_ix = -1;        /* start label stack again */
  831.     init_ids();
  832.     init_postdump_symbols(argc,argv,env);
  833.     return 0;
  834.     }
  835.  
  836.     if (PL_main_root) {
  837.     PL_curpad = AvARRAY(PL_comppad);
  838.     op_free(PL_main_root);
  839.     PL_main_root = Nullop;
  840.     }
  841.     PL_main_start = Nullop;
  842.     SvREFCNT_dec(PL_main_cv);
  843.     PL_main_cv = Nullcv;
  844.  
  845.     time(&PL_basetime);
  846.     oldscope = PL_scopestack_ix;
  847.     PL_dowarn = G_WARN_OFF;
  848.  
  849. #ifdef PERL_FLEXIBLE_EXCEPTIONS
  850.     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vparse_body), env, xsinit);
  851. #else
  852.     JMPENV_PUSH(ret);
  853. #endif
  854.     switch (ret) {
  855.     case 0:
  856. #ifndef PERL_FLEXIBLE_EXCEPTIONS
  857.     parse_body(env,xsinit);
  858. #endif
  859.     if (PL_checkav)
  860.         call_list(oldscope, PL_checkav);
  861.     ret = 0;
  862.     break;
  863.     case 1:
  864.     STATUS_ALL_FAILURE;
  865.     /* FALL THROUGH */
  866.     case 2:
  867.     /* my_exit() was called */
  868.     while (PL_scopestack_ix > oldscope)
  869.         LEAVE;
  870.     FREETMPS;
  871.     PL_curstash = PL_defstash;
  872.     if (PL_checkav)
  873.         call_list(oldscope, PL_checkav);
  874.     ret = STATUS_NATIVE_EXPORT;
  875.     break;
  876.     case 3:
  877.     PerlIO_printf(Perl_error_log, "panic: top_env\n");
  878.     ret = 1;
  879.     break;
  880.     }
  881.     JMPENV_POP;
  882.     return ret;
  883. }
  884.  
  885. #ifdef PERL_FLEXIBLE_EXCEPTIONS
  886. STATIC void *
  887. S_vparse_body(pTHX_ va_list args)
  888. {
  889.     char **env = va_arg(args, char**);
  890.     XSINIT_t xsinit = va_arg(args, XSINIT_t);
  891.  
  892.     return parse_body(env, xsinit);
  893. }
  894. #endif
  895.  
  896. STATIC void *
  897. S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
  898. {
  899.     dTHR;
  900.     int argc = PL_origargc;
  901.     char **argv = PL_origargv;
  902.     char *scriptname = NULL;
  903.     int fdscript = -1;
  904.     VOL bool dosearch = FALSE;
  905.     char *validarg = "";
  906.     AV* comppadlist;
  907.     register SV *sv;
  908.     register char *s;
  909.     char *cddir = Nullch;
  910.  
  911.     sv_setpvn(PL_linestr,"",0);
  912.     sv = newSVpvn("",0);        /* first used for -I flags */
  913.     SAVEFREESV(sv);
  914.     init_main_stash();
  915.  
  916.     for (argc--,argv++; argc > 0; argc--,argv++) {
  917.     if (argv[0][0] != '-' || !argv[0][1])
  918.         break;
  919. #ifdef DOSUID
  920.     if (*validarg)
  921.     validarg = " PHOOEY ";
  922.     else
  923.     validarg = argv[0];
  924. #endif
  925.     s = argv[0]+1;
  926.       reswitch:
  927.     switch (*s) {
  928.     case 'C':
  929. #ifdef    WIN32
  930.         win32_argv2utf8(argc-1, argv+1);
  931.         /* FALL THROUGH */
  932. #endif
  933. #ifndef PERL_STRICT_CR
  934.     case '\r':
  935. #endif
  936.     case ' ':
  937.     case '0':
  938.     case 'F':
  939.     case 'a':
  940.     case 'c':
  941.     case 'd':
  942.     case 'D':
  943.     case 'h':
  944.     case 'i':
  945.     case 'l':
  946.     case 'M':
  947.     case 'm':
  948.     case 'n':
  949.     case 'p':
  950.     case 's':
  951.     case 'u':
  952.     case 'U':
  953.     case 'v':
  954.     case 'W':
  955.     case 'X':
  956.     case 'w':
  957.         if ((s = moreswitches(s)))
  958.         goto reswitch;
  959.         break;
  960.  
  961.     case 'T':
  962.         PL_tainting = TRUE;
  963.         s++;
  964.         goto reswitch;
  965.  
  966.     case 'e':
  967.         if (PL_euid != PL_uid || PL_egid != PL_gid)
  968.         Perl_croak(aTHX_ "No -e allowed in setuid scripts");
  969.         if (!PL_e_script) {
  970.         PL_e_script = newSVpvn("",0);
  971.         filter_add(read_e_script, NULL);
  972.         }
  973.         if (*++s)
  974.         sv_catpv(PL_e_script, s);
  975.         else if (argv[1]) {
  976.         sv_catpv(PL_e_script, argv[1]);
  977.         argc--,argv++;
  978.         }
  979.         else
  980.         Perl_croak(aTHX_ "No code specified for -e");
  981.         sv_catpv(PL_e_script, "\n");
  982.         break;
  983.  
  984.     case 'I':    /* -I handled both here and in moreswitches() */
  985.         forbid_setid("-I");
  986.         if (!*++s && (s=argv[1]) != Nullch) {
  987.         argc--,argv++;
  988.         }
  989.         if (s && *s) {
  990.         char *p;
  991.         STRLEN len = strlen(s);
  992.         p = savepvn(s, len);
  993.         incpush(p, TRUE, TRUE);
  994.         sv_catpvn(sv, "-I", 2);
  995.         sv_catpvn(sv, p, len);
  996.         sv_catpvn(sv, " ", 1);
  997.         Safefree(p);
  998.         }
  999.         else
  1000.         Perl_croak(aTHX_ "No directory specified for -I");
  1001.         break;
  1002.     case 'P':
  1003.         forbid_setid("-P");
  1004.         PL_preprocess = TRUE;
  1005.         s++;
  1006.         goto reswitch;
  1007.     case 'S':
  1008.         forbid_setid("-S");
  1009.         dosearch = TRUE;
  1010.         s++;
  1011.         goto reswitch;
  1012.     case 'V':
  1013.         if (!PL_preambleav)
  1014.         PL_preambleav = newAV();
  1015.         av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
  1016.         if (*++s != ':')  {
  1017.         PL_Sv = newSVpv("print myconfig();",0);
  1018. #ifdef VMS
  1019.         sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
  1020. #else
  1021.         sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
  1022. #endif
  1023.         sv_catpv(PL_Sv,"\"  Compile-time options:");
  1024. #  ifdef DEBUGGING
  1025.         sv_catpv(PL_Sv," DEBUGGING");
  1026. #  endif
  1027. #  ifdef MULTIPLICITY
  1028.         sv_catpv(PL_Sv," MULTIPLICITY");
  1029. #  endif
  1030. #  ifdef USE_THREADS
  1031.         sv_catpv(PL_Sv," USE_THREADS");
  1032. #  endif
  1033. #  ifdef USE_ITHREADS
  1034.         sv_catpv(PL_Sv," USE_ITHREADS");
  1035. #  endif
  1036. #  ifdef USE_64_BIT_INT
  1037.         sv_catpv(PL_Sv," USE_64_BIT_INT");
  1038. #  endif
  1039. #  ifdef USE_64_BIT_ALL
  1040.         sv_catpv(PL_Sv," USE_64_BIT_ALL");
  1041. #  endif
  1042. #  ifdef USE_LONG_DOUBLE
  1043.         sv_catpv(PL_Sv," USE_LONG_DOUBLE");
  1044. #  endif
  1045. #  ifdef USE_LARGE_FILES
  1046.         sv_catpv(PL_Sv," USE_LARGE_FILES");
  1047. #  endif
  1048. #  ifdef USE_SOCKS
  1049.         sv_catpv(PL_Sv," USE_SOCKS");
  1050. #  endif
  1051. #  ifdef PERL_OBJECT
  1052.         sv_catpv(PL_Sv," PERL_OBJECT");
  1053. #  endif
  1054. #  ifdef PERL_IMPLICIT_CONTEXT
  1055.         sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
  1056. #  endif
  1057. #  ifdef PERL_IMPLICIT_SYS
  1058.         sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
  1059. #  endif
  1060.         sv_catpv(PL_Sv,"\\n\",");
  1061.  
  1062. #if defined(LOCAL_PATCH_COUNT)
  1063.         if (LOCAL_PATCH_COUNT > 0) {
  1064.             int i;
  1065.             sv_catpv(PL_Sv,"\"  Locally applied patches:\\n\",");
  1066.             for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
  1067.             if (PL_localpatches[i])
  1068.                 Perl_sv_catpvf(aTHX_ PL_Sv,"q\"  \t%s\n\",",PL_localpatches[i]);
  1069.             }
  1070.         }
  1071. #endif
  1072.         Perl_sv_catpvf(aTHX_ PL_Sv,"\"  Built under %s\\n\"",OSNAME);
  1073. #ifdef __DATE__
  1074. #  ifdef __TIME__
  1075.         Perl_sv_catpvf(aTHX_ PL_Sv,",\"  Compiled at %s %s\\n\"",__DATE__,__TIME__);
  1076. #  else
  1077.         Perl_sv_catpvf(aTHX_ PL_Sv,",\"  Compiled on %s\\n\"",__DATE__);
  1078. #  endif
  1079. #endif
  1080.         sv_catpv(PL_Sv, "; \
  1081. $\"=\"\\n    \"; \
  1082. @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
  1083. print \"  \\%ENV:\\n    @env\\n\" if @env; \
  1084. print \"  \\@INC:\\n    @INC\\n\";");
  1085.         }
  1086.         else {
  1087.         PL_Sv = newSVpv("config_vars(qw(",0);
  1088.         sv_catpv(PL_Sv, ++s);
  1089.         sv_catpv(PL_Sv, "))");
  1090.         s += strlen(s);
  1091.         }
  1092.         av_push(PL_preambleav, PL_Sv);
  1093.         scriptname = BIT_BUCKET;    /* don't look for script or read stdin */
  1094.         goto reswitch;
  1095.     case 'x':
  1096.         PL_doextract = TRUE;
  1097.         s++;
  1098.         if (*s)
  1099.         cddir = s;
  1100.         break;
  1101.     case 0:
  1102.         break;
  1103.     case '-':
  1104.         if (!*++s || isSPACE(*s)) {
  1105.         argc--,argv++;
  1106.         goto switch_end;
  1107.         }
  1108.         /* catch use of gnu style long options */
  1109.         if (strEQ(s, "version")) {
  1110.         s = "v";
  1111.         goto reswitch;
  1112.         }
  1113.         if (strEQ(s, "help")) {
  1114.         s = "h";
  1115.         goto reswitch;
  1116.         }
  1117.         s--;
  1118.         /* FALL THROUGH */
  1119.     default:
  1120.         Perl_croak(aTHX_ "Unrecognized switch: -%s  (-h will show valid options)",s);
  1121.     }
  1122.     }
  1123.   switch_end:
  1124.  
  1125.     if (
  1126. #ifndef SECURE_INTERNAL_GETENV
  1127.         !PL_tainting &&
  1128. #endif
  1129.     (s = PerlEnv_getenv("PERL5OPT")))
  1130.     {
  1131.     while (isSPACE(*s))
  1132.         s++;
  1133.     if (*s == '-' && *(s+1) == 'T')
  1134.         PL_tainting = TRUE;
  1135.     else {
  1136.         while (s && *s) {
  1137.         while (isSPACE(*s))
  1138.             s++;
  1139.         if (*s == '-') {
  1140.             s++;
  1141.             if (isSPACE(*s))
  1142.             continue;
  1143.         }
  1144.         if (!*s)
  1145.             break;
  1146.         if (!strchr("DIMUdmw", *s))
  1147.             Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
  1148.         s = moreswitches(s);
  1149.         }
  1150.     }
  1151.     }
  1152.  
  1153.     if (!scriptname)
  1154.     scriptname = argv[0];
  1155.     if (PL_e_script) {
  1156.     argc++,argv--;
  1157.     scriptname = BIT_BUCKET;    /* don't look for script or read stdin */
  1158.     }
  1159.     else if (scriptname == Nullch) {
  1160. #ifdef MSDOS
  1161.     if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
  1162.         moreswitches("h");
  1163. #endif
  1164.     scriptname = "-";
  1165.     }
  1166.  
  1167.     init_perllib();
  1168.  
  1169.     open_script(scriptname,dosearch,sv,&fdscript);
  1170.  
  1171.     validate_suid(validarg, scriptname,fdscript);
  1172.  
  1173. #if defined(SIGCHLD) || defined(SIGCLD)
  1174.     {
  1175. #ifndef SIGCHLD
  1176. #  define SIGCHLD SIGCLD
  1177. #endif
  1178.     Sighandler_t sigstate = rsignal_state(SIGCHLD);
  1179.     if (sigstate == SIG_IGN) {
  1180.         if (ckWARN(WARN_SIGNAL))
  1181.         Perl_warner(aTHX_ WARN_SIGNAL,
  1182.                 "Can't ignore signal CHLD, forcing to default");
  1183.         (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
  1184.     }
  1185.     }
  1186. #endif
  1187.  
  1188.     if (PL_doextract) {
  1189.     find_beginning();
  1190.     if (cddir && PerlDir_chdir(cddir) < 0)
  1191.         Perl_croak(aTHX_ "Can't chdir to %s",cddir);
  1192.  
  1193.     }
  1194.  
  1195.     PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
  1196.     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
  1197.     CvUNIQUE_on(PL_compcv);
  1198.  
  1199.     PL_comppad = newAV();
  1200.     av_push(PL_comppad, Nullsv);
  1201.     PL_curpad = AvARRAY(PL_comppad);
  1202.     PL_comppad_name = newAV();
  1203.     PL_comppad_name_fill = 0;
  1204.     PL_min_intro_pending = 0;
  1205.     PL_padix = 0;
  1206. #ifdef USE_THREADS
  1207.     av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
  1208.     PL_curpad[0] = (SV*)newAV();
  1209.     SvPADMY_on(PL_curpad[0]);    /* XXX Needed? */
  1210.     CvOWNER(PL_compcv) = 0;
  1211.     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
  1212.     MUTEX_INIT(CvMUTEXP(PL_compcv));
  1213. #endif /* USE_THREADS */
  1214.  
  1215.     comppadlist = newAV();
  1216.     AvREAL_off(comppadlist);
  1217.     av_store(comppadlist, 0, (SV*)PL_comppad_name);
  1218.     av_store(comppadlist, 1, (SV*)PL_comppad);
  1219.     CvPADLIST(PL_compcv) = comppadlist;
  1220.  
  1221.     boot_core_UNIVERSAL();
  1222. #ifndef PERL_MICRO
  1223.     boot_core_xsutils();
  1224. #endif
  1225.  
  1226.     if (xsinit)
  1227.     (*xsinit)(aTHXo);    /* in case linked C routines want magical variables */
  1228. #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__)
  1229.     init_os_extras();
  1230. #endif
  1231.  
  1232. #ifdef USE_SOCKS
  1233.     SOCKSinit(argv[0]);
  1234. #endif    
  1235.  
  1236.     init_predump_symbols();
  1237.     /* init_postdump_symbols not currently designed to be called */
  1238.     /* more than once (ENV isn't cleared first, for example)     */
  1239.     /* But running with -u leaves %ENV & @ARGV undefined!    XXX */
  1240.     if (!PL_do_undump)
  1241.     init_postdump_symbols(argc,argv,env);
  1242.  
  1243.     init_lexer();
  1244.  
  1245.     /* now parse the script */
  1246.  
  1247.     SETERRNO(0,SS$_NORMAL);
  1248.     PL_error_count = 0;
  1249.     if (yyparse() || PL_error_count) {
  1250.     if (PL_minus_c)
  1251.         Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
  1252.     else {
  1253.         Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
  1254.                PL_origfilename);
  1255.     }
  1256.     }
  1257.     CopLINE_set(PL_curcop, 0);
  1258.     PL_curstash = PL_defstash;
  1259.     PL_preprocess = FALSE;
  1260.     if (PL_e_script) {
  1261.     SvREFCNT_dec(PL_e_script);
  1262.     PL_e_script = Nullsv;
  1263.     }
  1264.  
  1265.     /* now that script is parsed, we can modify record separator */
  1266.     SvREFCNT_dec(PL_rs);
  1267.     PL_rs = SvREFCNT_inc(PL_nrs);
  1268.     sv_setsv(get_sv("/", TRUE), PL_rs);
  1269.     if (PL_do_undump)
  1270.     my_unexec();
  1271.  
  1272.     if (isWARN_ONCE) {
  1273.     SAVECOPFILE(PL_curcop);
  1274.     SAVECOPLINE(PL_curcop);
  1275.     gv_check(PL_defstash);
  1276.     }
  1277.  
  1278.     LEAVE;
  1279.     FREETMPS;
  1280.  
  1281. #ifdef MYMALLOC
  1282.     if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
  1283.     dump_mstats("after compilation:");
  1284. #endif
  1285.  
  1286.     ENTER;
  1287.     PL_restartop = 0;
  1288.     return NULL;
  1289. }
  1290.  
  1291. /*
  1292. =for apidoc perl_run
  1293.  
  1294. Tells a Perl interpreter to run.  See L<perlembed>.
  1295.  
  1296. =cut
  1297. */
  1298.  
  1299. int
  1300. perl_run(pTHXx)
  1301. {
  1302.     dTHR;
  1303.     I32 oldscope;
  1304.     int ret = 0;
  1305.     dJMPENV;
  1306. #ifdef USE_THREADS
  1307.     dTHX;
  1308. #endif
  1309.  
  1310.     oldscope = PL_scopestack_ix;
  1311.  
  1312. #ifdef PERL_FLEXIBLE_EXCEPTIONS
  1313.  redo_body:
  1314.     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
  1315. #else
  1316.     JMPENV_PUSH(ret);
  1317. #endif
  1318.     switch (ret) {
  1319.     case 1:
  1320.     cxstack_ix = -1;        /* start context stack again */
  1321.     goto redo_body;
  1322.     case 0:                /* normal completion */
  1323. #ifndef PERL_FLEXIBLE_EXCEPTIONS
  1324.  redo_body:
  1325.     run_body(oldscope);
  1326. #endif
  1327.     /* FALL THROUGH */
  1328.     case 2:                /* my_exit() */
  1329.     while (PL_scopestack_ix > oldscope)
  1330.         LEAVE;
  1331.     FREETMPS;
  1332.     PL_curstash = PL_defstash;
  1333.     if (PL_endav && !PL_minus_c)
  1334.         call_list(oldscope, PL_endav);
  1335. #ifdef MYMALLOC
  1336.     if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
  1337.         dump_mstats("after execution:  ");
  1338. #endif
  1339.     ret = STATUS_NATIVE_EXPORT;
  1340.     break;
  1341.     case 3:
  1342.     if (PL_restartop) {
  1343.         POPSTACK_TO(PL_mainstack);
  1344.         goto redo_body;
  1345.     }
  1346.     PerlIO_printf(Perl_error_log, "panic: restartop\n");
  1347.     FREETMPS;
  1348.     ret = 1;
  1349.     break;
  1350.     }
  1351.  
  1352.     JMPENV_POP;
  1353.     return ret;
  1354. }
  1355.  
  1356. #ifdef PERL_FLEXIBLE_EXCEPTIONS
  1357. STATIC void *
  1358. S_vrun_body(pTHX_ va_list args)
  1359. {
  1360.     I32 oldscope = va_arg(args, I32);
  1361.  
  1362.     return run_body(oldscope);
  1363. }
  1364. #endif
  1365.  
  1366.  
  1367. STATIC void *
  1368. S_run_body(pTHX_ I32 oldscope)
  1369. {
  1370.     dTHR;
  1371.  
  1372.     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
  1373.                     PL_sawampersand ? "Enabling" : "Omitting"));
  1374.  
  1375.     if (!PL_restartop) {
  1376.     DEBUG_x(dump_all());
  1377.     DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
  1378.     DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
  1379.                   PTR2UV(thr)));
  1380.  
  1381.     if (PL_minus_c) {
  1382.         PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
  1383.         my_exit(0);
  1384.     }
  1385.     if (PERLDB_SINGLE && PL_DBsingle)
  1386.         sv_setiv(PL_DBsingle, 1); 
  1387.     if (PL_initav)
  1388.         call_list(oldscope, PL_initav);
  1389.     }
  1390.  
  1391.     /* do it */
  1392.  
  1393.     if (PL_restartop) {
  1394.     PL_op = PL_restartop;
  1395.     PL_restartop = 0;
  1396.     CALLRUNOPS(aTHX);
  1397.     }
  1398.     else if (PL_main_start) {
  1399.     CvDEPTH(PL_main_cv) = 1;
  1400.     PL_op = PL_main_start;
  1401.     CALLRUNOPS(aTHX);
  1402.     }
  1403.  
  1404.     my_exit(0);
  1405.     /* NOTREACHED */
  1406.     return NULL;
  1407. }
  1408.  
  1409. /*
  1410. =for apidoc p||get_sv
  1411.  
  1412. Returns the SV of the specified Perl scalar.  If C<create> is set and the
  1413. Perl variable does not exist then it will be created.  If C<create> is not
  1414. set and the variable does not exist then NULL is returned.
  1415.  
  1416. =cut
  1417. */
  1418.  
  1419. SV*
  1420. Perl_get_sv(pTHX_ const char *name, I32 create)
  1421. {
  1422.     GV *gv;
  1423. #ifdef USE_THREADS
  1424.     if (name[1] == '\0' && !isALPHA(name[0])) {
  1425.     PADOFFSET tmp = find_threadsv(name);
  1426.         if (tmp != NOT_IN_PAD) {
  1427.         dTHR;
  1428.         return THREADSV(tmp);
  1429.     }
  1430.     }
  1431. #endif /* USE_THREADS */
  1432.     gv = gv_fetchpv(name, create, SVt_PV);
  1433.     if (gv)
  1434.     return GvSV(gv);
  1435.     return Nullsv;
  1436. }
  1437.  
  1438. /*
  1439. =for apidoc p||get_av
  1440.  
  1441. Returns the AV of the specified Perl array.  If C<create> is set and the
  1442. Perl variable does not exist then it will be created.  If C<create> is not
  1443. set and the variable does not exist then NULL is returned.
  1444.  
  1445. =cut
  1446. */
  1447.  
  1448. AV*
  1449. Perl_get_av(pTHX_ const char *name, I32 create)
  1450. {
  1451.     GV* gv = gv_fetchpv(name, create, SVt_PVAV);
  1452.     if (create)
  1453.         return GvAVn(gv);
  1454.     if (gv)
  1455.     return GvAV(gv);
  1456.     return Nullav;
  1457. }
  1458.  
  1459. /*
  1460. =for apidoc p||get_hv
  1461.  
  1462. Returns the HV of the specified Perl hash.  If C<create> is set and the
  1463. Perl variable does not exist then it will be created.  If C<create> is not
  1464. set and the variable does not exist then NULL is returned.
  1465.  
  1466. =cut
  1467. */
  1468.  
  1469. HV*
  1470. Perl_get_hv(pTHX_ const char *name, I32 create)
  1471. {
  1472.     GV* gv = gv_fetchpv(name, create, SVt_PVHV);
  1473.     if (create)
  1474.         return GvHVn(gv);
  1475.     if (gv)
  1476.     return GvHV(gv);
  1477.     return Nullhv;
  1478. }
  1479.  
  1480. /*
  1481. =for apidoc p||get_cv
  1482.  
  1483. Returns the CV of the specified Perl subroutine.  If C<create> is set and
  1484. the Perl subroutine does not exist then it will be declared (which has the
  1485. same effect as saying C<sub name;>).  If C<create> is not set and the
  1486. subroutine does not exist then NULL is returned.
  1487.  
  1488. =cut
  1489. */
  1490.  
  1491. CV*
  1492. Perl_get_cv(pTHX_ const char *name, I32 create)
  1493. {
  1494.     GV* gv = gv_fetchpv(name, create, SVt_PVCV);
  1495.     /* XXX unsafe for threads if eval_owner isn't held */
  1496.     /* XXX this is probably not what they think they're getting.
  1497.      * It has the same effect as "sub name;", i.e. just a forward
  1498.      * declaration! */
  1499.     if (create && !GvCVu(gv))
  1500.         return newSUB(start_subparse(FALSE, 0),
  1501.               newSVOP(OP_CONST, 0, newSVpv(name,0)),
  1502.               Nullop,
  1503.               Nullop);
  1504.     if (gv)
  1505.     return GvCVu(gv);
  1506.     return Nullcv;
  1507. }
  1508.  
  1509. /* Be sure to refetch the stack pointer after calling these routines. */
  1510.  
  1511. /*
  1512. =for apidoc p||call_argv
  1513.  
  1514. Performs a callback to the specified Perl sub.  See L<perlcall>.
  1515.  
  1516. =cut
  1517. */
  1518.  
  1519. I32
  1520. Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
  1521.               
  1522.                   /* See G_* flags in cop.h */
  1523.                          /* null terminated arg list */
  1524. {
  1525.     dSP;
  1526.  
  1527.     PUSHMARK(SP);
  1528.     if (argv) {
  1529.     while (*argv) {
  1530.         XPUSHs(sv_2mortal(newSVpv(*argv,0)));
  1531.         argv++;
  1532.     }
  1533.     PUTBACK;
  1534.     }
  1535.     return call_pv(sub_name, flags);
  1536. }
  1537.  
  1538. /*
  1539. =for apidoc p||call_pv
  1540.  
  1541. Performs a callback to the specified Perl sub.  See L<perlcall>.
  1542.  
  1543. =cut
  1544. */
  1545.  
  1546. I32
  1547. Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
  1548.                       /* name of the subroutine */
  1549.                   /* See G_* flags in cop.h */
  1550. {
  1551.     return call_sv((SV*)get_cv(sub_name, TRUE), flags);
  1552. }
  1553.  
  1554. /*
  1555. =for apidoc p||call_method
  1556.  
  1557. Performs a callback to the specified Perl method.  The blessed object must
  1558. be on the stack.  See L<perlcall>.
  1559.  
  1560. =cut
  1561. */
  1562.  
  1563. I32
  1564. Perl_call_method(pTHX_ const char *methname, I32 flags)
  1565.                        /* name of the subroutine */
  1566.                   /* See G_* flags in cop.h */
  1567. {
  1568.     dSP;
  1569.     OP myop;
  1570.     if (!PL_op) {
  1571.     Zero(&myop, 1, OP);
  1572.     PL_op = &myop;
  1573.     }
  1574.     XPUSHs(sv_2mortal(newSVpv(methname,0)));
  1575.     PUTBACK;
  1576.     pp_method();
  1577.     if (PL_op == &myop)
  1578.     PL_op = Nullop;
  1579.     return call_sv(*PL_stack_sp--, flags);
  1580. }
  1581.  
  1582. /* May be called with any of a CV, a GV, or an SV containing the name. */
  1583. /*
  1584. =for apidoc p||call_sv
  1585.  
  1586. Performs a callback to the Perl sub whose name is in the SV.  See
  1587. L<perlcall>.
  1588.  
  1589. =cut
  1590. */
  1591.  
  1592. I32
  1593. Perl_call_sv(pTHX_ SV *sv, I32 flags)
  1594.        
  1595.                   /* See G_* flags in cop.h */
  1596. {
  1597.     dSP;
  1598.     LOGOP myop;        /* fake syntax tree node */
  1599.     I32 oldmark;
  1600.     I32 retval;
  1601.     I32 oldscope;
  1602.     bool oldcatch = CATCH_GET;
  1603.     int ret;
  1604.     OP* oldop = PL_op;
  1605.     dJMPENV;
  1606.  
  1607.     if (flags & G_DISCARD) {
  1608.     ENTER;
  1609.     SAVETMPS;
  1610.     }
  1611.  
  1612.     Zero(&myop, 1, LOGOP);
  1613.     myop.op_next = Nullop;
  1614.     if (!(flags & G_NOARGS))
  1615.     myop.op_flags |= OPf_STACKED;
  1616.     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
  1617.               (flags & G_ARRAY) ? OPf_WANT_LIST :
  1618.               OPf_WANT_SCALAR);
  1619.     SAVEOP();
  1620.     PL_op = (OP*)&myop;
  1621.  
  1622.     EXTEND(PL_stack_sp, 1);
  1623.     *++PL_stack_sp = sv;
  1624.     oldmark = TOPMARK;
  1625.     oldscope = PL_scopestack_ix;
  1626.  
  1627.     if (PERLDB_SUB && PL_curstash != PL_debstash
  1628.        /* Handle first BEGIN of -d. */
  1629.       && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
  1630.        /* Try harder, since this may have been a sighandler, thus
  1631.         * curstash may be meaningless. */
  1632.       && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
  1633.       && !(flags & G_NODEBUG))
  1634.     PL_op->op_private |= OPpENTERSUB_DB;
  1635.  
  1636.     if (!(flags & G_EVAL)) {
  1637.     CATCH_SET(TRUE);
  1638.     call_body((OP*)&myop, FALSE);
  1639.     retval = PL_stack_sp - (PL_stack_base + oldmark);
  1640.     CATCH_SET(oldcatch);
  1641.     }
  1642.     else {
  1643.     cLOGOP->op_other = PL_op;
  1644.     PL_markstack_ptr--;
  1645.     /* we're trying to emulate pp_entertry() here */
  1646.     {
  1647.         register PERL_CONTEXT *cx;
  1648.         I32 gimme = GIMME_V;
  1649.         
  1650.         ENTER;
  1651.         SAVETMPS;
  1652.         
  1653.         push_return(PL_op->op_next);
  1654.         PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
  1655.         PUSHEVAL(cx, 0, 0);
  1656.         PL_eval_root = PL_op;             /* Only needed so that goto works right. */
  1657.         
  1658.         PL_in_eval = EVAL_INEVAL;
  1659.         if (flags & G_KEEPERR)
  1660.         PL_in_eval |= EVAL_KEEPERR;
  1661.         else
  1662.         sv_setpv(ERRSV,"");
  1663.     }
  1664.     PL_markstack_ptr++;
  1665.  
  1666. #ifdef PERL_FLEXIBLE_EXCEPTIONS
  1667.  redo_body:
  1668.     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
  1669.             (OP*)&myop, FALSE);
  1670. #else
  1671.     JMPENV_PUSH(ret);
  1672. #endif
  1673.     switch (ret) {
  1674.     case 0:
  1675. #ifndef PERL_FLEXIBLE_EXCEPTIONS
  1676.  redo_body:
  1677.         call_body((OP*)&myop, FALSE);
  1678. #endif
  1679.         retval = PL_stack_sp - (PL_stack_base + oldmark);
  1680.         if (!(flags & G_KEEPERR))
  1681.         sv_setpv(ERRSV,"");
  1682.         break;
  1683.     case 1:
  1684.         STATUS_ALL_FAILURE;
  1685.         /* FALL THROUGH */
  1686.     case 2:
  1687.         /* my_exit() was called */
  1688.         PL_curstash = PL_defstash;
  1689.         FREETMPS;
  1690.         JMPENV_POP;
  1691.         if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
  1692.         Perl_croak(aTHX_ "Callback called exit");
  1693.         my_exit_jump();
  1694.         /* NOTREACHED */
  1695.     case 3:
  1696.         if (PL_restartop) {
  1697.         PL_op = PL_restartop;
  1698.         PL_restartop = 0;
  1699.         goto redo_body;
  1700.         }
  1701.         PL_stack_sp = PL_stack_base + oldmark;
  1702.         if (flags & G_ARRAY)
  1703.         retval = 0;
  1704.         else {
  1705.         retval = 1;
  1706.         *++PL_stack_sp = &PL_sv_undef;
  1707.         }
  1708.         break;
  1709.     }
  1710.  
  1711.     if (PL_scopestack_ix > oldscope) {
  1712.         SV **newsp;
  1713.         PMOP *newpm;
  1714.         I32 gimme;
  1715.         register PERL_CONTEXT *cx;
  1716.         I32 optype;
  1717.  
  1718.         POPBLOCK(cx,newpm);
  1719.         POPEVAL(cx);
  1720.         pop_return();
  1721.         PL_curpm = newpm;
  1722.         LEAVE;
  1723.     }
  1724.     JMPENV_POP;
  1725.     }
  1726.  
  1727.     if (flags & G_DISCARD) {
  1728.     PL_stack_sp = PL_stack_base + oldmark;
  1729.     retval = 0;
  1730.     FREETMPS;
  1731.     LEAVE;
  1732.     }
  1733.     PL_op = oldop;
  1734.     return retval;
  1735. }
  1736.  
  1737. #ifdef PERL_FLEXIBLE_EXCEPTIONS
  1738. STATIC void *
  1739. S_vcall_body(pTHX_ va_list args)
  1740. {
  1741.     OP *myop = va_arg(args, OP*);
  1742.     int is_eval = va_arg(args, int);
  1743.  
  1744.     call_body(myop, is_eval);
  1745.     return NULL;
  1746. }
  1747. #endif
  1748.  
  1749. STATIC void
  1750. S_call_body(pTHX_ OP *myop, int is_eval)
  1751. {
  1752.     dTHR;
  1753.  
  1754.     if (PL_op == myop) {
  1755.     if (is_eval)
  1756.         PL_op = Perl_pp_entereval(aTHX);
  1757.     else
  1758.         PL_op = Perl_pp_entersub(aTHX);
  1759.     }
  1760.     if (PL_op)
  1761.     CALLRUNOPS(aTHX);
  1762. }
  1763.  
  1764. /* Eval a string. The G_EVAL flag is always assumed. */
  1765.  
  1766. /*
  1767. =for apidoc p||eval_sv
  1768.  
  1769. Tells Perl to C<eval> the string in the SV.
  1770.  
  1771. =cut
  1772. */
  1773.  
  1774. I32
  1775. Perl_eval_sv(pTHX_ SV *sv, I32 flags)
  1776.        
  1777.                   /* See G_* flags in cop.h */
  1778. {
  1779.     dSP;
  1780.     UNOP myop;        /* fake syntax tree node */
  1781.     I32 oldmark = SP - PL_stack_base;
  1782.     I32 retval;
  1783.     I32 oldscope;
  1784.     int ret;
  1785.     OP* oldop = PL_op;
  1786.     dJMPENV;
  1787.  
  1788.     if (flags & G_DISCARD) {
  1789.     ENTER;
  1790.     SAVETMPS;
  1791.     }
  1792.  
  1793.     SAVEOP();
  1794.     PL_op = (OP*)&myop;
  1795.     Zero(PL_op, 1, UNOP);
  1796.     EXTEND(PL_stack_sp, 1);
  1797.     *++PL_stack_sp = sv;
  1798.     oldscope = PL_scopestack_ix;
  1799.  
  1800.     if (!(flags & G_NOARGS))
  1801.     myop.op_flags = OPf_STACKED;
  1802.     myop.op_next = Nullop;
  1803.     myop.op_type = OP_ENTEREVAL;
  1804.     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
  1805.               (flags & G_ARRAY) ? OPf_WANT_LIST :
  1806.               OPf_WANT_SCALAR);
  1807.     if (flags & G_KEEPERR)
  1808.     myop.op_flags |= OPf_SPECIAL;
  1809.  
  1810. #ifdef PERL_FLEXIBLE_EXCEPTIONS
  1811.  redo_body:
  1812.     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
  1813.         (OP*)&myop, TRUE);
  1814. #else
  1815.     JMPENV_PUSH(ret);
  1816. #endif
  1817.     switch (ret) {
  1818.     case 0:
  1819. #ifndef PERL_FLEXIBLE_EXCEPTIONS
  1820.  redo_body:
  1821.     call_body((OP*)&myop,TRUE);
  1822. #endif
  1823.     retval = PL_stack_sp - (PL_stack_base + oldmark);
  1824.     if (!(flags & G_KEEPERR))
  1825.         sv_setpv(ERRSV,"");
  1826.     break;
  1827.     case 1:
  1828.     STATUS_ALL_FAILURE;
  1829.     /* FALL THROUGH */
  1830.     case 2:
  1831.     /* my_exit() was called */
  1832.     PL_curstash = PL_defstash;
  1833.     FREETMPS;
  1834.     JMPENV_POP;
  1835.     if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
  1836.         Perl_croak(aTHX_ "Callback called exit");
  1837.     my_exit_jump();
  1838.     /* NOTREACHED */
  1839.     case 3:
  1840.     if (PL_restartop) {
  1841.         PL_op = PL_restartop;
  1842.         PL_restartop = 0;
  1843.         goto redo_body;
  1844.     }
  1845.     PL_stack_sp = PL_stack_base + oldmark;
  1846.     if (flags & G_ARRAY)
  1847.         retval = 0;
  1848.     else {
  1849.         retval = 1;
  1850.         *++PL_stack_sp = &PL_sv_undef;
  1851.     }
  1852.     break;
  1853.     }
  1854.  
  1855.     JMPENV_POP;
  1856.     if (flags & G_DISCARD) {
  1857.     PL_stack_sp = PL_stack_base + oldmark;
  1858.     retval = 0;
  1859.     FREETMPS;
  1860.     LEAVE;
  1861.     }
  1862.     PL_op = oldop;
  1863.     return retval;
  1864. }
  1865.  
  1866. /*
  1867. =for apidoc p||eval_pv
  1868.  
  1869. Tells Perl to C<eval> the given string and return an SV* result.
  1870.  
  1871. =cut
  1872. */
  1873.  
  1874. SV*
  1875. Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
  1876. {
  1877.     dSP;
  1878.     SV* sv = newSVpv(p, 0);
  1879.  
  1880.     PUSHMARK(SP);
  1881.     eval_sv(sv, G_SCALAR);
  1882.     SvREFCNT_dec(sv);
  1883.  
  1884.     SPAGAIN;
  1885.     sv = POPs;
  1886.     PUTBACK;
  1887.  
  1888.     if (croak_on_error && SvTRUE(ERRSV)) {
  1889.     STRLEN n_a;
  1890.     Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
  1891.     }
  1892.  
  1893.     return sv;
  1894. }
  1895.  
  1896. /* Require a module. */
  1897.  
  1898. /*
  1899. =for apidoc p||require_pv
  1900.  
  1901. Tells Perl to C<require> a module.
  1902.  
  1903. =cut
  1904. */
  1905.  
  1906. void
  1907. Perl_require_pv(pTHX_ const char *pv)
  1908. {
  1909.     SV* sv;
  1910.     dSP;
  1911.     PUSHSTACKi(PERLSI_REQUIRE);
  1912.     PUTBACK;
  1913.     sv = sv_newmortal();
  1914.     sv_setpv(sv, "require '");
  1915.     sv_catpv(sv, pv);
  1916.     sv_catpv(sv, "'");
  1917.     eval_sv(sv, G_DISCARD);
  1918.     SPAGAIN;
  1919.     POPSTACK;
  1920. }
  1921.  
  1922. void
  1923. Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
  1924. {
  1925.     register GV *gv;
  1926.  
  1927.     if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
  1928.     sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
  1929. }
  1930.  
  1931. STATIC void
  1932. S_usage(pTHX_ char *name)        /* XXX move this out into a module ? */
  1933. {
  1934.     /* This message really ought to be max 23 lines.
  1935.      * Removed -h because the user already knows that opton. Others? */
  1936.  
  1937.     static char *usage_msg[] = {
  1938. "-0[octal]       specify record separator (\\0, if no argument)",
  1939. "-a              autosplit mode with -n or -p (splits $_ into @F)",
  1940. "-C              enable native wide character system interfaces",
  1941. "-c              check syntax only (runs BEGIN and END blocks)",
  1942. "-d[:debugger]   run program under debugger",
  1943. "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
  1944. "-e 'command'    one line of program (several -e's allowed, omit programfile)",
  1945. "-F/pattern/     split() pattern for -a switch (//'s are optional)",
  1946. "-i[extension]   edit <> files in place (makes backup if extension supplied)",
  1947. "-Idirectory     specify @INC/#include directory (several -I's allowed)",
  1948. "-l[octal]       enable line ending processing, specifies line terminator",
  1949. "-[mM][-]module  execute `use/no module...' before executing program",
  1950. "-n              assume 'while (<>) { ... }' loop around program",
  1951. "-p              assume loop like -n but print line also, like sed",
  1952. "-P              run program through C preprocessor before compilation",
  1953. "-s              enable rudimentary parsing for switches after programfile",
  1954. "-S              look for programfile using PATH environment variable",
  1955. "-T              enable tainting checks",
  1956. "-u              dump core after parsing program",
  1957. "-U              allow unsafe operations",
  1958. "-v              print version, subversion (includes VERY IMPORTANT perl info)",
  1959. "-V[:variable]   print configuration summary (or a single Config.pm variable)",
  1960. "-w              enable many useful warnings (RECOMMENDED)",
  1961. "-W              enable all warnings",
  1962. "-X              disable all warnings",
  1963. "-x[directory]   strip off text before #!perl line and perhaps cd to directory",
  1964. "\n",
  1965. NULL
  1966. };
  1967.     char **p = usage_msg;
  1968.  
  1969.     printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
  1970.     while (*p)
  1971.     printf("\n  %s", *p++);
  1972. }
  1973.  
  1974. /* This routine handles any switches that can be given during run */
  1975.  
  1976. char *
  1977. Perl_moreswitches(pTHX_ char *s)
  1978. {
  1979.     I32 numlen;
  1980.     U32 rschar;
  1981.  
  1982.     switch (*s) {
  1983.     case '0':
  1984.     {
  1985.     dTHR;
  1986.     rschar = (U32)scan_oct(s, 4, &numlen);
  1987.     SvREFCNT_dec(PL_nrs);
  1988.     if (rschar & ~((U8)~0))
  1989.         PL_nrs = &PL_sv_undef;
  1990.     else if (!rschar && numlen >= 2)
  1991.         PL_nrs = newSVpvn("", 0);
  1992.     else {
  1993.         char ch = rschar;
  1994.         PL_nrs = newSVpvn(&ch, 1);
  1995.     }
  1996.     return s + numlen;
  1997.     }
  1998.     case 'C':
  1999.     PL_widesyscalls = TRUE;
  2000.     s++;
  2001.     return s;
  2002.     case 'F':
  2003.     PL_minus_F = TRUE;
  2004.     PL_splitstr = savepv(s + 1);
  2005.     s += strlen(s);
  2006.     return s;
  2007.     case 'a':
  2008.     PL_minus_a = TRUE;
  2009.     s++;
  2010.     return s;
  2011.     case 'c':
  2012.     PL_minus_c = TRUE;
  2013.     s++;
  2014.     return s;
  2015.     case 'd':
  2016.     forbid_setid("-d");
  2017.     s++;
  2018.     if (*s == ':' || *s == '=')  {
  2019.         my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
  2020.         s += strlen(s);
  2021.     }
  2022.     if (!PL_perldb) {
  2023.         PL_perldb = PERLDB_ALL;
  2024.         init_debugger();
  2025.     }
  2026.     return s;
  2027.     case 'D':
  2028.     {    
  2029. #ifdef DEBUGGING
  2030.     forbid_setid("-D");
  2031.     if (isALPHA(s[1])) {
  2032.         static char debopts[] = "psltocPmfrxuLHXDS";
  2033.         char *d;
  2034.  
  2035.         for (s++; *s && (d = strchr(debopts,*s)); s++)
  2036.         PL_debug |= 1 << (d - debopts);
  2037.     }
  2038.     else {
  2039.         PL_debug = atoi(s+1);
  2040.         for (s++; isDIGIT(*s); s++) ;
  2041.     }
  2042.     PL_debug |= 0x80000000;
  2043. #else
  2044.     dTHR;
  2045.     if (ckWARN_d(WARN_DEBUGGING))
  2046.         Perl_warner(aTHX_ WARN_DEBUGGING,
  2047.                "Recompile perl with -DDEBUGGING to use -D switch\n");
  2048.     for (s++; isALNUM(*s); s++) ;
  2049. #endif
  2050.     /*SUPPRESS 530*/
  2051.     return s;
  2052.     }    
  2053.     case 'h':
  2054.     usage(PL_origargv[0]);    
  2055.     PerlProc_exit(0);
  2056.     case 'i':
  2057.     if (PL_inplace)
  2058.         Safefree(PL_inplace);
  2059.     PL_inplace = savepv(s+1);
  2060.     /*SUPPRESS 530*/
  2061.     for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
  2062.     if (*s) {
  2063.         *s++ = '\0';
  2064.         if (*s == '-')    /* Additional switches on #! line. */
  2065.             s++;
  2066.     }
  2067.     return s;
  2068.     case 'I':    /* -I handled both here and in parse_perl() */
  2069.     forbid_setid("-I");
  2070.     ++s;
  2071.     while (*s && isSPACE(*s))
  2072.         ++s;
  2073.     if (*s) {
  2074.         char *e, *p;
  2075.         p = s;
  2076.         /* ignore trailing spaces (possibly followed by other switches) */
  2077.         do {
  2078.         for (e = p; *e && !isSPACE(*e); e++) ;
  2079.         p = e;
  2080.         while (isSPACE(*p))
  2081.             p++;
  2082.         } while (*p && *p != '-');
  2083.         e = savepvn(s, e-s);
  2084.         incpush(e, TRUE, TRUE);
  2085.         Safefree(e);
  2086.         s = p;
  2087.         if (*s == '-')
  2088.         s++;
  2089.     }
  2090.     else
  2091.         Perl_croak(aTHX_ "No directory specified for -I");
  2092.     return s;
  2093.     case 'l':
  2094.     PL_minus_l = TRUE;
  2095.     s++;
  2096.     if (PL_ors)
  2097.         Safefree(PL_ors);
  2098.     if (isDIGIT(*s)) {
  2099.         PL_ors = savepv("\n");
  2100.         PL_orslen = 1;
  2101.         *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
  2102.         s += numlen;
  2103.     }
  2104.     else {
  2105.         dTHR;
  2106.         if (RsPARA(PL_nrs)) {
  2107.         PL_ors = "\n\n";
  2108.         PL_orslen = 2;
  2109.         }
  2110.         else
  2111.         PL_ors = SvPV(PL_nrs, PL_orslen);
  2112.         PL_ors = savepvn(PL_ors, PL_orslen);
  2113.     }
  2114.     return s;
  2115.     case 'M':
  2116.     forbid_setid("-M");    /* XXX ? */
  2117.     /* FALL THROUGH */
  2118.     case 'm':
  2119.     forbid_setid("-m");    /* XXX ? */
  2120.     if (*++s) {
  2121.         char *start;
  2122.         SV *sv;
  2123.         char *use = "use ";
  2124.         /* -M-foo == 'no foo'    */
  2125.         if (*s == '-') { use = "no "; ++s; }
  2126.         sv = newSVpv(use,0);
  2127.         start = s;
  2128.         /* We allow -M'Module qw(Foo Bar)'    */
  2129.         while(isALNUM(*s) || *s==':') ++s;
  2130.         if (*s != '=') {
  2131.         sv_catpv(sv, start);
  2132.         if (*(start-1) == 'm') {
  2133.             if (*s != '\0')
  2134.             Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
  2135.             sv_catpv( sv, " ()");
  2136.         }
  2137.         } else {
  2138.         sv_catpvn(sv, start, s-start);
  2139.         sv_catpv(sv, " split(/,/,q{");
  2140.         sv_catpv(sv, ++s);
  2141.         sv_catpv(sv,    "})");
  2142.         }
  2143.         s += strlen(s);
  2144.         if (!PL_preambleav)
  2145.         PL_preambleav = newAV();
  2146.         av_push(PL_preambleav, sv);
  2147.     }
  2148.     else
  2149.         Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
  2150.     return s;
  2151.     case 'n':
  2152.     PL_minus_n = TRUE;
  2153.     s++;
  2154.     return s;
  2155.     case 'p':
  2156.     PL_minus_p = TRUE;
  2157.     s++;
  2158.     return s;
  2159.     case 's':
  2160.     forbid_setid("-s");
  2161.     PL_doswitches = TRUE;
  2162.     s++;
  2163.     return s;
  2164.     case 'T':
  2165.     if (!PL_tainting)
  2166.         Perl_croak(aTHX_ "Too late for \"-T\" option");
  2167.     s++;
  2168.     return s;
  2169.     case 'u':
  2170.     PL_do_undump = TRUE;
  2171.     s++;
  2172.     return s;
  2173.     case 'U':
  2174.     PL_unsafe = TRUE;
  2175.     s++;
  2176.     return s;
  2177.     case 'v':
  2178.     printf(Perl_form(aTHX_ "\nThis is perl, v%vd built for %s",
  2179.              PL_patchlevel, ARCHNAME));
  2180. #if defined(LOCAL_PATCH_COUNT)
  2181.     if (LOCAL_PATCH_COUNT > 0)
  2182.         printf("\n(with %d registered patch%s, see perl -V for more detail)",
  2183.         (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
  2184. #endif
  2185.  
  2186.     printf("\n\nCopyright 1987-2000, Larry Wall\n");
  2187. #ifdef MSDOS
  2188.     printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
  2189. #endif
  2190. #ifdef DJGPP
  2191.     printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
  2192.     printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
  2193. #endif
  2194. #ifdef OS2
  2195.     printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
  2196.         "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
  2197. #endif
  2198. #ifdef atarist
  2199.     printf("atariST series port, ++jrb  bammi@cadence.com\n");
  2200. #endif
  2201. #ifdef __BEOS__
  2202.     printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
  2203. #endif
  2204. #ifdef MPE
  2205.     printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
  2206. #endif
  2207. #ifdef OEMVS
  2208.     printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
  2209. #endif
  2210. #ifdef __VOS__
  2211.     printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
  2212. #endif
  2213. #ifdef __OPEN_VM
  2214.     printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
  2215. #endif
  2216. #ifdef POSIX_BC
  2217.     printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
  2218. #endif
  2219. #ifdef __MINT__
  2220.     printf("MiNT port by Guido Flohr, 1997-1999\n");
  2221. #endif
  2222. #ifdef EPOC
  2223.     printf("EPOC port by Olaf Flebbe, 1999-2000\n");
  2224. #endif
  2225. #ifdef BINARY_BUILD_NOTICE
  2226.     BINARY_BUILD_NOTICE;
  2227. #endif
  2228.     printf("\n\
  2229. Perl may be copied only under the terms of either the Artistic License or the\n\
  2230. GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
  2231. Complete documentation for Perl, including FAQ lists, should be found on\n\
  2232. this system using `man perl' or `perldoc perl'.  If you have access to the\n\
  2233. Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
  2234.     PerlProc_exit(0);
  2235.     case 'w':
  2236.     if (! (PL_dowarn & G_WARN_ALL_MASK))
  2237.         PL_dowarn |= G_WARN_ON; 
  2238.     s++;
  2239.     return s;
  2240.     case 'W':
  2241.     PL_dowarn = G_WARN_ALL_ON|G_WARN_ON; 
  2242.     PL_compiling.cop_warnings = pWARN_ALL ;
  2243.     s++;
  2244.     return s;
  2245.     case 'X':
  2246.     PL_dowarn = G_WARN_ALL_OFF; 
  2247.     PL_compiling.cop_warnings = pWARN_NONE ;
  2248.     s++;
  2249.     return s;
  2250.     case '*':
  2251.     case ' ':
  2252.     if (s[1] == '-')    /* Additional switches on #! line. */
  2253.         return s+2;
  2254.     break;
  2255.     case '-':
  2256.     case 0:
  2257. #if defined(WIN32) || !defined(PERL_STRICT_CR)
  2258.     case '\r':
  2259. #endif
  2260.     case '\n':
  2261.     case '\t':
  2262.     break;
  2263. #ifdef ALTERNATE_SHEBANG
  2264.     case 'S':            /* OS/2 needs -S on "extproc" line. */
  2265.     break;
  2266. #endif
  2267.     case 'P':
  2268.     if (PL_preprocess)
  2269.         return s+1;
  2270.     /* FALL THROUGH */
  2271.     default:
  2272.     Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
  2273.     }
  2274.     return Nullch;
  2275. }
  2276.  
  2277. /* compliments of Tom Christiansen */
  2278.  
  2279. /* unexec() can be found in the Gnu emacs distribution */
  2280. /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
  2281.  
  2282. void
  2283. Perl_my_unexec(pTHX)
  2284. {
  2285. #ifdef UNEXEC
  2286.     SV*    prog;
  2287.     SV*    file;
  2288.     int    status = 1;
  2289.     extern int etext;
  2290.  
  2291.     prog = newSVpv(BIN_EXP, 0);
  2292.     sv_catpv(prog, "/perl");
  2293.     file = newSVpv(PL_origfilename, 0);
  2294.     sv_catpv(file, ".perldump");
  2295.  
  2296.     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
  2297.     /* unexec prints msg to stderr in case of failure */
  2298.     PerlProc_exit(status);
  2299. #else
  2300. #  ifdef VMS
  2301. #    include <lib$routines.h>
  2302.      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
  2303. #  else
  2304.     ABORT();        /* for use with undump */
  2305. #  endif
  2306. #endif
  2307. }
  2308.  
  2309. /* initialize curinterp */
  2310. STATIC void
  2311. S_init_interp(pTHX)
  2312. {
  2313.  
  2314. #ifdef PERL_OBJECT        /* XXX kludge */
  2315. #define I_REINIT \
  2316.   STMT_START {                \
  2317.     PL_chopset        = " \n-";    \
  2318.     PL_copline        = NOLINE;    \
  2319.     PL_curcop        = &PL_compiling;\
  2320.     PL_curcopdb        = NULL;        \
  2321.     PL_dbargs        = 0;        \
  2322.     PL_dumpindent    = 4;        \
  2323.     PL_laststatval    = -1;        \
  2324.     PL_laststype    = OP_STAT;    \
  2325.     PL_maxscream    = -1;        \
  2326.     PL_maxsysfd        = MAXSYSFD;    \
  2327.     PL_statname        = Nullsv;    \
  2328.     PL_tmps_floor    = -1;        \
  2329.     PL_tmps_ix        = -1;        \
  2330.     PL_op_mask        = NULL;        \
  2331.     PL_laststatval    = -1;        \
  2332.     PL_laststype    = OP_STAT;    \
  2333.     PL_mess_sv        = Nullsv;    \
  2334.     PL_splitstr        = " ";        \
  2335.     PL_generation    = 100;        \
  2336.     PL_exitlist        = NULL;        \
  2337.     PL_exitlistlen    = 0;        \
  2338.     PL_regindent    = 0;        \
  2339.     PL_in_clean_objs    = FALSE;    \
  2340.     PL_in_clean_all    = FALSE;    \
  2341.     PL_profiledata    = NULL;        \
  2342.     PL_rsfp        = Nullfp;    \
  2343.     PL_rsfp_filters    = Nullav;    \
  2344.     PL_dirty        = FALSE;    \
  2345.   } STMT_END
  2346.     I_REINIT;
  2347. #else
  2348. #  ifdef MULTIPLICITY
  2349. #    define PERLVAR(var,type)
  2350. #    define PERLVARA(var,n,type)
  2351. #    if defined(PERL_IMPLICIT_CONTEXT)
  2352. #      if defined(USE_THREADS)
  2353. #        define PERLVARI(var,type,init)        PERL_GET_INTERP->var = init;
  2354. #        define PERLVARIC(var,type,init)    PERL_GET_INTERP->var = init;
  2355. #      else /* !USE_THREADS */
  2356. #        define PERLVARI(var,type,init)        aTHX->var = init;
  2357. #        define PERLVARIC(var,type,init)    aTHX->var = init;
  2358. #      endif /* USE_THREADS */
  2359. #    else
  2360. #      define PERLVARI(var,type,init)    PERL_GET_INTERP->var = init;
  2361. #      define PERLVARIC(var,type,init)    PERL_GET_INTERP->var = init;
  2362. #    endif
  2363. #    include "intrpvar.h"
  2364. #    ifndef USE_THREADS
  2365. #      include "thrdvar.h"
  2366. #    endif
  2367. #    undef PERLVAR
  2368. #    undef PERLVARA
  2369. #    undef PERLVARI
  2370. #    undef PERLVARIC
  2371. #  else
  2372. #    define PERLVAR(var,type)
  2373. #    define PERLVARA(var,n,type)
  2374. #    define PERLVARI(var,type,init)    PL_##var = init;
  2375. #    define PERLVARIC(var,type,init)    PL_##var = init;
  2376. #    include "intrpvar.h"
  2377. #    ifndef USE_THREADS
  2378. #      include "thrdvar.h"
  2379. #    endif
  2380. #    undef PERLVAR
  2381. #    undef PERLVARA
  2382. #    undef PERLVARI
  2383. #    undef PERLVARIC
  2384. #  endif
  2385. #endif
  2386.  
  2387. }
  2388.  
  2389. STATIC void
  2390. S_init_main_stash(pTHX)
  2391. {
  2392.     dTHR;
  2393.     GV *gv;
  2394.  
  2395.     /* Note that strtab is a rather special HV.  Assumptions are made
  2396.        about not iterating on it, and not adding tie magic to it.
  2397.        It is properly deallocated in perl_destruct() */
  2398.     PL_strtab = newHV();
  2399. #ifdef USE_THREADS
  2400.     MUTEX_INIT(&PL_strtab_mutex);
  2401. #endif
  2402.     HvSHAREKEYS_off(PL_strtab);            /* mandatory */
  2403.     hv_ksplit(PL_strtab, 512);
  2404.     
  2405.     PL_curstash = PL_defstash = newHV();
  2406.     PL_curstname = newSVpvn("main",4);
  2407.     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
  2408.     SvREFCNT_dec(GvHV(gv));
  2409.     GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
  2410.     SvREADONLY_on(gv);
  2411.     HvNAME(PL_defstash) = savepv("main");
  2412.     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
  2413.     GvMULTI_on(PL_incgv);
  2414.     PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
  2415.     GvMULTI_on(PL_hintgv);
  2416.     PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
  2417.     PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
  2418.     GvMULTI_on(PL_errgv);
  2419.     PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
  2420.     GvMULTI_on(PL_replgv);
  2421.     (void)Perl_form(aTHX_ "%240s","");    /* Preallocate temp - for immediate signals. */
  2422.     sv_grow(ERRSV, 240);    /* Preallocate - for immediate signals. */
  2423.     sv_setpvn(ERRSV, "", 0);
  2424.     PL_curstash = PL_defstash;
  2425.     CopSTASH_set(&PL_compiling, PL_defstash);
  2426.     PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
  2427.     PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
  2428.     /* We must init $/ before switches are processed. */
  2429.     sv_setpvn(get_sv("/", TRUE), "\n", 1);
  2430. }
  2431.  
  2432. STATIC void
  2433. S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
  2434. {
  2435.     dTHR;
  2436.  
  2437.     *fdscript = -1;
  2438.  
  2439.     if (PL_e_script) {
  2440.     PL_origfilename = savepv("-e");
  2441.     }
  2442.     else {
  2443.     /* if find_script() returns, it returns a malloc()-ed value */
  2444.     PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
  2445.  
  2446.     if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
  2447.         char *s = scriptname + 8;
  2448.         *fdscript = atoi(s);
  2449.         while (isDIGIT(*s))
  2450.         s++;
  2451.         if (*s) {
  2452.         scriptname = savepv(s + 1);
  2453.         Safefree(PL_origfilename);
  2454.         PL_origfilename = scriptname;
  2455.         }
  2456.     }
  2457.     }
  2458.  
  2459.     CopFILE_set(PL_curcop, PL_origfilename);
  2460.     if (strEQ(PL_origfilename,"-"))
  2461.     scriptname = "";
  2462.     if (*fdscript >= 0) {
  2463.     PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
  2464. #if defined(HAS_FCNTL) && defined(F_SETFD)
  2465.     if (PL_rsfp)
  2466.         fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);  /* ensure close-on-exec */
  2467. #endif
  2468.     }
  2469.     else if (PL_preprocess) {
  2470.     char *cpp_cfg = CPPSTDIN;
  2471.     SV *cpp = newSVpvn("",0);
  2472.     SV *cmd = NEWSV(0,0);
  2473.  
  2474.     if (strEQ(cpp_cfg, "cppstdin"))
  2475.         Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
  2476.     sv_catpv(cpp, cpp_cfg);
  2477.  
  2478.     sv_catpvn(sv, "-I", 2);
  2479.     sv_catpv(sv,PRIVLIB_EXP);
  2480.  
  2481. #ifdef MSDOS
  2482.     Perl_sv_setpvf(aTHX_ cmd, "\
  2483. sed %s -e \"/^[^#]/b\" \
  2484.  -e \"/^#[     ]*include[     ]/b\" \
  2485.  -e \"/^#[     ]*define[     ]/b\" \
  2486.  -e \"/^#[     ]*if[     ]/b\" \
  2487.  -e \"/^#[     ]*ifdef[     ]/b\" \
  2488.  -e \"/^#[     ]*ifndef[     ]/b\" \
  2489.  -e \"/^#[     ]*else/b\" \
  2490.  -e \"/^#[     ]*elif[     ]/b\" \
  2491.  -e \"/^#[     ]*undef[     ]/b\" \
  2492.  -e \"/^#[     ]*endif/b\" \
  2493.  -e \"s/^#.*//\" \
  2494.  %s | %"SVf" -C %"SVf" %s",
  2495.       (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
  2496. #else
  2497. #  ifdef __OPEN_VM
  2498.     Perl_sv_setpvf(aTHX_ cmd, "\
  2499. %s %s -e '/^[^#]/b' \
  2500.  -e '/^#[     ]*include[     ]/b' \
  2501.  -e '/^#[     ]*define[     ]/b' \
  2502.  -e '/^#[     ]*if[     ]/b' \
  2503.  -e '/^#[     ]*ifdef[     ]/b' \
  2504.  -e '/^#[     ]*ifndef[     ]/b' \
  2505.  -e '/^#[     ]*else/b' \
  2506.  -e '/^#[     ]*elif[     ]/b' \
  2507.  -e '/^#[     ]*undef[     ]/b' \
  2508.  -e '/^#[     ]*endif/b' \
  2509.  -e 's/^[     ]*#.*//' \
  2510.  %s | %"SVf" %"SVf" %s",
  2511. #  else
  2512.     Perl_sv_setpvf(aTHX_ cmd, "\
  2513. %s %s -e '/^[^#]/b' \
  2514.  -e '/^#[     ]*include[     ]/b' \
  2515.  -e '/^#[     ]*define[     ]/b' \
  2516.  -e '/^#[     ]*if[     ]/b' \
  2517.  -e '/^#[     ]*ifdef[     ]/b' \
  2518.  -e '/^#[     ]*ifndef[     ]/b' \
  2519.  -e '/^#[     ]*else/b' \
  2520.  -e '/^#[     ]*elif[     ]/b' \
  2521.  -e '/^#[     ]*undef[     ]/b' \
  2522.  -e '/^#[     ]*endif/b' \
  2523.  -e 's/^[     ]*#.*//' \
  2524.  %s | %"SVf" -C %"SVf" %s",
  2525. #  endif
  2526. #ifdef LOC_SED
  2527.       LOC_SED,
  2528. #else
  2529.       "sed",
  2530. #endif
  2531.       (PL_doextract ? "-e '1,/^#/d\n'" : ""),
  2532. #endif
  2533.       scriptname, cpp, sv, CPPMINUS);
  2534.     PL_doextract = FALSE;
  2535. #ifdef IAMSUID                /* actually, this is caught earlier */
  2536.     if (PL_euid != PL_uid && !PL_euid) {    /* if running suidperl */
  2537. #ifdef HAS_SETEUID
  2538.         (void)seteuid(PL_uid);        /* musn't stay setuid root */
  2539. #else
  2540. #ifdef HAS_SETREUID
  2541.         (void)setreuid((Uid_t)-1, PL_uid);
  2542. #else
  2543. #ifdef HAS_SETRESUID
  2544.         (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
  2545. #else
  2546.         PerlProc_setuid(PL_uid);
  2547. #endif
  2548. #endif
  2549. #endif
  2550.         if (PerlProc_geteuid() != PL_uid)
  2551.         Perl_croak(aTHX_ "Can't do seteuid!\n");
  2552.     }
  2553. #endif /* IAMSUID */
  2554.     PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
  2555.     SvREFCNT_dec(cmd);
  2556.     SvREFCNT_dec(cpp);
  2557.     }
  2558.     else if (!*scriptname) {
  2559.     forbid_setid("program input from stdin");
  2560.     PL_rsfp = PerlIO_stdin();
  2561.     }
  2562.     else {
  2563.     PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
  2564. #if defined(HAS_FCNTL) && defined(F_SETFD)
  2565.     if (PL_rsfp)
  2566.         fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);  /* ensure close-on-exec */
  2567. #endif
  2568.     }
  2569.     if (!PL_rsfp) {
  2570. #ifdef DOSUID
  2571. #ifndef IAMSUID        /* in case script is not readable before setuid */
  2572.     if (PL_euid &&
  2573.         PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
  2574.         PL_statbuf.st_mode & (S_ISUID|S_ISGID))
  2575.     {
  2576.         /* try again */
  2577.         PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
  2578.                      (int)PERL_REVISION, (int)PERL_VERSION,
  2579.                      (int)PERL_SUBVERSION), PL_origargv);
  2580.         Perl_croak(aTHX_ "Can't do setuid\n");
  2581.     }
  2582. #endif
  2583. #endif
  2584.     Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
  2585.            CopFILE(PL_curcop), Strerror(errno));
  2586.     }
  2587. }
  2588.  
  2589. /* Mention
  2590.  * I_SYSSTATVFS    HAS_FSTATVFS
  2591.  * I_SYSMOUNT
  2592.  * I_STATFS    HAS_FSTATFS    HAS_GETFSSTAT
  2593.  * I_MNTENT    HAS_GETMNTENT    HAS_HASMNTOPT
  2594.  * here so that metaconfig picks them up. */
  2595.  
  2596. #ifdef IAMSUID
  2597. STATIC int
  2598. S_fd_on_nosuid_fs(pTHX_ int fd)
  2599. {
  2600.     int check_okay = 0; /* able to do all the required sys/libcalls */
  2601.     int on_nosuid  = 0; /* the fd is on a nosuid fs */
  2602. /*
  2603.  * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
  2604.  * fstatvfs() is UNIX98.
  2605.  * fstatfs() is 4.3 BSD.
  2606.  * ustat()+getmnt() is pre-4.3 BSD.
  2607.  * getmntent() is O(number-of-mounted-filesystems) and can hang on
  2608.  * an irrelevant filesystem while trying to reach the right one.
  2609.  */
  2610.  
  2611. #   ifdef HAS_FSTATVFS
  2612.     struct statvfs stfs;
  2613.     check_okay = fstatvfs(fd, &stfs) == 0;
  2614.     on_nosuid  = check_okay && (stfs.f_flag  & ST_NOSUID);
  2615. #   else
  2616. #       ifdef PERL_MOUNT_NOSUID
  2617. #           if defined(HAS_FSTATFS) && \
  2618.            defined(HAS_STRUCT_STATFS) && \
  2619.            defined(HAS_STRUCT_STATFS_F_FLAGS)
  2620.     struct statfs  stfs;
  2621.     check_okay = fstatfs(fd, &stfs)  == 0;
  2622.     on_nosuid  = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
  2623. #           else
  2624. #               if defined(HAS_FSTAT) && \
  2625.            defined(HAS_USTAT) && \
  2626.            defined(HAS_GETMNT) && \
  2627.            defined(HAS_STRUCT_FS_DATA) && \
  2628.            defined(NOSTAT_ONE)
  2629.     struct stat fdst;
  2630.     if (fstat(fd, &fdst) == 0) {
  2631.     struct ustat us;
  2632.     if (ustat(fdst.st_dev, &us) == 0) {
  2633.         struct fs_data fsd;
  2634.         /* NOSTAT_ONE here because we're not examining fields which
  2635.          * vary between that case and STAT_ONE. */
  2636.             if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
  2637.         size_t cmplen = sizeof(us.f_fname);
  2638.         if (sizeof(fsd.fd_req.path) < cmplen)
  2639.             cmplen = sizeof(fsd.fd_req.path);
  2640.         if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
  2641.             fdst.st_dev == fsd.fd_req.dev) {
  2642.             check_okay = 1;
  2643.             on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
  2644.             }
  2645.         }
  2646.         }
  2647.     }
  2648.     }
  2649. #               endif /* fstat+ustat+getmnt */
  2650. #           endif /* fstatfs */
  2651. #       else
  2652. #           if defined(HAS_GETMNTENT) && \
  2653.            defined(HAS_HASMNTOPT) && \
  2654.            defined(MNTOPT_NOSUID)
  2655.     FILE        *mtab = fopen("/etc/mtab", "r");
  2656.     struct mntent    *entry;
  2657.     struct stat        stb, fsb;
  2658.  
  2659.     if (mtab && (fstat(fd, &stb) == 0)) {
  2660.     while (entry = getmntent(mtab)) {
  2661.         if (stat(entry->mnt_dir, &fsb) == 0
  2662.         && fsb.st_dev == stb.st_dev)
  2663.         {
  2664.         /* found the filesystem */
  2665.         check_okay = 1;
  2666.         if (hasmntopt(entry, MNTOPT_NOSUID))
  2667.             on_nosuid = 1;
  2668.         break;
  2669.         } /* A single fs may well fail its stat(). */
  2670.     }
  2671.     }
  2672.     if (mtab)
  2673.     fclose(mtab);
  2674. #           endif /* getmntent+hasmntopt */
  2675. #       endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */
  2676. #   endif /* statvfs */
  2677.  
  2678.     if (!check_okay) 
  2679.     Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
  2680.     return on_nosuid;
  2681. }
  2682. #endif /* IAMSUID */
  2683.  
  2684. STATIC void
  2685. S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
  2686. {
  2687. #ifdef IAMSUID
  2688.     int which;
  2689. #endif
  2690.  
  2691.     /* do we need to emulate setuid on scripts? */
  2692.  
  2693.     /* This code is for those BSD systems that have setuid #! scripts disabled
  2694.      * in the kernel because of a security problem.  Merely defining DOSUID
  2695.      * in perl will not fix that problem, but if you have disabled setuid
  2696.      * scripts in the kernel, this will attempt to emulate setuid and setgid
  2697.      * on scripts that have those now-otherwise-useless bits set.  The setuid
  2698.      * root version must be called suidperl or sperlN.NNN.  If regular perl
  2699.      * discovers that it has opened a setuid script, it calls suidperl with
  2700.      * the same argv that it had.  If suidperl finds that the script it has
  2701.      * just opened is NOT setuid root, it sets the effective uid back to the
  2702.      * uid.  We don't just make perl setuid root because that loses the
  2703.      * effective uid we had before invoking perl, if it was different from the
  2704.      * uid.
  2705.      *
  2706.      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
  2707.      * be defined in suidperl only.  suidperl must be setuid root.  The
  2708.      * Configure script will set this up for you if you want it.
  2709.      */
  2710.  
  2711. #ifdef DOSUID
  2712.     dTHR;
  2713.     char *s, *s2;
  2714.  
  2715.     if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0)    /* normal stat is insecure */
  2716.     Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
  2717.     if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
  2718.     I32 len;
  2719.     STRLEN n_a;
  2720.  
  2721. #ifdef IAMSUID
  2722. #ifndef HAS_SETREUID
  2723.     /* On this access check to make sure the directories are readable,
  2724.      * there is actually a small window that the user could use to make
  2725.      * filename point to an accessible directory.  So there is a faint
  2726.      * chance that someone could execute a setuid script down in a
  2727.      * non-accessible directory.  I don't know what to do about that.
  2728.      * But I don't think it's too important.  The manual lies when
  2729.      * it says access() is useful in setuid programs.
  2730.      */
  2731.     if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
  2732.         Perl_croak(aTHX_ "Permission denied");
  2733. #else
  2734.     /* If we can swap euid and uid, then we can determine access rights
  2735.      * with a simple stat of the file, and then compare device and
  2736.      * inode to make sure we did stat() on the same file we opened.
  2737.      * Then we just have to make sure he or she can execute it.
  2738.      */
  2739.     {
  2740.         struct stat tmpstatbuf;
  2741.  
  2742.         if (
  2743. #ifdef HAS_SETREUID
  2744.         setreuid(PL_euid,PL_uid) < 0
  2745. #else
  2746. # if HAS_SETRESUID
  2747.         setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
  2748. # endif
  2749. #endif
  2750.         || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
  2751.         Perl_croak(aTHX_ "Can't swap uid and euid");    /* really paranoid */
  2752.         if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
  2753.         Perl_croak(aTHX_ "Permission denied");    /* testing full pathname here */
  2754. #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
  2755.         if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
  2756.         Perl_croak(aTHX_ "Permission denied");
  2757. #endif
  2758.         if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
  2759.         tmpstatbuf.st_ino != PL_statbuf.st_ino) {
  2760.         (void)PerlIO_close(PL_rsfp);
  2761.         if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) {    /* heh, heh */
  2762.             PerlIO_printf(PL_rsfp,
  2763. "User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
  2764. (Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n",
  2765.             PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
  2766.             (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
  2767.             CopFILE(PL_curcop),
  2768.             PL_statbuf.st_uid, PL_statbuf.st_gid);
  2769.             (void)PerlProc_pclose(PL_rsfp);
  2770.         }
  2771.         Perl_croak(aTHX_ "Permission denied\n");
  2772.         }
  2773.         if (
  2774. #ifdef HAS_SETREUID
  2775.               setreuid(PL_uid,PL_euid) < 0
  2776. #else
  2777. # if defined(HAS_SETRESUID)
  2778.               setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
  2779. # endif
  2780. #endif
  2781.               || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
  2782.         Perl_croak(aTHX_ "Can't reswap uid and euid");
  2783.         if (!cando(S_IXUSR,FALSE,&PL_statbuf))        /* can real uid exec? */
  2784.         Perl_croak(aTHX_ "Permission denied\n");
  2785.     }
  2786. #endif /* HAS_SETREUID */
  2787. #endif /* IAMSUID */
  2788.  
  2789.     if (!S_ISREG(PL_statbuf.st_mode))
  2790.         Perl_croak(aTHX_ "Permission denied");
  2791.     if (PL_statbuf.st_mode & S_IWOTH)
  2792.         Perl_croak(aTHX_ "Setuid/gid script is writable by world");
  2793.     PL_doswitches = FALSE;        /* -s is insecure in suid */
  2794.     CopLINE_inc(PL_curcop);
  2795.     if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
  2796.       strnNE(SvPV(PL_linestr,n_a),"#!",2) )    /* required even on Sys V */
  2797.         Perl_croak(aTHX_ "No #! line");
  2798.     s = SvPV(PL_linestr,n_a)+2;
  2799.     if (*s == ' ') s++;
  2800.     while (!isSPACE(*s)) s++;
  2801.     for (s2 = s;  (s2 > SvPV(PL_linestr,n_a)+2 &&
  2802.                (isDIGIT(s2[-1]) || strchr("._-", s2[-1])));  s2--) ;
  2803.     if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
  2804.         Perl_croak(aTHX_ "Not a perl script");
  2805.     while (*s == ' ' || *s == '\t') s++;
  2806.     /*
  2807.      * #! arg must be what we saw above.  They can invoke it by
  2808.      * mentioning suidperl explicitly, but they may not add any strange
  2809.      * arguments beyond what #! says if they do invoke suidperl that way.
  2810.      */
  2811.     len = strlen(validarg);
  2812.     if (strEQ(validarg," PHOOEY ") ||
  2813.         strnNE(s,validarg,len) || !isSPACE(s[len]))
  2814.         Perl_croak(aTHX_ "Args must match #! line");
  2815.  
  2816. #ifndef IAMSUID
  2817.     if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
  2818.         PL_euid == PL_statbuf.st_uid)
  2819.         if (!PL_do_undump)
  2820.         Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
  2821. FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
  2822. #endif /* IAMSUID */
  2823.  
  2824.     if (PL_euid) {    /* oops, we're not the setuid root perl */
  2825.         (void)PerlIO_close(PL_rsfp);
  2826. #ifndef IAMSUID
  2827.         /* try again */
  2828.         PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
  2829.                      (int)PERL_REVISION, (int)PERL_VERSION,
  2830.                      (int)PERL_SUBVERSION), PL_origargv);
  2831. #endif
  2832.         Perl_croak(aTHX_ "Can't do setuid\n");
  2833.     }
  2834.  
  2835.     if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
  2836. #ifdef HAS_SETEGID
  2837.         (void)setegid(PL_statbuf.st_gid);
  2838. #else
  2839. #ifdef HAS_SETREGID
  2840.            (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
  2841. #else
  2842. #ifdef HAS_SETRESGID
  2843.            (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
  2844. #else
  2845.         PerlProc_setgid(PL_statbuf.st_gid);
  2846. #endif
  2847. #endif
  2848. #endif
  2849.         if (PerlProc_getegid() != PL_statbuf.st_gid)
  2850.         Perl_croak(aTHX_ "Can't do setegid!\n");
  2851.     }
  2852.     if (PL_statbuf.st_mode & S_ISUID) {
  2853.         if (PL_statbuf.st_uid != PL_euid)
  2854. #ifdef HAS_SETEUID
  2855.         (void)seteuid(PL_statbuf.st_uid);    /* all that for this */
  2856. #else
  2857. #ifdef HAS_SETREUID
  2858.                 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
  2859. #else
  2860. #ifdef HAS_SETRESUID
  2861.                 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
  2862. #else
  2863.         PerlProc_setuid(PL_statbuf.st_uid);
  2864. #endif
  2865. #endif
  2866. #endif
  2867.         if (PerlProc_geteuid() != PL_statbuf.st_uid)
  2868.         Perl_croak(aTHX_ "Can't do seteuid!\n");
  2869.     }
  2870.     else if (PL_uid) {            /* oops, mustn't run as root */
  2871. #ifdef HAS_SETEUID
  2872.           (void)seteuid((Uid_t)PL_uid);
  2873. #else
  2874. #ifdef HAS_SETREUID
  2875.           (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
  2876. #else
  2877. #ifdef HAS_SETRESUID
  2878.           (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
  2879. #else
  2880.           PerlProc_setuid((Uid_t)PL_uid);
  2881. #endif
  2882. #endif
  2883. #endif
  2884.         if (PerlProc_geteuid() != PL_uid)
  2885.         Perl_croak(aTHX_ "Can't do seteuid!\n");
  2886.     }
  2887.     init_ids();
  2888.     if (!cando(S_IXUSR,TRUE,&PL_statbuf))
  2889.         Perl_croak(aTHX_ "Permission denied\n");    /* they can't do this */
  2890.     }
  2891. #ifdef IAMSUID
  2892.     else if (PL_preprocess)
  2893.     Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
  2894.     else if (fdscript >= 0)
  2895.     Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
  2896.     else
  2897.     Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
  2898.  
  2899.     /* We absolutely must clear out any saved ids here, so we */
  2900.     /* exec the real perl, substituting fd script for scriptname. */
  2901.     /* (We pass script name as "subdir" of fd, which perl will grok.) */
  2902.     PerlIO_rewind(PL_rsfp);
  2903.     PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0);  /* just in case rewind didn't */
  2904.     for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
  2905.     if (!PL_origargv[which])
  2906.     Perl_croak(aTHX_ "Permission denied");
  2907.     PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
  2908.                   PerlIO_fileno(PL_rsfp), PL_origargv[which]));
  2909. #if defined(HAS_FCNTL) && defined(F_SETFD)
  2910.     fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0);    /* ensure no close-on-exec */
  2911. #endif
  2912.     PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
  2913.                  (int)PERL_REVISION, (int)PERL_VERSION,
  2914.                  (int)PERL_SUBVERSION), PL_origargv);/* try again */
  2915.     Perl_croak(aTHX_ "Can't do setuid\n");
  2916. #endif /* IAMSUID */
  2917. #else /* !DOSUID */
  2918.     if (PL_euid != PL_uid || PL_egid != PL_gid) {    /* (suidperl doesn't exist, in fact) */
  2919. #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
  2920.     dTHR;
  2921.     PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf);    /* may be either wrapped or real suid */
  2922.     if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
  2923.         ||
  2924.         (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
  2925.        )
  2926.         if (!PL_do_undump)
  2927.         Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
  2928. FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
  2929. #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
  2930.     /* not set-id, must be wrapped */
  2931.     }
  2932. #endif /* DOSUID */
  2933. }
  2934.  
  2935. STATIC void
  2936. S_find_beginning(pTHX)
  2937. {
  2938.     register char *s, *s2;
  2939.  
  2940.     /* skip forward in input to the real script? */
  2941.  
  2942.     forbid_setid("-x");
  2943.     while (PL_doextract) {
  2944.     if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
  2945.         Perl_croak(aTHX_ "No Perl script found in input\n");
  2946.     if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
  2947.         PerlIO_ungetc(PL_rsfp, '\n');        /* to keep line count right */
  2948.         PL_doextract = FALSE;
  2949.         while (*s && !(isSPACE (*s) || *s == '#')) s++;
  2950.         s2 = s;
  2951.         while (*s == ' ' || *s == '\t') s++;
  2952.         if (*s++ == '-') {
  2953.         while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
  2954.         if (strnEQ(s2-4,"perl",4))
  2955.             /*SUPPRESS 530*/
  2956.             while ((s = moreswitches(s)))
  2957.             ;
  2958.         }
  2959.     }
  2960.     }
  2961. }
  2962.  
  2963.  
  2964. STATIC void
  2965. S_init_ids(pTHX)
  2966. {
  2967.     PL_uid = PerlProc_getuid();
  2968.     PL_euid = PerlProc_geteuid();
  2969.     PL_gid = PerlProc_getgid();
  2970.     PL_egid = PerlProc_getegid();
  2971. #ifdef VMS
  2972.     PL_uid |= PL_gid << 16;
  2973.     PL_euid |= PL_egid << 16;
  2974. #endif
  2975.     PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
  2976. }
  2977.  
  2978. STATIC void
  2979. S_forbid_setid(pTHX_ char *s)
  2980. {
  2981.     if (PL_euid != PL_uid)
  2982.         Perl_croak(aTHX_ "No %s allowed while running setuid", s);
  2983.     if (PL_egid != PL_gid)
  2984.         Perl_croak(aTHX_ "No %s allowed while running setgid", s);
  2985. }
  2986.  
  2987. void
  2988. Perl_init_debugger(pTHX)
  2989. {
  2990.     dTHR;
  2991.     HV *ostash = PL_curstash;
  2992.  
  2993.     PL_curstash = PL_debstash;
  2994.     PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
  2995.     AvREAL_off(PL_dbargs);
  2996.     PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
  2997.     PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
  2998.     PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
  2999.     sv_upgrade(GvSV(PL_DBsub), SVt_IV);    /* IVX accessed if PERLDB_SUB_NN */
  3000.     PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
  3001.     sv_setiv(PL_DBsingle, 0); 
  3002.     PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
  3003.     sv_setiv(PL_DBtrace, 0); 
  3004.     PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
  3005.     sv_setiv(PL_DBsignal, 0); 
  3006.     PL_curstash = ostash;
  3007. }
  3008.  
  3009. #ifndef STRESS_REALLOC
  3010. #define REASONABLE(size) (size)
  3011. #else
  3012. #define REASONABLE(size) (1) /* unreasonable */
  3013. #endif
  3014.  
  3015. void
  3016. Perl_init_stacks(pTHX)
  3017. {
  3018.     /* start with 128-item stack and 8K cxstack */
  3019.     PL_curstackinfo = new_stackinfo(REASONABLE(128),
  3020.                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
  3021.     PL_curstackinfo->si_type = PERLSI_MAIN;
  3022.     PL_curstack = PL_curstackinfo->si_stack;
  3023.     PL_mainstack = PL_curstack;        /* remember in case we switch stacks */
  3024.  
  3025.     PL_stack_base = AvARRAY(PL_curstack);
  3026.     PL_stack_sp = PL_stack_base;
  3027.     PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
  3028.  
  3029.     New(50,PL_tmps_stack,REASONABLE(128),SV*);
  3030.     PL_tmps_floor = -1;
  3031.     PL_tmps_ix = -1;
  3032.     PL_tmps_max = REASONABLE(128);
  3033.  
  3034.     New(54,PL_markstack,REASONABLE(32),I32);
  3035.     PL_markstack_ptr = PL_markstack;
  3036.     PL_markstack_max = PL_markstack + REASONABLE(32);
  3037.  
  3038.     SET_MARK_OFFSET;
  3039.  
  3040.     New(54,PL_scopestack,REASONABLE(32),I32);
  3041.     PL_scopestack_ix = 0;
  3042.     PL_scopestack_max = REASONABLE(32);
  3043.  
  3044.     New(54,PL_savestack,REASONABLE(128),ANY);
  3045.     PL_savestack_ix = 0;
  3046.     PL_savestack_max = REASONABLE(128);
  3047.  
  3048.     New(54,PL_retstack,REASONABLE(16),OP*);
  3049.     PL_retstack_ix = 0;
  3050.     PL_retstack_max = REASONABLE(16);
  3051. }
  3052.  
  3053. #undef REASONABLE
  3054.  
  3055. STATIC void
  3056. S_nuke_stacks(pTHX)
  3057. {
  3058.     dTHR;
  3059.     while (PL_curstackinfo->si_next)
  3060.     PL_curstackinfo = PL_curstackinfo->si_next;
  3061.     while (PL_curstackinfo) {
  3062.     PERL_SI *p = PL_curstackinfo->si_prev;
  3063.     /* curstackinfo->si_stack got nuked by sv_free_arenas() */
  3064.     Safefree(PL_curstackinfo->si_cxstack);
  3065.     Safefree(PL_curstackinfo);
  3066.     PL_curstackinfo = p;
  3067.     }
  3068.     Safefree(PL_tmps_stack);
  3069.     Safefree(PL_markstack);
  3070.     Safefree(PL_scopestack);
  3071.     Safefree(PL_savestack);
  3072.     Safefree(PL_retstack);
  3073. }
  3074.  
  3075. #ifndef PERL_OBJECT
  3076. static PerlIO *tmpfp;  /* moved outside init_lexer() because of UNICOS bug */
  3077. #endif
  3078.  
  3079. STATIC void
  3080. S_init_lexer(pTHX)
  3081. {
  3082. #ifdef PERL_OBJECT
  3083.     PerlIO *tmpfp;
  3084. #endif
  3085.     tmpfp = PL_rsfp;
  3086.     PL_rsfp = Nullfp;
  3087.     lex_start(PL_linestr);
  3088.     PL_rsfp = tmpfp;
  3089.     PL_subname = newSVpvn("main",4);
  3090. }
  3091.  
  3092. STATIC void
  3093. S_init_predump_symbols(pTHX)
  3094. {
  3095.     dTHR;
  3096.     GV *tmpgv;
  3097.     IO *io;
  3098.  
  3099.     sv_setpvn(get_sv("\"", TRUE), " ", 1);
  3100.     PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
  3101.     GvMULTI_on(PL_stdingv);
  3102.     io = GvIOp(PL_stdingv);
  3103.     IoIFP(io) = PerlIO_stdin();
  3104.     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
  3105.     GvMULTI_on(tmpgv);
  3106.     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
  3107.  
  3108.     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
  3109.     GvMULTI_on(tmpgv);
  3110.     io = GvIOp(tmpgv);
  3111.     IoOFP(io) = IoIFP(io) = PerlIO_stdout();
  3112.     setdefout(tmpgv);
  3113.     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
  3114.     GvMULTI_on(tmpgv);
  3115.     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
  3116.  
  3117.     PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
  3118.     GvMULTI_on(PL_stderrgv);
  3119.     io = GvIOp(PL_stderrgv);
  3120.     IoOFP(io) = IoIFP(io) = PerlIO_stderr();
  3121.     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
  3122.     GvMULTI_on(tmpgv);
  3123.     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
  3124.  
  3125.     PL_statname = NEWSV(66,0);        /* last filename we did stat on */
  3126.  
  3127.     if (!PL_osname)
  3128.     PL_osname = savepv(OSNAME);
  3129. }
  3130.  
  3131. STATIC void
  3132. S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
  3133. {
  3134.     dTHR;
  3135.     char *s;
  3136.     SV *sv;
  3137.     GV* tmpgv;
  3138.  
  3139.     argc--,argv++;    /* skip name of script */
  3140.     if (PL_doswitches) {
  3141.     for (; argc > 0 && **argv == '-'; argc--,argv++) {
  3142.         if (!argv[0][1])
  3143.         break;
  3144.         if (argv[0][1] == '-' && !argv[0][2]) {
  3145.         argc--,argv++;
  3146.         break;
  3147.         }
  3148.         if ((s = strchr(argv[0], '='))) {
  3149.         *s++ = '\0';
  3150.         sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
  3151.         }
  3152.         else
  3153.         sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
  3154.     }
  3155.     }
  3156.     PL_toptarget = NEWSV(0,0);
  3157.     sv_upgrade(PL_toptarget, SVt_PVFM);
  3158.     sv_setpvn(PL_toptarget, "", 0);
  3159.     PL_bodytarget = NEWSV(0,0);
  3160.     sv_upgrade(PL_bodytarget, SVt_PVFM);
  3161.     sv_setpvn(PL_bodytarget, "", 0);
  3162.     PL_formtarget = PL_bodytarget;
  3163.  
  3164.     TAINT;
  3165.     if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
  3166.     sv_setpv(GvSV(tmpgv),PL_origfilename);
  3167.     magicname("0", "0", 1);
  3168.     }
  3169.     if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV)))
  3170. #ifdef OS2
  3171.     sv_setpv(GvSV(tmpgv), os2_execname());
  3172. #else
  3173.     sv_setpv(GvSV(tmpgv),PL_origargv[0]);
  3174. #endif
  3175.     if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
  3176.     GvMULTI_on(PL_argvgv);
  3177.     (void)gv_AVadd(PL_argvgv);
  3178.     av_clear(GvAVn(PL_argvgv));
  3179.     for (; argc > 0; argc--,argv++) {
  3180.         SV *sv = newSVpv(argv[0],0);
  3181.         av_push(GvAVn(PL_argvgv),sv);
  3182.         if (PL_widesyscalls)
  3183.         sv_utf8_upgrade(sv);
  3184.     }
  3185.     }
  3186.     if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
  3187.     HV *hv;
  3188.     GvMULTI_on(PL_envgv);
  3189.     hv = GvHVn(PL_envgv);
  3190.     hv_magic(hv, PL_envgv, 'E');
  3191. #if !defined( VMS) && !defined(EPOC)  /* VMS doesn't have environ array */
  3192.     /* Note that if the supplied env parameter is actually a copy
  3193.        of the global environ then it may now point to free'd memory
  3194.        if the environment has been modified since. To avoid this
  3195.        problem we treat env==NULL as meaning 'use the default'
  3196.     */
  3197.     if (!env)
  3198.         env = environ;
  3199.     if (env != environ)
  3200.         environ[0] = Nullch;
  3201.     for (; *env; env++) {
  3202.         if (!(s = strchr(*env,'=')))
  3203.         continue;
  3204.         *s++ = '\0';
  3205. #if defined(MSDOS)
  3206.         (void)strupr(*env);
  3207. #endif
  3208.         sv = newSVpv(s--,0);
  3209.         (void)hv_store(hv, *env, s - *env, sv, 0);
  3210.         *s = '=';
  3211. #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
  3212.         /* Sins of the RTL. See note in my_setenv(). */
  3213.         (void)PerlEnv_putenv(savepv(*env));
  3214. #endif
  3215.     }
  3216. #endif
  3217. #ifdef DYNAMIC_ENV_FETCH
  3218.     HvNAME(hv) = savepv(ENV_HV_NAME);
  3219. #endif
  3220.     }
  3221.     TAINT_NOT;
  3222.     if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV)))
  3223.     sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
  3224. }
  3225.  
  3226. STATIC void
  3227. S_init_perllib(pTHX)
  3228. {
  3229.     char *s;
  3230.     if (!PL_tainting) {
  3231. #ifndef VMS
  3232.     s = PerlEnv_getenv("PERL5LIB");
  3233.     if (s)
  3234.         incpush(s, TRUE, TRUE);
  3235.     else
  3236.         incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE);
  3237. #else /* VMS */
  3238.     /* Treat PERL5?LIB as a possible search list logical name -- the
  3239.      * "natural" VMS idiom for a Unix path string.  We allow each
  3240.      * element to be a set of |-separated directories for compatibility.
  3241.      */
  3242.     char buf[256];
  3243.     int idx = 0;
  3244.     if (my_trnlnm("PERL5LIB",buf,0))
  3245.         do { incpush(buf,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
  3246.     else
  3247.         while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE);
  3248. #endif /* VMS */
  3249.     }
  3250.  
  3251. /* Use the ~-expanded versions of APPLLIB (undocumented),
  3252.     ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
  3253. */
  3254. #ifdef APPLLIB_EXP
  3255.     incpush(APPLLIB_EXP, TRUE, TRUE);
  3256. #endif
  3257.  
  3258. #ifdef ARCHLIB_EXP
  3259.     incpush(ARCHLIB_EXP, FALSE, FALSE);
  3260. #endif
  3261. #ifndef PRIVLIB_EXP
  3262. #  define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
  3263. #endif
  3264. #if defined(WIN32) 
  3265.     incpush(PRIVLIB_EXP, TRUE, FALSE);
  3266. #else
  3267.     incpush(PRIVLIB_EXP, FALSE, FALSE);
  3268. #endif
  3269.  
  3270. #ifdef SITEARCH_EXP
  3271.     /* sitearch is always relative to sitelib on Windows for
  3272.      * DLL-based path intuition to work correctly */
  3273. #  if !defined(WIN32)
  3274.     incpush(SITEARCH_EXP, FALSE, FALSE);
  3275. #  endif
  3276. #endif
  3277.  
  3278. #ifdef SITELIB_EXP
  3279. #  if defined(WIN32)
  3280.     incpush(SITELIB_EXP, TRUE, FALSE);    /* this picks up sitearch as well */
  3281. #  else
  3282.     incpush(SITELIB_EXP, FALSE, FALSE);
  3283. #  endif
  3284. #endif
  3285.  
  3286. #ifdef SITELIB_STEM /* Search for version-specific dirs below here */
  3287.     incpush(SITELIB_STEM, FALSE, TRUE);
  3288. #endif
  3289.  
  3290. #ifdef PERL_VENDORARCH_EXP
  3291.     /* vendorarch is always relative to vendorlib on Windows for
  3292.      * DLL-based path intuition to work correctly */
  3293. #  if !defined(WIN32)
  3294.     incpush(PERL_VENDORARCH_EXP, FALSE, FALSE);
  3295. #  endif
  3296. #endif
  3297.  
  3298. #ifdef PERL_VENDORLIB_EXP
  3299. #  if defined(WIN32)
  3300.     incpush(PERL_VENDORLIB_EXP, TRUE, FALSE);    /* this picks up vendorarch as well */
  3301. #  else
  3302.     incpush(PERL_VENDORLIB_EXP, FALSE, FALSE);
  3303. #  endif
  3304. #endif
  3305.  
  3306. #ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
  3307.     incpush(PERL_VENDORLIB_STEM, FALSE, TRUE);
  3308. #endif
  3309.  
  3310.     if (!PL_tainting)
  3311.     incpush(".", FALSE, FALSE);
  3312. }
  3313.  
  3314. #if defined(DOSISH)
  3315. #    define PERLLIB_SEP ';'
  3316. #else
  3317. #  if defined(VMS)
  3318. #    define PERLLIB_SEP '|'
  3319. #  else
  3320. #    define PERLLIB_SEP ':'
  3321. #  endif
  3322. #endif
  3323. #ifndef PERLLIB_MANGLE
  3324. #  define PERLLIB_MANGLE(s,n) (s)
  3325. #endif 
  3326.  
  3327. STATIC void
  3328. S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
  3329. {
  3330.     SV *subdir = Nullsv;
  3331.  
  3332.     if (!p || !*p)
  3333.     return;
  3334.  
  3335.     if (addsubdirs || addoldvers) {
  3336.     subdir = sv_newmortal();
  3337.     }
  3338.  
  3339.     /* Break at all separators */
  3340.     while (p && *p) {
  3341.     SV *libdir = NEWSV(55,0);
  3342.     char *s;
  3343.  
  3344.     /* skip any consecutive separators */
  3345.     while ( *p == PERLLIB_SEP ) {
  3346.         /* Uncomment the next line for PATH semantics */
  3347.         /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
  3348.         p++;
  3349.     }
  3350.  
  3351.     if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
  3352.         sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
  3353.               (STRLEN)(s - p));
  3354.         p = s + 1;
  3355.     }
  3356.     else {
  3357.         sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
  3358.         p = Nullch;    /* break out */
  3359.     }
  3360.  
  3361.     /*
  3362.      * BEFORE pushing libdir onto @INC we may first push version- and
  3363.      * archname-specific sub-directories.
  3364.      */
  3365.     if (addsubdirs || addoldvers) {
  3366. #ifdef PERL_INC_VERSION_LIST
  3367.         /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
  3368.         const char *incverlist[] = { PERL_INC_VERSION_LIST };
  3369.         const char **incver;
  3370. #endif
  3371.         struct stat tmpstatbuf;
  3372. #ifdef VMS
  3373.         char *unix;
  3374.         STRLEN len;
  3375.  
  3376.         if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
  3377.         len = strlen(unix);
  3378.         while (unix[len-1] == '/') len--;  /* Cosmetic */
  3379.         sv_usepvn(libdir,unix,len);
  3380.         }
  3381.         else
  3382.         PerlIO_printf(Perl_error_log,
  3383.                       "Failed to unixify @INC element \"%s\"\n",
  3384.                   SvPV(libdir,len));
  3385. #endif
  3386.         if (addsubdirs) {
  3387.         /* .../version/archname if -d .../version/archname */
  3388.         Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT"/%s", 
  3389.                 libdir,
  3390.                    (int)PERL_REVISION, (int)PERL_VERSION,
  3391.                    (int)PERL_SUBVERSION, ARCHNAME);
  3392.         if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
  3393.               S_ISDIR(tmpstatbuf.st_mode))
  3394.             av_push(GvAVn(PL_incgv), newSVsv(subdir));
  3395.  
  3396.         /* .../version if -d .../version */
  3397.         Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT, libdir,
  3398.                    (int)PERL_REVISION, (int)PERL_VERSION,
  3399.                    (int)PERL_SUBVERSION);
  3400.         if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
  3401.               S_ISDIR(tmpstatbuf.st_mode))
  3402.             av_push(GvAVn(PL_incgv), newSVsv(subdir));
  3403.  
  3404.         /* .../archname if -d .../archname */
  3405.         Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, ARCHNAME);
  3406.         if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
  3407.               S_ISDIR(tmpstatbuf.st_mode))
  3408.             av_push(GvAVn(PL_incgv), newSVsv(subdir));
  3409.         }
  3410.  
  3411. #ifdef PERL_INC_VERSION_LIST
  3412.         if (addoldvers) {
  3413.         for (incver = incverlist; *incver; incver++) {
  3414.             /* .../xxx if -d .../xxx */
  3415.             Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, *incver);
  3416.             if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
  3417.               S_ISDIR(tmpstatbuf.st_mode))
  3418.             av_push(GvAVn(PL_incgv), newSVsv(subdir));
  3419.         }
  3420.         }
  3421. #endif
  3422.     }
  3423.  
  3424.     /* finally push this lib directory on the end of @INC */
  3425.     av_push(GvAVn(PL_incgv), libdir);
  3426.     }
  3427. }
  3428.  
  3429. #ifdef USE_THREADS
  3430. STATIC struct perl_thread *
  3431. S_init_main_thread(pTHX)
  3432. {
  3433. #if !defined(PERL_IMPLICIT_CONTEXT)
  3434.     struct perl_thread *thr;
  3435. #endif
  3436.     XPV *xpv;
  3437.  
  3438.     Newz(53, thr, 1, struct perl_thread);
  3439.     PL_curcop = &PL_compiling;
  3440.     thr->interp = PERL_GET_INTERP;
  3441.     thr->cvcache = newHV();
  3442.     thr->threadsv = newAV();
  3443.     /* thr->threadsvp is set when find_threadsv is called */
  3444.     thr->specific = newAV();
  3445.     thr->flags = THRf_R_JOINABLE;
  3446.     MUTEX_INIT(&thr->mutex);
  3447.     /* Handcraft thrsv similarly to mess_sv */
  3448.     New(53, PL_thrsv, 1, SV);
  3449.     Newz(53, xpv, 1, XPV);
  3450.     SvFLAGS(PL_thrsv) = SVt_PV;
  3451.     SvANY(PL_thrsv) = (void*)xpv;
  3452.     SvREFCNT(PL_thrsv) = 1 << 30;    /* practically infinite */
  3453.     SvPVX(PL_thrsv) = (char*)thr;
  3454.     SvCUR_set(PL_thrsv, sizeof(thr));
  3455.     SvLEN_set(PL_thrsv, sizeof(thr));
  3456.     *SvEND(PL_thrsv) = '\0';    /* in the trailing_nul field */
  3457.     thr->oursv = PL_thrsv;
  3458.     PL_chopset = " \n-";
  3459.     PL_dumpindent = 4;
  3460.  
  3461.     MUTEX_LOCK(&PL_threads_mutex);
  3462.     PL_nthreads++;
  3463.     thr->tid = 0;
  3464.     thr->next = thr;
  3465.     thr->prev = thr;
  3466.     MUTEX_UNLOCK(&PL_threads_mutex);
  3467.  
  3468. #ifdef HAVE_THREAD_INTERN
  3469.     Perl_init_thread_intern(thr);
  3470. #endif
  3471.  
  3472. #ifdef SET_THREAD_SELF
  3473.     SET_THREAD_SELF(thr);
  3474. #else
  3475.     thr->self = pthread_self();
  3476. #endif /* SET_THREAD_SELF */
  3477.     PERL_SET_THX(thr);
  3478.  
  3479.     /*
  3480.      * These must come after the SET_THR because sv_setpvn does
  3481.      * SvTAINT and the taint fields require dTHR.
  3482.      */
  3483.     PL_toptarget = NEWSV(0,0);
  3484.     sv_upgrade(PL_toptarget, SVt_PVFM);
  3485.     sv_setpvn(PL_toptarget, "", 0);
  3486.     PL_bodytarget = NEWSV(0,0);
  3487.     sv_upgrade(PL_bodytarget, SVt_PVFM);
  3488.     sv_setpvn(PL_bodytarget, "", 0);
  3489.     PL_formtarget = PL_bodytarget;
  3490.     thr->errsv = newSVpvn("", 0);
  3491.     (void) find_threadsv("@");    /* Ensure $@ is initialised early */
  3492.  
  3493.     PL_maxscream = -1;
  3494.     PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
  3495.     PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
  3496.     PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
  3497.     PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
  3498.     PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
  3499.     PL_regindent = 0;
  3500.     PL_reginterp_cnt = 0;
  3501.  
  3502.     return thr;
  3503. }
  3504. #endif /* USE_THREADS */
  3505.  
  3506. void
  3507. Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
  3508. {
  3509.     dTHR;
  3510.     SV *atsv;
  3511.     line_t oldline = CopLINE(PL_curcop);
  3512.     CV *cv;
  3513.     STRLEN len;
  3514.     int ret;
  3515.     dJMPENV;
  3516.  
  3517.     while (AvFILL(paramList) >= 0) {
  3518.     cv = (CV*)av_shift(paramList);
  3519.     SAVEFREESV(cv);
  3520. #ifdef PERL_FLEXIBLE_EXCEPTIONS
  3521.     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
  3522. #else
  3523.     JMPENV_PUSH(ret);
  3524. #endif
  3525.     switch (ret) {
  3526.     case 0:
  3527. #ifndef PERL_FLEXIBLE_EXCEPTIONS
  3528.         call_list_body(cv);
  3529. #endif
  3530.         atsv = ERRSV;
  3531.         (void)SvPV(atsv, len);
  3532.         if (len) {
  3533.         STRLEN n_a;
  3534.         PL_curcop = &PL_compiling;
  3535.         CopLINE_set(PL_curcop, oldline);
  3536.         if (paramList == PL_beginav)
  3537.             sv_catpv(atsv, "BEGIN failed--compilation aborted");
  3538.         else
  3539.             Perl_sv_catpvf(aTHX_ atsv,
  3540.                    "%s failed--call queue aborted",
  3541.                    paramList == PL_checkav ? "CHECK"
  3542.                    : paramList == PL_initav ? "INIT"
  3543.                    : "END");
  3544.         while (PL_scopestack_ix > oldscope)
  3545.             LEAVE;
  3546.         JMPENV_POP;
  3547.         Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
  3548.         }
  3549.         break;
  3550.     case 1:
  3551.         STATUS_ALL_FAILURE;
  3552.         /* FALL THROUGH */
  3553.     case 2:
  3554.         /* my_exit() was called */
  3555.         while (PL_scopestack_ix > oldscope)
  3556.         LEAVE;
  3557.         FREETMPS;
  3558.         PL_curstash = PL_defstash;
  3559.         PL_curcop = &PL_compiling;
  3560.         CopLINE_set(PL_curcop, oldline);
  3561.         JMPENV_POP;
  3562.         if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
  3563.         if (paramList == PL_beginav)
  3564.             Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
  3565.         else
  3566.             Perl_croak(aTHX_ "%s failed--call queue aborted",
  3567.                    paramList == PL_checkav ? "CHECK"
  3568.                    : paramList == PL_initav ? "INIT"
  3569.                    : "END");
  3570.         }
  3571.         my_exit_jump();
  3572.         /* NOTREACHED */
  3573.     case 3:
  3574.         if (PL_restartop) {
  3575.         PL_curcop = &PL_compiling;
  3576.         CopLINE_set(PL_curcop, oldline);
  3577.         JMPENV_JUMP(3);
  3578.         }
  3579.         PerlIO_printf(Perl_error_log, "panic: restartop\n");
  3580.         FREETMPS;
  3581.         break;
  3582.     }
  3583.     JMPENV_POP;
  3584.     }
  3585. }
  3586.  
  3587. #ifdef PERL_FLEXIBLE_EXCEPTIONS
  3588. STATIC void *
  3589. S_vcall_list_body(pTHX_ va_list args)
  3590. {
  3591.     CV *cv = va_arg(args, CV*);
  3592.     return call_list_body(cv);
  3593. }
  3594. #endif
  3595.  
  3596. STATIC void *
  3597. S_call_list_body(pTHX_ CV *cv)
  3598. {
  3599.     PUSHMARK(PL_stack_sp);
  3600.     call_sv((SV*)cv, G_EVAL|G_DISCARD);
  3601.     return NULL;
  3602. }
  3603.  
  3604. void
  3605. Perl_my_exit(pTHX_ U32 status)
  3606. {
  3607.     dTHR;
  3608.  
  3609.     DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
  3610.               thr, (unsigned long) status));
  3611.     switch (status) {
  3612.     case 0:
  3613.     STATUS_ALL_SUCCESS;
  3614.     break;
  3615.     case 1:
  3616.     STATUS_ALL_FAILURE;
  3617.     break;
  3618.     default:
  3619.     STATUS_NATIVE_SET(status);
  3620.     break;
  3621.     }
  3622.     my_exit_jump();
  3623. }
  3624.  
  3625. void
  3626. Perl_my_failure_exit(pTHX)
  3627. {
  3628. #ifdef VMS
  3629.     if (vaxc$errno & 1) {
  3630.     if (STATUS_NATIVE & 1)        /* fortuitiously includes "-1" */
  3631.         STATUS_NATIVE_SET(44);
  3632.     }
  3633.     else {
  3634.     if (!vaxc$errno && errno)    /* unlikely */
  3635.         STATUS_NATIVE_SET(44);
  3636.     else
  3637.         STATUS_NATIVE_SET(vaxc$errno);
  3638.     }
  3639. #else
  3640.     int exitstatus;
  3641.     if (errno & 255)
  3642.     STATUS_POSIX_SET(errno);
  3643.     else {
  3644.     exitstatus = STATUS_POSIX >> 8; 
  3645.     if (exitstatus & 255)
  3646.         STATUS_POSIX_SET(exitstatus);
  3647.     else
  3648.         STATUS_POSIX_SET(255);
  3649.     }
  3650. #endif
  3651.     my_exit_jump();
  3652. }
  3653.  
  3654. STATIC void
  3655. S_my_exit_jump(pTHX)
  3656. {
  3657.     dTHR;
  3658.     register PERL_CONTEXT *cx;
  3659.     I32 gimme;
  3660.     SV **newsp;
  3661.  
  3662.     if (PL_e_script) {
  3663.     SvREFCNT_dec(PL_e_script);
  3664.     PL_e_script = Nullsv;
  3665.     }
  3666.  
  3667.     POPSTACK_TO(PL_mainstack);
  3668.     if (cxstack_ix >= 0) {
  3669.     if (cxstack_ix > 0)
  3670.         dounwind(0);
  3671.     POPBLOCK(cx,PL_curpm);
  3672.     LEAVE;
  3673.     }
  3674.  
  3675.     JMPENV_JUMP(2);
  3676. }
  3677.  
  3678. #ifdef PERL_OBJECT
  3679. #include "XSUB.h"
  3680. #endif
  3681.  
  3682. static I32
  3683. read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
  3684. {
  3685.     char *p, *nl;
  3686.     p  = SvPVX(PL_e_script);
  3687.     nl = strchr(p, '\n');
  3688.     nl = (nl) ? nl+1 : SvEND(PL_e_script);
  3689.     if (nl-p == 0) {
  3690.     filter_del(read_e_script);
  3691.     return 0;
  3692.     }
  3693.     sv_catpvn(buf_sv, p, nl-p);
  3694.     sv_chop(PL_e_script, nl);
  3695.     return 1;
  3696. }
  3697.