perl.c

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