perl.c

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