perl.c

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