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