perl.c

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