perl.c

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