perl.c

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