1			/*    perl.c
     2			 *
     3			 *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
     4			 *    2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
     5			 *
     6			 *    You may distribute under the terms of either the GNU General Public
     7			 *    License or the Artistic License, as specified in the README file.
     8			 *
     9			 */
    10			
    11			/*
    12			 * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
    13			 */
    14			
    15			/* This file contains the top-level functions that are used to create, use
    16			 * and destroy a perl interpreter, plus the functions used by XS code to
    17			 * call back into perl. Note that it does not contain the actual main()
    18			 * function of the interpreter; that can be found in perlmain.c
    19			 */
    20			
    21			/* PSz 12 Nov 03
    22			 * 
    23			 * Be proud that perl(1) may proclaim:
    24			 *   Setuid Perl scripts are safer than C programs ...
    25			 * Do not abandon (deprecate) suidperl. Do not advocate C wrappers.
    26			 * 
    27			 * The flow was: perl starts, notices script is suid, execs suidperl with same
    28			 * arguments; suidperl opens script, checks many things, sets itself with
    29			 * right UID, execs perl with similar arguments but with script pre-opened on
    30			 * /dev/fd/xxx; perl checks script is as should be and does work. This was
    31			 * insecure: see perlsec(1) for many problems with this approach.
    32			 * 
    33			 * The "correct" flow should be: perl starts, opens script and notices it is
    34			 * suid, checks many things, execs suidperl with similar arguments but with
    35			 * script on /dev/fd/xxx; suidperl checks script and /dev/fd/xxx object are
    36			 * same, checks arguments match #! line, sets itself with right UID, execs
    37			 * perl with same arguments; perl checks many things and does work.
    38			 * 
    39			 * (Opening the script in perl instead of suidperl, we "lose" scripts that
    40			 * are readable to the target UID but not to the invoker. Where did
    41			 * unreadable scripts work anyway?)
    42			 * 
    43			 * For now, suidperl and perl are pretty much the same large and cumbersome
    44			 * program, so suidperl can check its argument list (see comments elsewhere).
    45			 * 
    46			 * References:
    47			 * Original bug report:
    48			 *   http://bugs.perl.org/index.html?req=bug_id&bug_id=20010322.218
    49			 *   http://rt.perl.org/rt2/Ticket/Display.html?id=6511
    50			 * Comments and discussion with Debian:
    51			 *   http://bugs.debian.org/203426
    52			 *   http://bugs.debian.org/220486
    53			 * Debian Security Advisory DSA 431-1 (does not fully fix problem):
    54			 *   http://www.debian.org/security/2004/dsa-431
    55			 * CVE candidate:
    56			 *   http://cve.mitre.org/cgi-bin/cvename.cgi?name=CAN-2003-0618
    57			 * Previous versions of this patch sent to perl5-porters:
    58			 *   http://www.mail-archive.com/perl5-porters@perl.org/msg71953.html
    59			 *   http://www.mail-archive.com/perl5-porters@perl.org/msg75245.html
    60			 *   http://www.mail-archive.com/perl5-porters@perl.org/msg75563.html
    61			 *   http://www.mail-archive.com/perl5-porters@perl.org/msg75635.html
    62			 * 
    63			Paul Szabo - psz@maths.usyd.edu.au  http://www.maths.usyd.edu.au:8000/u/psz/
    64			School of Mathematics and Statistics  University of Sydney   2006  Australia
    65			 * 
    66			 */
    67			/* PSz 13 Nov 03
    68			 * Use truthful, neat, specific error messages.
    69			 * Cannot always hide the truth; security must not depend on doing so.
    70			 */
    71			
    72			/* PSz 18 Feb 04
    73			 * Use global(?), thread-local fdscript for easier checks.
    74			 * (I do not understand how we could possibly get a thread race:
    75			 * do not all threads go through the same initialization? Or in
    76			 * fact, are not threads started only after we get the script and
    77			 * so know what to do? Oh well, make things super-safe...)
    78			 */
    79			
    80			#include "EXTERN.h"
    81			#define PERL_IN_PERL_C
    82			#include "perl.h"
    83			#include "patchlevel.h"			/* for local_patches */
    84			
    85			#ifdef NETWARE
    86			#include "nwutil.h"	
    87			char *nw_get_sitelib(const char *pl);
    88			#endif
    89			
    90			/* XXX If this causes problems, set i_unistd=undef in the hint file.  */
    91			#ifdef I_UNISTD
    92			#include <unistd.h>
    93			#endif
    94			
    95			#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
    96			#  ifdef I_SYS_WAIT
    97			#   include <sys/wait.h>
    98			#  endif
    99			#  ifdef I_SYSUIO
   100			#    include <sys/uio.h>
   101			#  endif
   102			
   103			union control_un {
   104			  struct cmsghdr cm;
   105			  char control[CMSG_SPACE(sizeof(int))];
   106			};
   107			
   108			#endif
   109			
   110			#ifdef __BEOS__
   111			#  define HZ 1000000
   112			#endif
   113			
   114			#ifndef HZ
   115			#  ifdef CLK_TCK
   116			#    define HZ CLK_TCK
   117			#  else
   118			#    define HZ 60
   119			#  endif
   120			#endif
   121			
   122			#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
   123			char *getenv (char *); /* Usually in <stdlib.h> */
   124			#endif
   125			
   126			static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
   127			
   128			#ifdef IAMSUID
   129			#ifndef DOSUID
   130			#define DOSUID
   131			#endif
   132			#endif /* IAMSUID */
   133			
   134			#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
   135			#ifdef DOSUID
   136			#undef DOSUID
   137			#endif
   138			#endif
   139			
   140			static void
   141			S_init_tls_and_interp(PerlInterpreter *my_perl)
   142	        4503    {
   143			    dVAR;
   144	        4503        if (!PL_curinterp) {			
   145	        4503    	PERL_SET_INTERP(my_perl);
   146			#if defined(USE_ITHREADS)
   147				INIT_THREADS;
   148				ALLOC_THREAD_KEY;
   149				PERL_SET_THX(my_perl);
   150				OP_REFCNT_INIT;
   151				MUTEX_INIT(&PL_dollarzero_mutex);
   152			#  endif
   153			    }
   154			    else {
   155	        4503    	PERL_SET_THX(my_perl);
   156			    }
   157			}
   158			
   159			#ifdef PERL_IMPLICIT_SYS
   160			PerlInterpreter *
   161			perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
   162					 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
   163					 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
   164					 struct IPerlDir* ipD, struct IPerlSock* ipS,
   165					 struct IPerlProc* ipP)
   166			{
   167			    PerlInterpreter *my_perl;
   168			    /* New() needs interpreter, so call malloc() instead */
   169			    my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
   170			    S_init_tls_and_interp(my_perl);
   171			    Zero(my_perl, 1, PerlInterpreter);
   172			    PL_Mem = ipM;
   173			    PL_MemShared = ipMS;
   174			    PL_MemParse = ipMP;
   175			    PL_Env = ipE;
   176			    PL_StdIO = ipStd;
   177			    PL_LIO = ipLIO;
   178			    PL_Dir = ipD;
   179			    PL_Sock = ipS;
   180			    PL_Proc = ipP;
   181			
   182			    return my_perl;
   183			}
   184			#else
   185			
   186			/*
   187			=head1 Embedding Functions
   188			
   189			=for apidoc perl_alloc
   190			
   191			Allocates a new Perl interpreter.  See L<perlembed>.
   192			
   193			=cut
   194			*/
   195			
   196			PerlInterpreter *
   197			perl_alloc(void)
   198	        4503    {
   199	        4503        PerlInterpreter *my_perl;
   200			
   201			    /* New() needs interpreter, so call malloc() instead */
   202	        4503        my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
   203			
   204	        4503        S_init_tls_and_interp(my_perl);
   205	        4503        return (PerlInterpreter *) ZeroD(my_perl, 1, PerlInterpreter);
   206			}
   207			#endif /* PERL_IMPLICIT_SYS */
   208			
   209			/*
   210			=for apidoc perl_construct
   211			
   212			Initializes a new Perl interpreter.  See L<perlembed>.
   213			
   214			=cut
   215			*/
   216			
   217			void
   218			perl_construct(pTHXx)
   219	        4503    {
   220			    dVAR;
   221	        4503        PERL_UNUSED_ARG(my_perl);
   222			#ifdef MULTIPLICITY
   223			    init_interp();
   224			    PL_perl_destruct_level = 1;
   225			#else
   226	        4503       if (PL_perl_destruct_level > 0)
   227	      ######           init_interp();
   228			#endif
   229			   /* Init the real globals (and main thread)? */
   230	        4503        if (!PL_linestr) {
   231	        4503    	PL_curcop = &PL_compiling;	/* needed by ckWARN, right away */
   232			
   233	        4503    	PL_linestr = NEWSV(65,79);
   234	        4503    	sv_upgrade(PL_linestr,SVt_PVIV);
   235			
   236	        4503    	if (!SvREADONLY(&PL_sv_undef)) {
   237				    /* set read-only and try to insure than we wont see REFCNT==0
   238				       very often */
   239			
   240	        4503    	    SvREADONLY_on(&PL_sv_undef);
   241	        4503    	    SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
   242			
   243	        4503    	    sv_setpv(&PL_sv_no,PL_No);
   244				    /* value lookup in void context - happens to have the side effect
   245				       of caching the numeric forms.  */
   246	        4503    	    SvIV(&PL_sv_no);
   247	        4503    	    SvNV(&PL_sv_no);
   248	        4503    	    SvREADONLY_on(&PL_sv_no);
   249	        4503    	    SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
   250			
   251	        4503    	    sv_setpv(&PL_sv_yes,PL_Yes);
   252	        4503    	    SvIV(&PL_sv_yes);
   253	        4503    	    SvNV(&PL_sv_yes);
   254	        4503    	    SvREADONLY_on(&PL_sv_yes);
   255	        4503    	    SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
   256			
   257	        4503    	    SvREADONLY_on(&PL_sv_placeholder);
   258	        4503    	    SvREFCNT(&PL_sv_placeholder) = (~(U32)0)/2;
   259				}
   260			
   261	        4503    	PL_sighandlerp = Perl_sighandler;
   262	        4503    	PL_pidstatus = newHV();
   263			    }
   264			
   265	        4503        PL_rs = newSVpvn("\n", 1);
   266			
   267	        4503        init_stacks();
   268			
   269	        4503        init_ids();
   270	        4503        PL_lex_state = LEX_NOTPARSING;
   271			
   272	        4503        JMPENV_BOOTSTRAP;
   273	        4503        STATUS_ALL_SUCCESS;
   274			
   275	        4503        init_i18nl10n(1);
   276	        4503        SET_NUMERIC_STANDARD();
   277			
   278			#if defined(LOCAL_PATCH_COUNT)
   279	        4503        PL_localpatches = local_patches;	/* For possible -v */
   280			#endif
   281			
   282			#ifdef HAVE_INTERP_INTERN
   283			    sys_intern_init();
   284			#endif
   285			
   286	        4503        PerlIO_init(aTHX);			/* Hook to IO system */
   287			
   288	        4503        PL_fdpid = newAV();			/* for remembering popen pids by fd */
   289	        4503        PL_modglobal = newHV();		/* pointers to per-interpreter module globals */
   290	        4503        PL_errors = newSVpvn("",0);
   291	        4503        sv_setpvn(PERL_DEBUG_PAD(0), "", 0);	/* For regex debugging. */
   292	        4503        sv_setpvn(PERL_DEBUG_PAD(1), "", 0);	/* ext/re needs these */
   293	        4503        sv_setpvn(PERL_DEBUG_PAD(2), "", 0);	/* even without DEBUGGING. */
   294			#ifdef USE_ITHREADS
   295			    PL_regex_padav = newAV();
   296			    av_push(PL_regex_padav,(SV*)newAV());    /* First entry is an array of empty elements */
   297			    PL_regex_pad = AvARRAY(PL_regex_padav);
   298			#endif
   299			#ifdef USE_REENTRANT_API
   300			    Perl_reentrant_init(aTHX);
   301			#endif
   302			
   303			    /* Note that strtab is a rather special HV.  Assumptions are made
   304			       about not iterating on it, and not adding tie magic to it.
   305			       It is properly deallocated in perl_destruct() */
   306	        4503        PL_strtab = newHV();
   307			
   308	        4503        HvSHAREKEYS_off(PL_strtab);			/* mandatory */
   309	        4503        hv_ksplit(PL_strtab, 512);
   310			
   311			#if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
   312			    _dyld_lookup_and_bind
   313				("__environ", (unsigned long *) &environ_pointer, NULL);
   314			#endif /* environ */
   315			
   316			#ifndef PERL_MICRO
   317			#   ifdef  USE_ENVIRON_ARRAY
   318	        4503        PL_origenviron = environ;
   319			#   endif
   320			#endif
   321			
   322			    /* Use sysconf(_SC_CLK_TCK) if available, if not
   323			     * available or if the sysconf() fails, use the HZ.
   324			     * BeOS has those, but returns the wrong value.
   325			     * The HZ if not originally defined has been by now
   326			     * been defined as CLK_TCK, if available. */
   327			#if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK) && !defined(__BEOS__)
   328	        4503        PL_clocktick = sysconf(_SC_CLK_TCK);
   329	        4503        if (PL_clocktick <= 0)
   330			#endif
   331	      ######    	 PL_clocktick = HZ;
   332			
   333	        4503        PL_stashcache = newHV();
   334			
   335	        4503        PL_patchlevel = Perl_newSVpvf(aTHX_ "%d.%d.%d", (int)PERL_REVISION,
   336							  (int)PERL_VERSION, (int)PERL_SUBVERSION);
   337			
   338			#ifdef HAS_MMAP
   339	        4503        if (!PL_mmap_page_size) {
   340			#if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_MMAP_PAGE_SIZE))
   341			      {
   342	        4503    	SETERRNO(0, SS_NORMAL);
   343			#   ifdef _SC_PAGESIZE
   344	        4503    	PL_mmap_page_size = sysconf(_SC_PAGESIZE);
   345			#   else
   346				PL_mmap_page_size = sysconf(_SC_MMAP_PAGE_SIZE);
   347			#   endif
   348	        4503    	if ((long) PL_mmap_page_size < 0) {
   349	      ######    	  if (errno) {
   350	      ######    	    SV *error = ERRSV;
   351	      ######    	    (void) SvUPGRADE(error, SVt_PV);
   352	      ######    	    Perl_croak(aTHX_ "panic: sysconf: %s", SvPV_nolen_const(error));
   353				  }
   354				  else
   355	      ######    	    Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
   356				}
   357			      }
   358			#else
   359			#   ifdef HAS_GETPAGESIZE
   360			      PL_mmap_page_size = getpagesize();
   361			#   else
   362			#       if defined(I_SYS_PARAM) && defined(PAGESIZE)
   363			      PL_mmap_page_size = PAGESIZE;       /* compiletime, bad */
   364			#       endif
   365			#   endif
   366			#endif
   367	        4503          if (PL_mmap_page_size <= 0)
   368	      ######    	Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
   369					   (IV) PL_mmap_page_size);
   370			    }
   371			#endif /* HAS_MMAP */
   372			
   373			#if defined(HAS_TIMES) && defined(PERL_NEED_TIMESBASE)
   374			    PL_timesbase.tms_utime  = 0;
   375			    PL_timesbase.tms_stime  = 0;
   376			    PL_timesbase.tms_cutime = 0;
   377			    PL_timesbase.tms_cstime = 0;
   378			#endif
   379			
   380	        4503        ENTER;
   381			}
   382			
   383			/*
   384			=for apidoc nothreadhook
   385			
   386			Stub that provides thread hook for perl_destruct when there are
   387			no threads.
   388			
   389			=cut
   390			*/
   391			
   392			int
   393			Perl_nothreadhook(pTHX)
   394	        4549    {
   395	        4549        return 0;
   396			}
   397			
   398			#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
   399			void
   400			Perl_dump_sv_child(pTHX_ SV *sv)
   401			{
   402			    ssize_t got;
   403			    const int sock = PL_dumper_fd;
   404			    const int debug_fd = PerlIO_fileno(Perl_debug_log);
   405			    union control_un control;
   406			    struct msghdr msg;
   407			    struct iovec vec[2];
   408			    struct cmsghdr *cmptr;
   409			    int returned_errno;
   410			    unsigned char buffer[256];
   411			
   412			    if(sock == -1 || debug_fd == -1)
   413				return;
   414			
   415			    PerlIO_flush(Perl_debug_log);
   416			
   417			    /* All these shenanigans are to pass a file descriptor over to our child for
   418			       it to dump out to.  We can't let it hold open the file descriptor when it
   419			       forks, as the file descriptor it will dump to can turn out to be one end
   420			       of pipe that some other process will wait on for EOF. (So as it would
   421			       be open, the wait would be forever.  */
   422			
   423			    msg.msg_control = control.control;
   424			    msg.msg_controllen = sizeof(control.control);
   425			    /* We're a connected socket so we don't need a destination  */
   426			    msg.msg_name = NULL;
   427			    msg.msg_namelen = 0;
   428			    msg.msg_iov = vec;
   429			    msg.msg_iovlen = 1;
   430			
   431			    cmptr = CMSG_FIRSTHDR(&msg);
   432			    cmptr->cmsg_len = CMSG_LEN(sizeof(int));
   433			    cmptr->cmsg_level = SOL_SOCKET;
   434			    cmptr->cmsg_type = SCM_RIGHTS;
   435			    *((int *)CMSG_DATA(cmptr)) = 1;
   436			
   437			    vec[0].iov_base = (void*)&sv;
   438			    vec[0].iov_len = sizeof(sv);
   439			    got = sendmsg(sock, &msg, 0);
   440			
   441			    if(got < 0) {
   442				perror("Debug leaking scalars parent sendmsg failed");
   443				abort();
   444			    }
   445			    if(got < sizeof(sv)) {
   446				perror("Debug leaking scalars parent short sendmsg");
   447				abort();
   448			    }
   449			
   450			    /* Return protocol is
   451			       int:		errno value
   452			       unsigned char:	length of location string (0 for empty)
   453			       unsigned char*:	string (not terminated)
   454			    */
   455			    vec[0].iov_base = (void*)&returned_errno;
   456			    vec[0].iov_len = sizeof(returned_errno);
   457			    vec[1].iov_base = buffer;
   458			    vec[1].iov_len = 1;
   459			
   460			    got = readv(sock, vec, 2);
   461			
   462			    if(got < 0) {
   463				perror("Debug leaking scalars parent read failed");
   464				PerlIO_flush(PerlIO_stderr());
   465				abort();
   466			    }
   467			    if(got < sizeof(returned_errno) + 1) {
   468				perror("Debug leaking scalars parent short read");
   469				PerlIO_flush(PerlIO_stderr());
   470				abort();
   471			    }
   472			
   473			    if (*buffer) {
   474				got = read(sock, buffer + 1, *buffer);
   475				if(got < 0) {
   476				    perror("Debug leaking scalars parent read 2 failed");
   477				    PerlIO_flush(PerlIO_stderr());
   478				    abort();
   479				}
   480			
   481				if(got < *buffer) {
   482				    perror("Debug leaking scalars parent short read 2");
   483				    PerlIO_flush(PerlIO_stderr());
   484				    abort();
   485				}
   486			    }
   487			
   488			    if (returned_errno || *buffer) {
   489				Perl_warn(aTHX_ "Debug leaking scalars child failed%s%.*s with errno"
   490					  " %d: %s", (*buffer ? " at " : ""), (int) *buffer, buffer + 1,
   491					  returned_errno, strerror(returned_errno));
   492			    }
   493			}
   494			#endif
   495			
   496			/*
   497			=for apidoc perl_destruct
   498			
   499			Shuts down a Perl interpreter.  See L<perlembed>.
   500			
   501			=cut
   502			*/
   503			
   504			int
   505			perl_destruct(pTHXx)
   506	        4549    {
   507			    dVAR;
   508	        4549        volatile int destruct_level;  /* 0=none, 1=full, 2=full with checks */
   509	        4549        HV *hv;
   510			#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
   511			    pid_t child;
   512			#endif
   513			
   514	        4549        PERL_UNUSED_ARG(my_perl);
   515			
   516			    /* wait for all pseudo-forked children to finish */
   517	        4549        PERL_WAIT_FOR_CHILDREN;
   518			
   519	        4549        destruct_level = PL_perl_destruct_level;
   520			#ifdef DEBUGGING
   521			    {
   522	        4549    	const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
   523	        4549    	if (s) {
   524	        4549                const int i = atoi(s);
   525	        4549    	    if (destruct_level < i)
   526	        4549    		destruct_level = i;
   527				}
   528			    }
   529			#endif
   530			
   531	        4549        if (PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
   532	        4548            dJMPENV;
   533	        4548            int x = 0;
   534			
   535	        4548            JMPENV_PUSH(x);
   536	        4557    	PERL_UNUSED_VAR(x);
   537	        4557            if (PL_endav && !PL_minus_c)
   538	         749                call_list(PL_scopestack_ix, PL_endav);
   539	        4548            JMPENV_POP;
   540			    }
   541	        4549        LEAVE;
   542	        4549        FREETMPS;
   543			
   544			    /* Need to flush since END blocks can produce output */
   545	        4549        my_fflush_all();
   546			
   547	        4549        if (CALL_FPTR(PL_threadhook)(aTHX)) {
   548			        /* Threads hook has vetoed further cleanup */
   549	      ######            return STATUS_NATIVE_EXPORT;
   550			    }
   551			
   552			#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
   553			    if (destruct_level != 0) {
   554				/* Fork here to create a child. Our child's job is to preserve the
   555				   state of scalars prior to destruction, so that we can instruct it
   556				   to dump any scalars that we later find have leaked.
   557				   There's no subtlety in this code - it assumes POSIX, and it doesn't
   558				   fail gracefully  */
   559				int fd[2];
   560			
   561				if(socketpair(AF_UNIX, SOCK_STREAM, 0, fd)) {
   562				    perror("Debug leaking scalars socketpair failed");
   563				    abort();
   564				}
   565			
   566				child = fork();
   567				if(child == -1) {
   568				    perror("Debug leaking scalars fork failed");
   569				    abort();
   570				}
   571				if (!child) {
   572				    /* We are the child */
   573				    const int sock = fd[1];
   574				    const int debug_fd = PerlIO_fileno(Perl_debug_log);
   575				    int f;
   576				    const char *where;
   577				    /* Our success message is an integer 0, and a char 0  */
   578				    static const char success[sizeof(int) + 1];
   579			
   580				    close(fd[0]);
   581			
   582				    /* We need to close all other file descriptors otherwise we end up
   583				       with interesting hangs, where the parent closes its end of a
   584				       pipe, and sits waiting for (another) child to terminate. Only
   585				       that child never terminates, because it never gets EOF, because
   586				       we also have the far end of the pipe open.  We even need to
   587				       close the debugging fd, because sometimes it happens to be one
   588				       end of a pipe, and a process is waiting on the other end for
   589				       EOF. Normally it would be closed at some point earlier in
   590				       destruction, but if we happen to cause the pipe to remain open,
   591				       EOF never occurs, and we get an infinite hang. Hence all the
   592				       games to pass in a file descriptor if it's actually needed.  */
   593			
   594				    f = sysconf(_SC_OPEN_MAX);
   595				    if(f < 0) {
   596					where = "sysconf failed";
   597					goto abort;
   598				    }
   599				    while (f--) {
   600					if (f == sock)
   601					    continue;
   602					close(f);
   603				    }
   604			
   605				    while (1) {
   606					SV *target;
   607					union control_un control;
   608					struct msghdr msg;
   609					struct iovec vec[1];
   610					struct cmsghdr *cmptr;
   611					ssize_t got;
   612					int got_fd;
   613			
   614					msg.msg_control = control.control;
   615					msg.msg_controllen = sizeof(control.control);
   616					/* We're a connected socket so we don't need a source  */
   617					msg.msg_name = NULL;
   618					msg.msg_namelen = 0;
   619					msg.msg_iov = vec;
   620					msg.msg_iovlen = sizeof(vec)/sizeof(vec[0]);
   621			
   622					vec[0].iov_base = (void*)&target;
   623					vec[0].iov_len = sizeof(target);
   624			      
   625					got = recvmsg(sock, &msg, 0);
   626			
   627					if(got == 0)
   628					    break;
   629					if(got < 0) {
   630					    where = "recv failed";
   631					    goto abort;
   632					}
   633					if(got < sizeof(target)) {
   634					    where = "short recv";
   635					    goto abort;
   636					}
   637			
   638					if(!(cmptr = CMSG_FIRSTHDR(&msg))) {
   639					    where = "no cmsg";
   640					    goto abort;
   641					}
   642					if(cmptr->cmsg_len != CMSG_LEN(sizeof(int))) {
   643					    where = "wrong cmsg_len";
   644					    goto abort;
   645					}
   646					if(cmptr->cmsg_level != SOL_SOCKET) {
   647					    where = "wrong cmsg_level";
   648					    goto abort;
   649					}
   650					if(cmptr->cmsg_type != SCM_RIGHTS) {
   651					    where = "wrong cmsg_type";
   652					    goto abort;
   653					}
   654			
   655					got_fd = *(int*)CMSG_DATA(cmptr);
   656					/* For our last little bit of trickery, put the file descriptor
   657					   back into Perl_debug_log, as if we never actually closed it
   658					*/
   659					if(got_fd != debug_fd) {
   660					    if (dup2(got_fd, debug_fd) == -1) {
   661						where = "dup2";
   662						goto abort;
   663					    }
   664					}
   665					sv_dump(target);
   666			
   667					PerlIO_flush(Perl_debug_log);
   668			
   669					got = write(sock, &success, sizeof(success));
   670			
   671					if(got < 0) {
   672					    where = "write failed";
   673					    goto abort;
   674					}
   675					if(got < sizeof(success)) {
   676					    where = "short write";
   677					    goto abort;
   678					}
   679				    }
   680				    _exit(0);
   681				abort:
   682				    {
   683					int send_errno = errno;
   684					unsigned char length = (unsigned char) strlen(where);
   685					struct iovec failure[3] = {
   686					    {(void*)&send_errno, sizeof(send_errno)},
   687					    {&length, 1},
   688					    {(void*)where, length}
   689					};
   690					int got = writev(sock, failure, 3);
   691					/* Bad news travels fast. Faster than data. We'll get a SIGPIPE
   692					   in the parent if we try to read from the socketpair after the
   693					   child has exited, even if there was data to read.
   694					   So sleep a bit to give the parent a fighting chance of
   695					   reading the data.  */
   696					sleep(2);
   697					_exit((got == -1) ? errno : 0);
   698				    }
   699				    /* End of child.  */
   700				}
   701				PL_dumper_fd = fd[0];
   702				close(fd[1]);
   703			    }
   704			#endif
   705			    
   706			    /* We must account for everything.  */
   707			
   708			    /* Destroy the main CV and syntax tree */
   709			    /* Do this now, because destroying ops can cause new SVs to be generated
   710			       in Perl_pad_swipe, and when running with -DDEBUG_LEAKING_SCALARS they
   711			       PL_curcop to point to a valid op from which the filename structure
   712			       member is copied.  */
   713	        4549        PL_curcop = &PL_compiling;
   714	        4549        if (PL_main_root) {
   715				/* ensure comppad/curpad to refer to main's pad */
   716	        4425    	if (CvPADLIST(PL_main_cv)) {
   717	        4425    	    PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1);
   718				}
   719	        4425    	op_free(PL_main_root);
   720	        4425    	PL_main_root = Nullop;
   721			    }
   722	        4549        PL_main_start = Nullop;
   723	        4549        SvREFCNT_dec(PL_main_cv);
   724	        4549        PL_main_cv = Nullcv;
   725	        4549        PL_dirty = TRUE;
   726			
   727			    /* Tell PerlIO we are about to tear things apart in case
   728			       we have layers which are using resources that should
   729			       be cleaned up now.
   730			     */
   731			
   732	        4549        PerlIO_destruct(aTHX);
   733			
   734	        4549        if (PL_sv_objcount) {
   735				/*
   736				 * Try to destruct global references.  We do this first so that the
   737				 * destructors and destructees still exist.  Some sv's might remain.
   738				 * Non-referenced objects are on their own.
   739				 */
   740	        2213    	sv_clean_objs();
   741	        2213    	PL_sv_objcount = 0;
   742			    }
   743			
   744			    /* unhook hooks which will soon be, or use, destroyed data */
   745	        4549        SvREFCNT_dec(PL_warnhook);
   746	        4549        PL_warnhook = Nullsv;
   747	        4549        SvREFCNT_dec(PL_diehook);
   748	        4549        PL_diehook = Nullsv;
   749			
   750			    /* call exit list functions */
   751	        4549        while (PL_exitlistlen-- > 0)
   752	      ######    	PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
   753			
   754	        4549        Safefree(PL_exitlist);
   755			
   756	        4549        PL_exitlist = NULL;
   757	        4549        PL_exitlistlen = 0;
   758			
   759	        4549        if (destruct_level == 0){
   760			
   761	      ######    	DEBUG_P(debprofdump());
   762			
   763			#if defined(PERLIO_LAYERS)
   764				/* No more IO - including error messages ! */
   765	      ######    	PerlIO_cleanup(aTHX);
   766			#endif
   767			
   768				/* The exit() function will do everything that needs doing. */
   769	      ######            return STATUS_NATIVE_EXPORT;
   770			    }
   771			
   772			    /* jettison our possibly duplicated environment */
   773			    /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
   774			     * so we certainly shouldn't free it here
   775			     */
   776			#ifndef PERL_MICRO
   777			#if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
   778	        4549        if (environ != PL_origenviron && !PL_use_safe_putenv
   779			#ifdef USE_ITHREADS
   780				/* only main thread can free environ[0] contents */
   781				&& PL_curinterp == aTHX
   782			#endif
   783				)
   784			    {
   785	        4548    	I32 i;
   786			
   787	      221792    	for (i = 0; environ[i]; i++)
   788	      217244    	    safesysfree(environ[i]);
   789			
   790				/* Must use safesysfree() when working with environ. */
   791	        4548    	safesysfree(environ);		
   792			
   793	        4548    	environ = PL_origenviron;
   794			    }
   795			#endif
   796			#endif /* !PERL_MICRO */
   797			
   798			    /* reset so print() ends up where we expect */
   799	        4549        setdefout(Nullgv);
   800			
   801			#ifdef USE_ITHREADS
   802			    /* the syntax tree is shared between clones
   803			     * so op_free(PL_main_root) only ReREFCNT_dec's
   804			     * REGEXPs in the parent interpreter
   805			     * we need to manually ReREFCNT_dec for the clones
   806			     */
   807			    {
   808			        I32 i = AvFILLp(PL_regex_padav) + 1;
   809			        SV **ary = AvARRAY(PL_regex_padav);
   810			
   811			        while (i) {
   812			            SV *resv = ary[--i];
   813			
   814			            if (SvFLAGS(resv) & SVf_BREAK) {
   815			                /* this is PL_reg_curpm, already freed
   816			                 * flag is set in regexec.c:S_regtry
   817			                 */
   818			                SvFLAGS(resv) &= ~SVf_BREAK;
   819			            }
   820				    else if(SvREPADTMP(resv)) {
   821				      SvREPADTMP_off(resv);
   822				    }
   823			            else if(SvIOKp(resv)) {
   824					REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv));
   825			                ReREFCNT_dec(re);
   826			            }
   827			        }
   828			    }
   829			    SvREFCNT_dec(PL_regex_padav);
   830			    PL_regex_padav = Nullav;
   831			    PL_regex_pad = NULL;
   832			#endif
   833			
   834	        4549        SvREFCNT_dec((SV*) PL_stashcache);
   835	        4549        PL_stashcache = NULL;
   836			
   837			    /* loosen bonds of global variables */
   838			
   839	        4549        if(PL_rsfp) {
   840	      ######    	(void)PerlIO_close(PL_rsfp);
   841	      ######    	PL_rsfp = Nullfp;
   842			    }
   843			
   844			    /* Filters for program text */
   845	        4549        SvREFCNT_dec(PL_rsfp_filters);
   846	        4549        PL_rsfp_filters = Nullav;
   847			
   848			    /* switches */
   849	        4549        PL_preprocess   = FALSE;
   850	        4549        PL_minus_n      = FALSE;
   851	        4549        PL_minus_p      = FALSE;
   852	        4549        PL_minus_l      = FALSE;
   853	        4549        PL_minus_a      = FALSE;
   854	        4549        PL_minus_F      = FALSE;
   855	        4549        PL_doswitches   = FALSE;
   856	        4549        PL_dowarn       = G_WARN_OFF;
   857	        4549        PL_doextract    = FALSE;
   858	        4549        PL_sawampersand = FALSE;	/* must save all match strings */
   859	        4549        PL_unsafe       = FALSE;
   860			
   861	        4549        Safefree(PL_inplace);
   862	        4549        PL_inplace = Nullch;
   863	        4549        SvREFCNT_dec(PL_patchlevel);
   864			
   865	        4549        if (PL_e_script) {
   866	      ######    	SvREFCNT_dec(PL_e_script);
   867	      ######    	PL_e_script = Nullsv;
   868			    }
   869			
   870	        4549        PL_perldb = 0;
   871			
   872			    /* magical thingies */
   873			
   874	        4549        SvREFCNT_dec(PL_ofs_sv);	/* $, */
   875	        4549        PL_ofs_sv = Nullsv;
   876			
   877	        4549        SvREFCNT_dec(PL_ors_sv);	/* $\ */
   878	        4549        PL_ors_sv = Nullsv;
   879			
   880	        4549        SvREFCNT_dec(PL_rs);	/* $/ */
   881	        4549        PL_rs = Nullsv;
   882			
   883	        4549        PL_multiline = 0;		/* $* */
   884	        4549        Safefree(PL_osname);	/* $^O */
   885	        4549        PL_osname = Nullch;
   886			
   887	        4549        SvREFCNT_dec(PL_statname);
   888	        4549        PL_statname = Nullsv;
   889	        4549        PL_statgv = Nullgv;
   890			
   891			    /* defgv, aka *_ should be taken care of elsewhere */
   892			
   893			    /* clean up after study() */
   894	        4549        SvREFCNT_dec(PL_lastscream);
   895	        4549        PL_lastscream = Nullsv;
   896	        4549        Safefree(PL_screamfirst);
   897	        4549        PL_screamfirst = 0;
   898	        4549        Safefree(PL_screamnext);
   899	        4549        PL_screamnext  = 0;
   900			
   901			    /* float buffer */
   902	        4549        Safefree(PL_efloatbuf);
   903	        4549        PL_efloatbuf = Nullch;
   904	        4549        PL_efloatsize = 0;
   905			
   906			    /* startup and shutdown function lists */
   907	        4549        SvREFCNT_dec(PL_beginav);
   908	        4549        SvREFCNT_dec(PL_beginav_save);
   909	        4549        SvREFCNT_dec(PL_endav);
   910	        4549        SvREFCNT_dec(PL_checkav);
   911	        4549        SvREFCNT_dec(PL_checkav_save);
   912	        4549        SvREFCNT_dec(PL_initav);
   913	        4549        PL_beginav = Nullav;
   914	        4549        PL_beginav_save = Nullav;
   915	        4549        PL_endav = Nullav;
   916	        4549        PL_checkav = Nullav;
   917	        4549        PL_checkav_save = Nullav;
   918	        4549        PL_initav = Nullav;
   919			
   920			    /* shortcuts just get cleared */
   921	        4549        PL_envgv = Nullgv;
   922	        4549        PL_incgv = Nullgv;
   923	        4549        PL_hintgv = Nullgv;
   924	        4549        PL_errgv = Nullgv;
   925	        4549        PL_argvgv = Nullgv;
   926	        4549        PL_argvoutgv = Nullgv;
   927	        4549        PL_stdingv = Nullgv;
   928	        4549        PL_stderrgv = Nullgv;
   929	        4549        PL_last_in_gv = Nullgv;
   930	        4549        PL_replgv = Nullgv;
   931	        4549        PL_DBgv = Nullgv;
   932	        4549        PL_DBline = Nullgv;
   933	        4549        PL_DBsub = Nullgv;
   934	        4549        PL_DBsingle = Nullsv;
   935	        4549        PL_DBtrace = Nullsv;
   936	        4549        PL_DBsignal = Nullsv;
   937	        4549        PL_DBassertion = Nullsv;
   938	        4549        PL_DBcv = Nullcv;
   939	        4549        PL_dbargs = Nullav;
   940	        4549        PL_debstash = Nullhv;
   941			
   942	        4549        SvREFCNT_dec(PL_argvout_stack);
   943	        4549        PL_argvout_stack = Nullav;
   944			
   945	        4549        SvREFCNT_dec(PL_modglobal);
   946	        4549        PL_modglobal = Nullhv;
   947	        4549        SvREFCNT_dec(PL_preambleav);
   948	        4549        PL_preambleav = Nullav;
   949	        4549        SvREFCNT_dec(PL_subname);
   950	        4549        PL_subname = Nullsv;
   951	        4549        SvREFCNT_dec(PL_linestr);
   952	        4549        PL_linestr = Nullsv;
   953	        4549        SvREFCNT_dec(PL_pidstatus);
   954	        4549        PL_pidstatus = Nullhv;
   955	        4549        SvREFCNT_dec(PL_toptarget);
   956	        4549        PL_toptarget = Nullsv;
   957	        4549        SvREFCNT_dec(PL_bodytarget);
   958	        4549        PL_bodytarget = Nullsv;
   959	        4549        PL_formtarget = Nullsv;
   960			
   961			    /* free locale stuff */
   962			#ifdef USE_LOCALE_COLLATE
   963	        4549        Safefree(PL_collation_name);
   964	        4549        PL_collation_name = Nullch;
   965			#endif
   966			
   967			#ifdef USE_LOCALE_NUMERIC
   968	        4549        Safefree(PL_numeric_name);
   969	        4549        PL_numeric_name = Nullch;
   970	        4549        SvREFCNT_dec(PL_numeric_radix_sv);
   971	        4549        PL_numeric_radix_sv = Nullsv;
   972			#endif
   973			
   974			    /* clear utf8 character classes */
   975	        4549        SvREFCNT_dec(PL_utf8_alnum);
   976	        4549        SvREFCNT_dec(PL_utf8_alnumc);
   977	        4549        SvREFCNT_dec(PL_utf8_ascii);
   978	        4549        SvREFCNT_dec(PL_utf8_alpha);
   979	        4549        SvREFCNT_dec(PL_utf8_space);
   980	        4549        SvREFCNT_dec(PL_utf8_cntrl);
   981	        4549        SvREFCNT_dec(PL_utf8_graph);
   982	        4549        SvREFCNT_dec(PL_utf8_digit);
   983	        4549        SvREFCNT_dec(PL_utf8_upper);
   984	        4549        SvREFCNT_dec(PL_utf8_lower);
   985	        4549        SvREFCNT_dec(PL_utf8_print);
   986	        4549        SvREFCNT_dec(PL_utf8_punct);
   987	        4549        SvREFCNT_dec(PL_utf8_xdigit);
   988	        4549        SvREFCNT_dec(PL_utf8_mark);
   989	        4549        SvREFCNT_dec(PL_utf8_toupper);
   990	        4549        SvREFCNT_dec(PL_utf8_totitle);
   991	        4549        SvREFCNT_dec(PL_utf8_tolower);
   992	        4549        SvREFCNT_dec(PL_utf8_tofold);
   993	        4549        SvREFCNT_dec(PL_utf8_idstart);
   994	        4549        SvREFCNT_dec(PL_utf8_idcont);
   995	        4549        PL_utf8_alnum	= Nullsv;
   996	        4549        PL_utf8_alnumc	= Nullsv;
   997	        4549        PL_utf8_ascii	= Nullsv;
   998	        4549        PL_utf8_alpha	= Nullsv;
   999	        4549        PL_utf8_space	= Nullsv;
  1000	        4549        PL_utf8_cntrl	= Nullsv;
  1001	        4549        PL_utf8_graph	= Nullsv;
  1002	        4549        PL_utf8_digit	= Nullsv;
  1003	        4549        PL_utf8_upper	= Nullsv;
  1004	        4549        PL_utf8_lower	= Nullsv;
  1005	        4549        PL_utf8_print	= Nullsv;
  1006	        4549        PL_utf8_punct	= Nullsv;
  1007	        4549        PL_utf8_xdigit	= Nullsv;
  1008	        4549        PL_utf8_mark	= Nullsv;
  1009	        4549        PL_utf8_toupper	= Nullsv;
  1010	        4549        PL_utf8_totitle	= Nullsv;
  1011	        4549        PL_utf8_tolower	= Nullsv;
  1012	        4549        PL_utf8_tofold	= Nullsv;
  1013	        4549        PL_utf8_idstart	= Nullsv;
  1014	        4549        PL_utf8_idcont	= Nullsv;
  1015			
  1016	        4549        if (!specialWARN(PL_compiling.cop_warnings))
  1017	           3    	SvREFCNT_dec(PL_compiling.cop_warnings);
  1018	        4549        PL_compiling.cop_warnings = Nullsv;
  1019	        4549        if (!specialCopIO(PL_compiling.cop_io))
  1020	           3    	SvREFCNT_dec(PL_compiling.cop_io);
  1021	        4549        PL_compiling.cop_io = Nullsv;
  1022	        4549        CopFILE_free(&PL_compiling);
  1023			    CopSTASH_free(&PL_compiling);
  1024			
  1025			    /* Prepare to destruct main symbol table.  */
  1026			
  1027	        4549        hv = PL_defstash;
  1028	        4549        PL_defstash = 0;
  1029	        4549        SvREFCNT_dec(hv);
  1030	        4549        SvREFCNT_dec(PL_curstname);
  1031	        4549        PL_curstname = Nullsv;
  1032			
  1033			    /* clear queued errors */
  1034	        4549        SvREFCNT_dec(PL_errors);
  1035	        4549        PL_errors = Nullsv;
  1036			
  1037	        4549        FREETMPS;
  1038	        4549        if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
  1039	        4549    	if (PL_scopestack_ix != 0)
  1040	      ######    	    Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
  1041				         "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
  1042					 (long)PL_scopestack_ix);
  1043	        4549    	if (PL_savestack_ix != 0)
  1044	      ######    	    Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
  1045					 "Unbalanced saves: %ld more saves than restores\n",
  1046					 (long)PL_savestack_ix);
  1047	        4549    	if (PL_tmps_floor != -1)
  1048	      ######    	    Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
  1049					 (long)PL_tmps_floor + 1);
  1050	        4549    	if (cxstack_ix != -1)
  1051	      ######    	    Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
  1052					 (long)cxstack_ix + 1);
  1053			    }
  1054			
  1055			    /* Now absolutely destruct everything, somehow or other, loops or no. */
  1056	        4549        SvFLAGS(PL_fdpid) |= SVTYPEMASK;		/* don't clean out pid table now */
  1057	        4549        SvFLAGS(PL_strtab) |= SVTYPEMASK;		/* don't clean out strtab now */
  1058			
  1059			    /* the 2 is for PL_fdpid and PL_strtab */
  1060	       10728        while (PL_sv_count > 2 && sv_clean_all())
  1061				;
  1062			
  1063	        4549        SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
  1064	        4549        SvFLAGS(PL_fdpid) |= SVt_PVAV;
  1065	        4549        SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
  1066	        4549        SvFLAGS(PL_strtab) |= SVt_PVHV;
  1067			
  1068	        4549        AvREAL_off(PL_fdpid);		/* no surviving entries */
  1069	        4549        SvREFCNT_dec(PL_fdpid);		/* needed in io_close() */
  1070	        4549        PL_fdpid = Nullav;
  1071			
  1072			#ifdef HAVE_INTERP_INTERN
  1073			    sys_intern_clear();
  1074			#endif
  1075			
  1076			    /* Destruct the global string table. */
  1077			    {
  1078				/* Yell and reset the HeVAL() slots that are still holding refcounts,
  1079				 * so that sv_free() won't fail on them.
  1080				 * Now that the global string table is using a single hunk of memory
  1081				 * for both HE and HEK, we either need to explicitly unshare it the
  1082				 * correct way, or actually free things here.
  1083				 */
  1084	        4549    	I32 riter = 0;
  1085	        4549    	const I32 max = HvMAX(PL_strtab);
  1086	        4549    	HE **array = HvARRAY(PL_strtab);
  1087	        4549    	HE *hent = array[0];
  1088			
  1089	     8020539    	for (;;) {
  1090	     4012544    	    if (hent && ckWARN_d(WARN_INTERNAL)) {
  1091	      ######    		HE *next = HeNEXT(hent);
  1092	      ######    		Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
  1093					     "Unbalanced string table refcount: (%d) for \"%s\"",
  1094					     HeVAL(hent) - Nullsv, HeKEY(hent));
  1095	      ######    		Safefree(hent);
  1096	      ######    		hent = next;
  1097				    }
  1098	     4012544    	    if (!hent) {
  1099	     4012544    		if (++riter > max)
  1100	        4549    		    break;
  1101	     4007995    		hent = array[riter];
  1102				    }
  1103				}
  1104			
  1105	        4549    	Safefree(array);
  1106	        4549    	HvARRAY(PL_strtab) = 0;
  1107	        4549    	HvTOTALKEYS(PL_strtab) = 0;
  1108	        4549    	HvFILL(PL_strtab) = 0;
  1109			    }
  1110	        4549        SvREFCNT_dec(PL_strtab);
  1111			
  1112			#ifdef USE_ITHREADS
  1113			    /* free the pointer tables used for cloning */
  1114			    ptr_table_free(PL_ptr_table);
  1115			    PL_ptr_table = (PTR_TBL_t*)NULL;
  1116			#endif
  1117			
  1118			    /* free special SVs */
  1119			
  1120	        4549        SvREFCNT(&PL_sv_yes) = 0;
  1121	        4549        sv_clear(&PL_sv_yes);
  1122	        4549        SvANY(&PL_sv_yes) = NULL;
  1123	        4549        SvFLAGS(&PL_sv_yes) = 0;
  1124			
  1125	        4549        SvREFCNT(&PL_sv_no) = 0;
  1126	        4549        sv_clear(&PL_sv_no);
  1127	        4549        SvANY(&PL_sv_no) = NULL;
  1128	        4549        SvFLAGS(&PL_sv_no) = 0;
  1129			
  1130			    {
  1131	        4549            int i;
  1132	       18196            for (i=0; i<=2; i++) {
  1133	       13647                SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
  1134	       13647                sv_clear(PERL_DEBUG_PAD(i));
  1135	       13647                SvANY(PERL_DEBUG_PAD(i)) = NULL;
  1136	       13647                SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
  1137			        }
  1138			    }
  1139			
  1140	        4549        if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
  1141	      ######    	Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
  1142			
  1143			#ifdef DEBUG_LEAKING_SCALARS
  1144			    if (PL_sv_count != 0) {
  1145				SV* sva;
  1146				SV* sv;
  1147				register SV* svend;
  1148			
  1149				for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
  1150				    svend = &sva[SvREFCNT(sva)];
  1151				    for (sv = sva + 1; sv < svend; ++sv) {
  1152					if (SvTYPE(sv) != SVTYPEMASK) {
  1153					    PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
  1154						" flags=0x%"UVxf
  1155						" refcnt=%"UVuf pTHX__FORMAT "\n"
  1156						"\tallocated at %s:%d %s %s%s\n",
  1157						sv, sv->sv_flags, sv->sv_refcnt pTHX__VALUE,
  1158						sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
  1159						sv->sv_debug_line,
  1160						sv->sv_debug_inpad ? "for" : "by",
  1161						sv->sv_debug_optype ?
  1162						    PL_op_name[sv->sv_debug_optype]: "(none)",
  1163						sv->sv_debug_cloned ? " (cloned)" : ""
  1164					    );
  1165			#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
  1166					    Perl_dump_sv_child(aTHX_ sv);
  1167			#endif
  1168					}
  1169				    }
  1170				}
  1171			    }
  1172			#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
  1173			    {
  1174				int status;
  1175				fd_set rset;
  1176				/* Wait for up to 4 seconds for child to terminate.
  1177				   This seems to be the least effort way of timing out on reaping
  1178				   its exit status.  */
  1179				struct timeval waitfor = {4, 0};
  1180				int sock = PL_dumper_fd;
  1181			
  1182				shutdown(sock, 1);
  1183				FD_ZERO(&rset);
  1184				FD_SET(sock, &rset);
  1185				select(sock + 1, &rset, NULL, NULL, &waitfor);
  1186				waitpid(child, &status, WNOHANG);
  1187				close(sock);
  1188			    }
  1189			#endif
  1190			#endif
  1191	        4549        PL_sv_count = 0;
  1192			
  1193			
  1194			#if defined(PERLIO_LAYERS)
  1195			    /* No more IO - including error messages ! */
  1196	        4549        PerlIO_cleanup(aTHX);
  1197			#endif
  1198			
  1199			    /* sv_undef needs to stay immortal until after PerlIO_cleanup
  1200			       as currently layers use it rather than Nullsv as a marker
  1201			       for no arg - and will try and SvREFCNT_dec it.
  1202			     */
  1203	        4549        SvREFCNT(&PL_sv_undef) = 0;
  1204	        4549        SvREADONLY_off(&PL_sv_undef);
  1205			
  1206	        4549        Safefree(PL_origfilename);
  1207	        4549        PL_origfilename = Nullch;
  1208	        4549        Safefree(PL_reg_start_tmp);
  1209	        4549        PL_reg_start_tmp = (char**)NULL;
  1210	        4549        PL_reg_start_tmpl = 0;
  1211	        4549        Safefree(PL_reg_curpm);
  1212	        4549        Safefree(PL_reg_poscache);
  1213	        4549        free_tied_hv_pool();
  1214	        4549        Safefree(PL_op_mask);
  1215	        4549        Safefree(PL_psig_ptr);
  1216	        4549        PL_psig_ptr = (SV**)NULL;
  1217	        4549        Safefree(PL_psig_name);
  1218	        4549        PL_psig_name = (SV**)NULL;
  1219	        4549        Safefree(PL_bitcount);
  1220	        4549        PL_bitcount = Nullch;
  1221	        4549        Safefree(PL_psig_pend);
  1222	        4549        PL_psig_pend = (int*)NULL;
  1223	        4549        PL_formfeed = Nullsv;
  1224	        4549        nuke_stacks();
  1225	        4549        PL_tainting = FALSE;
  1226	        4549        PL_taint_warn = FALSE;
  1227	        4549        PL_hints = 0;		/* Reset hints. Should hints be per-interpreter ? */
  1228	        4549        PL_debug = 0;
  1229			
  1230	        4549        DEBUG_P(debprofdump());
  1231			
  1232			#ifdef USE_REENTRANT_API
  1233			    Perl_reentrant_free(aTHX);
  1234			#endif
  1235			
  1236	        4549        sv_free_arenas();
  1237			
  1238			    /* As the absolutely last thing, free the non-arena SV for mess() */
  1239			
  1240	        4549        if (PL_mess_sv) {
  1241				/* we know that type == SVt_PVMG */
  1242			
  1243				/* it could have accumulated taint magic */
  1244	           3    	MAGIC* mg;
  1245	           3    	MAGIC* moremagic;
  1246	           3    	for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
  1247	      ######    	    moremagic = mg->mg_moremagic;
  1248	      ######    	    if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
  1249					&& mg->mg_len >= 0)
  1250	      ######    		Safefree(mg->mg_ptr);
  1251	      ######    	    Safefree(mg);
  1252				}
  1253			
  1254				/* we know that type >= SVt_PV */
  1255	           3    	SvPV_free(PL_mess_sv);
  1256	           3    	Safefree(SvANY(PL_mess_sv));
  1257	           3    	Safefree(PL_mess_sv);
  1258	           3    	PL_mess_sv = Nullsv;
  1259			    }
  1260	        4549        return STATUS_NATIVE_EXPORT;
  1261			}
  1262			
  1263			/*
  1264			=for apidoc perl_free
  1265			
  1266			Releases a Perl interpreter.  See L<perlembed>.
  1267			
  1268			=cut
  1269			*/
  1270			
  1271			void
  1272			perl_free(pTHXx)
  1273	        4549    {
  1274			#if defined(WIN32) || defined(NETWARE)
  1275			#  if defined(PERL_IMPLICIT_SYS)
  1276			#    ifdef NETWARE
  1277			    void *host = nw_internal_host;
  1278			#    else
  1279			    void *host = w32_internal_host;
  1280			#    endif
  1281			    PerlMem_free(aTHXx);
  1282			#    ifdef NETWARE
  1283			    nw_delete_internal_host(host);
  1284			#    else
  1285			    win32_delete_internal_host(host);
  1286			#    endif
  1287			#  else
  1288			    PerlMem_free(aTHXx);
  1289			#  endif
  1290			#else
  1291	        4549        PerlMem_free(aTHXx);
  1292			#endif
  1293			}
  1294			
  1295			#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
  1296			/* provide destructors to clean up the thread key when libperl is unloaded */
  1297			#ifndef WIN32 /* handled during DLL_PROCESS_DETACH in win32/perllib.c */
  1298			
  1299			#if defined(__hpux) && __ux_version > 1020 && !defined(__GNUC__)
  1300			#pragma fini "perl_fini"
  1301			#endif
  1302			
  1303			static void
  1304			#if defined(__GNUC__)
  1305			__attribute__((destructor))
  1306			#endif
  1307			perl_fini(void)
  1308			{
  1309			    dVAR;
  1310			    if (PL_curinterp)
  1311				FREE_THREAD_KEY;
  1312			}
  1313			
  1314			#endif /* WIN32 */
  1315			#endif /* THREADS */
  1316			
  1317			void
  1318			Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
  1319	      ######    {
  1320	      ######        Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
  1321	      ######        PL_exitlist[PL_exitlistlen].fn = fn;
  1322	      ######        PL_exitlist[PL_exitlistlen].ptr = ptr;
  1323	      ######        ++PL_exitlistlen;
  1324			}
  1325			
  1326			#ifdef HAS_PROCSELFEXE
  1327			/* This is a function so that we don't hold on to MAXPATHLEN
  1328			   bytes of stack longer than necessary
  1329			 */
  1330			STATIC void
  1331			S_procself_val(pTHX_ SV *sv, const char *arg0)
  1332	        4500    {
  1333	        4500        char buf[MAXPATHLEN];
  1334	        4500        int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
  1335			
  1336			    /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
  1337			       includes a spurious NUL which will cause $^X to fail in system
  1338			       or backticks (this will prevent extensions from being built and
  1339			       many tests from working). readlink is not meant to add a NUL.
  1340			       Normal readlink works fine.
  1341			     */
  1342	        4500        if (len > 0 && buf[len-1] == '\0') {
  1343	      ######          len--;
  1344			    }
  1345			
  1346			    /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
  1347			       returning the text "unknown" from the readlink rather than the path
  1348			       to the executable (or returning an error from the readlink).  Any valid
  1349			       path has a '/' in it somewhere, so use that to validate the result.
  1350			       See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
  1351			    */
  1352	        4500        if (len > 0 && memchr(buf, '/', len)) {
  1353	        4500    	sv_setpvn(sv,buf,len);
  1354			    }
  1355			    else {
  1356	      ######    	sv_setpv(sv,arg0);
  1357			    }
  1358			}
  1359			#endif /* HAS_PROCSELFEXE */
  1360			
  1361			STATIC void
  1362	        4500    S_set_caret_X(pTHX) {
  1363	        4500        GV* tmpgv = gv_fetchpv("\030",TRUE, SVt_PV); /* $^X */
  1364	        4500        if (tmpgv) {
  1365			#ifdef HAS_PROCSELFEXE
  1366	        4500    	S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
  1367			#else
  1368			#ifdef OS2
  1369				sv_setpv(GvSVn(tmpgv), os2_execname(aTHX));
  1370			#else
  1371				sv_setpv(GvSVn(tmpgv),PL_origargv[0]);
  1372			#endif
  1373			#endif
  1374			    }
  1375			}
  1376			
  1377			/*
  1378			=for apidoc perl_parse
  1379			
  1380			Tells a Perl interpreter to parse a Perl script.  See L<perlembed>.
  1381			
  1382			=cut
  1383			*/
  1384			
  1385			int
  1386			perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
  1387	        4503    {
  1388			    dVAR;
  1389	        4503        I32 oldscope;
  1390	        4503        int ret;
  1391	        4503        dJMPENV;
  1392			
  1393	        4503        PERL_UNUSED_VAR(my_perl);
  1394			
  1395			#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  1396			#ifdef IAMSUID
  1397			#undef IAMSUID
  1398			    Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
  1399			setuid perl scripts securely.\n");
  1400			#endif /* IAMSUID */
  1401			#endif
  1402			
  1403			#if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
  1404			    /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0
  1405			     * This MUST be done before any hash stores or fetches take place.
  1406			     * If you set PL_rehash_seed (and assumedly also PL_rehash_seed_set)
  1407			     * yourself, it is your responsibility to provide a good random seed!
  1408			     * You can also define PERL_HASH_SEED in compile time, see hv.h. */
  1409	        4503        if (!PL_rehash_seed_set)
  1410	        4503    	 PL_rehash_seed = get_hash_seed();
  1411			    {
  1412	        4503    	const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
  1413			
  1414	        4503    	if (s && (atoi(s) == 1))
  1415	      ######    	    PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n", PL_rehash_seed);
  1416			    }
  1417			#endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
  1418			
  1419	        4503        PL_origargc = argc;
  1420	        4503        PL_origargv = argv;
  1421			
  1422			    {
  1423				/* Set PL_origalen be the sum of the contiguous argv[]
  1424				 * elements plus the size of the env in case that it is
  1425				 * contiguous with the argv[].  This is used in mg.c:Perl_magic_set()
  1426				 * as the maximum modifiable length of $0.  In the worst case
  1427				 * the area we are able to modify is limited to the size of
  1428				 * the original argv[0].  (See below for 'contiguous', though.)
  1429				 * --jhi */
  1430	        4503    	 const char *s = NULL;
  1431	        4503    	 int i;
  1432	        4503    	 const UV mask =
  1433	        4503    	   ~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0);
  1434			         /* Do the mask check only if the args seem like aligned. */
  1435	        4503    	 const UV aligned =
  1436	        4503    	   (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
  1437			
  1438				 /* See if all the arguments are contiguous in memory.  Note
  1439				  * that 'contiguous' is a loose term because some platforms
  1440				  * align the argv[] and the envp[].  If the arguments look
  1441				  * like non-aligned, assume that they are 'strictly' or
  1442				  * 'traditionally' contiguous.  If the arguments look like
  1443				  * aligned, we just check that they are within aligned
  1444				  * PTRSIZE bytes.  As long as no system has something bizarre
  1445				  * like the argv[] interleaved with some other data, we are
  1446				  * fine.  (Did I just evoke Murphy's Law?)  --jhi */
  1447	        4503    	 if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) {
  1448	      154927    	      while (*s) s++;
  1449	       16716    	      for (i = 1; i < PL_origargc; i++) {
  1450	       12213    		   if ((PL_origargv[i] == s + 1
  1451			#ifdef OS2
  1452						|| PL_origargv[i] == s + 2
  1453			#endif 
  1454						    )
  1455					       ||
  1456					       (aligned &&
  1457						(PL_origargv[i] >  s &&
  1458						 PL_origargv[i] <=
  1459						 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
  1460						)
  1461					   {
  1462	       12213    			s = PL_origargv[i];
  1463	      171168    			while (*s) s++;
  1464					   }
  1465					   else
  1466	       12213    			break;
  1467				      }
  1468				 }
  1469				 /* Can we grab env area too to be used as the area for $0? */
  1470	        4503    	 if (PL_origenviron) {
  1471	        4503    	      if ((PL_origenviron[0] == s + 1
  1472			#ifdef OS2
  1473					   || (PL_origenviron[0] == s + 9 && (s += 8))
  1474			#endif 
  1475					  )
  1476					  ||
  1477					  (aligned &&
  1478					   (PL_origenviron[0] >  s &&
  1479					    PL_origenviron[0] <=
  1480					    INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
  1481					 )
  1482				      {
  1483			#ifndef OS2
  1484	        4502    		   s = PL_origenviron[0];
  1485	       63843    		   while (*s) s++;
  1486			#endif
  1487	        4502    		   my_setenv("NoNe  SuCh", Nullch);
  1488					   /* Force copy of environment. */
  1489	      214770    		   for (i = 1; PL_origenviron[i]; i++) {
  1490	      210268    			if (PL_origenviron[i] == s + 1
  1491						    ||
  1492						    (aligned &&
  1493						     (PL_origenviron[i] >  s &&
  1494						      PL_origenviron[i] <=
  1495						      INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
  1496						   )
  1497						{
  1498	      210268    			     s = PL_origenviron[i];
  1499	    11163643    			     while (*s) s++;
  1500						}
  1501						else
  1502	      210268    			     break;
  1503					   }
  1504				      }
  1505				 }
  1506	        4503    	 PL_origalen = s - PL_origargv[0] + 1;
  1507			    }
  1508			
  1509	        4503        if (PL_do_undump) {
  1510			
  1511				/* Come here if running an undumped a.out. */
  1512			
  1513	      ######    	PL_origfilename = savepv(argv[0]);
  1514	      ######    	PL_do_undump = FALSE;
  1515	      ######    	cxstack_ix = -1;		/* start label stack again */
  1516	      ######    	init_ids();
  1517	      ######    	assert (!PL_tainted);
  1518	      ######    	TAINT;
  1519	      ######    	S_set_caret_X(aTHX);
  1520	      ######    	TAINT_NOT;
  1521	      ######    	init_postdump_symbols(argc,argv,env);
  1522	      ######    	return 0;
  1523			    }
  1524			
  1525	        4503        if (PL_main_root) {
  1526	      ######    	op_free(PL_main_root);
  1527	      ######    	PL_main_root = Nullop;
  1528			    }
  1529	        4503        PL_main_start = Nullop;
  1530	        4503        SvREFCNT_dec(PL_main_cv);
  1531	        4503        PL_main_cv = Nullcv;
  1532			
  1533	        4503        time(&PL_basetime);
  1534	        4503        oldscope = PL_scopestack_ix;
  1535	        4503        PL_dowarn = G_WARN_OFF;
  1536			
  1537	        4503        JMPENV_PUSH(ret);
  1538	        4636        switch (ret) {
  1539			    case 0:
  1540	        4503    	parse_body(env,xsinit);
  1541	        4373    	if (PL_checkav)
  1542	          83    	    call_list(oldscope, PL_checkav);
  1543	        4372    	ret = 0;
  1544	        4372    	break;
  1545			    case 1:
  1546	      ######    	STATUS_ALL_FAILURE;
  1547				/* FALL THROUGH */
  1548			    case 2:
  1549				/* my_exit() was called */
  1550	         229    	while (PL_scopestack_ix > oldscope)
  1551	          96    	    LEAVE;
  1552	         133    	FREETMPS;
  1553	         133    	PL_curstash = PL_defstash;
  1554	         133    	if (PL_checkav)
  1555	           3    	    call_list(oldscope, PL_checkav);
  1556	         133    	ret = STATUS_NATIVE_EXPORT;
  1557	         133    	break;
  1558			    case 3:
  1559	      ######    	PerlIO_printf(Perl_error_log, "panic: top_env\n");
  1560	      ######    	ret = 1;
  1561				break;
  1562			    }
  1563	        4505        JMPENV_POP;
  1564	        4505        return ret;
  1565			}
  1566			
  1567			STATIC void *
  1568			S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
  1569	        4503    {
  1570			    dVAR;
  1571	        4503        int argc = PL_origargc;
  1572	        4503        char **argv = PL_origargv;
  1573	        4503        const char *scriptname = NULL;
  1574	        4503        VOL bool dosearch = FALSE;
  1575	        4503        const char *validarg = "";
  1576	        4503        register SV *sv;
  1577	        4503        register char *s;
  1578	        4503        const char *cddir = Nullch;
  1579			#ifdef USE_SITECUSTOMIZE
  1580			    bool minus_f = FALSE;
  1581			#endif
  1582			
  1583	        4503        PL_fdscript = -1;
  1584	        4503        PL_suidscript = -1;
  1585	        4503        sv_setpvn(PL_linestr,"",0);
  1586	        4503        sv = newSVpvn("",0);		/* first used for -I flags */
  1587	        4503        SAVEFREESV(sv);
  1588	        4503        init_main_stash();
  1589			
  1590	       10316        for (argc--,argv++; argc > 0; argc--,argv++) {
  1591	        8781    	if (argv[0][0] != '-' || !argv[0][1])
  1592	          18    	    break;
  1593			#ifdef DOSUID
  1594			    if (*validarg)
  1595				validarg = " PHOOEY ";
  1596			    else
  1597				validarg = argv[0];
  1598			    /*
  1599			     * Can we rely on the kernel to start scripts with argv[1] set to
  1600			     * contain all #! line switches (the whole line)? (argv[0] is set to
  1601			     * the interpreter name, argv[2] to the script name; argv[3] and
  1602			     * above may contain other arguments.)
  1603			     */
  1604			#endif
  1605	        5834    	s = argv[0]+1;
  1606			      reswitch:
  1607	        8048    	switch (*s) {
  1608				case 'C':
  1609			#ifndef PERL_STRICT_CR
  1610				case '\r':
  1611			#endif
  1612				case ' ':
  1613				case '0':
  1614				case 'F':
  1615				case 'a':
  1616				case 'c':
  1617				case 'd':
  1618				case 'D':
  1619				case 'h':
  1620				case 'i':
  1621				case 'l':
  1622				case 'M':
  1623				case 'm':
  1624				case 'n':
  1625				case 'p':
  1626				case 's':
  1627				case 'u':
  1628				case 'U':
  1629				case 'v':
  1630				case 'W':
  1631				case 'X':
  1632				case 'w':
  1633				case 'A':
  1634	        2157    	    if ((s = moreswitches(s)))
  1635	        2155    		goto reswitch;
  1636	           2    	    break;
  1637			
  1638				case 't':
  1639	           2    	    CHECK_MALLOC_TOO_LATE_FOR('t');
  1640	           2    	    if( !PL_tainting ) {
  1641	           2    	         PL_taint_warn = TRUE;
  1642	           2    	         PL_tainting = TRUE;
  1643				    }
  1644	           2    	    s++;
  1645	           2    	    goto reswitch;
  1646				case 'T':
  1647	          41    	    CHECK_MALLOC_TOO_LATE_FOR('T');
  1648	          41    	    PL_tainting = TRUE;
  1649	          41    	    PL_taint_warn = FALSE;
  1650	          41    	    s++;
  1651	          41    	    goto reswitch;
  1652			
  1653				case 'e':
  1654			#ifdef MACOS_TRADITIONAL
  1655				    /* ignore -e for Dev:Pseudo argument */
  1656				    if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
  1657					break;
  1658			#endif
  1659	        2041    	    forbid_setid("-e");
  1660	        2041    	    if (!PL_e_script) {
  1661	        2034    		PL_e_script = newSVpvn("",0);
  1662	        2034    		filter_add(read_e_script, NULL);
  1663				    }
  1664	        2041    	    if (*++s)
  1665	           7    		sv_catpv(PL_e_script, s);
  1666	        2034    	    else if (argv[1]) {
  1667	        2034    		sv_catpv(PL_e_script, argv[1]);
  1668	        2034    		argc--,argv++;
  1669				    }
  1670				    else
  1671	      ######    		Perl_croak(aTHX_ "No code specified for -e");
  1672	        2041    	    sv_catpv(PL_e_script, "\n");
  1673	        2041    	    break;
  1674			
  1675				case 'f':
  1676			#ifdef USE_SITECUSTOMIZE
  1677				    minus_f = TRUE;
  1678			#endif
  1679	           8    	    s++;
  1680	           8    	    goto reswitch;
  1681			
  1682				case 'I':	/* -I handled both here and in moreswitches() */
  1683	        2804    	    forbid_setid("-I");
  1684	        2804    	    if (!*++s && (s=argv[1]) != Nullch) {
  1685	      ######    		argc--,argv++;
  1686				    }
  1687	        2804    	    if (s && *s) {
  1688	        2804    		char *p;
  1689	        2804    		STRLEN len = strlen(s);
  1690	        2804    		p = savepvn(s, len);
  1691	        2804    		incpush(p, TRUE, TRUE, FALSE, FALSE);
  1692	        2804    		sv_catpvn(sv, "-I", 2);
  1693	        2804    		sv_catpvn(sv, p, len);
  1694	        2804    		sv_catpvn(sv, " ", 1);
  1695	        2804    		Safefree(p);
  1696				    }
  1697				    else
  1698	      ######    		Perl_croak(aTHX_ "No directory specified for -I");
  1699	           3    	    break;
  1700				case 'P':
  1701	           3    	    forbid_setid("-P");
  1702	           3    	    PL_preprocess = TRUE;
  1703	           3    	    s++;
  1704	           3    	    goto reswitch;
  1705				case 'S':
  1706	      ######    	    forbid_setid("-S");
  1707	      ######    	    dosearch = TRUE;
  1708	      ######    	    s++;
  1709	      ######    	    goto reswitch;
  1710				case 'V':
  1711				    {
  1712	           5    		SV *opts_prog;
  1713			
  1714	           5    		if (!PL_preambleav)
  1715	           5    		    PL_preambleav = newAV();
  1716	           5    		av_push(PL_preambleav,
  1717						newSVpv("use Config;",0));
  1718	           5    		if (*++s != ':')  {
  1719	           2    		    STRLEN opts;
  1720					
  1721	           2    		    opts_prog = newSVpv("print Config::myconfig(),",0);
  1722			#ifdef VMS
  1723					    sv_catpv(opts_prog,"\"\\nCharacteristics of this PERLSHR image: \\n\",");
  1724			#else
  1725	           2    		    sv_catpv(opts_prog,"\"\\nCharacteristics of this binary (from libperl): \\n\",");
  1726			#endif
  1727	           2    		    opts = SvCUR(opts_prog);
  1728			
  1729	           2    		    sv_catpv(opts_prog,"\"  Compile-time options:");
  1730			#  ifdef DEBUGGING
  1731	           2    		    sv_catpv(opts_prog," DEBUGGING");
  1732			#  endif
  1733			#  ifdef MULTIPLICITY
  1734					    sv_catpv(opts_prog," MULTIPLICITY");
  1735			#  endif
  1736			#  ifdef USE_5005THREADS
  1737					    sv_catpv(opts_prog," USE_5005THREADS");
  1738			#  endif
  1739			#  ifdef USE_ITHREADS
  1740					    sv_catpv(opts_prog," USE_ITHREADS");
  1741			#  endif
  1742			#  ifdef USE_64_BIT_INT
  1743					    sv_catpv(opts_prog," USE_64_BIT_INT");
  1744			#  endif
  1745			#  ifdef USE_64_BIT_ALL
  1746					    sv_catpv(opts_prog," USE_64_BIT_ALL");
  1747			#  endif
  1748			#  ifdef USE_LONG_DOUBLE
  1749					    sv_catpv(opts_prog," USE_LONG_DOUBLE");
  1750			#  endif
  1751			#  ifdef USE_LARGE_FILES
  1752	           2    		    sv_catpv(opts_prog," USE_LARGE_FILES");
  1753			#  endif
  1754			#  ifdef USE_SOCKS
  1755					    sv_catpv(opts_prog," USE_SOCKS");
  1756			#  endif
  1757			#  ifdef USE_SITECUSTOMIZE
  1758					    sv_catpv(opts_prog," USE_SITECUSTOMIZE");
  1759			#  endif	       
  1760			#  ifdef PERL_IMPLICIT_CONTEXT
  1761					    sv_catpv(opts_prog," PERL_IMPLICIT_CONTEXT");
  1762			#  endif
  1763			#  ifdef PERL_IMPLICIT_SYS
  1764					    sv_catpv(opts_prog," PERL_IMPLICIT_SYS");
  1765			#  endif
  1766			
  1767	           2    		    while (SvCUR(opts_prog) > opts+76) {
  1768						/* find last space after "options: " and before col 76
  1769						 */
  1770			
  1771	      ######    			const char *space;
  1772	      ######    			char *pv = SvPV_nolen(opts_prog);
  1773	      ######    			const char c = pv[opts+76];
  1774	      ######    			pv[opts+76] = '\0';
  1775	      ######    			space = strrchr(pv+opts+26, ' ');
  1776	      ######    			pv[opts+76] = c;
  1777	      ######    			if (!space) break; /* "Can't happen" */
  1778			
  1779						/* break the line before that space */
  1780			
  1781	      ######    			opts = space - pv;
  1782	      ######    			sv_insert(opts_prog, opts, 0,
  1783							  "\\n                       ", 25);
  1784					    }
  1785			
  1786	           2    		    sv_catpv(opts_prog,"\\n\",");
  1787			
  1788			#if defined(LOCAL_PATCH_COUNT)
  1789	           2    		    if (LOCAL_PATCH_COUNT > 0) {
  1790	           2    			int i;
  1791	           2    			sv_catpv(opts_prog,
  1792							 "\"  Locally applied patches:\\n\",");
  1793	           4    			for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
  1794	           2    			    if (PL_localpatches[i])
  1795	           2    				Perl_sv_catpvf(aTHX_ opts_prog,"q%c\t%s\n%c,",
  1796								       0, PL_localpatches[i], 0);
  1797						}
  1798					    }
  1799			#endif
  1800	           2    		    Perl_sv_catpvf(aTHX_ opts_prog,
  1801							   "\"  Built under %s\\n\"",OSNAME);
  1802			#ifdef __DATE__
  1803			#  ifdef __TIME__
  1804	           2    		    Perl_sv_catpvf(aTHX_ opts_prog,
  1805							   ",\"  Compiled at %s %s\\n\"",__DATE__,
  1806							   __TIME__);
  1807			#  else
  1808					    Perl_sv_catpvf(aTHX_ opts_prog,",\"  Compiled on %s\\n\"",
  1809							   __DATE__);
  1810			#  endif
  1811			#endif
  1812	           2    		    sv_catpv(opts_prog, "; $\"=\"\\n    \"; "
  1813						     "@env = map { \"$_=\\\"$ENV{$_}\\\"\" } "
  1814						     "sort grep {/^PERL/} keys %ENV; ");
  1815			#ifdef __CYGWIN__
  1816					    sv_catpv(opts_prog,
  1817						     "push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
  1818			#endif
  1819	           2    		    sv_catpv(opts_prog, 
  1820						     "print \"  \\%ENV:\\n    @env\\n\" if @env;"
  1821						     "print \"  \\@INC:\\n    @INC\\n\";");
  1822					}
  1823					else {
  1824	           3    		    ++s;
  1825	           3    		    opts_prog = Perl_newSVpvf(aTHX_
  1826								      "Config::config_vars(qw%c%s%c)",
  1827								      0, s, 0);
  1828	           3    		    s += strlen(s);
  1829					}
  1830	           5    		av_push(PL_preambleav, opts_prog);
  1831					/* don't look for script or read stdin */
  1832	           5    		scriptname = BIT_BUCKET;
  1833	           5    		goto reswitch;
  1834				    }
  1835				case 'x':
  1836	           8    	    PL_doextract = TRUE;
  1837	           8    	    s++;
  1838	           8    	    if (*s)
  1839	      ######    		cddir = s;
  1840	      ######    	    break;
  1841				case 0:
  1842	          18    	    break;
  1843				case '-':
  1844	          18    	    if (!*++s || isSPACE(*s)) {
  1845	          18    		argc--,argv++;
  1846	          18    		goto switch_end;
  1847				    }
  1848				    /* catch use of gnu style long options */
  1849	      ######    	    if (strEQ(s, "version")) {
  1850	      ######    		s = (char *)"v";
  1851	      ######    		goto reswitch;
  1852				    }
  1853	      ######    	    if (strEQ(s, "help")) {
  1854	      ######    		s = (char *)"h";
  1855	      ######    		goto reswitch;
  1856				    }
  1857	      ######    	    s--;
  1858				    /* FALL THROUGH */
  1859				default:
  1860	           1    	    Perl_croak(aTHX_ "Unrecognized switch: -%s  (-h will show valid options)",s);
  1861				}
  1862			    }
  1863			  switch_end:
  1864			
  1865	        4500        if (
  1866			#ifndef SECURE_INTERNAL_GETENV
  1867			        !PL_tainting &&
  1868			#endif
  1869				(s = PerlEnv_getenv("PERL5OPT")))
  1870			    {
  1871	          11        	const char *popt = s;
  1872	          11    	while (isSPACE(*s))
  1873	      ######    	    s++;
  1874	          11    	if (*s == '-' && *(s+1) == 'T') {
  1875	      ######    	    CHECK_MALLOC_TOO_LATE_FOR('T');
  1876	      ######    	    PL_tainting = TRUE;
  1877	      ######                PL_taint_warn = FALSE;
  1878				}
  1879				else {
  1880	          11    	    char *popt_copy = Nullch;
  1881	          28    	    while (s && *s) {
  1882	          17    	        char *d;
  1883	          17    		while (isSPACE(*s))
  1884	      ######    		    s++;
  1885	          17    		if (*s == '-') {
  1886	          17    		    s++;
  1887	          17    		    if (isSPACE(*s))
  1888	          17    			continue;
  1889					}
  1890	          17    		d = s;
  1891	          17    		if (!*s)
  1892	      ######    		    break;
  1893	          17    		if (!strchr("DIMUdmtwA", *s))
  1894	      ######    		    Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
  1895	          85    		while (++s && *s) {
  1896	          74    		    if (isSPACE(*s)) {
  1897	           6    			if (!popt_copy) {
  1898	           6    			    popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
  1899	           6    			    s = popt_copy + (s - popt);
  1900	           6    			    d = popt_copy + (d - popt);
  1901						}
  1902	           6    		        *s++ = '\0';
  1903						break;
  1904					    }
  1905					}
  1906	          17    		if (*d == 't') {
  1907	           1    		    if( !PL_tainting ) {
  1908	           1    		        PL_taint_warn = TRUE;
  1909	           1    		        PL_tainting = TRUE;
  1910					    }
  1911					} else {
  1912	          16    		    moreswitches(d);
  1913					}
  1914				    }
  1915				}
  1916			    }
  1917			
  1918			#ifdef USE_SITECUSTOMIZE
  1919			    if (!minus_f) {
  1920				if (!PL_preambleav)
  1921				    PL_preambleav = newAV();
  1922				av_unshift(PL_preambleav, 1);
  1923				(void)av_store(PL_preambleav, 0, Perl_newSVpvf(aTHX_ "BEGIN { do '%s/sitecustomize.pl' }", SITELIB_EXP));
  1924			    }
  1925			#endif
  1926			
  1927	        4500        if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
  1928	           3           PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
  1929			    }
  1930			
  1931	        4500        if (!scriptname)
  1932	        4495    	scriptname = argv[0];
  1933	        4500        if (PL_e_script) {
  1934	        2034    	argc++,argv--;
  1935	        2034    	scriptname = BIT_BUCKET;	/* don't look for script or read stdin */
  1936			    }
  1937	        2466        else if (scriptname == Nullch) {
  1938			#ifdef MSDOS
  1939				if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
  1940				    moreswitches("h");
  1941			#endif
  1942	           1    	scriptname = "-";
  1943			    }
  1944			
  1945			    /* Set $^X early so that it can be used for relocatable paths in @INC  */
  1946	        4500        assert (!PL_tainted);
  1947	        4500        TAINT;
  1948	        4500        S_set_caret_X(aTHX);
  1949	        4500        TAINT_NOT;
  1950	        4500        init_perllib();
  1951			
  1952	        4500        open_script(scriptname,dosearch,sv);
  1953			
  1954	        4500        validate_suid(validarg, scriptname);
  1955			
  1956			#ifndef PERL_MICRO
  1957			#if defined(SIGCHLD) || defined(SIGCLD)
  1958			    {
  1959			#ifndef SIGCHLD
  1960			#  define SIGCHLD SIGCLD
  1961			#endif
  1962	        4500    	Sighandler_t sigstate = rsignal_state(SIGCHLD);
  1963	        4500    	if (sigstate == SIG_IGN) {
  1964	      ######    	    if (ckWARN(WARN_SIGNAL))
  1965	      ######    		Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
  1966						    "Can't ignore signal CHLD, forcing to default");
  1967	      ######    	    (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
  1968				}
  1969			    }
  1970			#endif
  1971			#endif
  1972			
  1973			#ifdef MACOS_TRADITIONAL
  1974			    if (PL_doextract || gMacPerl_AlwaysExtract) {
  1975			#else
  1976	        4500        if (PL_doextract) {
  1977			#endif
  1978	           7    	find_beginning();
  1979	           7    	if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
  1980	      ######    	    Perl_croak(aTHX_ "Can't chdir to %s",cddir);
  1981			
  1982			    }
  1983			
  1984	        4500        PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
  1985	        4500        sv_upgrade((SV *)PL_compcv, SVt_PVCV);
  1986	        4500        CvUNIQUE_on(PL_compcv);
  1987			
  1988	        4500        CvPADLIST(PL_compcv) = pad_new(0);
  1989			#ifdef USE_5005THREADS
  1990			    CvOWNER(PL_compcv) = 0;
  1991			    New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
  1992			    MUTEX_INIT(CvMUTEXP(PL_compcv));
  1993			#endif /* USE_5005THREADS */
  1994			
  1995	        4500        boot_core_PerlIO();
  1996	        4500        boot_core_UNIVERSAL();
  1997	        4500        boot_core_xsutils();
  1998			
  1999	        4500        if (xsinit)
  2000	        4499    	(*xsinit)(aTHX);	/* in case linked C routines want magical variables */
  2001			#ifndef PERL_MICRO
  2002			#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
  2003			    init_os_extras();
  2004			#endif
  2005			#endif
  2006			
  2007			#ifdef USE_SOCKS
  2008			#   ifdef HAS_SOCKS5_INIT
  2009			    socks5_init(argv[0]);
  2010			#   else
  2011			    SOCKSinit(argv[0]);
  2012			#   endif
  2013			#endif
  2014			
  2015	        4500        init_predump_symbols();
  2016			    /* init_postdump_symbols not currently designed to be called */
  2017			    /* more than once (ENV isn't cleared first, for example)	 */
  2018			    /* But running with -u leaves %ENV & @ARGV undefined!    XXX */
  2019	        4500        if (!PL_do_undump)
  2020	        4500    	init_postdump_symbols(argc,argv,env);
  2021			
  2022			    /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE},
  2023			     * or explicitly in some platforms.
  2024			     * locale.c:Perl_init_i18nl10n() if the environment
  2025			     * look like the user wants to use UTF-8. */
  2026			#if defined(SYMBIAN)
  2027			    PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */
  2028			#endif
  2029	        4500        if (PL_unicode) {
  2030				 /* Requires init_predump_symbols(). */
  2031	           6    	 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
  2032	           6    	      IO* io;
  2033	           6    	      PerlIO* fp;
  2034	           6    	      SV* sv;
  2035			
  2036				      /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
  2037				       * and the default open disciplines. */
  2038	           6    	      if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
  2039					  PL_stdingv  && (io = GvIO(PL_stdingv)) &&
  2040					  (fp = IoIFP(io)))
  2041	           1    		   PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
  2042	           6    	      if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
  2043					  PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
  2044					  (fp = IoOFP(io)))
  2045	           1    		   PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
  2046	           6    	      if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
  2047					  PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
  2048					  (fp = IoOFP(io)))
  2049	           1    		   PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
  2050	           6    	      if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
  2051					  (sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
  2052	           2    		   U32 in  = PL_unicode & PERL_UNICODE_IN_FLAG;
  2053	           2    		   U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
  2054	           2    		   if (in) {
  2055	           1    			if (out)
  2056	      ######    			     sv_setpvn(sv, ":utf8\0:utf8", 11);
  2057						else
  2058	           1    			     sv_setpvn(sv, ":utf8\0", 6);
  2059					   }
  2060	           1    		   else if (out)
  2061	           1    			sv_setpvn(sv, "\0:utf8", 6);
  2062	           2    		   SvSETMAGIC(sv);
  2063				      }
  2064				 }
  2065			    }
  2066			
  2067	        4500        if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
  2068	      ######    	 if (strEQ(s, "unsafe"))
  2069	      ######    	      PL_signals |=  PERL_SIGNALS_UNSAFE_FLAG;
  2070	      ######    	 else if (strEQ(s, "safe"))
  2071	      ######    	      PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
  2072				 else
  2073	      ######    	      Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
  2074			    }
  2075			
  2076	        4500        init_lexer();
  2077			
  2078			    /* now parse the script */
  2079			
  2080	        4500        SETERRNO(0,SS_NORMAL);
  2081	        4500        PL_error_count = 0;
  2082			#ifdef MACOS_TRADITIONAL
  2083			    if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
  2084				if (PL_minus_c)
  2085				    Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
  2086				else {
  2087				    Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
  2088					       MacPerl_MPWFileName(PL_origfilename));
  2089				}
  2090			    }
  2091			#else
  2092	        4500        if (yyparse() || PL_error_count) {
  2093	          40    	if (PL_minus_c)
  2094	           2    	    Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
  2095				else {
  2096	          38    	    Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
  2097					       PL_origfilename);
  2098				}
  2099			    }
  2100			#endif
  2101	        4373        CopLINE_set(PL_curcop, 0);
  2102	        4373        PL_curstash = PL_defstash;
  2103	        4373        PL_preprocess = FALSE;
  2104	        4373        if (PL_e_script) {
  2105	        2028    	SvREFCNT_dec(PL_e_script);
  2106	        2028    	PL_e_script = Nullsv;
  2107			    }
  2108			
  2109	        4373        if (PL_do_undump)
  2110	      ######    	my_unexec();
  2111			
  2112	        4373        if (isWARN_ONCE) {
  2113	        1447    	SAVECOPFILE(PL_curcop);
  2114	        1447    	SAVECOPLINE(PL_curcop);
  2115	        1447    	gv_check(PL_defstash);
  2116			    }
  2117			
  2118	        4373        LEAVE;
  2119	        4373        FREETMPS;
  2120			
  2121			#ifdef MYMALLOC
  2122			    if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
  2123				dump_mstats("after compilation:");
  2124			#endif
  2125			
  2126	        4373        ENTER;
  2127	        4373        PL_restartop = 0;
  2128	        4373        return NULL;
  2129			}
  2130			
  2131			/*
  2132			=for apidoc perl_run
  2133			
  2134			Tells a Perl interpreter to run.  See L<perlembed>.
  2135			
  2136			=cut
  2137			*/
  2138			
  2139			int
  2140			perl_run(pTHXx)
  2141	        4421    {
  2142	        4421        I32 oldscope;
  2143	        4421        int ret = 0;
  2144	        4421        dJMPENV;
  2145			
  2146	        4421        PERL_UNUSED_ARG(my_perl);
  2147			
  2148	        4421        oldscope = PL_scopestack_ix;
  2149			#ifdef VMS
  2150			    VMSISH_HUSHED = 0;
  2151			#endif
  2152			
  2153	        4421        JMPENV_PUSH(ret);
  2154	       12204        switch (ret) {
  2155			    case 1:
  2156	      ######    	cxstack_ix = -1;		/* start context stack again */
  2157				goto redo_body;
  2158			    case 0:				/* normal completion */
  2159			 redo_body:
  2160	        7739    	run_body(oldscope);
  2161				/* FALL THROUGH */
  2162			    case 2:				/* my_exit() */
  2163	        4465    	while (PL_scopestack_ix > oldscope)
  2164	      ######    	    LEAVE;
  2165	        4465    	FREETMPS;
  2166	        4465    	PL_curstash = PL_defstash;
  2167	        4465    	if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
  2168				    PL_endav && !PL_minus_c)
  2169	      ######    	    call_list(oldscope, PL_endav);
  2170			#ifdef MYMALLOC
  2171				if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
  2172				    dump_mstats("after execution:  ");
  2173			#endif
  2174	        4465    	ret = STATUS_NATIVE_EXPORT;
  2175	        4465    	break;
  2176			    case 3:
  2177	        3318    	if (PL_restartop) {
  2178	        3318    	    POPSTACK_TO(PL_mainstack);
  2179	      ######    	    goto redo_body;
  2180				}
  2181	      ######    	PerlIO_printf(Perl_error_log, "panic: restartop\n");
  2182	      ######    	FREETMPS;
  2183	      ######    	ret = 1;
  2184				break;
  2185			    }
  2186			
  2187	        4465        JMPENV_POP;
  2188	        4465        return ret;
  2189			}
  2190			
  2191			
  2192			STATIC void
  2193			S_run_body(pTHX_ I32 oldscope)
  2194	        7739    {
  2195			    DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
  2196	        7739                        PL_sawampersand ? "Enabling" : "Omitting"));
  2197			
  2198	        7739        if (!PL_restartop) {
  2199	        4421    	DEBUG_x(dump_all());
  2200	        4421    	if (!DEBUG_q_TEST)
  2201	        4421    	  PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
  2202				DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
  2203						      PTR2UV(thr)));
  2204			
  2205	        4421    	if (PL_minus_c) {
  2206			#ifdef MACOS_TRADITIONAL
  2207				    PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
  2208					(gMacPerl_ErrorFormat ? "# " : ""),
  2209					MacPerl_MPWFileName(PL_origfilename));
  2210			#else
  2211	          78    	    PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
  2212			#endif
  2213	          78    	    my_exit(0);
  2214				}
  2215	        4343    	if (PERLDB_SINGLE && PL_DBsingle)
  2216	           1    	    sv_setiv(PL_DBsingle, 1);
  2217	        4343    	if (PL_initav)
  2218	           4    	    call_list(oldscope, PL_initav);
  2219			    }
  2220			
  2221			    /* do it */
  2222			
  2223	        7660        if (PL_restartop) {
  2224	        3318    	PL_op = PL_restartop;
  2225	        3318    	PL_restartop = 0;
  2226	        3318    	CALLRUNOPS(aTHX);
  2227			    }
  2228	        4342        else if (PL_main_start) {
  2229	        4263    	CvDEPTH(PL_main_cv) = 1;
  2230	        4263    	PL_op = PL_main_start;
  2231	        4263    	CALLRUNOPS(aTHX);
  2232			    }
  2233	        4010        my_exit(0);
  2234			    /* NOTREACHED */
  2235			}
  2236			
  2237			/*
  2238			=head1 SV Manipulation Functions
  2239			
  2240			=for apidoc p||get_sv
  2241			
  2242			Returns the SV of the specified Perl scalar.  If C<create> is set and the
  2243			Perl variable does not exist then it will be created.  If C<create> is not
  2244			set and the variable does not exist then NULL is returned.
  2245			
  2246			=cut
  2247			*/
  2248			
  2249			SV*
  2250			Perl_get_sv(pTHX_ const char *name, I32 create)
  2251	     4211113    {
  2252	     4211113        GV *gv;
  2253			#ifdef USE_5005THREADS
  2254			    if (name[1] == '\0' && !isALPHA(name[0])) {
  2255				PADOFFSET tmp = find_threadsv(name);
  2256			    	if (tmp != NOT_IN_PAD)
  2257				    return THREADSV(tmp);
  2258			    }
  2259			#endif /* USE_5005THREADS */
  2260	     4211113        gv = gv_fetchpv(name, create, SVt_PV);
  2261	     4211113        if (gv)
  2262	      309720    	return GvSV(gv);
  2263	     3901393        return Nullsv;
  2264			}
  2265			
  2266			/*
  2267			=head1 Array Manipulation Functions
  2268			
  2269			=for apidoc p||get_av
  2270			
  2271			Returns the AV of the specified Perl array.  If C<create> is set and the
  2272			Perl variable does not exist then it will be created.  If C<create> is not
  2273			set and the variable does not exist then NULL is returned.
  2274			
  2275			=cut
  2276			*/
  2277			
  2278			AV*
  2279			Perl_get_av(pTHX_ const char *name, I32 create)
  2280	        9111    {
  2281	        9111        GV* gv = gv_fetchpv(name, create, SVt_PVAV);
  2282	        9111        if (create)
  2283	        9109        	return GvAVn(gv);
  2284	           2        if (gv)
  2285	           1    	return GvAV(gv);
  2286	           1        return Nullav;
  2287			}
  2288			
  2289			/*
  2290			=head1 Hash Manipulation Functions
  2291			
  2292			=for apidoc p||get_hv
  2293			
  2294			Returns the HV of the specified Perl hash.  If C<create> is set and the
  2295			Perl variable does not exist then it will be created.  If C<create> is not
  2296			set and the variable does not exist then NULL is returned.
  2297			
  2298			=cut
  2299			*/
  2300			
  2301			HV*
  2302			Perl_get_hv(pTHX_ const char *name, I32 create)
  2303	       65177    {
  2304	       65177        GV* gv = gv_fetchpv(name, create, SVt_PVHV);
  2305	       65177        if (create)
  2306	           1        	return GvHVn(gv);
  2307	       65176        if (gv)
  2308	       64242    	return GvHV(gv);
  2309	         934        return Nullhv;
  2310			}
  2311			
  2312			/*
  2313			=head1 CV Manipulation Functions
  2314			
  2315			=for apidoc p||get_cv
  2316			
  2317			Returns the CV of the specified Perl subroutine.  If C<create> is set and
  2318			the Perl subroutine does not exist then it will be declared (which has the
  2319			same effect as saying C<sub name;>).  If C<create> is not set and the
  2320			subroutine does not exist then NULL is returned.
  2321			
  2322			=cut
  2323			*/
  2324			
  2325			CV*
  2326			Perl_get_cv(pTHX_ const char *name, I32 create)
  2327	       10503    {
  2328	       10503        GV* gv = gv_fetchpv(name, create, SVt_PVCV);
  2329			    /* XXX unsafe for threads if eval_owner isn't held */
  2330			    /* XXX this is probably not what they think they're getting.
  2331			     * It has the same effect as "sub name;", i.e. just a forward
  2332			     * declaration! */
  2333	       10503        if (create && !GvCVu(gv))
  2334	           5        	return newSUB(start_subparse(FALSE, 0),
  2335					      newSVOP(OP_CONST, 0, newSVpv(name,0)),
  2336					      Nullop,
  2337					      Nullop);
  2338	       10498        if (gv)
  2339	        9727    	return GvCVu(gv);
  2340	         771        return Nullcv;
  2341			}
  2342			
  2343			/* Be sure to refetch the stack pointer after calling these routines. */
  2344			
  2345			/*
  2346			
  2347			=head1 Callback Functions
  2348			
  2349			=for apidoc p||call_argv
  2350			
  2351			Performs a callback to the specified Perl sub.  See L<perlcall>.
  2352			
  2353			=cut
  2354			*/
  2355			
  2356			I32
  2357			Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
  2358			
  2359			          		/* See G_* flags in cop.h */
  2360			                     	/* null terminated arg list */
  2361	           6    {
  2362	           6        dSP;
  2363			
  2364	           6        PUSHMARK(SP);
  2365	           6        if (argv) {
  2366	          15    	while (*argv) {
  2367	           9    	    XPUSHs(sv_2mortal(newSVpv(*argv,0)));
  2368	           9    	    argv++;
  2369				}
  2370	           6    	PUTBACK;
  2371			    }
  2372	           6        return call_pv(sub_name, flags);
  2373			}
  2374			
  2375			/*
  2376			=for apidoc p||call_pv
  2377			
  2378			Performs a callback to the specified Perl sub.  See L<perlcall>.
  2379			
  2380			=cut
  2381			*/
  2382			
  2383			I32
  2384			Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
  2385			              		/* name of the subroutine */
  2386			          		/* See G_* flags in cop.h */
  2387	        1016    {
  2388	        1016        return call_sv((SV*)get_cv(sub_name, TRUE), flags);
  2389			}
  2390			
  2391			/*
  2392			=for apidoc p||call_method
  2393			
  2394			Performs a callback to the specified Perl method.  The blessed object must
  2395			be on the stack.  See L<perlcall>.
  2396			
  2397			=cut
  2398			*/
  2399			
  2400			I32
  2401			Perl_call_method(pTHX_ const char *methname, I32 flags)
  2402			               		/* name of the subroutine */
  2403			          		/* See G_* flags in cop.h */
  2404	      317675    {
  2405	      317675        return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
  2406			}
  2407			
  2408			/* May be called with any of a CV, a GV, or an SV containing the name. */
  2409			/*
  2410			=for apidoc p||call_sv
  2411			
  2412			Performs a callback to the Perl sub whose name is in the SV.  See
  2413			L<perlcall>.
  2414			
  2415			=cut
  2416			*/
  2417			
  2418			I32
  2419			Perl_call_sv(pTHX_ SV *sv, I32 flags)
  2420			          		/* See G_* flags in cop.h */
  2421	      722834    {
  2422	      722834        dVAR; dSP;
  2423	      722834        LOGOP myop;		/* fake syntax tree node */
  2424	      722834        UNOP method_op;
  2425	      722834        I32 oldmark;
  2426	      722834        volatile I32 retval = 0;
  2427	      722834        I32 oldscope;
  2428	      722834        bool oldcatch = CATCH_GET;
  2429	      722834        int ret;
  2430	      722834        OP* oldop = PL_op;
  2431	      722834        dJMPENV;
  2432			
  2433	      722834        if (flags & G_DISCARD) {
  2434	      161720    	ENTER;
  2435	      161720    	SAVETMPS;
  2436			    }
  2437			
  2438	      722834        Zero(&myop, 1, LOGOP);
  2439	      722834        myop.op_next = Nullop;
  2440	      722834        if (!(flags & G_NOARGS))
  2441	      722818    	myop.op_flags |= OPf_STACKED;
  2442	      722834        myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
  2443					      (flags & G_ARRAY) ? OPf_WANT_LIST :
  2444					      OPf_WANT_SCALAR);
  2445	      722834        SAVEOP();
  2446	      722834        PL_op = (OP*)&myop;
  2447			
  2448	      722834        EXTEND(PL_stack_sp, 1);
  2449	      722834        *++PL_stack_sp = sv;
  2450	      722834        oldmark = TOPMARK;
  2451	      722834        oldscope = PL_scopestack_ix;
  2452			
  2453	      722834        if (PERLDB_SUB && PL_curstash != PL_debstash
  2454				   /* Handle first BEGIN of -d. */
  2455				  && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
  2456				   /* Try harder, since this may have been a sighandler, thus
  2457				    * curstash may be meaningless. */
  2458				  && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
  2459				  && !(flags & G_NODEBUG))
  2460	       80010    	PL_op->op_private |= OPpENTERSUB_DB;
  2461			
  2462	      722834        if (flags & G_METHOD) {
  2463	      317675    	Zero(&method_op, 1, UNOP);
  2464	      317675    	method_op.op_next = PL_op;
  2465	      317675    	method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
  2466	      317675    	myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
  2467	      317675    	PL_op = (OP*)&method_op;
  2468			    }
  2469			
  2470	      722834        if (!(flags & G_EVAL)) {
  2471	      568604    	CATCH_SET(TRUE);
  2472	      568604    	call_body((OP*)&myop, FALSE);
  2473	      568308    	retval = PL_stack_sp - (PL_stack_base + oldmark);
  2474	      568308    	CATCH_SET(oldcatch);
  2475			    }
  2476			    else {
  2477	      154230    	myop.op_other = (OP*)&myop;
  2478	      154230    	PL_markstack_ptr--;
  2479				/* we're trying to emulate pp_entertry() here */
  2480				{
  2481	      154230    	    register PERL_CONTEXT *cx;
  2482	      154230    	    const I32 gimme = GIMME_V;
  2483				
  2484	      154230    	    ENTER;
  2485	      154230    	    SAVETMPS;
  2486				
  2487	      154230    	    PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
  2488	      154230    	    PUSHEVAL(cx, 0, 0);
  2489	      154230    	    PL_eval_root = PL_op;             /* Only needed so that goto works right. */
  2490				
  2491	      154230    	    PL_in_eval = EVAL_INEVAL;
  2492	      154230    	    if (flags & G_KEEPERR)
  2493	       74668    		PL_in_eval |= EVAL_KEEPERR;
  2494				    else
  2495	       79562    		sv_setpvn(ERRSV,"",0);
  2496				}
  2497	      154230    	PL_markstack_ptr++;
  2498			
  2499	      154230    	JMPENV_PUSH(ret);
  2500	      155208    	switch (ret) {
  2501				case 0:
  2502			 redo_body:
  2503	      154919    	    call_body((OP*)&myop, FALSE);
  2504	      153943    	    retval = PL_stack_sp - (PL_stack_base + oldmark);
  2505	      153943    	    if (!(flags & G_KEEPERR))
  2506	       79340    		sv_setpvn(ERRSV,"",0);
  2507	       79340    	    break;
  2508				case 1:
  2509	      ######    	    STATUS_ALL_FAILURE;
  2510				    /* FALL THROUGH */
  2511				case 2:
  2512				    /* my_exit() was called */
  2513	          58    	    PL_curstash = PL_defstash;
  2514	          58    	    FREETMPS;
  2515	          58    	    JMPENV_POP;
  2516	          58    	    if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
  2517	      ######    		Perl_croak(aTHX_ "Callback called exit");
  2518	          58    	    my_exit_jump();
  2519				    /* NOTREACHED */
  2520				case 3:
  2521	         920    	    if (PL_restartop) {
  2522	         689    		PL_op = PL_restartop;
  2523	         689    		PL_restartop = 0;
  2524	         689    		goto redo_body;
  2525				    }
  2526	         231    	    PL_stack_sp = PL_stack_base + oldmark;
  2527	         231    	    if (flags & G_ARRAY)
  2528	          12    		retval = 0;
  2529				    else {
  2530	         219    		retval = 1;
  2531	         219    		*++PL_stack_sp = &PL_sv_undef;
  2532				    }
  2533				    break;
  2534				}
  2535			
  2536	      154174    	if (PL_scopestack_ix > oldscope) {
  2537	      153943    	    SV **newsp;
  2538	      153943    	    PMOP *newpm;
  2539	      153943    	    I32 gimme;
  2540	      153943    	    register PERL_CONTEXT *cx;
  2541	      153943    	    I32 optype;
  2542			
  2543	      153943    	    POPBLOCK(cx,newpm);
  2544	      153943    	    POPEVAL(cx);
  2545	      153943    	    PL_curpm = newpm;
  2546	      153943    	    LEAVE;
  2547	      154174    	    PERL_UNUSED_VAR(newsp);
  2548	      154174    	    PERL_UNUSED_VAR(gimme);
  2549	      154174    	    PERL_UNUSED_VAR(optype);
  2550				}
  2551	      154174    	JMPENV_POP;
  2552			    }
  2553			
  2554	      722482        if (flags & G_DISCARD) {
  2555	      161607    	PL_stack_sp = PL_stack_base + oldmark;
  2556	      161607    	retval = 0;
  2557	      161607    	FREETMPS;
  2558	      161607    	LEAVE;
  2559			    }
  2560	      722482        PL_op = oldop;
  2561	      722482        return retval;
  2562			}
  2563			
  2564			STATIC void
  2565			S_call_body(pTHX_ const OP *myop, bool is_eval)
  2566	      723625    {
  2567	      723625        if (PL_op == myop) {
  2568	      405261    	if (is_eval)
  2569	         102    	    PL_op = Perl_pp_entereval(aTHX);	/* this doesn't do a POPMARK */
  2570				else
  2571	      405159    	    PL_op = Perl_pp_entersub(aTHX);	/* this does */
  2572			    }
  2573	      723625        if (PL_op)
  2574	      611462    	CALLRUNOPS(aTHX);
  2575			}
  2576			
  2577			/* Eval a string. The G_EVAL flag is always assumed. */
  2578			
  2579			/*
  2580			=for apidoc p||eval_sv
  2581			
  2582			Tells Perl to C<eval> the string in the SV.
  2583			
  2584			=cut
  2585			*/
  2586			
  2587			I32
  2588			Perl_eval_sv(pTHX_ SV *sv, I32 flags)
  2589			
  2590			          		/* See G_* flags in cop.h */
  2591	         103    {
  2592	         103        dSP;
  2593	         103        UNOP myop;		/* fake syntax tree node */
  2594	         103        volatile I32 oldmark = SP - PL_stack_base;
  2595	         103        volatile I32 retval = 0;
  2596	         103        int ret;
  2597	         103        OP* oldop = PL_op;
  2598	         103        dJMPENV;
  2599			
  2600	         103        if (flags & G_DISCARD) {
  2601	          14    	ENTER;
  2602	          14    	SAVETMPS;
  2603			    }
  2604			
  2605	         103        SAVEOP();
  2606	         103        PL_op = (OP*)&myop;
  2607	         103        Zero(PL_op, 1, UNOP);
  2608	         103        EXTEND(PL_stack_sp, 1);
  2609	         103        *++PL_stack_sp = sv;
  2610			
  2611	         103        if (!(flags & G_NOARGS))
  2612	          95    	myop.op_flags = OPf_STACKED;
  2613	         103        myop.op_next = Nullop;
  2614	         103        myop.op_type = OP_ENTEREVAL;
  2615	         103        myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
  2616					      (flags & G_ARRAY) ? OPf_WANT_LIST :
  2617					      OPf_WANT_SCALAR);
  2618	         103        if (flags & G_KEEPERR)
  2619	           8    	myop.op_flags |= OPf_SPECIAL;
  2620			
  2621			    /* fail now; otherwise we could fail after the JMPENV_PUSH but
  2622			     * before a PUSHEVAL, which corrupts the stack after a croak */
  2623	         103        TAINT_PROPER("eval_sv()");
  2624			
  2625	         102        JMPENV_PUSH(ret);
  2626	         128        switch (ret) {
  2627			    case 0:
  2628			 redo_body:
  2629	         102    	call_body((OP*)&myop,TRUE);
  2630	          76    	retval = PL_stack_sp - (PL_stack_base + oldmark);
  2631	          76    	if (!(flags & G_KEEPERR))
  2632	          76    	    sv_setpvn(ERRSV,"",0);
  2633	          76    	break;
  2634			    case 1:
  2635	      ######    	STATUS_ALL_FAILURE;
  2636				/* FALL THROUGH */
  2637			    case 2:
  2638				/* my_exit() was called */
  2639	      ######    	PL_curstash = PL_defstash;
  2640	      ######    	FREETMPS;
  2641	      ######    	JMPENV_POP;
  2642	      ######    	if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
  2643	      ######    	    Perl_croak(aTHX_ "Callback called exit");
  2644	      ######    	my_exit_jump();
  2645				/* NOTREACHED */
  2646			    case 3:
  2647	          26    	if (PL_restartop) {
  2648	      ######    	    PL_op = PL_restartop;
  2649	      ######    	    PL_restartop = 0;
  2650	      ######    	    goto redo_body;
  2651				}
  2652	          26    	PL_stack_sp = PL_stack_base + oldmark;
  2653	          26    	if (flags & G_ARRAY)
  2654	           6    	    retval = 0;
  2655				else {
  2656	          20    	    retval = 1;
  2657	          20    	    *++PL_stack_sp = &PL_sv_undef;
  2658				}
  2659				break;
  2660			    }
  2661			
  2662	         102        JMPENV_POP;
  2663	         102        if (flags & G_DISCARD) {
  2664	          14    	PL_stack_sp = PL_stack_base + oldmark;
  2665	          14    	retval = 0;
  2666	          14    	FREETMPS;
  2667	          14    	LEAVE;
  2668			    }
  2669	         102        PL_op = oldop;
  2670	         102        return retval;
  2671			}
  2672			
  2673			/*
  2674			=for apidoc p||eval_pv
  2675			
  2676			Tells Perl to C<eval> the given string and return an SV* result.
  2677			
  2678			=cut
  2679			*/
  2680			
  2681			SV*
  2682			Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
  2683	          54    {
  2684	          54        dSP;
  2685	          54        SV* sv = newSVpv(p, 0);
  2686			
  2687	          54        eval_sv(sv, G_SCALAR);
  2688	          54        SvREFCNT_dec(sv);
  2689			
  2690	          54        SPAGAIN;
  2691	          54        sv = POPs;
  2692	          54        PUTBACK;
  2693			
  2694	          54        if (croak_on_error && SvTRUE(ERRSV)) {
  2695	           1    	Perl_croak(aTHX_ SvPVx_nolen_const(ERRSV));
  2696			    }
  2697			
  2698	          53        return sv;
  2699			}
  2700			
  2701			/* Require a module. */
  2702			
  2703			/*
  2704			=head1 Embedding Functions
  2705			
  2706			=for apidoc p||require_pv
  2707			
  2708			Tells Perl to C<require> the file named by the string argument.  It is
  2709			analogous to the Perl code C<eval "require '$file'">.  It's even
  2710			implemented that way; consider using load_module instead.
  2711			
  2712			=cut */
  2713			
  2714			void
  2715			Perl_require_pv(pTHX_ const char *pv)
  2716	      ######    {
  2717	      ######        SV* sv;
  2718	      ######        dSP;
  2719	      ######        PUSHSTACKi(PERLSI_REQUIRE);
  2720	      ######        PUTBACK;
  2721	      ######        sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0);
  2722	      ######        eval_sv(sv_2mortal(sv), G_DISCARD);
  2723	      ######        SPAGAIN;
  2724	      ######        POPSTACK;
  2725			}
  2726			
  2727			void
  2728			Perl_magicname(pTHX_ const char *sym, const char *name, I32 namlen)
  2729	        4500    {
  2730	        4500        register GV *gv;
  2731			
  2732	        4500        if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
  2733	        4500    	sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
  2734			}
  2735			
  2736			STATIC void
  2737			S_usage(pTHX_ const char *name)		/* XXX move this out into a module ? */
  2738	           1    {
  2739			    /* This message really ought to be max 23 lines.
  2740			     * Removed -h because the user already knows that option. Others? */
  2741			
  2742			    static const char * const usage_msg[] = {
  2743			"-0[octal]         specify record separator (\\0, if no argument)",
  2744			"-A[mod][=pattern] activate all/given assertions",
  2745			"-a                autosplit mode with -n or -p (splits $_ into @F)",
  2746			"-C[number/list]   enables the listed Unicode features",
  2747			"-c                check syntax only (runs BEGIN and CHECK blocks)",
  2748			"-d[:debugger]     run program under debugger",
  2749			"-D[number/list]   set debugging flags (argument is a bit mask or alphabets)",
  2750			"-e program        one line of program (several -e's allowed, omit programfile)",
  2751			"-f                don't do $sitelib/sitecustomize.pl at startup",
  2752			"-F/pattern/       split() pattern for -a switch (//'s are optional)",
  2753			"-i[extension]     edit <> files in place (makes backup if extension supplied)",
  2754			"-Idirectory       specify @INC/#include directory (several -I's allowed)",
  2755			"-l[octal]         enable line ending processing, specifies line terminator",
  2756			"-[mM][-]module    execute \"use/no module...\" before executing program",
  2757			"-n                assume \"while (<>) { ... }\" loop around program",
  2758			"-p                assume loop like -n but print line also, like sed",
  2759			"-P                run program through C preprocessor before compilation",
  2760			"-s                enable rudimentary parsing for switches after programfile",
  2761			"-S                look for programfile using PATH environment variable",
  2762			"-t                enable tainting warnings",
  2763			"-T                enable tainting checks",
  2764			"-u                dump core after parsing program",
  2765			"-U                allow unsafe operations",
  2766			"-v                print version, subversion (includes VERY IMPORTANT perl info)",
  2767			"-V[:variable]     print configuration summary (or a single Config.pm variable)",
  2768			"-w                enable many useful warnings (RECOMMENDED)",
  2769			"-W                enable all warnings",
  2770			"-x[directory]     strip off text before #!perl line and perhaps cd to directory",
  2771			"-X                disable all warnings",
  2772			"\n",
  2773			NULL
  2774	           1    };
  2775	           1        const char * const *p = usage_msg;
  2776			
  2777	           1        PerlIO_printf(PerlIO_stdout(),
  2778					  "\nUsage: %s [switches] [--] [programfile] [arguments]",
  2779					  name);
  2780	          31        while (*p)
  2781	          30    	PerlIO_printf(PerlIO_stdout(), "\n  %s", *p++);
  2782			}
  2783			
  2784			/* convert a string of -D options (or digits) into an int.
  2785			 * sets *s to point to the char after the options */
  2786			
  2787			#ifdef DEBUGGING
  2788			int
  2789			Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
  2790	           1    {
  2791			    static const char * const usage_msgd[] = {
  2792			      " Debugging flag values: (see also -d)",
  2793			      "  p  Tokenizing and parsing (with v, displays parse stack)",
  2794			      "  s  Stack snapshots (with v, displays all stacks)",
  2795			      "  l  Context (loop) stack processing",
  2796			      "  t  Trace execution",
  2797			      "  o  Method and overloading resolution",
  2798			      "  c  String/numeric conversions",
  2799			      "  P  Print profiling info, preprocessor command for -P, source file input state",
  2800			      "  m  Memory allocation",
  2801			      "  f  Format processing",
  2802			      "  r  Regular expression parsing and execution",
  2803			      "  x  Syntax tree dump",
  2804			      "  u  Tainting checks",
  2805			      "  H  Hash dump -- usurps values()",
  2806			      "  X  Scratchpad allocation",
  2807			      "  D  Cleaning up",
  2808			      "  S  Thread synchronization",
  2809			      "  T  Tokenising",
  2810			      "  R  Include reference counts of dumped variables (eg when using -Ds)",
  2811			      "  J  Do not s,t,P-debug (Jump over) opcodes within package DB",
  2812			      "  v  Verbose: use in conjunction with other flags",
  2813			      "  C  Copy On Write",
  2814			      "  A  Consistency checks on internal structures",
  2815			      "  q  quiet - currently only suppresses the 'EXECUTING' message",
  2816			      NULL
  2817	           1        };
  2818	           1        int i = 0;
  2819	           1        if (isALPHA(**s)) {
  2820				/* if adding extra options, remember to update DEBUG_MASK */
  2821	           2    	static const char debopts[] = "psltocPmfrxu HXDSTRJvCAq";
  2822			
  2823	           3    	for (; isALNUM(**s); (*s)++) {
  2824	           1    	    const char *d = strchr(debopts,**s);
  2825	           1    	    if (d)
  2826	           1    		i |= 1 << (d - debopts);
  2827	      ######    	    else if (ckWARN_d(WARN_DEBUGGING))
  2828	      ######    	        Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
  2829					    "invalid option -D%c, use -D'' to see choices\n", **s);
  2830				}
  2831			    }
  2832	      ######        else if (isDIGIT(**s)) {
  2833	      ######    	i = atoi(*s);
  2834	      ######    	for (; isALNUM(**s); (*s)++) ;
  2835			    }
  2836	      ######        else if (givehelp) {
  2837	      ######          char **p = (char **)usage_msgd;
  2838	      ######          while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++);
  2839			    }
  2840			#  ifdef EBCDIC
  2841			    if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
  2842				Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
  2843					"-Dp not implemented on this platform\n");
  2844			#  endif
  2845	           1        return i;
  2846			}
  2847			#endif
  2848			
  2849			/* This routine handles any switches that can be given during run */
  2850			
  2851			char *
  2852			Perl_moreswitches(pTHX_ char *s)
  2853	        3005    {
  2854			    dVAR;
  2855	        3005        UV rschar;
  2856			
  2857	        3005        switch (*s) {
  2858			    case '0':
  2859			    {
  2860	           9    	 I32 flags = 0;
  2861	           9    	 STRLEN numlen;
  2862			
  2863	           9    	 SvREFCNT_dec(PL_rs);
  2864	           9    	 if (s[1] == 'x' && s[2]) {
  2865	      ######    	      const char *e = s+=2;
  2866	      ######    	      U8 *tmps;
  2867			
  2868	      ######    	      while (*e)
  2869	      ######    		e++;
  2870	      ######    	      numlen = e - s;
  2871	      ######    	      flags = PERL_SCAN_SILENT_ILLDIGIT;
  2872	      ######    	      rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
  2873	      ######    	      if (s + numlen < e) {
  2874	      ######    		   rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
  2875	      ######    		   numlen = 0;
  2876	      ######    		   s--;
  2877				      }
  2878	      ######    	      PL_rs = newSVpvn("", 0);
  2879	      ######    	      SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
  2880	      ######    	      tmps = (U8*)SvPVX(PL_rs);
  2881	      ######    	      uvchr_to_utf8(tmps, rschar);
  2882	      ######    	      SvCUR_set(PL_rs, UNISKIP(rschar));
  2883	      ######    	      SvUTF8_on(PL_rs);
  2884				 }
  2885				 else {
  2886	           9    	      numlen = 4;
  2887	           9    	      rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
  2888	           9    	      if (rschar & ~((U8)~0))
  2889	           1    		   PL_rs = &PL_sv_undef;
  2890	           8    	      else if (!rschar && numlen >= 2)
  2891	           1    		   PL_rs = newSVpvn("", 0);
  2892				      else {
  2893	           7    		   char ch = (char)rschar;
  2894	           7    		   PL_rs = newSVpvn(&ch, 1);
  2895				      }
  2896				 }
  2897	           9    	 sv_setsv(get_sv("/", TRUE), PL_rs);
  2898	           9    	 return s + numlen;
  2899			    }
  2900			    case 'C':
  2901	           6            s++;
  2902	           6            PL_unicode = parse_unicode_opts( (const char **)&s );
  2903	           6    	return s;
  2904			    case 'F':
  2905	           2    	PL_minus_F = TRUE;
  2906	           2    	PL_splitstr = ++s;
  2907	          15    	while (*s && !isSPACE(*s)) ++s;
  2908	           2    	*s = '\0';
  2909	           2    	PL_splitstr = savepv(PL_splitstr);
  2910	           2    	return s;
  2911			    case 'a':
  2912	           7    	PL_minus_a = TRUE;
  2913	           7    	s++;
  2914	           7    	return s;
  2915			    case 'c':
  2916	           1    	PL_minus_c = TRUE;
  2917	           1    	s++;
  2918	           1    	return s;
  2919			    case 'd':
  2920	           9    	forbid_setid("-d");
  2921	           9    	s++;
  2922			
  2923			        /* -dt indicates to the debugger that threads will be used */
  2924	           9    	if (*s == 't' && !isALNUM(s[1])) {
  2925	      ######    	    ++s;
  2926	      ######    	    my_setenv("PERL5DB_THREADED", "1");
  2927				}
  2928			
  2929				/* The following permits -d:Mod to accepts arguments following an =
  2930				   in the fashion that -MSome::Mod does. */
  2931	           9    	if (*s == ':' || *s == '=') {
  2932	           9                const char *start;
  2933	           9    	    SV *sv;
  2934	           9    	    sv = newSVpv("use Devel::", 0);
  2935	           9    	    start = ++s;
  2936				    /* We now allow -d:Module=Foo,Bar */
  2937	          56    	    while(isALNUM(*s) || *s==':') ++s;
  2938	           9    	    if (*s != '=')
  2939	           9    		sv_catpv(sv, start);
  2940				    else {
  2941	      ######    		sv_catpvn(sv, start, s-start);
  2942	      ######    		Perl_sv_catpvf(aTHX_ sv, " split(/,/,q%c%s%c)", 0, ++s, 0);
  2943				    }
  2944	           9    	    s += strlen(s);
  2945	           9    	    my_setenv("PERL5DB", SvPV_nolen_const(sv));
  2946				}
  2947	           9    	if (!PL_perldb) {
  2948	           9    	    PL_perldb = PERLDB_ALL;
  2949	           9    	    init_debugger();
  2950				}
  2951	           9    	return s;
  2952			    case 'D':
  2953			    {	
  2954			#ifdef DEBUGGING
  2955	           1    	forbid_setid("-D");
  2956	           1    	s++;
  2957	           1    	PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
  2958			#else /* !DEBUGGING */
  2959				if (ckWARN_d(WARN_DEBUGGING))
  2960				    Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
  2961				           "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
  2962				for (s++; isALNUM(*s); s++) ;
  2963			#endif
  2964	           1    	return s;
  2965			    }	
  2966			    case 'h':
  2967	           1    	usage(PL_origargv[0]);
  2968	           1    	my_exit(0);
  2969			    case 'i':
  2970	           3    	Safefree(PL_inplace);
  2971			#if defined(__CYGWIN__) /* do backup extension automagically */
  2972				if (*(s+1) == '\0') {
  2973				PL_inplace = savepv(".bak");
  2974				return s+1;
  2975				}
  2976			#endif /* __CYGWIN__ */
  2977	           3    	PL_inplace = savepv(s+1);
  2978	           3    	for (s = PL_inplace; *s && !isSPACE(*s); s++)
  2979				    ;
  2980	           3    	if (*s) {
  2981	           1    	    *s++ = '\0';
  2982	           1    	    if (*s == '-')	/* Additional switches on #! line. */
  2983	      ######    	        s++;
  2984				}
  2985	           3    	return s;
  2986			    case 'I':	/* -I handled both here and in parse_body() */
  2987	           2    	forbid_setid("-I");
  2988	           2    	++s;
  2989	           2    	while (*s && isSPACE(*s))
  2990	      ######    	    ++s;
  2991	           2    	if (*s) {
  2992	           2    	    char *e, *p;
  2993	           2    	    p = s;
  2994				    /* ignore trailing spaces (possibly followed by other switches) */
  2995	           2    	    do {
  2996	           2    		for (e = p; *e && !isSPACE(*e); e++) ;
  2997	           2    		p = e;
  2998	           4    		while (isSPACE(*p))
  2999	           2    		    p++;
  3000	           2    	    } while (*p && *p != '-');
  3001	           2    	    e = savepvn(s, e-s);
  3002	           2    	    incpush(e, TRUE, TRUE, FALSE, FALSE);
  3003	           2    	    Safefree(e);
  3004	           2    	    s = p;
  3005	           2    	    if (*s == '-')
  3006	           1    		s++;
  3007				}
  3008				else
  3009	      ######    	    Perl_croak(aTHX_ "No directory specified for -I");
  3010	           2    	return s;
  3011			    case 'l':
  3012	        1245    	PL_minus_l = TRUE;
  3013	        1245    	s++;
  3014	        1245    	if (PL_ors_sv) {
  3015	      ######    	    SvREFCNT_dec(PL_ors_sv);
  3016	      ######    	    PL_ors_sv = Nullsv;
  3017				}
  3018	        1245    	if (isDIGIT(*s)) {
  3019	           1                I32 flags = 0;
  3020	           1    	    STRLEN numlen;
  3021	           1    	    PL_ors_sv = newSVpvn("\n",1);
  3022	           1    	    numlen = 3 + (*s == '0');
  3023	           1    	    *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
  3024	           1    	    s += numlen;
  3025				}
  3026				else {
  3027	        1244    	    if (RsPARA(PL_rs)) {
  3028	      ######    		PL_ors_sv = newSVpvn("\n\n",2);
  3029				    }
  3030				    else {
  3031	        1244    		PL_ors_sv = newSVsv(PL_rs);
  3032				    }
  3033				}
  3034	        1245    	return s;
  3035			    case 'A':
  3036	           5    	forbid_setid("-A");
  3037	           5    	if (!PL_preambleav)
  3038	           5    	    PL_preambleav = newAV();
  3039	           5    	s++;
  3040				{
  3041	           5    	    char *start = s;
  3042	           5    	    SV *sv = newSVpv("use assertions::activate", 24);
  3043	           5    	    while(isALNUM(*s) || *s == ':') ++s;
  3044	           5    	    if (s != start) {
  3045	      ######    		sv_catpvn(sv, "::", 2);
  3046	      ######    		sv_catpvn(sv, start, s-start);
  3047				    }
  3048	           5    	    if (*s == '=') {
  3049	           4    		Perl_sv_catpvf(aTHX_ sv, " split(/,/,q%c%s%c)", 0, ++s, 0);
  3050	           4    		s+=strlen(s);
  3051				    }
  3052	           1    	    else if (*s != '\0') {
  3053	      ######    		Perl_croak(aTHX_ "Can't use '%c' after -A%.*s", *s, s-start, start);
  3054				    }
  3055	           5    	    av_push(PL_preambleav, sv);
  3056	           5    	    return s;
  3057				}
  3058			    case 'M':
  3059	         694    	forbid_setid("-M");	/* XXX ? */
  3060				/* FALL THROUGH */
  3061			    case 'm':
  3062	         696    	forbid_setid("-m");	/* XXX ? */
  3063	         696    	if (*++s) {
  3064	         696    	    char *start;
  3065	         696    	    SV *sv;
  3066	         696    	    const char *use = "use ";
  3067				    /* -M-foo == 'no foo'	*/
  3068				    /* Leading space on " no " is deliberate, to make both
  3069				       possibilities the same length.  */
  3070	         696    	    if (*s == '-') { use = " no "; ++s; }
  3071	         696    	    sv = newSVpvn(use,4);
  3072	         696    	    start = s;
  3073				    /* We allow -M'Module qw(Foo Bar)'	*/
  3074	       10854    	    while(isALNUM(*s) || *s==':') ++s;
  3075	         696    	    if (*s != '=') {
  3076	         605    		sv_catpv(sv, start);
  3077	         605    		if (*(start-1) == 'm') {
  3078	           1    		    if (*s != '\0')
  3079	      ######    			Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
  3080	           1    		    sv_catpv( sv, " ()");
  3081					}
  3082				    } else {
  3083	          91                    if (s == start)
  3084	      ######                        Perl_croak(aTHX_ "Module name required with -%c option",
  3085						       s[-1]);
  3086	          91    		sv_catpvn(sv, start, s-start);
  3087	          91    		sv_catpv(sv, " split(/,/,q");
  3088	          91    		sv_catpvn(sv, "\0)", 1);        /* Use NUL as q//-delimiter. */
  3089	          91    		sv_catpv(sv, ++s);
  3090	          91    		sv_catpvn(sv,  "\0)", 2);
  3091				    }
  3092	         696    	    s += strlen(s);
  3093	         696    	    if (!PL_preambleav)
  3094	         693    		PL_preambleav = newAV();
  3095	         696    	    av_push(PL_preambleav, sv);
  3096				}
  3097				else
  3098	      ######    	    Perl_croak(aTHX_ "Missing argument to -%c", *(s-1));
  3099	         696    	return s;
  3100			    case 'n':
  3101	          11    	PL_minus_n = TRUE;
  3102	          11    	s++;
  3103	          11    	return s;
  3104			    case 'p':
  3105	          10    	PL_minus_p = TRUE;
  3106	          10    	s++;
  3107	          10    	return s;
  3108			    case 's':
  3109	           2    	forbid_setid("-s");
  3110	           2    	PL_doswitches = TRUE;
  3111	           2    	s++;
  3112	           2    	return s;
  3113			    case 't':
  3114	           2            if (!PL_tainting)
  3115	      ######    	    TOO_LATE_FOR('t');
  3116	           2            s++;
  3117	           2            return s;
  3118			    case 'T':
  3119	          36    	if (!PL_tainting)
  3120	      ######    	    TOO_LATE_FOR('T');
  3121	          36    	s++;
  3122	          36    	return s;
  3123			    case 'u':
  3124			#ifdef MACOS_TRADITIONAL
  3125				Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
  3126			#endif
  3127	      ######    	PL_do_undump = TRUE;
  3128	      ######    	s++;
  3129	      ######    	return s;
  3130			    case 'U':
  3131	           2    	PL_unsafe = TRUE;
  3132	           2    	s++;
  3133	           2    	return s;
  3134			    case 'v':
  3135	           1    	if (!sv_derived_from(PL_patchlevel, "version"))
  3136	           1    		(void *)upg_version(PL_patchlevel);
  3137			#if !defined(DGUX)
  3138	           1    	PerlIO_printf(PerlIO_stdout(),
  3139					Perl_form(aTHX_ "\nThis is perl, %"SVf" built for %s",
  3140					    vstringify(PL_patchlevel),
  3141					    ARCHNAME));
  3142			#else /* DGUX */
  3143			/* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
  3144				PerlIO_printf(PerlIO_stdout(),
  3145					Perl_form(aTHX_ "\nThis is perl, %"SVf"\n",
  3146					    vstringify(PL_patchlevel)));
  3147				PerlIO_printf(PerlIO_stdout(),
  3148						Perl_form(aTHX_ "        built under %s at %s %s\n",
  3149								OSNAME, __DATE__, __TIME__));
  3150				PerlIO_printf(PerlIO_stdout(),
  3151						Perl_form(aTHX_ "        OS Specific Release: %s\n",
  3152								OSVERS));
  3153			#endif /* !DGUX */
  3154			
  3155			#if defined(LOCAL_PATCH_COUNT)
  3156	           1    	if (LOCAL_PATCH_COUNT > 0)
  3157	           1    	    PerlIO_printf(PerlIO_stdout(),
  3158						  "\n(with %d registered patch%s, "
  3159						  "see perl -V for more detail)",
  3160						  (int)LOCAL_PATCH_COUNT,
  3161						  (LOCAL_PATCH_COUNT!=1) ? "es" : "");
  3162			#endif
  3163			
  3164	           1    	PerlIO_printf(PerlIO_stdout(),
  3165					      "\n\nCopyright 1987-2005, Larry Wall\n");
  3166			#ifdef MACOS_TRADITIONAL
  3167				PerlIO_printf(PerlIO_stdout(),
  3168					      "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
  3169					      "maintained by Chris Nandor\n");
  3170			#endif
  3171			#ifdef MSDOS
  3172				PerlIO_printf(PerlIO_stdout(),
  3173					      "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
  3174			#endif
  3175			#ifdef DJGPP
  3176				PerlIO_printf(PerlIO_stdout(),
  3177					      "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
  3178					      "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
  3179			#endif
  3180			#ifdef OS2
  3181				PerlIO_printf(PerlIO_stdout(),
  3182					      "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
  3183					      "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
  3184			#endif
  3185			#ifdef atarist
  3186				PerlIO_printf(PerlIO_stdout(),
  3187					      "atariST series port, ++jrb  bammi@cadence.com\n");
  3188			#endif
  3189			#ifdef __BEOS__
  3190				PerlIO_printf(PerlIO_stdout(),
  3191					      "BeOS port Copyright Tom Spindler, 1997-1999\n");
  3192			#endif
  3193			#ifdef MPE
  3194				PerlIO_printf(PerlIO_stdout(),
  3195					      "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2003\n");
  3196			#endif
  3197			#ifdef OEMVS
  3198				PerlIO_printf(PerlIO_stdout(),
  3199					      "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
  3200			#endif
  3201			#ifdef __VOS__
  3202				PerlIO_printf(PerlIO_stdout(),
  3203					      "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
  3204			#endif
  3205			#ifdef __OPEN_VM
  3206				PerlIO_printf(PerlIO_stdout(),
  3207					      "VM/ESA port by Neale Ferguson, 1998-1999\n");
  3208			#endif
  3209			#ifdef POSIX_BC
  3210				PerlIO_printf(PerlIO_stdout(),
  3211					      "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
  3212			#endif
  3213			#ifdef __MINT__
  3214				PerlIO_printf(PerlIO_stdout(),
  3215					      "MiNT port by Guido Flohr, 1997-1999\n");
  3216			#endif
  3217			#ifdef EPOC
  3218				PerlIO_printf(PerlIO_stdout(),
  3219					      "EPOC port by Olaf Flebbe, 1999-2002\n");
  3220			#endif
  3221			#ifdef UNDER_CE
  3222				PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
  3223				PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
  3224				wce_hitreturn();
  3225			#endif
  3226			#ifdef SYMBIAN
  3227				PerlIO_printf(PerlIO_stdout(),
  3228					      "Symbian port by Nokia, 2004-2005\n");
  3229			#endif
  3230			#ifdef BINARY_BUILD_NOTICE
  3231				BINARY_BUILD_NOTICE;
  3232			#endif
  3233	           1    	PerlIO_printf(PerlIO_stdout(),
  3234					      "\n\
  3235			Perl may be copied only under the terms of either the Artistic License or the\n\
  3236			GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
  3237			Complete documentation for Perl, including FAQ lists, should be found on\n\
  3238			this system using \"man perl\" or \"perldoc perl\".  If you have access to the\n\
  3239			Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
  3240	           1    	my_exit(0);
  3241			    case 'w':
  3242	         513    	if (! (PL_dowarn & G_WARN_ALL_MASK))
  3243	         511    	    PL_dowarn |= G_WARN_ON;
  3244	         513    	s++;
  3245	         513    	return s;
  3246			    case 'W':
  3247	          21    	PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
  3248	          21            if (!specialWARN(PL_compiling.cop_warnings))
  3249	      ######                SvREFCNT_dec(PL_compiling.cop_warnings);
  3250	          21    	PL_compiling.cop_warnings = pWARN_ALL ;
  3251	          21    	s++;
  3252	          21    	return s;
  3253			    case 'X':
  3254	          21    	PL_dowarn = G_WARN_ALL_OFF;
  3255	          21            if (!specialWARN(PL_compiling.cop_warnings))
  3256	      ######                SvREFCNT_dec(PL_compiling.cop_warnings);
  3257	          21    	PL_compiling.cop_warnings = pWARN_NONE ;
  3258	          21    	s++;
  3259	          21    	return s;
  3260			    case '*':
  3261			    case ' ':
  3262	           7    	if (s[1] == '-')	/* Additional switches on #! line. */
  3263	      ######    	    return s+2;
  3264	      ######    	break;
  3265			    case '-':
  3266			    case 0:
  3267			#if defined(WIN32) || !defined(PERL_STRICT_CR)
  3268			    case '\r':
  3269			#endif
  3270			    case '\n':
  3271			    case '\t':
  3272	      ######    	break;
  3273			#ifdef ALTERNATE_SHEBANG
  3274			    case 'S':			/* OS/2 needs -S on "extproc" line. */
  3275				break;
  3276			#endif
  3277			    case 'P':
  3278	      ######    	if (PL_preprocess)
  3279	      ######    	    return s+1;
  3280				/* FALL THROUGH */
  3281			    default:
  3282	      ######    	Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
  3283			    }
  3284	         399        return Nullch;
  3285			}
  3286			
  3287			/* compliments of Tom Christiansen */
  3288			
  3289			/* unexec() can be found in the Gnu emacs distribution */
  3290			/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
  3291			
  3292			void
  3293			Perl_my_unexec(pTHX)
  3294	      ######    {
  3295			#ifdef UNEXEC
  3296			    SV*    prog;
  3297			    SV*    file;
  3298			    int    status = 1;
  3299			    extern int etext;
  3300			
  3301			    prog = newSVpv(BIN_EXP, 0);
  3302			    sv_catpv(prog, "/perl");
  3303			    file = newSVpv(PL_origfilename, 0);
  3304			    sv_catpv