perl.c

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