perl.c

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