perl.c

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