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(file, ".perldump");
  3305			
  3306			    unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
  3307			    /* unexec prints msg to stderr in case of failure */
  3308			    PerlProc_exit(status);
  3309			#else
  3310			#  ifdef VMS
  3311			#    include <lib$routines.h>
  3312			     lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
  3313			#  else
  3314	      ######        ABORT();		/* for use with undump */
  3315			#  endif
  3316			#endif
  3317			}
  3318			
  3319			/* initialize curinterp */
  3320			STATIC void
  3321			S_init_interp(pTHX)
  3322	      ######    {
  3323			
  3324			#ifdef MULTIPLICITY
  3325			#  define PERLVAR(var,type)
  3326			#  define PERLVARA(var,n,type)
  3327			#  if defined(PERL_IMPLICIT_CONTEXT)
  3328			#    if defined(USE_5005THREADS)
  3329			#      define PERLVARI(var,type,init)		PERL_GET_INTERP->var = init;
  3330			#      define PERLVARIC(var,type,init)		PERL_GET_INTERP->var = init;
  3331			#    else /* !USE_5005THREADS */
  3332			#      define PERLVARI(var,type,init)		aTHX->var = init;
  3333			#      define PERLVARIC(var,type,init)	aTHX->var = init;
  3334			#    endif /* USE_5005THREADS */
  3335			#  else
  3336			#    define PERLVARI(var,type,init)	PERL_GET_INTERP->var = init;
  3337			#    define PERLVARIC(var,type,init)	PERL_GET_INTERP->var = init;
  3338			#  endif
  3339			#  include "intrpvar.h"
  3340			#  ifndef USE_5005THREADS
  3341			#    include "thrdvar.h"
  3342			#  endif
  3343			#  undef PERLVAR
  3344			#  undef PERLVARA
  3345			#  undef PERLVARI
  3346			#  undef PERLVARIC
  3347			#else
  3348			#  define PERLVAR(var,type)
  3349			#  define PERLVARA(var,n,type)
  3350			#  define PERLVARI(var,type,init)	PL_##var = init;
  3351			#  define PERLVARIC(var,type,init)	PL_##var = init;
  3352			#  include "intrpvar.h"
  3353			#  ifndef USE_5005THREADS
  3354			#    include "thrdvar.h"
  3355			#  endif
  3356			#  undef PERLVAR
  3357			#  undef PERLVARA
  3358			#  undef PERLVARI
  3359			#  undef PERLVARIC
  3360			#endif
  3361			
  3362			}
  3363			
  3364			STATIC void
  3365			S_init_main_stash(pTHX)
  3366	        4503    {
  3367	        4503        GV *gv;
  3368			
  3369	        4503        PL_curstash = PL_defstash = newHV();
  3370	        4503        PL_curstname = newSVpvn("main",4);
  3371	        4503        gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
  3372	        4503        SvREFCNT_dec(GvHV(gv));
  3373	        4503        GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
  3374	        4503        SvREADONLY_on(gv);
  3375	        4503        Perl_hv_name_set(aTHX_ PL_defstash, "main", 4, 0);
  3376	        4503        PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
  3377	        4503        GvMULTI_on(PL_incgv);
  3378	        4503        PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
  3379	        4503        GvMULTI_on(PL_hintgv);
  3380	        4503        PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
  3381	        4503        PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
  3382	        4503        GvMULTI_on(PL_errgv);
  3383	        4503        PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
  3384	        4503        GvMULTI_on(PL_replgv);
  3385	        4503        (void)Perl_form(aTHX_ "%240s","");	/* Preallocate temp - for immediate signals. */
  3386			#ifdef PERL_DONT_CREATE_GVSV
  3387			    gv_SVadd(PL_errgv);
  3388			#endif
  3389	        4503        sv_grow(ERRSV, 240);	/* Preallocate - for immediate signals. */
  3390	        4503        sv_setpvn(ERRSV, "", 0);
  3391	        4503        PL_curstash = PL_defstash;
  3392	        4503        CopSTASH_set(&PL_compiling, PL_defstash);
  3393	        4503        PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
  3394	        4503        PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
  3395			    /* We must init $/ before switches are processed. */
  3396	        4503        sv_setpvn(get_sv("/", TRUE), "\n", 1);
  3397			}
  3398			
  3399			/* PSz 18 Nov 03  fdscript now global but do not change prototype */
  3400			STATIC void
  3401			S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv)
  3402	        4500    {
  3403			#ifndef IAMSUID
  3404	        4500        const char *quote;
  3405	        4500        const char *code;
  3406	        4500        const char *cpp_discard_flag;
  3407	        4500        const char *perl;
  3408			#endif
  3409			    dVAR;
  3410			
  3411	        4500        PL_fdscript = -1;
  3412	        4500        PL_suidscript = -1;
  3413			
  3414	        4500        if (PL_e_script) {
  3415	        2034    	PL_origfilename = savepvn("-e", 2);
  3416			    }
  3417			    else {
  3418				/* if find_script() returns, it returns a malloc()-ed value */
  3419	        2466    	scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
  3420			
  3421	        2466    	if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
  3422	      ######                const char *s = scriptname + 8;
  3423	      ######    	    PL_fdscript = atoi(s);
  3424	      ######    	    while (isDIGIT(*s))
  3425	      ######    		s++;
  3426	      ######    	    if (*s) {
  3427					/* PSz 18 Feb 04
  3428					 * Tell apart "normal" usage of fdscript, e.g.
  3429					 * with bash on FreeBSD:
  3430					 *   perl <( echo '#!perl -DA'; echo 'print "$0\n"')
  3431					 * from usage in suidperl.
  3432					 * Does any "normal" usage leave garbage after the number???
  3433					 * Is it a mistake to use a similar /dev/fd/ construct for
  3434					 * suidperl?
  3435					 */
  3436	      ######    		PL_suidscript = 1;
  3437					/* PSz 20 Feb 04  
  3438					 * Be supersafe and do some sanity-checks.
  3439					 * Still, can we be sure we got the right thing?
  3440					 */
  3441	      ######    		if (*s != '/') {
  3442	      ######    		    Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
  3443					}
  3444	      ######    		if (! *(s+1)) {
  3445	      ######    		    Perl_croak(aTHX_ "Missing (suid) fd script name\n");
  3446					}
  3447	      ######    		scriptname = savepv(s + 1);
  3448	      ######    		Safefree(PL_origfilename);
  3449	      ######    		PL_origfilename = (char *)scriptname;
  3450				    }
  3451				}
  3452			    }
  3453			
  3454	        4500        CopFILE_free(PL_curcop);
  3455	        4500        CopFILE_set(PL_curcop, PL_origfilename);
  3456	        4500        if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
  3457	          19    	scriptname = (char *)"";
  3458	        4500        if (PL_fdscript >= 0) {
  3459	      ######    	PL_rsfp = PerlIO_fdopen(PL_fdscript,PERL_SCRIPT_MODE);
  3460			#       if defined(HAS_FCNTL) && defined(F_SETFD)
  3461	      ######    	    if (PL_rsfp)
  3462			                /* ensure close-on-exec */
  3463	      ######    	        fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
  3464			#       endif
  3465			    }
  3466			#ifdef IAMSUID
  3467			    else {
  3468				Perl_croak(aTHX_ "sperl needs fd script\n"
  3469					   "You should not call sperl directly; do you need to "
  3470					   "change a #! line\nfrom sperl to perl?\n");
  3471			
  3472			/* PSz 11 Nov 03
  3473			 * Do not open (or do other fancy stuff) while setuid.
  3474			 * Perl does the open, and hands script to suidperl on a fd;
  3475			 * suidperl only does some checks, sets up UIDs and re-execs
  3476			 * perl with that fd as it has always done.
  3477			 */
  3478			    }
  3479			    if (PL_suidscript != 1) {
  3480				Perl_croak(aTHX_ "suidperl needs (suid) fd script\n");
  3481			    }
  3482			#else /* IAMSUID */
  3483	        4500        else if (PL_preprocess) {
  3484	           3    	const char *cpp_cfg = CPPSTDIN;
  3485	           3    	SV *cpp = newSVpvn("",0);
  3486	           3    	SV *cmd = NEWSV(0,0);
  3487			
  3488	           3    	if (cpp_cfg[0] == 0) /* PERL_MICRO? */
  3489	      ######    	     Perl_croak(aTHX_ "Can't run with cpp -P with CPPSTDIN undefined");
  3490	           3    	if (strEQ(cpp_cfg, "cppstdin"))
  3491	      ######    	    Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
  3492	           3    	sv_catpv(cpp, cpp_cfg);
  3493			
  3494			#       ifndef VMS
  3495	           3    	    sv_catpvn(sv, "-I", 2);
  3496	           3    	    sv_catpv(sv,PRIVLIB_EXP);
  3497			#       endif
  3498			
  3499				DEBUG_P(PerlIO_printf(Perl_debug_log,
  3500						      "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
  3501						      scriptname, SvPVX_const (cpp), SvPVX_const (sv),
  3502	           3    			      CPPMINUS));
  3503			
  3504			#       if defined(MSDOS) || defined(WIN32) || defined(VMS)
  3505			            quote = "\"";
  3506			#       else
  3507	           3                quote = "'";
  3508			#       endif
  3509			
  3510			#       ifdef VMS
  3511			            cpp_discard_flag = "";
  3512			#       else
  3513	           3                cpp_discard_flag = "-C";
  3514			#       endif
  3515			
  3516			#       ifdef OS2
  3517			            perl = os2_execname(aTHX);
  3518			#       else
  3519	           3                perl = PL_origargv[0];
  3520			#       endif
  3521			
  3522			
  3523			        /* This strips off Perl comments which might interfere with
  3524			           the C pre-processor, including #!.  #line directives are
  3525			           deliberately stripped to avoid confusion with Perl's version
  3526			           of #line.  FWP played some golf with it so it will fit
  3527			           into VMS's 255 character buffer.
  3528			        */
  3529	           3            if( PL_doextract )
  3530	           1                code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
  3531			        else
  3532	           2                code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
  3533			
  3534	           3            Perl_sv_setpvf(aTHX_ cmd, "\
  3535			%s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
  3536			                       perl, quote, code, quote, scriptname, cpp,
  3537			                       cpp_discard_flag, sv, CPPMINUS);
  3538			
  3539	           3    	PL_doextract = FALSE;
  3540			
  3541			        DEBUG_P(PerlIO_printf(Perl_debug_log,
  3542			                              "PL_preprocess: cmd=\"%s\"\n",
  3543	           3                                  SvPVX_const(cmd)));
  3544			
  3545	           3    	PL_rsfp = PerlProc_popen((char *)SvPVX_const(cmd), (char *)"r");
  3546	           3    	SvREFCNT_dec(cmd);
  3547	           3    	SvREFCNT_dec(cpp);
  3548			    }
  3549	        4497        else if (!*scriptname) {
  3550	          19    	forbid_setid("program input from stdin");
  3551	          19    	PL_rsfp = PerlIO_stdin();
  3552			    }
  3553			    else {
  3554	        4478    	PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
  3555			#       if defined(HAS_FCNTL) && defined(F_SETFD)
  3556	        4478    	    if (PL_rsfp)
  3557			                /* ensure close-on-exec */
  3558	        4478    	        fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
  3559			#       endif
  3560			    }
  3561			#endif /* IAMSUID */
  3562	        4500        if (!PL_rsfp) {
  3563				/* PSz 16 Sep 03  Keep neat error message */
  3564	      ######    	Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
  3565					CopFILE(PL_curcop), Strerror(errno));
  3566			    }
  3567			}
  3568			
  3569			/* Mention
  3570			 * I_SYSSTATVFS	HAS_FSTATVFS
  3571			 * I_SYSMOUNT
  3572			 * I_STATFS	HAS_FSTATFS	HAS_GETFSSTAT
  3573			 * I_MNTENT	HAS_GETMNTENT	HAS_HASMNTOPT
  3574			 * here so that metaconfig picks them up. */
  3575			
  3576			#ifdef IAMSUID
  3577			STATIC int
  3578			S_fd_on_nosuid_fs(pTHX_ int fd)
  3579			{
  3580			/* PSz 27 Feb 04
  3581			 * We used to do this as "plain" user (after swapping UIDs with setreuid);
  3582			 * but is needed also on machines without setreuid.
  3583			 * Seems safe enough to run as root.
  3584			 */
  3585			    int check_okay = 0; /* able to do all the required sys/libcalls */
  3586			    int on_nosuid  = 0; /* the fd is on a nosuid fs */
  3587			    /* PSz 12 Nov 03
  3588			     * Need to check noexec also: nosuid might not be set, the average
  3589			     * sysadmin would say that nosuid is irrelevant once he sets noexec.
  3590			     */
  3591			    int on_noexec  = 0; /* the fd is on a noexec fs */
  3592			
  3593			/*
  3594			 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
  3595			 * fstatvfs() is UNIX98.
  3596			 * fstatfs() is 4.3 BSD.
  3597			 * ustat()+getmnt() is pre-4.3 BSD.
  3598			 * getmntent() is O(number-of-mounted-filesystems) and can hang on
  3599			 * an irrelevant filesystem while trying to reach the right one.
  3600			 */
  3601			
  3602			#undef FD_ON_NOSUID_CHECK_OKAY  /* found the syscalls to do the check? */
  3603			
  3604			#   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
  3605			        defined(HAS_FSTATVFS)
  3606			#   define FD_ON_NOSUID_CHECK_OKAY
  3607			    struct statvfs stfs;
  3608			
  3609			    check_okay = fstatvfs(fd, &stfs) == 0;
  3610			    on_nosuid  = check_okay && (stfs.f_flag  & ST_NOSUID);
  3611			#ifdef ST_NOEXEC
  3612			    /* ST_NOEXEC certainly absent on AIX 5.1, and doesn't seem to be documented
  3613			       on platforms where it is present.  */
  3614			    on_noexec  = check_okay && (stfs.f_flag  & ST_NOEXEC);
  3615			#endif
  3616			#   endif /* fstatvfs */
  3617			
  3618			#   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
  3619			        defined(PERL_MOUNT_NOSUID)	&& \
  3620			        defined(PERL_MOUNT_NOEXEC)	&& \
  3621			        defined(HAS_FSTATFS) 		&& \
  3622			        defined(HAS_STRUCT_STATFS)	&& \
  3623			        defined(HAS_STRUCT_STATFS_F_FLAGS)
  3624			#   define FD_ON_NOSUID_CHECK_OKAY
  3625			    struct statfs  stfs;
  3626			
  3627			    check_okay = fstatfs(fd, &stfs)  == 0;
  3628			    on_nosuid  = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
  3629			    on_noexec  = check_okay && (stfs.f_flags & PERL_MOUNT_NOEXEC);
  3630			#   endif /* fstatfs */
  3631			
  3632			#   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
  3633			        defined(PERL_MOUNT_NOSUID)	&& \
  3634			        defined(PERL_MOUNT_NOEXEC)	&& \
  3635			        defined(HAS_FSTAT)		&& \
  3636			        defined(HAS_USTAT)		&& \
  3637			        defined(HAS_GETMNT)		&& \
  3638			        defined(HAS_STRUCT_FS_DATA)	&& \
  3639			        defined(NOSTAT_ONE)
  3640			#   define FD_ON_NOSUID_CHECK_OKAY
  3641			    Stat_t fdst;
  3642			
  3643			    if (fstat(fd, &fdst) == 0) {
  3644			        struct ustat us;
  3645			        if (ustat(fdst.st_dev, &us) == 0) {
  3646			            struct fs_data fsd;
  3647			            /* NOSTAT_ONE here because we're not examining fields which
  3648			             * vary between that case and STAT_ONE. */
  3649			            if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
  3650			                size_t cmplen = sizeof(us.f_fname);
  3651			                if (sizeof(fsd.fd_req.path) < cmplen)
  3652			                    cmplen = sizeof(fsd.fd_req.path);
  3653			                if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
  3654			                    fdst.st_dev == fsd.fd_req.dev) {
  3655			                        check_okay = 1;
  3656			                        on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
  3657			                        on_noexec = fsd.fd_req.flags & PERL_MOUNT_NOEXEC;
  3658			                    }
  3659			                }
  3660			            }
  3661			        }
  3662			    }
  3663			#   endif /* fstat+ustat+getmnt */
  3664			
  3665			#   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
  3666			        defined(HAS_GETMNTENT)		&& \
  3667			        defined(HAS_HASMNTOPT)		&& \
  3668			        defined(MNTOPT_NOSUID)		&& \
  3669			        defined(MNTOPT_NOEXEC)
  3670			#   define FD_ON_NOSUID_CHECK_OKAY
  3671			    FILE                *mtab = fopen("/etc/mtab", "r");
  3672			    struct mntent       *entry;
  3673			    Stat_t              stb, fsb;
  3674			
  3675			    if (mtab && (fstat(fd, &stb) == 0)) {
  3676			        while (entry = getmntent(mtab)) {
  3677			            if (stat(entry->mnt_dir, &fsb) == 0
  3678			                && fsb.st_dev == stb.st_dev)
  3679			            {
  3680			                /* found the filesystem */
  3681			                check_okay = 1;
  3682			                if (hasmntopt(entry, MNTOPT_NOSUID))
  3683			                    on_nosuid = 1;
  3684			                if (hasmntopt(entry, MNTOPT_NOEXEC))
  3685			                    on_noexec = 1;
  3686			                break;
  3687			            } /* A single fs may well fail its stat(). */
  3688			        }
  3689			    }
  3690			    if (mtab)
  3691			        fclose(mtab);
  3692			#   endif /* getmntent+hasmntopt */
  3693			
  3694			    if (!check_okay)
  3695				Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid/noexec", PL_origfilename);
  3696			    if (on_nosuid)
  3697				Perl_croak(aTHX_ "Setuid script \"%s\" on nosuid filesystem", PL_origfilename);
  3698			    if (on_noexec)
  3699				Perl_croak(aTHX_ "Setuid script \"%s\" on noexec filesystem", PL_origfilename);
  3700			    return ((!check_okay) || on_nosuid || on_noexec);
  3701			}
  3702			#endif /* IAMSUID */
  3703			
  3704			STATIC void
  3705			S_validate_suid(pTHX_ const char *validarg, const char *scriptname)
  3706	        4500    {
  3707			    dVAR;
  3708			#ifdef IAMSUID
  3709			    /* int which; */
  3710			#endif /* IAMSUID */
  3711			
  3712			    /* do we need to emulate setuid on scripts? */
  3713			
  3714			    /* This code is for those BSD systems that have setuid #! scripts disabled
  3715			     * in the kernel because of a security problem.  Merely defining DOSUID
  3716			     * in perl will not fix that problem, but if you have disabled setuid
  3717			     * scripts in the kernel, this will attempt to emulate setuid and setgid
  3718			     * on scripts that have those now-otherwise-useless bits set.  The setuid
  3719			     * root version must be called suidperl or sperlN.NNN.  If regular perl
  3720			     * discovers that it has opened a setuid script, it calls suidperl with
  3721			     * the same argv that it had.  If suidperl finds that the script it has
  3722			     * just opened is NOT setuid root, it sets the effective uid back to the
  3723			     * uid.  We don't just make perl setuid root because that loses the
  3724			     * effective uid we had before invoking perl, if it was different from the
  3725			     * uid.
  3726			     * PSz 27 Feb 04
  3727			     * Description/comments above do not match current workings:
  3728			     *   suidperl must be hardlinked to sperlN.NNN (that is what we exec);
  3729			     *   suidperl called with script open and name changed to /dev/fd/N/X;
  3730			     *   suidperl croaks if script is not setuid;
  3731			     *   making perl setuid would be a huge security risk (and yes, that
  3732			     *     would lose any euid we might have had).
  3733			     *
  3734			     * DOSUID must be defined in both perl and suidperl, and IAMSUID must
  3735			     * be defined in suidperl only.  suidperl must be setuid root.  The
  3736			     * Configure script will set this up for you if you want it.
  3737			     */
  3738			
  3739			#ifdef DOSUID
  3740			    const char *s, *s2;
  3741			
  3742			    if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0)	/* normal stat is insecure */
  3743				Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
  3744			    if (PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
  3745				I32 len;
  3746				const char *linestr;
  3747			
  3748			#ifdef IAMSUID
  3749				if (PL_fdscript < 0 || PL_suidscript != 1)
  3750				    Perl_croak(aTHX_ "Need (suid) fdscript in suidperl\n");	/* We already checked this */
  3751				/* PSz 11 Nov 03
  3752				 * Since the script is opened by perl, not suidperl, some of these
  3753				 * checks are superfluous. Leaving them in probably does not lower
  3754				 * security(?!).
  3755				 */
  3756				/* PSz 27 Feb 04
  3757				 * Do checks even for systems with no HAS_SETREUID.
  3758				 * We used to swap, then re-swap UIDs with
  3759			#ifdef HAS_SETREUID
  3760				    if (setreuid(PL_euid,PL_uid) < 0
  3761					|| PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
  3762					Perl_croak(aTHX_ "Can't swap uid and euid");
  3763			#endif
  3764			#ifdef HAS_SETREUID
  3765				    if (setreuid(PL_uid,PL_euid) < 0
  3766					|| PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
  3767					Perl_croak(aTHX_ "Can't reswap uid and euid");
  3768			#endif
  3769				 */
  3770			
  3771				/* On this access check to make sure the directories are readable,
  3772				 * there is actually a small window that the user could use to make
  3773				 * filename point to an accessible directory.  So there is a faint
  3774				 * chance that someone could execute a setuid script down in a
  3775				 * non-accessible directory.  I don't know what to do about that.
  3776				 * But I don't think it's too important.  The manual lies when
  3777				 * it says access() is useful in setuid programs.
  3778				 * 
  3779				 * So, access() is pretty useless... but not harmful... do anyway.
  3780				 */
  3781				if (PerlLIO_access(CopFILE(PL_curcop),1)) { /*double check*/
  3782				    Perl_croak(aTHX_ "Can't access() script\n");
  3783				}
  3784			
  3785				/* If we can swap euid and uid, then we can determine access rights
  3786				 * with a simple stat of the file, and then compare device and
  3787				 * inode to make sure we did stat() on the same file we opened.
  3788				 * Then we just have to make sure he or she can execute it.
  3789				 * 
  3790				 * PSz 24 Feb 04
  3791				 * As the script is opened by perl, not suidperl, we do not need to
  3792				 * care much about access rights.
  3793				 * 
  3794				 * The 'script changed' check is needed, or we can get lied to
  3795				 * about $0 with e.g.
  3796				 *  suidperl /dev/fd/4//bin/x 4<setuidscript
  3797				 * Without HAS_SETREUID, is it safe to stat() as root?
  3798				 * 
  3799				 * Are there any operating systems that pass /dev/fd/xxx for setuid
  3800				 * scripts, as suggested/described in perlsec(1)? Surely they do not
  3801				 * pass the script name as we do, so the "script changed" test would
  3802				 * fail for them... but we never get here with
  3803				 * SETUID_SCRIPTS_ARE_SECURE_NOW defined.
  3804				 * 
  3805				 * This is one place where we must "lie" about return status: not
  3806				 * say if the stat() failed. We are doing this as root, and could
  3807				 * be tricked into reporting existence or not of files that the
  3808				 * "plain" user cannot even see.
  3809				 */
  3810				{
  3811				    Stat_t tmpstatbuf;
  3812				    if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0 ||
  3813					tmpstatbuf.st_dev != PL_statbuf.st_dev ||
  3814					tmpstatbuf.st_ino != PL_statbuf.st_ino) {
  3815					Perl_croak(aTHX_ "Setuid script changed\n");
  3816				    }
  3817			
  3818				}
  3819				if (!cando(S_IXUSR,FALSE,&PL_statbuf))		/* can real uid exec? */
  3820				    Perl_croak(aTHX_ "Real UID cannot exec script\n");
  3821			
  3822				/* PSz 27 Feb 04
  3823				 * We used to do this check as the "plain" user (after swapping
  3824				 * UIDs). But the check for nosuid and noexec filesystem is needed,
  3825				 * and should be done even without HAS_SETREUID. (Maybe those
  3826				 * operating systems do not have such mount options anyway...)
  3827				 * Seems safe enough to do as root.
  3828				 */
  3829			#if !defined(NO_NOSUID_CHECK)
  3830				if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp))) {
  3831				    Perl_croak(aTHX_ "Setuid script on nosuid or noexec filesystem\n");
  3832				}
  3833			#endif
  3834			#endif /* IAMSUID */
  3835			
  3836				if (!S_ISREG(PL_statbuf.st_mode)) {
  3837				    Perl_croak(aTHX_ "Setuid script not plain file\n");
  3838				}
  3839				if (PL_statbuf.st_mode & S_IWOTH)
  3840				    Perl_croak(aTHX_ "Setuid/gid script is writable by world");
  3841				PL_doswitches = FALSE;		/* -s is insecure in suid */
  3842				/* PSz 13 Nov 03  But -s was caught elsewhere ... so unsetting it here is useless(?!) */
  3843				CopLINE_inc(PL_curcop);
  3844				linestr = SvPV_nolen_const(PL_linestr);
  3845				if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
  3846				  strnNE(linestr,"#!",2) )	/* required even on Sys V */
  3847				    Perl_croak(aTHX_ "No #! line");
  3848				linestr+=2;
  3849				s = linestr;
  3850				/* PSz 27 Feb 04 */
  3851				/* Sanity check on line length */
  3852				if (strlen(s) < 1 || strlen(s) > 4000)
  3853				    Perl_croak(aTHX_ "Very long #! line");
  3854				/* Allow more than a single space after #! */
  3855				while (isSPACE(*s)) s++;
  3856				/* Sanity check on buffer end */
  3857				while ((*s) && !isSPACE(*s)) s++;
  3858				for (s2 = s;  (s2 > linestr &&
  3859					       (isDIGIT(s2[-1]) || s2[-1] == '.' || s2[-1] == '_'
  3860						|| s2[-1] == '-'));  s2--) ;
  3861				/* Sanity check on buffer start */
  3862				if ( (s2-4 < linestr || strnNE(s2-4,"perl",4)) &&
  3863				      (s-9 < linestr || strnNE(s-9,"perl",4)) )
  3864				    Perl_croak(aTHX_ "Not a perl script");
  3865				while (*s == ' ' || *s == '\t') s++;
  3866				/*
  3867				 * #! arg must be what we saw above.  They can invoke it by
  3868				 * mentioning suidperl explicitly, but they may not add any strange
  3869				 * arguments beyond what #! says if they do invoke suidperl that way.
  3870				 */
  3871				/*
  3872				 * The way validarg was set up, we rely on the kernel to start
  3873				 * scripts with argv[1] set to contain all #! line switches (the
  3874				 * whole line).
  3875				 */
  3876				/*
  3877				 * Check that we got all the arguments listed in the #! line (not
  3878				 * just that there are no extraneous arguments). Might not matter
  3879				 * much, as switches from #! line seem to be acted upon (also), and
  3880				 * so may be checked and trapped in perl. But, security checks must
  3881				 * be done in suidperl and not deferred to perl. Note that suidperl
  3882				 * does not get around to parsing (and checking) the switches on
  3883				 * the #! line (but execs perl sooner).
  3884				 * Allow (require) a trailing newline (which may be of two
  3885				 * characters on some architectures?) (but no other trailing
  3886				 * whitespace).
  3887				 */
  3888				len = strlen(validarg);
  3889				if (strEQ(validarg," PHOOEY ") ||
  3890				    strnNE(s,validarg,len) || !isSPACE(s[len]) ||
  3891				    !(strlen(s) == len+1 || (strlen(s) == len+2 && isSPACE(s[len+1]))))
  3892				    Perl_croak(aTHX_ "Args must match #! line");
  3893			
  3894			#ifndef IAMSUID
  3895				if (PL_fdscript < 0 &&
  3896				    PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
  3897				    PL_euid == PL_statbuf.st_uid)
  3898				    if (!PL_do_undump)
  3899					Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
  3900			FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
  3901			#endif /* IAMSUID */
  3902			
  3903				if (PL_fdscript < 0 &&
  3904				    PL_euid) {	/* oops, we're not the setuid root perl */
  3905				    /* PSz 18 Feb 04
  3906				     * When root runs a setuid script, we do not go through the same
  3907				     * steps of execing sperl and then perl with fd scripts, but
  3908				     * simply set up UIDs within the same perl invocation; so do
  3909				     * not have the same checks (on options, whatever) that we have
  3910				     * for plain users. No problem really: would have to be a script
  3911				     * that does not actually work for plain users; and if root is
  3912				     * foolish and can be persuaded to run such an unsafe script, he
  3913				     * might run also non-setuid ones, and deserves what he gets.
  3914				     * 
  3915				     * Or, we might drop the PL_euid check above (and rely just on
  3916				     * PL_fdscript to avoid loops), and do the execs
  3917				     * even for root.
  3918				     */
  3919			#ifndef IAMSUID
  3920				    int which;
  3921				    /* PSz 11 Nov 03
  3922				     * Pass fd script to suidperl.
  3923				     * Exec suidperl, substituting fd script for scriptname.
  3924				     * Pass script name as "subdir" of fd, which perl will grok;
  3925				     * in fact will use that to distinguish this from "normal"
  3926				     * usage, see comments above.
  3927				     */
  3928				    PerlIO_rewind(PL_rsfp);
  3929				    PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0);  /* just in case rewind didn't */
  3930				    /* PSz 27 Feb 04  Sanity checks on scriptname */
  3931				    if ((!scriptname) || (!*scriptname) ) {
  3932					Perl_croak(aTHX_ "No setuid script name\n");
  3933				    }
  3934				    if (*scriptname == '-') {
  3935					Perl_croak(aTHX_ "Setuid script name may not begin with dash\n");
  3936					/* Or we might confuse it with an option when replacing
  3937					 * name in argument list, below (though we do pointer, not
  3938					 * string, comparisons).
  3939					 */
  3940				    }
  3941				    for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
  3942				    if (!PL_origargv[which]) {
  3943					Perl_croak(aTHX_ "Can't change argv to have fd script\n");
  3944				    }
  3945				    PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
  3946								  PerlIO_fileno(PL_rsfp), PL_origargv[which]));
  3947			#if defined(HAS_FCNTL) && defined(F_SETFD)
  3948				    fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0);	/* ensure no close-on-exec */
  3949			#endif
  3950				    PERL_FPU_PRE_EXEC
  3951				    PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
  3952							     (int)PERL_REVISION, (int)PERL_VERSION,
  3953							     (int)PERL_SUBVERSION), PL_origargv);
  3954				    PERL_FPU_POST_EXEC
  3955			#endif /* IAMSUID */
  3956				    Perl_croak(aTHX_ "Can't do setuid (cannot exec sperl)\n");
  3957				}
  3958			
  3959				if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
  3960			/* PSz 26 Feb 04
  3961			 * This seems back to front: we try HAS_SETEGID first; if not available
  3962			 * then try HAS_SETREGID; as a last chance we try HAS_SETRESGID. May be OK
  3963			 * in the sense that we only want to set EGID; but are there any machines
  3964			 * with either of the latter, but not the former? Same with UID, later.
  3965			 */
  3966			#ifdef HAS_SETEGID
  3967				    (void)setegid(PL_statbuf.st_gid);
  3968			#else
  3969			#ifdef HAS_SETREGID
  3970			           (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
  3971			#else
  3972			#ifdef HAS_SETRESGID
  3973			           (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
  3974			#else
  3975				    PerlProc_setgid(PL_statbuf.st_gid);
  3976			#endif
  3977			#endif
  3978			#endif
  3979				    if (PerlProc_getegid() != PL_statbuf.st_gid)
  3980					Perl_croak(aTHX_ "Can't do setegid!\n");
  3981				}
  3982				if (PL_statbuf.st_mode & S_ISUID) {
  3983				    if (PL_statbuf.st_uid != PL_euid)
  3984			#ifdef HAS_SETEUID
  3985					(void)seteuid(PL_statbuf.st_uid);	/* all that for this */
  3986			#else
  3987			#ifdef HAS_SETREUID
  3988			                (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
  3989			#else
  3990			#ifdef HAS_SETRESUID
  3991			                (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
  3992			#else
  3993					PerlProc_setuid(PL_statbuf.st_uid);
  3994			#endif
  3995			#endif
  3996			#endif
  3997				    if (PerlProc_geteuid() != PL_statbuf.st_uid)
  3998					Perl_croak(aTHX_ "Can't do seteuid!\n");
  3999				}
  4000				else if (PL_uid) {			/* oops, mustn't run as root */
  4001			#ifdef HAS_SETEUID
  4002			          (void)seteuid((Uid_t)PL_uid);
  4003			#else
  4004			#ifdef HAS_SETREUID
  4005			          (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
  4006			#else
  4007			#ifdef HAS_SETRESUID
  4008			          (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
  4009			#else
  4010			          PerlProc_setuid((Uid_t)PL_uid);
  4011			#endif
  4012			#endif
  4013			#endif
  4014				    if (PerlProc_geteuid() != PL_uid)
  4015					Perl_croak(aTHX_ "Can't do seteuid!\n");
  4016				}
  4017				init_ids();
  4018				if (!cando(S_IXUSR,TRUE,&PL_statbuf))
  4019				    Perl_croak(aTHX_ "Effective UID cannot exec script\n");	/* they can't do this */
  4020			    }
  4021			#ifdef IAMSUID
  4022			    else if (PL_preprocess)	/* PSz 13 Nov 03  Caught elsewhere, useless(?!) here */
  4023				Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
  4024			    else if (PL_fdscript < 0 || PL_suidscript != 1)
  4025				/* PSz 13 Nov 03  Caught elsewhere, useless(?!) here */
  4026				Perl_croak(aTHX_ "(suid) fdscript needed in suidperl\n");
  4027			    else {
  4028			/* PSz 16 Sep 03  Keep neat error message */
  4029				Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
  4030			    }
  4031			
  4032			    /* We absolutely must clear out any saved ids here, so we */
  4033			    /* exec the real perl, substituting fd script for scriptname. */
  4034			    /* (We pass script name as "subdir" of fd, which perl will grok.) */
  4035			    /* 
  4036			     * It might be thought that using setresgid and/or setresuid (changed to
  4037			     * set the saved IDs) above might obviate the need to exec, and we could
  4038			     * go on to "do the perl thing".
  4039			     * 
  4040			     * Is there such a thing as "saved GID", and is that set for setuid (but
  4041			     * not setgid) execution like suidperl? Without exec, it would not be
  4042			     * cleared for setuid (but not setgid) scripts (or might need a dummy
  4043			     * setresgid).
  4044			     * 
  4045			     * We need suidperl to do the exact same argument checking that perl
  4046			     * does. Thus it cannot be very small; while it could be significantly
  4047			     * smaller, it is safer (simpler?) to make it essentially the same
  4048			     * binary as perl (but they are not identical). - Maybe could defer that
  4049			     * check to the invoked perl, and suidperl be a tiny wrapper instead;
  4050			     * but prefer to do thorough checks in suidperl itself. Such deferral
  4051			     * would make suidperl security rely on perl, a design no-no.
  4052			     * 
  4053			     * Setuid things should be short and simple, thus easy to understand and
  4054			     * verify. They should do their "own thing", without influence by
  4055			     * attackers. It may help if their internal execution flow is fixed,
  4056			     * regardless of platform: it may be best to exec anyway.
  4057			     * 
  4058			     * Suidperl should at least be conceptually simple: a wrapper only,
  4059			     * never to do any real perl. Maybe we should put
  4060			     * #ifdef IAMSUID
  4061			     *         Perl_croak(aTHX_ "Suidperl should never do real perl\n");
  4062			     * #endif
  4063			     * into the perly bits.
  4064			     */
  4065			    PerlIO_rewind(PL_rsfp);
  4066			    PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0);  /* just in case rewind didn't */
  4067			    /* PSz 11 Nov 03
  4068			     * Keep original arguments: suidperl already has fd script.
  4069			     */
  4070			/*  for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;	*/
  4071			/*  if (!PL_origargv[which]) {						*/
  4072			/*	errno = EPERM;							*/
  4073			/*	Perl_croak(aTHX_ "Permission denied\n");			*/
  4074			/*  }									*/
  4075			/*  PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",	*/
  4076			/*				  PerlIO_fileno(PL_rsfp), PL_origargv[which]));	*/
  4077			#if defined(HAS_FCNTL) && defined(F_SETFD)
  4078			    fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0);	/* ensure no close-on-exec */
  4079			#endif
  4080			    PERL_FPU_PRE_EXEC
  4081			    PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
  4082						     (int)PERL_REVISION, (int)PERL_VERSION,
  4083						     (int)PERL_SUBVERSION), PL_origargv);/* try again */
  4084			    PERL_FPU_POST_EXEC
  4085			    Perl_croak(aTHX_ "Can't do setuid (suidperl cannot exec perl)\n");
  4086			#endif /* IAMSUID */
  4087			#else /* !DOSUID */
  4088	        4500        if (PL_euid != PL_uid || PL_egid != PL_gid) {	/* (suidperl doesn't exist, in fact) */
  4089			#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
  4090	      ######    	PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf);	/* may be either wrapped or real suid */
  4091	      ######    	if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
  4092				    ||
  4093				    (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
  4094				   )
  4095	      ######    	    if (!PL_do_undump)
  4096	      ######    		Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
  4097			FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
  4098			#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
  4099				/* not set-id, must be wrapped */
  4100			    }
  4101			#endif /* DOSUID */
  4102	        4500        (void)validarg;
  4103	        4500        (void)scriptname;
  4104			}
  4105			
  4106			STATIC void
  4107			S_find_beginning(pTHX)
  4108	           7    {
  4109	           7        register char *s;
  4110	           7        register const char *s2;
  4111			#ifdef MACOS_TRADITIONAL
  4112			    int maclines = 0;
  4113			#endif
  4114			
  4115			    /* skip forward in input to the real script? */
  4116			
  4117	           7        forbid_setid("-x");
  4118			#ifdef MACOS_TRADITIONAL
  4119			    /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
  4120			
  4121			    while (PL_doextract || gMacPerl_AlwaysExtract) {
  4122				if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
  4123				    if (!gMacPerl_AlwaysExtract)
  4124					Perl_croak(aTHX_ "No Perl script found in input\n");
  4125			
  4126				    if (PL_doextract)			/* require explicit override ? */
  4127					if (!OverrideExtract(PL_origfilename))
  4128					    Perl_croak(aTHX_ "User aborted script\n");
  4129					else
  4130					    PL_doextract = FALSE;
  4131			
  4132				    /* Pater peccavi, file does not have #! */
  4133				    PerlIO_rewind(PL_rsfp);
  4134			
  4135				    break;
  4136				}
  4137			#else
  4138	         860        while (PL_doextract) {
  4139	         853    	if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
  4140	      ######    	    Perl_croak(aTHX_ "No Perl script found in input\n");
  4141			#endif
  4142	         853    	s2 = s;
  4143	         853    	if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
  4144	           7    	    PerlIO_ungetc(PL_rsfp, '\n');		/* to keep line count right */
  4145	           7    	    PL_doextract = FALSE;
  4146	          35    	    while (*s && !(isSPACE (*s) || *s == '#')) s++;
  4147	           7    	    s2 = s;
  4148	          14    	    while (*s == ' ' || *s == '\t') s++;
  4149	           7    	    if (*s++ == '-') {
  4150	           7    		while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
  4151	      ######    		       || s2[-1] == '_') s2--;
  4152	           7    		if (strnEQ(s2-4,"perl",4))
  4153	          14    		    while ((s = moreswitches(s)))
  4154						;
  4155				    }
  4156			#ifdef MACOS_TRADITIONAL
  4157				    /* We are always searching for the #!perl line in MacPerl,
  4158				     * so if we find it, still keep the line count correct
  4159				     * by counting lines we already skipped over
  4160				     */
  4161				    for (; maclines > 0 ; maclines--)
  4162					PerlIO_ungetc(PL_rsfp, '\n');
  4163			
  4164				    break;
  4165			
  4166				/* gMacPerl_AlwaysExtract is false in MPW tool */
  4167				} else if (gMacPerl_AlwaysExtract) {
  4168				    ++maclines;
  4169			#endif
  4170				}
  4171			    }
  4172			}
  4173			
  4174			
  4175			STATIC void
  4176			S_init_ids(pTHX)
  4177	        4503    {
  4178	        4503        PL_uid = PerlProc_getuid();
  4179	        4503        PL_euid = PerlProc_geteuid();
  4180	        4503        PL_gid = PerlProc_getgid();
  4181	        4503        PL_egid = PerlProc_getegid();
  4182			#ifdef VMS
  4183			    PL_uid |= PL_gid << 16;
  4184			    PL_euid |= PL_egid << 16;
  4185			#endif
  4186			    /* Should not happen: */
  4187	        4503        CHECK_MALLOC_TAINT(PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
  4188	        4503        PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
  4189			    /* BUG */
  4190			    /* PSz 27 Feb 04
  4191			     * Should go by suidscript, not uid!=euid: why disallow
  4192			     * system("ls") in scripts run from setuid things?
  4193			     * Or, is this run before we check arguments and set suidscript?
  4194			     * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
  4195			     * (We never have suidscript, can we be sure to have fdscript?)
  4196			     * Or must then go by UID checks? See comments in forbid_setid also.
  4197			     */
  4198			}
  4199			
  4200			/* This is used very early in the lifetime of the program,
  4201			 * before even the options are parsed, so PL_tainting has
  4202			 * not been initialized properly.  */
  4203			bool
  4204			Perl_doing_taint(int argc, char *argv[], char *envp[])
  4205	      ######    {
  4206			#ifndef PERL_IMPLICIT_SYS
  4207			    /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
  4208			     * before we have an interpreter-- and the whole point of this
  4209			     * function is to be called at such an early stage.  If you are on
  4210			     * a system with PERL_IMPLICIT_SYS but you do have a concept of
  4211			     * "tainted because running with altered effective ids', you'll
  4212			     * have to add your own checks somewhere in here.  The two most
  4213			     * known samples of 'implicitness' are Win32 and NetWare, neither
  4214			     * of which has much of concept of 'uids'. */
  4215	      ######        int uid  = PerlProc_getuid();
  4216	      ######        int euid = PerlProc_geteuid();
  4217	      ######        int gid  = PerlProc_getgid();
  4218	      ######        int egid = PerlProc_getegid();
  4219	      ######        (void)envp;
  4220			
  4221			#ifdef VMS
  4222			    uid  |=  gid << 16;
  4223			    euid |= egid << 16;
  4224			#endif
  4225	      ######        if (uid && (euid != uid || egid != gid))
  4226	      ######    	return 1;
  4227			#endif /* !PERL_IMPLICIT_SYS */
  4228			    /* This is a really primitive check; environment gets ignored only
  4229			     * if -T are the first chars together; otherwise one gets
  4230			     *  "Too late" message. */
  4231	      ######        if ( argc > 1 && argv[1][0] == '-'
  4232			         && (argv[1][1] == 't' || argv[1][1] == 'T') )
  4233	      ######    	return 1;
  4234	      ######        return 0;
  4235			}
  4236			
  4237			STATIC void
  4238			S_forbid_setid(pTHX_ const char *s)
  4239	        6283    {
  4240			#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  4241			    if (PL_euid != PL_uid)
  4242			        Perl_croak(aTHX_ "No %s allowed while running setuid", s);
  4243			    if (PL_egid != PL_gid)
  4244			        Perl_croak(aTHX_ "No %s allowed while running setgid", s);
  4245			#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
  4246			    /* PSz 29 Feb 04
  4247			     * Checks for UID/GID above "wrong": why disallow
  4248			     *   perl -e 'print "Hello\n"'
  4249			     * from within setuid things?? Simply drop them: replaced by
  4250			     * fdscript/suidscript and #ifdef IAMSUID checks below.
  4251			     * 
  4252			     * This may be too late for command-line switches. Will catch those on
  4253			     * the #! line, after finding the script name and setting up
  4254			     * fdscript/suidscript. Note that suidperl does not get around to
  4255			     * parsing (and checking) the switches on the #! line, but checks that
  4256			     * the two sets are identical.
  4257			     * 
  4258			     * With SETUID_SCRIPTS_ARE_SECURE_NOW, could we use fdscript, also or
  4259			     * instead, or would that be "too late"? (We never have suidscript, can
  4260			     * we be sure to have fdscript?)
  4261			     * 
  4262			     * Catch things with suidscript (in descendant of suidperl), even with
  4263			     * right UID/GID. Was already checked in suidperl, with #ifdef IAMSUID,
  4264			     * below; but I am paranoid.
  4265			     * 
  4266			     * Also see comments about root running a setuid script, elsewhere.
  4267			     */
  4268	        6283        if (PL_suidscript >= 0)
  4269	      ######            Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", s);
  4270			#ifdef IAMSUID
  4271			    /* PSz 11 Nov 03  Catch it in suidperl, always! */
  4272			    Perl_croak(aTHX_ "No %s allowed in suidperl", s);
  4273			#endif /* IAMSUID */
  4274			}
  4275			
  4276			void
  4277			Perl_init_debugger(pTHX)
  4278	          10    {
  4279	          10        HV *ostash = PL_curstash;
  4280			
  4281	          10        PL_curstash = PL_debstash;
  4282	          10        PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("DB::args", GV_ADDMULTI, SVt_PVAV))));
  4283	          10        AvREAL_off(PL_dbargs);
  4284	          10        PL_DBgv = gv_fetchpv("DB::DB", GV_ADDMULTI, SVt_PVGV);
  4285	          10        PL_DBline = gv_fetchpv("DB::dbline", GV_ADDMULTI, SVt_PVAV);
  4286	          10        PL_DBsub = gv_HVadd(gv_fetchpv("DB::sub", GV_ADDMULTI, SVt_PVHV));
  4287	          10        PL_DBsingle = GvSV((gv_fetchpv("DB::single", GV_ADDMULTI, SVt_PV)));
  4288	          10        sv_setiv(PL_DBsingle, 0);
  4289	          10        PL_DBtrace = GvSV((gv_fetchpv("DB::trace", GV_ADDMULTI, SVt_PV)));
  4290	          10        sv_setiv(PL_DBtrace, 0);
  4291	          10        PL_DBsignal = GvSV((gv_fetchpv("DB::signal", GV_ADDMULTI, SVt_PV)));
  4292	          10        sv_setiv(PL_DBsignal, 0);
  4293	          10        PL_DBassertion = GvSV((gv_fetchpv("DB::assertion", GV_ADDMULTI, SVt_PV)));
  4294	          10        sv_setiv(PL_DBassertion, 0);
  4295	          10        PL_curstash = ostash;
  4296			}
  4297			
  4298			#ifndef STRESS_REALLOC
  4299			#define REASONABLE(size) (size)
  4300			#else
  4301			#define REASONABLE(size) (1) /* unreasonable */
  4302			#endif
  4303			
  4304			void
  4305			Perl_init_stacks(pTHX)
  4306	        4503    {
  4307			    /* start with 128-item stack and 8K cxstack */
  4308	        4503        PL_curstackinfo = new_stackinfo(REASONABLE(128),
  4309							 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
  4310	        4503        PL_curstackinfo->si_type = PERLSI_MAIN;
  4311	        4503        PL_curstack = PL_curstackinfo->si_stack;
  4312	        4503        PL_mainstack = PL_curstack;		/* remember in case we switch stacks */
  4313			
  4314	        4503        PL_stack_base = AvARRAY(PL_curstack);
  4315	        4503        PL_stack_sp = PL_stack_base;
  4316	        4503        PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
  4317			
  4318	        4503        New(50,PL_tmps_stack,REASONABLE(128),SV*);
  4319	        4503        PL_tmps_floor = -1;
  4320	        4503        PL_tmps_ix = -1;
  4321	        4503        PL_tmps_max = REASONABLE(128);
  4322			
  4323	        4503        New(54,PL_markstack,REASONABLE(32),I32);
  4324	        4503        PL_markstack_ptr = PL_markstack;
  4325	        4503        PL_markstack_max = PL_markstack + REASONABLE(32);
  4326			
  4327	        4503        SET_MARK_OFFSET;
  4328			
  4329	        4503        New(54,PL_scopestack,REASONABLE(32),I32);
  4330	        4503        PL_scopestack_ix = 0;
  4331	        4503        PL_scopestack_max = REASONABLE(32);
  4332			
  4333	        4503        New(54,PL_savestack,REASONABLE(128),ANY);
  4334	        4503        PL_savestack_ix = 0;
  4335	        4503        PL_savestack_max = REASONABLE(128);
  4336			}
  4337			
  4338			#undef REASONABLE
  4339			
  4340			STATIC void
  4341			S_nuke_stacks(pTHX)
  4342	        4549    {
  4343	        6483        while (PL_curstackinfo->si_next)
  4344	        1934    	PL_curstackinfo = PL_curstackinfo->si_next;
  4345	       11032        while (PL_curstackinfo) {
  4346	        6483    	PERL_SI *p = PL_curstackinfo->si_prev;
  4347				/* curstackinfo->si_stack got nuked by sv_free_arenas() */
  4348	        6483    	Safefree(PL_curstackinfo->si_cxstack);
  4349	        6483    	Safefree(PL_curstackinfo);
  4350	        6483    	PL_curstackinfo = p;
  4351			    }
  4352	        4549        Safefree(PL_tmps_stack);
  4353	        4549        Safefree(PL_markstack);
  4354	        4549        Safefree(PL_scopestack);
  4355	        4549        Safefree(PL_savestack);
  4356			}
  4357			
  4358			STATIC void
  4359			S_init_lexer(pTHX)
  4360	        4500    {
  4361	        4500        PerlIO *tmpfp;
  4362	        4500        tmpfp = PL_rsfp;
  4363	        4500        PL_rsfp = Nullfp;
  4364	        4500        lex_start(PL_linestr);
  4365	        4500        PL_rsfp = tmpfp;
  4366	        4500        PL_subname = newSVpvn("main",4);
  4367			}
  4368			
  4369			STATIC void
  4370			S_init_predump_symbols(pTHX)
  4371	        4500    {
  4372	        4500        GV *tmpgv;
  4373	        4500        IO *io;
  4374			
  4375	        4500        sv_setpvn(get_sv("\"", TRUE), " ", 1);
  4376	        4500        PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
  4377	        4500        GvMULTI_on(PL_stdingv);
  4378	        4500        io = GvIOp(PL_stdingv);
  4379	        4500        IoTYPE(io) = IoTYPE_RDONLY;
  4380	        4500        IoIFP(io) = PerlIO_stdin();
  4381	        4500        tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
  4382	        4500        GvMULTI_on(tmpgv);
  4383	        4500        GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
  4384			
  4385	        4500        tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
  4386	        4500        GvMULTI_on(tmpgv);
  4387	        4500        io = GvIOp(tmpgv);
  4388	        4500        IoTYPE(io) = IoTYPE_WRONLY;
  4389	        4500        IoOFP(io) = IoIFP(io) = PerlIO_stdout();
  4390	        4500        setdefout(tmpgv);
  4391	        4500        tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
  4392	        4500        GvMULTI_on(tmpgv);
  4393	        4500        GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
  4394			
  4395	        4500        PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
  4396	        4500        GvMULTI_on(PL_stderrgv);
  4397	        4500        io = GvIOp(PL_stderrgv);
  4398	        4500        IoTYPE(io) = IoTYPE_WRONLY;
  4399	        4500        IoOFP(io) = IoIFP(io) = PerlIO_stderr();
  4400	        4500        tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
  4401	        4500        GvMULTI_on(tmpgv);
  4402	        4500        GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
  4403			
  4404	        4500        PL_statname = NEWSV(66,0);		/* last filename we did stat on */
  4405			
  4406	        4500        Safefree(PL_osname);
  4407	        4500        PL_osname = savepv(OSNAME);
  4408			}
  4409			
  4410			void
  4411			Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
  4412	        4501    {
  4413	        4501        char *s;
  4414	        4501        argc--,argv++;	/* skip name of script */
  4415	        4501        if (PL_doswitches) {
  4416	           8    	for (; argc > 0 && **argv == '-'; argc--,argv++) {
  4417	           3    	    if (!argv[0][1])
  4418	      ######    		break;
  4419	           3    	    if (argv[0][1] == '-' && !argv[0][2]) {
  4420	      ######    		argc--,argv++;
  4421	      ######    		break;
  4422				    }
  4423	           3    	    if ((s = strchr(argv[0], '='))) {
  4424	           2    		*s++ = '\0';
  4425	           2    		sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
  4426				    }
  4427				    else
  4428	           1    		sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
  4429				}
  4430			    }
  4431	        4501        if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
  4432	        4501    	GvMULTI_on(PL_argvgv);
  4433	        4501    	(void)gv_AVadd(PL_argvgv);
  4434	        4501    	av_clear(GvAVn(PL_argvgv));
  4435	        8267    	for (; argc > 0; argc--,argv++) {
  4436	        1883    	    SV *sv = newSVpv(argv[0],0);
  4437	        1883    	    av_push(GvAVn(PL_argvgv),sv);
  4438	        1883    	    if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
  4439	        1883    		 if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
  4440	           1    		      SvUTF8_on(sv);
  4441				    }
  4442	        1883    	    if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
  4443	      ######    		 (void)sv_utf8_decode(sv);
  4444				}
  4445			    }
  4446			}
  4447			
  4448			STATIC void
  4449			S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
  4450	        4500    {
  4451			    dVAR;
  4452	        4500        GV* tmpgv;
  4453			
  4454	        4500        PL_toptarget = NEWSV(0,0);
  4455	        4500        sv_upgrade(PL_toptarget, SVt_PVFM);
  4456	        4500        sv_setpvn(PL_toptarget, "", 0);
  4457	        4500        PL_bodytarget = NEWSV(0,0);
  4458	        4500        sv_upgrade(PL_bodytarget, SVt_PVFM);
  4459	        4500        sv_setpvn(PL_bodytarget, "", 0);
  4460	        4500        PL_formtarget = PL_bodytarget;
  4461			
  4462	        4500        TAINT;
  4463			
  4464	        4500        init_argv_symbols(argc,argv);
  4465			
  4466	        4500        if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
  4467			#ifdef MACOS_TRADITIONAL
  4468				/* $0 is not majick on a Mac */
  4469				sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
  4470			#else
  4471	        4500    	sv_setpv(GvSV(tmpgv),PL_origfilename);
  4472	        4500    	magicname("0", "0", 1);
  4473			#endif
  4474			    }
  4475	        4500        if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
  4476	        4500    	HV *hv;
  4477	        4500    	GvMULTI_on(PL_envgv);
  4478	        4500    	hv = GvHVn(PL_envgv);
  4479	        4500    	hv_magic(hv, Nullgv, PERL_MAGIC_env);
  4480			#ifndef PERL_MICRO
  4481			#ifdef USE_ENVIRON_ARRAY
  4482				/* Note that if the supplied env parameter is actually a copy
  4483				   of the global environ then it may now point to free'd memory
  4484				   if the environment has been modified since. To avoid this
  4485				   problem we treat env==NULL as meaning 'use the default'
  4486				*/
  4487	        4500    	if (!env)
  4488	        4499    	    env = environ;
  4489	        4500    	if (env != environ
  4490			#  ifdef USE_ITHREADS
  4491				    && PL_curinterp == aTHX
  4492			#  endif
  4493				   )
  4494				{
  4495	      ######    	    environ[0] = Nullch;
  4496				}
  4497	        4500    	if (env) {
  4498	        4500              char** origenv = environ;
  4499	      219184    	  char *s;
  4500	      219184    	  SV *sv;
  4501	      433868    	  for (; *env; env++) {
  4502	      214684    	    if (!(s = strchr(*env,'=')) || s == *env)
  4503	      214684    		continue;
  4504			#if defined(MSDOS) && !defined(DJGPP)
  4505				    *s = '\0';
  4506				    (void)strupr(*env);
  4507				    *s = '=';
  4508			#endif
  4509	      214684    	    sv = newSVpv(s+1, 0);
  4510	      214684    	    (void)hv_store(hv, *env, s - *env, sv, 0);
  4511	      214684    	    if (env != environ)
  4512	      210184    	        mg_set(sv);
  4513	      214684    	    if (origenv != environ) {
  4514				      /* realloc has shifted us */
  4515	      ######    	      env = (env - origenv) + environ;
  4516	      ######    	      origenv = environ;
  4517				    }
  4518				  }
  4519			      }
  4520			#endif /* USE_ENVIRON_ARRAY */
  4521			#endif /* !PERL_MICRO */
  4522			    }
  4523	        4500        TAINT_NOT;
  4524	        4500        if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
  4525	        4500            SvREADONLY_off(GvSV(tmpgv));
  4526	        4500    	sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
  4527	        4500            SvREADONLY_on(GvSV(tmpgv));
  4528			    }
  4529			#ifdef THREADS_HAVE_PIDS
  4530			    PL_ppid = (IV)getppid();
  4531			#endif
  4532			
  4533			    /* touch @F array to prevent spurious warnings 20020415 MJD */
  4534	        4500        if (PL_minus_a) {
  4535	           4          (void) get_av("main::F", TRUE | GV_ADDMULTI);
  4536			    }
  4537			    /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */
  4538	        4500        (void) get_av("main::-", TRUE | GV_ADDMULTI);
  4539	        4500        (void) get_av("main::+", TRUE | GV_ADDMULTI);
  4540			}
  4541			
  4542			STATIC void
  4543			S_init_perllib(pTHX)
  4544	        4500    {
  4545	        4500        char *s;
  4546	        4500        if (!PL_tainting) {
  4547			#ifndef VMS
  4548	        4456    	s = PerlEnv_getenv("PERL5LIB");
  4549	        4456    	if (s)
  4550	        3878    	    incpush(s, TRUE, TRUE, TRUE, FALSE);
  4551				else
  4552	         578    	    incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE, FALSE);
  4553			#else /* VMS */
  4554				/* Treat PERL5?LIB as a possible search list logical name -- the
  4555				 * "natural" VMS idiom for a Unix path string.  We allow each
  4556				 * element to be a set of |-separated directories for compatibility.
  4557				 */
  4558				char buf[256];
  4559				int idx = 0;
  4560				if (my_trnlnm("PERL5LIB",buf,0))
  4561				    do { incpush(buf,TRUE,TRUE,TRUE,FALSE); } while (my_trnlnm("PERL5LIB",buf,++idx));
  4562				else
  4563				    while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE,TRUE,FALSE);
  4564			#endif /* VMS */
  4565			    }
  4566			
  4567			/* Use the ~-expanded versions of APPLLIB (undocumented),
  4568			    ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
  4569			*/
  4570			#ifdef APPLLIB_EXP
  4571			    incpush(APPLLIB_EXP, TRUE, TRUE, TRUE, TRUE);
  4572			#endif
  4573			
  4574			#ifdef ARCHLIB_EXP
  4575	        4500        incpush(ARCHLIB_EXP, FALSE, FALSE, TRUE, TRUE);
  4576			#endif
  4577			#ifdef MACOS_TRADITIONAL
  4578			    {
  4579				Stat_t tmpstatbuf;
  4580			    	SV * privdir = NEWSV(55, 0);
  4581				char * macperl = PerlEnv_getenv("MACPERL");
  4582				
  4583				if (!macperl)
  4584				    macperl = "";
  4585				
  4586				Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
  4587				if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
  4588				    incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE);
  4589				Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
  4590				if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
  4591				    incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE);
  4592				
  4593			   	SvREFCNT_dec(privdir);
  4594			    }
  4595			    if (!PL_tainting)
  4596				incpush(":", FALSE, FALSE, TRUE, FALSE);
  4597			#else
  4598			#ifndef PRIVLIB_EXP
  4599			#  define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
  4600			#endif
  4601			#if defined(WIN32)
  4602			    incpush(PRIVLIB_EXP, TRUE, FALSE, TRUE, TRUE);
  4603			#else
  4604	        4500        incpush(PRIVLIB_EXP, FALSE, FALSE, TRUE, TRUE);
  4605			#endif
  4606			
  4607			#ifdef SITEARCH_EXP
  4608			    /* sitearch is always relative to sitelib on Windows for
  4609			     * DLL-based path intuition to work correctly */
  4610			#  if !defined(WIN32)
  4611	        4500        incpush(SITEARCH_EXP, FALSE, FALSE, TRUE, TRUE);
  4612			#  endif
  4613			#endif
  4614			
  4615			#ifdef SITELIB_EXP
  4616			#  if defined(WIN32)
  4617			    /* this picks up sitearch as well */
  4618			    incpush(SITELIB_EXP, TRUE, FALSE, TRUE, TRUE);
  4619			#  else
  4620	        4500        incpush(SITELIB_EXP, FALSE, FALSE, TRUE, TRUE);
  4621			#  endif
  4622			#endif
  4623			
  4624			#ifdef SITELIB_STEM /* Search for version-specific dirs below here */
  4625	        4500        incpush(SITELIB_STEM, FALSE, TRUE, TRUE, TRUE);
  4626			#endif
  4627			
  4628			#ifdef PERL_VENDORARCH_EXP
  4629			    /* vendorarch is always relative to vendorlib on Windows for
  4630			     * DLL-based path intuition to work correctly */
  4631			#  if !defined(WIN32)
  4632			    incpush(PERL_VENDORARCH_EXP, FALSE, FALSE, TRUE, TRUE);
  4633			#  endif
  4634			#endif
  4635			
  4636			#ifdef PERL_VENDORLIB_EXP
  4637			#  if defined(WIN32)
  4638			    incpush(PERL_VENDORLIB_EXP, TRUE, FALSE, TRUE, TRUE);	/* this picks up vendorarch as well */
  4639			#  else
  4640			    incpush(PERL_VENDORLIB_EXP, FALSE, FALSE, TRUE, TRUE);
  4641			#  endif
  4642			#endif
  4643			
  4644			#ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
  4645			    incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE, TRUE);
  4646			#endif
  4647			
  4648			#ifdef PERL_OTHERLIBDIRS
  4649			    incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE, TRUE);
  4650			#endif
  4651			
  4652	        4500        if (!PL_tainting)
  4653	        4456    	incpush(".", FALSE, FALSE, TRUE, FALSE);
  4654			#endif /* MACOS_TRADITIONAL */
  4655			}
  4656			
  4657			#if defined(DOSISH) || defined(EPOC) || defined(SYMBIAN)
  4658			#    define PERLLIB_SEP ';'
  4659			#else
  4660			#  if defined(VMS)
  4661			#    define PERLLIB_SEP '|'
  4662			#  else
  4663			#    if defined(MACOS_TRADITIONAL)
  4664			#      define PERLLIB_SEP ','
  4665			#    else
  4666			#      define PERLLIB_SEP ':'
  4667			#    endif
  4668			#  endif
  4669			#endif
  4670			#ifndef PERLLIB_MANGLE
  4671			#  define PERLLIB_MANGLE(s,n) (s)
  4672			#endif
  4673			
  4674			/* Push a directory onto @INC if it exists.
  4675			   Generate a new SV if we do this, to save needing to copy the SV we push
  4676			   onto @INC  */
  4677			STATIC SV *
  4678			S_incpush_if_exists(pTHX_ SV *dir)
  4679	       17430    {
  4680	       17430        Stat_t tmpstatbuf;
  4681	       17430        if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
  4682				S_ISDIR(tmpstatbuf.st_mode)) {
  4683	      ######    	av_push(GvAVn(PL_incgv), dir);
  4684	      ######    	dir = NEWSV(0,0);
  4685			    }
  4686	       17430        return dir;
  4687			}
  4688			
  4689			STATIC void
  4690			S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep,
  4691				  bool canrelocate)
  4692	       34218    {
  4693	       34218        SV *subdir = Nullsv;
  4694	       34218        const char *p = dir;
  4695			
  4696	       34218        if (!p || !*p)
  4697	        1125    	return;
  4698			
  4699	       32517        if (addsubdirs || addoldvers) {
  4700	       10059    	subdir = NEWSV(0,0);
  4701			    }
  4702			
  4703			    /* Break at all separators */
  4704	       65287        while (p && *p) {
  4705	       32770    	SV *libdir = NEWSV(55,0);
  4706	       32770            const char *s;
  4707			
  4708				/* skip any consecutive separators */
  4709	       32770    	if (usesep) {
  4710	       29964    	    while ( *p == PERLLIB_SEP ) {
  4711					/* Uncomment the next line for PATH semantics */
  4712					/* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
  4713	      ######    		p++;
  4714				    }
  4715				}
  4716			
  4717	       32770    	if ( usesep && (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
  4718	         253    	    sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
  4719					      (STRLEN)(s - p));
  4720	         253    	    p = s + 1;
  4721				}
  4722				else {
  4723	       32517    	    sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
  4724	       32517    	    p = Nullch;	/* break out */
  4725				}
  4726			#ifdef MACOS_TRADITIONAL
  4727				if (!strchr(SvPVX(libdir), ':')) {
  4728				    char buf[256];
  4729			
  4730				    sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
  4731				}
  4732				if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
  4733				    sv_catpv(libdir, ":");
  4734			#endif
  4735			
  4736				/* Do the if() outside the #ifdef to avoid warnings about an unused
  4737				   parameter.  */
  4738	       32770    	if (canrelocate) {
  4739			#ifdef PERL_RELOCATABLE_INC
  4740				/*
  4741				 * Relocatable include entries are marked with a leading .../
  4742				 *
  4743				 * The algorithm is
  4744				 * 0: Remove that leading ".../"
  4745				 * 1: Remove trailing executable name (anything after the last '/')
  4746				 *    from the perl path to give a perl prefix
  4747				 * Then
  4748				 * While the @INC element starts "../" and the prefix ends with a real
  4749				 * directory (ie not . or ..) chop that real directory off the prefix
  4750				 * and the leading "../" from the @INC element. ie a logical "../"
  4751				 * cleanup
  4752				 * Finally concatenate the prefix and the remainder of the @INC element
  4753				 * The intent is that /usr/local/bin/perl and .../../lib/perl5
  4754				 * generates /usr/local/lib/perl5
  4755				 */
  4756	       22500    	    char *libpath = SvPVX(libdir);
  4757	       22500    	    STRLEN libpath_len = SvCUR(libdir);
  4758	       22500    	    if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) {
  4759					/* Game on!  */
  4760	      ######    		SV *caret_X = get_sv("\030", 0);
  4761					/* Going to use the SV just as a scratch buffer holding a C
  4762					   string:  */
  4763	      ######    		SV *prefix_sv;
  4764	      ######    		char *prefix;
  4765	      ######    		char *lastslash;
  4766			
  4767					/* $^X is *the* source of taint if tainting is on, hence
  4768					   SvPOK() won't be true.  */
  4769	      ######    		assert(caret_X);
  4770	      ######    		assert(SvPOKp(caret_X));
  4771	      ######    		prefix_sv = newSVpvn(SvPVX(caret_X), SvCUR(caret_X));
  4772					/* Firstly take off the leading .../
  4773					   If all else fail we'll do the paths relative to the current
  4774					   directory.  */
  4775	      ######    		sv_chop(libdir, libpath + 4);
  4776					/* Don't use SvPV as we're intentionally bypassing taining,
  4777					   mortal copies that the mg_get of tainting creates, and
  4778					   corruption that seems to come via the save stack.
  4779					   I guess that the save stack isn't correctly set up yet.  */
  4780	      ######    		libpath = SvPVX(libdir);
  4781	      ######    		libpath_len = SvCUR(libdir);
  4782			
  4783					/* This would work more efficiently with memrchr, but as it's
  4784					   only a GNU extension we'd need to probe for it and
  4785					   implement our own. Not hard, but maybe not worth it?  */
  4786			
  4787	      ######    		prefix = SvPVX(prefix_sv);
  4788	      ######    		lastslash = strrchr(prefix, '/');
  4789			
  4790					/* First time in with the *lastslash = '\0' we just wipe off
  4791					   the trailing /perl from (say) /usr/foo/bin/perl
  4792					*/
  4793	      ######    		if (lastslash) {
  4794	      ######    		    SV *tempsv;
  4795	      ######    		    while ((*lastslash = '\0'), /* Do that, come what may.  */
  4796						   (libpath_len >= 3 && memEQ(libpath, "../", 3)
  4797						    && (lastslash = strrchr(prefix, '/')))) {
  4798	      ######    			if (lastslash[1] == '\0'
  4799						    || (lastslash[1] == '.'
  4800							&& (lastslash[2] == '/' /* ends "/."  */
  4801							    || (lastslash[2] == '/'
  4802								&& lastslash[3] == '/' /* or "/.."  */
  4803								)))) {
  4804						    /* Prefix ends "/" or "/." or "/..", any of which
  4805						       are fishy, so don't do any more logical cleanup.
  4806						    */
  4807	      ######    			    break;
  4808						}
  4809						/* Remove leading "../" from path  */
  4810	      ######    			libpath += 3;
  4811	      ######    			libpath_len -= 3;
  4812						/* Next iteration round the loop removes the last
  4813						   directory name from prefix by writing a '\0' in
  4814						   the while clause.  */
  4815					    }
  4816					    /* prefix has been terminated with a '\0' to the correct
  4817					       length. libpath points somewhere into the libdir SV.
  4818					       We need to join the 2 with '/' and drop the result into
  4819					       libdir.  */
  4820	      ######    		    tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath);
  4821	      ######    		    SvREFCNT_dec(libdir);
  4822					    /* And this is the new libdir.  */
  4823	      ######    		    libdir = tempsv;
  4824	      ######    		    if (PL_tainting &&
  4825						(PL_uid != PL_euid || PL_gid != PL_egid)) {
  4826						/* Need to taint reloccated paths if running set ID  */
  4827	      ######    			SvTAINTED_on(libdir);
  4828					    }
  4829					}
  4830	      ######    		SvREFCNT_dec(prefix_sv);
  4831				    }
  4832			#endif
  4833				}
  4834				/*
  4835				 * BEFORE pushing libdir onto @INC we may first push version- and
  4836				 * archname-specific sub-directories.
  4837				 */
  4838	       32770    	if (addsubdirs || addoldvers) {
  4839			#ifdef PERL_INC_VERSION_LIST
  4840				    /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
  4841	       10310    	    const char *incverlist[] = { PERL_INC_VERSION_LIST };
  4842	       10310    	    const char **incver;
  4843			#endif
  4844			#ifdef VMS
  4845				    char *unix;
  4846				    STRLEN len;
  4847			
  4848				    if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
  4849					len = strlen(unix);
  4850					while (unix[len-1] == '/') len--;  /* Cosmetic */
  4851					sv_usepvn(libdir,unix,len);
  4852				    }
  4853				    else
  4854					PerlIO_printf(Perl_error_log,
  4855					              "Failed to unixify @INC element \"%s\"\n",
  4856						      SvPV(libdir,len));
  4857			#endif
  4858	       10310    	    if (addsubdirs) {
  4859			#ifdef MACOS_TRADITIONAL
  4860			#define PERL_AV_SUFFIX_FMT	""
  4861			#define PERL_ARCH_FMT 		"%s:"
  4862			#define PERL_ARCH_FMT_PATH	PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
  4863			#else
  4864			#define PERL_AV_SUFFIX_FMT 	"/"
  4865			#define PERL_ARCH_FMT 		"/%s"
  4866			#define PERL_ARCH_FMT_PATH	PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
  4867			#endif
  4868					/* .../version/archname if -d .../version/archname */
  4869	        5810    		Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
  4870							libdir,
  4871						       (int)PERL_REVISION, (int)PERL_VERSION,
  4872						       (int)PERL_SUBVERSION, ARCHNAME);
  4873	        5810    		subdir = S_incpush_if_exists(aTHX_ subdir);
  4874			
  4875					/* .../version if -d .../version */
  4876	        5810    		Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
  4877						       (int)PERL_REVISION, (int)PERL_VERSION,
  4878						       (int)PERL_SUBVERSION);
  4879	        5810    		subdir = S_incpush_if_exists(aTHX_ subdir);
  4880			
  4881					/* .../archname if -d .../archname */
  4882	        5810    		Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
  4883	        5810    		subdir = S_incpush_if_exists(aTHX_ subdir);
  4884			
  4885				    }
  4886			
  4887			#ifdef PERL_INC_VERSION_LIST
  4888	       10310    	    if (addoldvers) {
  4889	       10310    		for (incver = incverlist; *incver; incver++) {
  4890					    /* .../xxx if -d .../xxx */
  4891	      ######    		    Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
  4892	      ######    		    subdir = S_incpush_if_exists(aTHX_ subdir);
  4893					}
  4894				    }
  4895			#endif
  4896				}
  4897			
  4898				/* finally push this lib directory on the end of @INC */
  4899	       32770    	av_push(GvAVn(PL_incgv), libdir);
  4900			    }
  4901	       32517        if (subdir) {
  4902	       10059    	assert (SvREFCNT(subdir) == 1);
  4903	       10059    	SvREFCNT_dec(subdir);
  4904			    }
  4905			}
  4906			
  4907			#ifdef USE_5005THREADS
  4908			STATIC struct perl_thread *
  4909			S_init_main_thread(pTHX)
  4910			{
  4911			#if !defined(PERL_IMPLICIT_CONTEXT)
  4912			    struct perl_thread *thr;
  4913			#endif
  4914			    XPV *xpv;
  4915			
  4916			    Newz(53, thr, 1, struct perl_thread);
  4917			    PL_curcop = &PL_compiling;
  4918			    thr->interp = PERL_GET_INTERP;
  4919			    thr->cvcache = newHV();
  4920			    thr->threadsv = newAV();
  4921			    /* thr->threadsvp is set when find_threadsv is called */
  4922			    thr->specific = newAV();
  4923			    thr->flags = THRf_R_JOINABLE;
  4924			    MUTEX_INIT(&thr->mutex);
  4925			    /* Handcraft thrsv similarly to mess_sv */
  4926			    New(53, PL_thrsv, 1, SV);
  4927			    Newz(53, xpv, 1, XPV);
  4928			    SvFLAGS(PL_thrsv) = SVt_PV;
  4929			    SvANY(PL_thrsv) = (void*)xpv;
  4930			    SvREFCNT(PL_thrsv) = 1 << 30;	/* practically infinite */
  4931			    SvPV_set(PL_thrsvr, (char*)thr);
  4932			    SvCUR_set(PL_thrsv, sizeof(thr));
  4933			    SvLEN_set(PL_thrsv, sizeof(thr));
  4934			    *SvEND(PL_thrsv) = '\0';	/* in the trailing_nul field */
  4935			    thr->oursv = PL_thrsv;
  4936			    PL_chopset = " \n-";
  4937			    PL_dumpindent = 4;
  4938			
  4939			    MUTEX_LOCK(&PL_threads_mutex);
  4940			    PL_nthreads++;
  4941			    thr->tid = 0;
  4942			    thr->next = thr;
  4943			    thr->prev = thr;
  4944			    thr->thr_done = 0;
  4945			    MUTEX_UNLOCK(&PL_threads_mutex);
  4946			
  4947			#ifdef HAVE_THREAD_INTERN
  4948			    Perl_init_thread_intern(thr);
  4949			#endif
  4950			
  4951			#ifdef SET_THREAD_SELF
  4952			    SET_THREAD_SELF(thr);
  4953			#else
  4954			    thr->self = pthread_self();
  4955			#endif /* SET_THREAD_SELF */
  4956			    PERL_SET_THX(thr);
  4957			
  4958			    /*
  4959			     * These must come after the thread self setting
  4960			     * because sv_setpvn does SvTAINT and the taint
  4961			     * fields thread selfness being set.
  4962			     */
  4963			    PL_toptarget = NEWSV(0,0);
  4964			    sv_upgrade(PL_toptarget, SVt_PVFM);
  4965			    sv_setpvn(PL_toptarget, "", 0);
  4966			    PL_bodytarget = NEWSV(0,0);
  4967			    sv_upgrade(PL_bodytarget, SVt_PVFM);
  4968			    sv_setpvn(PL_bodytarget, "", 0);
  4969			    PL_formtarget = PL_bodytarget;
  4970			    thr->errsv = newSVpvn("", 0);
  4971			    (void) find_threadsv("@");	/* Ensure $@ is initialised early */
  4972			
  4973			    PL_maxscream = -1;
  4974			    PL_peepp = MEMBER_TO_FPTR(Perl_peep);
  4975			    PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
  4976			    PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
  4977			    PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
  4978			    PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
  4979			    PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
  4980			    PL_regindent = 0;
  4981			    PL_reginterp_cnt = 0;
  4982			
  4983			    return thr;
  4984			}
  4985			#endif /* USE_5005THREADS */
  4986			
  4987			void
  4988			Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
  4989	       78708    {
  4990			    dVAR;
  4991	       78708        SV *atsv;
  4992	       78708        const line_t oldline = CopLINE(PL_curcop);
  4993	      157508        CV *cv;
  4994	      157508        STRLEN len;
  4995	      157508        int ret;
  4996	      157508        dJMPENV;
  4997			
  4998	      157508        while (av_len(paramList) >= 0) {
  4999	       78992    	cv = (CV*)av_shift(paramList);
  5000	       78992    	if (PL_savebegin) {
  5001	        1062    	    if (paramList == PL_beginav) {
  5002					/* save PL_beginav for compiler */
  5003	         977    		if (! PL_beginav_save)
  5004	          79    		    PL_beginav_save = newAV();
  5005	         977    		av_push(PL_beginav_save, (SV*)cv);
  5006				    }
  5007	          85    	    else if (paramList == PL_checkav) {
  5008					/* save PL_checkav for compiler */
  5009	          85    		if (! PL_checkav_save)
  5010	          79    		    PL_checkav_save = newAV();
  5011	          85    		av_push(PL_checkav_save, (SV*)cv);
  5012				    }
  5013				} else {
  5014	       77930    	    SAVEFREESV(cv);
  5015				}
  5016	       78992    	JMPENV_PUSH(ret);
  5017	       79049    	switch (ret) {
  5018				case 0:
  5019	       78992    	    call_list_body(cv);
  5020	       78937    	    atsv = ERRSV;
  5021	       78937    	    (void)SvPV_const(atsv, len);
  5022	       78937    	    if (len) {
  5023	         137    		PL_curcop = &PL_compiling;
  5024	         137    		CopLINE_set(PL_curcop, oldline);
  5025	         137    		if (paramList == PL_beginav)
  5026	         136    		    sv_catpv(atsv, "BEGIN failed--compilation aborted");
  5027					else
  5028	           1    		    Perl_sv_catpvf(aTHX_ atsv,
  5029							   "%s failed--call queue aborted",
  5030							   paramList == PL_checkav ? "CHECK"
  5031							   : paramList == PL_initav ? "INIT"
  5032							   : "END");
  5033	         273    		while (PL_scopestack_ix > oldscope)
  5034	         136    		    LEAVE;
  5035	         137    		JMPENV_POP;
  5036	         137    		Perl_croak(aTHX_ "%"SVf"", atsv);
  5037				    }
  5038	      ######    	    break;
  5039				case 1:
  5040	      ######    	    STATUS_ALL_FAILURE;
  5041				    /* FALL THROUGH */
  5042				case 2:
  5043				    /* my_exit() was called */
  5044	         161    	    while (PL_scopestack_ix > oldscope)
  5045	         104    		LEAVE;
  5046	          57    	    FREETMPS;
  5047	          57    	    PL_curstash = PL_defstash;
  5048	          57    	    PL_curcop = &PL_compiling;
  5049	          57    	    CopLINE_set(PL_curcop, oldline);
  5050	          57    	    JMPENV_POP;
  5051	          57    	    if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
  5052	      ######    		if (paramList == PL_beginav)
  5053	      ######    		    Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
  5054					else
  5055	      ######    		    Perl_croak(aTHX_ "%s failed--call queue aborted",
  5056						       paramList == PL_checkav ? "CHECK"
  5057						       : paramList == PL_initav ? "INIT"
  5058						       : "END");
  5059				    }
  5060	          57    	    my_exit_jump();
  5061				    /* NOTREACHED */
  5062				case 3:
  5063	      ######    	    if (PL_restartop) {
  5064	      ######    		PL_curcop = &PL_compiling;
  5065	      ######    		CopLINE_set(PL_curcop, oldline);
  5066	      ######    		JMPENV_JUMP(3);
  5067				    }
  5068	      ######    	    PerlIO_printf(Perl_error_log, "panic: restartop\n");
  5069	      ######    	    FREETMPS;
  5070				    break;
  5071				}
  5072	       78800    	JMPENV_POP;
  5073			    }
  5074			}
  5075			
  5076			STATIC void *
  5077			S_call_list_body(pTHX_ CV *cv)
  5078	       78992    {
  5079	       78992        PUSHMARK(PL_stack_sp);
  5080	       78992        call_sv((SV*)cv, G_EVAL|G_DISCARD);
  5081	       78937        return NULL;
  5082			}
  5083			
  5084			void
  5085			Perl_my_exit(pTHX_ U32 status)
  5086	        4434    {
  5087			    DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
  5088						  thr, (unsigned long) status));
  5089	        4434        switch (status) {
  5090			    case 0:
  5091	        4417    	STATUS_ALL_SUCCESS;
  5092	        4417    	break;
  5093			    case 1:
  5094	           9    	STATUS_ALL_FAILURE;
  5095	           9    	break;
  5096			    default:
  5097	           8    	STATUS_NATIVE_SET(status);
  5098	        4434    	break;
  5099			    }
  5100	        4434        my_exit_jump();
  5101			}
  5102			
  5103			void
  5104			Perl_my_failure_exit(pTHX)
  5105	         173    {
  5106			#ifdef VMS
  5107			    if (vaxc$errno & 1) {
  5108				if (STATUS_NATIVE & 1)		/* fortuitiously includes "-1" */
  5109				    STATUS_NATIVE_SET(44);
  5110			    }
  5111			    else {
  5112				if (!vaxc$errno)		/* unlikely */
  5113				    STATUS_NATIVE_SET(44);
  5114				else
  5115				    STATUS_NATIVE_SET(vaxc$errno);
  5116			    }
  5117			#else
  5118	         173        int exitstatus;
  5119	         173        if (errno & 255)
  5120	          51    	STATUS_UNIX_SET(errno);
  5121			    else {
  5122	         122    	exitstatus = STATUS_UNIX >> 8;
  5123	         122    	if (exitstatus & 255)
  5124	           3    	    STATUS_UNIX_SET(exitstatus);
  5125				else
  5126	         119    	    STATUS_UNIX_SET(255);
  5127			    }
  5128			#endif
  5129	         173        my_exit_jump();
  5130			}
  5131			
  5132			STATIC void
  5133			S_my_exit_jump(pTHX)
  5134	        4722    {
  5135			    dVAR;
  5136	        4722        register PERL_CONTEXT *cx;
  5137	        4722        I32 gimme;
  5138	        4722        SV **newsp;
  5139			
  5140	        4722        if (PL_e_script) {
  5141	           6    	SvREFCNT_dec(PL_e_script);
  5142	           6    	PL_e_script = Nullsv;
  5143			    }
  5144			
  5145	        4722        POPSTACK_TO(PL_mainstack);
  5146	        4722        if (cxstack_ix >= 0) {
  5147	         433    	if (cxstack_ix > 0)
  5148	         241    	    dounwind(0);
  5149	         433    	POPBLOCK(cx,PL_curpm);
  5150	         433    	LEAVE;
  5151			    }
  5152			
  5153	        4722        JMPENV_JUMP(2);
  5154			    PERL_UNUSED_VAR(gimme);
  5155			    PERL_UNUSED_VAR(newsp);
  5156			}
  5157			
  5158			static I32
  5159			read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
  5160	        4118    {
  5161	        4118        const char * const p  = SvPVX_const(PL_e_script);
  5162	        4118        const char *nl = strchr(p, '\n');
  5163			
  5164	        4118        PERL_UNUSED_ARG(idx);
  5165	        4118        PERL_UNUSED_ARG(maxlen);
  5166			
  5167	        4118        nl = (nl) ? nl+1 : SvEND(PL_e_script);
  5168	        4118        if (nl-p == 0) {
  5169	        2032    	filter_del(read_e_script);
  5170	        2032    	return 0;
  5171			    }
  5172	        2086        sv_catpvn(buf_sv, p, nl-p);
  5173	        2086        sv_chop(PL_e_script, nl);
  5174	        2086        return 1;
  5175			}
  5176			
  5177			/*
  5178			 * Local variables:
  5179			 * c-indentation-style: bsd
  5180			 * c-basic-offset: 4
  5181			 * indent-tabs-mode: t
  5182			 * End:
  5183			 *
  5184			 * ex: set ts=8 sts=4 sw=4 noet:
  5185			 */