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