3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
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.
12 * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
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
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.
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.
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.
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?)
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).
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
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
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
68 * Use truthful, neat, specific error messages.
69 * Cannot always hide the truth; security must not depend on doing so.
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...)
81 #define PERL_IN_PERL_C
83 #include "patchlevel.h" /* for local_patches */
87 char *nw_get_sitelib(const char *pl);
90 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
95 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
97 # include <sys/wait.h>
100 # include <sys/uio.h>
105 char control[CMSG_SPACE(sizeof(int))];
122 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
123 char *getenv (char *); /* Usually in <stdlib.h> */
126 static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
134 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
140 #if defined(USE_5005THREADS)
141 # define INIT_TLS_AND_INTERP \
143 if (!PL_curinterp) { \
144 PERL_SET_INTERP(my_perl); \
150 # if defined(USE_ITHREADS)
151 # define INIT_TLS_AND_INTERP \
153 if (!PL_curinterp) { \
154 PERL_SET_INTERP(my_perl); \
157 PERL_SET_THX(my_perl); \
159 MUTEX_INIT(&PL_dollarzero_mutex); \
162 PERL_SET_THX(my_perl); \
166 # define INIT_TLS_AND_INTERP \
168 if (!PL_curinterp) { \
169 PERL_SET_INTERP(my_perl); \
171 PERL_SET_THX(my_perl); \
176 #ifdef PERL_IMPLICIT_SYS
178 perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
179 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
180 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
181 struct IPerlDir* ipD, struct IPerlSock* ipS,
182 struct IPerlProc* ipP)
184 PerlInterpreter *my_perl;
185 /* Newx() needs interpreter, so call malloc() instead */
186 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
188 Zero(my_perl, 1, PerlInterpreter);
204 =head1 Embedding Functions
206 =for apidoc perl_alloc
208 Allocates a new Perl interpreter. See L<perlembed>.
216 PerlInterpreter *my_perl;
217 #ifdef USE_5005THREADS
221 /* Newx() needs interpreter, so call malloc() instead */
222 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
225 return (PerlInterpreter *) ZeroD(my_perl, 1, PerlInterpreter);
227 #endif /* PERL_IMPLICIT_SYS */
230 =for apidoc perl_construct
232 Initializes a new Perl interpreter. See L<perlembed>.
238 perl_construct(pTHXx)
240 #ifdef USE_5005THREADS
242 struct perl_thread *thr = NULL;
243 #endif /* FAKE_THREADS */
244 #endif /* USE_5005THREADS */
246 PERL_UNUSED_ARG(my_perl);
249 PL_perl_destruct_level = 1;
251 if (PL_perl_destruct_level > 0)
254 /* Init the real globals (and main thread)? */
256 #ifdef USE_5005THREADS
257 MUTEX_INIT(&PL_sv_mutex);
259 * Safe to use basic SV functions from now on (though
260 * not things like mortals or tainting yet).
262 MUTEX_INIT(&PL_eval_mutex);
263 COND_INIT(&PL_eval_cond);
264 MUTEX_INIT(&PL_threads_mutex);
265 COND_INIT(&PL_nthreads_cond);
266 # ifdef EMULATE_ATOMIC_REFCOUNTS
267 MUTEX_INIT(&PL_svref_mutex);
268 # endif /* EMULATE_ATOMIC_REFCOUNTS */
270 MUTEX_INIT(&PL_cred_mutex);
271 MUTEX_INIT(&PL_sv_lock_mutex);
272 MUTEX_INIT(&PL_fdpid_mutex);
274 thr = init_main_thread();
275 #endif /* USE_5005THREADS */
277 #ifdef PERL_FLEXIBLE_EXCEPTIONS
278 PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
281 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
283 PL_linestr = NEWSV(65,79);
284 sv_upgrade(PL_linestr,SVt_PVIV);
286 if (!SvREADONLY(&PL_sv_undef)) {
287 /* set read-only and try to insure than we wont see REFCNT==0
290 SvREADONLY_on(&PL_sv_undef);
291 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
293 sv_setpv(&PL_sv_no,PL_No);
294 /* value lookup in void context - happens to have the side effect
295 of caching the numeric forms. */
298 SvREADONLY_on(&PL_sv_no);
299 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
301 sv_setpv(&PL_sv_yes,PL_Yes);
304 SvREADONLY_on(&PL_sv_yes);
305 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
307 SvREADONLY_on(&PL_sv_placeholder);
308 SvREFCNT(&PL_sv_placeholder) = (~(U32)0)/2;
311 PL_sighandlerp = Perl_sighandler;
312 PL_pidstatus = newHV();
315 PL_rs = newSVpvn("\n", 1);
320 PL_lex_state = LEX_NOTPARSING;
326 SET_NUMERIC_STANDARD();
330 PL_patchlevel = NEWSV(0,4);
331 (void)SvUPGRADE(PL_patchlevel, SVt_PVNV);
332 if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
333 SvGROW(PL_patchlevel, UTF8_MAXLEN*3+1);
334 s = (U8*)SvPVX(PL_patchlevel);
335 /* Build version strings using "native" characters */
336 s = uvchr_to_utf8(s, (UV)PERL_REVISION);
337 s = uvchr_to_utf8(s, (UV)PERL_VERSION);
338 s = uvchr_to_utf8(s, (UV)PERL_SUBVERSION);
340 SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel));
341 SvPOK_on(PL_patchlevel);
342 SvNVX(PL_patchlevel) = (NV)PERL_REVISION +
343 ((NV)PERL_VERSION / (NV)1000) +
344 ((NV)PERL_SUBVERSION / (NV)1000000);
345 SvNOK_on(PL_patchlevel); /* dual valued */
346 SvUTF8_on(PL_patchlevel);
347 SvREADONLY_on(PL_patchlevel);
350 #if defined(LOCAL_PATCH_COUNT)
351 PL_localpatches = (char **) local_patches; /* For possible -v */
354 #ifdef HAVE_INTERP_INTERN
358 PerlIO_init(aTHX); /* Hook to IO system */
360 PL_fdpid = newAV(); /* for remembering popen pids by fd */
361 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
362 PL_errors = newSVpvn("",0);
363 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
364 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
365 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
367 PL_regex_padav = newAV();
368 av_push(PL_regex_padav,(SV*)newAV()); /* First entry is an array of empty elements */
369 PL_regex_pad = AvARRAY(PL_regex_padav);
371 #ifdef USE_REENTRANT_API
372 Perl_reentrant_init(aTHX);
375 /* Note that strtab is a rather special HV. Assumptions are made
376 about not iterating on it, and not adding tie magic to it.
377 It is properly deallocated in perl_destruct() */
380 #ifdef USE_5005THREADS
381 MUTEX_INIT(&PL_strtab_mutex);
383 HvSHAREKEYS_off(PL_strtab); /* mandatory */
384 hv_ksplit(PL_strtab, 512);
386 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
387 _dyld_lookup_and_bind
388 ("__environ", (unsigned long *) &environ_pointer, NULL);
392 # ifdef USE_ENVIRON_ARRAY
393 PL_origenviron = environ;
397 /* Use sysconf(_SC_CLK_TCK) if available, if not
398 * available or if the sysconf() fails, use the HZ.
399 * BeOS has those, but returns the wrong value.
400 * The HZ if not originally defined has been by now
401 * been defined as CLK_TCK, if available. */
402 #if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK) && !defined(__BEOS__)
403 PL_clocktick = sysconf(_SC_CLK_TCK);
404 if (PL_clocktick <= 0)
408 PL_stashcache = newHV();
414 =for apidoc nothreadhook
416 Stub that provides thread hook for perl_destruct when there are
423 Perl_nothreadhook(pTHX)
428 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
430 Perl_dump_sv_child(pTHX_ SV *sv)
433 const int sock = PL_dumper_fd;
434 const int debug_fd = PerlIO_fileno(Perl_debug_log);
435 union control_un control;
438 struct cmsghdr *cmptr;
440 unsigned char buffer[256];
442 if(sock == -1 || debug_fd == -1)
445 PerlIO_flush(Perl_debug_log);
447 /* All these shenanigans are to pass a file descriptor over to our child for
448 it to dump out to. We can't let it hold open the file descriptor when it
449 forks, as the file descriptor it will dump to can turn out to be one end
450 of pipe that some other process will wait on for EOF. (So as it would
451 be open, the wait would be forever. */
453 msg.msg_control = control.control;
454 msg.msg_controllen = sizeof(control.control);
455 /* We're a connected socket so we don't need a destination */
461 cmptr = CMSG_FIRSTHDR(&msg);
462 cmptr->cmsg_len = CMSG_LEN(sizeof(int));
463 cmptr->cmsg_level = SOL_SOCKET;
464 cmptr->cmsg_type = SCM_RIGHTS;
465 *((int *)CMSG_DATA(cmptr)) = 1;
467 vec[0].iov_base = (void*)&sv;
468 vec[0].iov_len = sizeof(sv);
469 got = sendmsg(sock, &msg, 0);
472 perror("Debug leaking scalars parent sendmsg failed");
475 if(got < sizeof(sv)) {
476 perror("Debug leaking scalars parent short sendmsg");
480 /* Return protocol is
482 unsigned char: length of location string (0 for empty)
483 unsigned char*: string (not terminated)
485 vec[0].iov_base = (void*)&returned_errno;
486 vec[0].iov_len = sizeof(returned_errno);
487 vec[1].iov_base = buffer;
490 got = readv(sock, vec, 2);
493 perror("Debug leaking scalars parent read failed");
494 PerlIO_flush(PerlIO_stderr());
497 if(got < sizeof(returned_errno) + 1) {
498 perror("Debug leaking scalars parent short read");
499 PerlIO_flush(PerlIO_stderr());
504 got = read(sock, buffer + 1, *buffer);
506 perror("Debug leaking scalars parent read 2 failed");
507 PerlIO_flush(PerlIO_stderr());
512 perror("Debug leaking scalars parent short read 2");
513 PerlIO_flush(PerlIO_stderr());
518 if (returned_errno || *buffer) {
519 Perl_warn(aTHX_ "Debug leaking scalars child failed%s%.*s with errno"
520 " %d: %s", (*buffer ? " at " : ""), (int) *buffer, buffer + 1,
521 returned_errno, strerror(returned_errno));
527 =for apidoc perl_destruct
529 Shuts down a Perl interpreter. See L<perlembed>.
537 volatile int destruct_level; /* 0=none, 1=full, 2=full with checks */
539 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
542 #ifdef USE_5005THREADS
545 #endif /* USE_5005THREADS */
547 PERL_UNUSED_ARG(my_perl);
549 /* wait for all pseudo-forked children to finish */
550 PERL_WAIT_FOR_CHILDREN;
552 #ifdef USE_5005THREADS
554 /* Pass 1 on any remaining threads: detach joinables, join zombies */
556 MUTEX_LOCK(&PL_threads_mutex);
557 DEBUG_S(PerlIO_printf(Perl_debug_log,
558 "perl_destruct: waiting for %d threads...\n",
560 for (t = thr->next; t != thr; t = t->next) {
561 MUTEX_LOCK(&t->mutex);
562 switch (ThrSTATE(t)) {
565 DEBUG_S(PerlIO_printf(Perl_debug_log,
566 "perl_destruct: joining zombie %p\n", t));
567 ThrSETSTATE(t, THRf_DEAD);
568 MUTEX_UNLOCK(&t->mutex);
571 * The SvREFCNT_dec below may take a long time (e.g. av
572 * may contain an object scalar whose destructor gets
573 * called) so we have to unlock threads_mutex and start
576 MUTEX_UNLOCK(&PL_threads_mutex);
578 SvREFCNT_dec((SV*)av);
579 DEBUG_S(PerlIO_printf(Perl_debug_log,
580 "perl_destruct: joined zombie %p OK\n", t));
582 case THRf_R_JOINABLE:
583 DEBUG_S(PerlIO_printf(Perl_debug_log,
584 "perl_destruct: detaching thread %p\n", t));
585 ThrSETSTATE(t, THRf_R_DETACHED);
587 * We unlock threads_mutex and t->mutex in the opposite order
588 * from which we locked them just so that DETACH won't
589 * deadlock if it panics. It's only a breach of good style
590 * not a bug since they are unlocks not locks.
592 MUTEX_UNLOCK(&PL_threads_mutex);
594 MUTEX_UNLOCK(&t->mutex);
597 DEBUG_S(PerlIO_printf(Perl_debug_log,
598 "perl_destruct: ignoring %p (state %u)\n",
600 MUTEX_UNLOCK(&t->mutex);
601 /* fall through and out */
604 /* We leave the above "Pass 1" loop with threads_mutex still locked */
606 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
607 while (PL_nthreads > 1)
609 DEBUG_S(PerlIO_printf(Perl_debug_log,
610 "perl_destruct: final wait for %d threads\n",
612 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
614 /* At this point, we're the last thread */
615 MUTEX_UNLOCK(&PL_threads_mutex);
616 DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
617 MUTEX_DESTROY(&PL_threads_mutex);
618 COND_DESTROY(&PL_nthreads_cond);
620 #endif /* !defined(FAKE_THREADS) */
621 #endif /* USE_5005THREADS */
623 destruct_level = PL_perl_destruct_level;
626 const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
628 const int i = atoi(s);
629 if (destruct_level < i)
635 if (PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
641 if (PL_endav && !PL_minus_c)
642 call_list(PL_scopestack_ix, PL_endav);
648 /* Need to flush since END blocks can produce output */
651 if (CALL_FPTR(PL_threadhook)(aTHX)) {
652 /* Threads hook has vetoed further cleanup */
653 return STATUS_NATIVE_EXPORT;
656 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
657 if (destruct_level != 0) {
658 /* Fork here to create a child. Our child's job is to preserve the
659 state of scalars prior to destruction, so that we can instruct it
660 to dump any scalars that we later find have leaked.
661 There's no subtlety in this code - it assumes POSIX, and it doesn't
665 if(socketpair(AF_UNIX, SOCK_STREAM, 0, fd)) {
666 perror("Debug leaking scalars socketpair failed");
672 perror("Debug leaking scalars fork failed");
676 /* We are the child */
677 const int sock = fd[1];
678 const int debug_fd = PerlIO_fileno(Perl_debug_log);
681 /* Our success message is an integer 0, and a char 0 */
682 static const char success[sizeof(int) + 1];
686 /* We need to close all other file descriptors otherwise we end up
687 with interesting hangs, where the parent closes its end of a
688 pipe, and sits waiting for (another) child to terminate. Only
689 that child never terminates, because it never gets EOF, because
690 we also have the far end of the pipe open. We even need to
691 close the debugging fd, because sometimes it happens to be one
692 end of a pipe, and a process is waiting on the other end for
693 EOF. Normally it would be closed at some point earlier in
694 destruction, but if we happen to cause the pipe to remain open,
695 EOF never occurs, and we get an infinite hang. Hence all the
696 games to pass in a file descriptor if it's actually needed. */
698 f = sysconf(_SC_OPEN_MAX);
700 where = "sysconf failed";
711 union control_un control;
714 struct cmsghdr *cmptr;
718 msg.msg_control = control.control;
719 msg.msg_controllen = sizeof(control.control);
720 /* We're a connected socket so we don't need a source */
724 msg.msg_iovlen = sizeof(vec)/sizeof(vec[0]);
726 vec[0].iov_base = (void*)⌖
727 vec[0].iov_len = sizeof(target);
729 got = recvmsg(sock, &msg, 0);
734 where = "recv failed";
737 if(got < sizeof(target)) {
738 where = "short recv";
742 if(!(cmptr = CMSG_FIRSTHDR(&msg))) {
746 if(cmptr->cmsg_len != CMSG_LEN(sizeof(int))) {
747 where = "wrong cmsg_len";
750 if(cmptr->cmsg_level != SOL_SOCKET) {
751 where = "wrong cmsg_level";
754 if(cmptr->cmsg_type != SCM_RIGHTS) {
755 where = "wrong cmsg_type";
759 got_fd = *(int*)CMSG_DATA(cmptr);
760 /* For our last little bit of trickery, put the file descriptor
761 back into Perl_debug_log, as if we never actually closed it
763 if(got_fd != debug_fd) {
764 if (dup2(got_fd, debug_fd) == -1) {
771 PerlIO_flush(Perl_debug_log);
773 got = write(sock, &success, sizeof(success));
776 where = "write failed";
779 if(got < sizeof(success)) {
780 where = "short write";
787 int send_errno = errno;
788 unsigned char length = (unsigned char) strlen(where);
789 struct iovec failure[3] = {
790 {(void*)&send_errno, sizeof(send_errno)},
792 {(void*)where, length}
794 int got = writev(sock, failure, 3);
795 /* Bad news travels fast. Faster than data. We'll get a SIGPIPE
796 in the parent if we try to read from the socketpair after the
797 child has exited, even if there was data to read.
798 So sleep a bit to give the parent a fighting chance of
801 _exit((got == -1) ? errno : 0);
805 PL_dumper_fd = fd[0];
810 /* We must account for everything. */
812 /* Destroy the main CV and syntax tree */
813 /* Do this now, because destroying ops can cause new SVs to be generated
814 in Perl_pad_swipe, and when running with -DDEBUG_LEAKING_SCALARS they
815 PL_curcop to point to a valid op from which the filename structure
817 PL_curcop = &PL_compiling;
819 /* ensure comppad/curpad to refer to main's pad */
820 if (CvPADLIST(PL_main_cv)) {
821 PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1);
823 op_free(PL_main_root);
824 PL_main_root = Nullop;
826 PL_main_start = Nullop;
827 SvREFCNT_dec(PL_main_cv);
831 /* Tell PerlIO we are about to tear things apart in case
832 we have layers which are using resources that should
836 PerlIO_destruct(aTHX);
838 if (PL_sv_objcount) {
840 * Try to destruct global references. We do this first so that the
841 * destructors and destructees still exist. Some sv's might remain.
842 * Non-referenced objects are on their own.
846 if (PL_defoutgv && !SvREFCNT(PL_defoutgv))
847 PL_defoutgv = Nullgv; /* may have been freed */
850 /* unhook hooks which will soon be, or use, destroyed data */
851 SvREFCNT_dec(PL_warnhook);
852 PL_warnhook = Nullsv;
853 SvREFCNT_dec(PL_diehook);
856 /* call exit list functions */
857 while (PL_exitlistlen-- > 0)
858 PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
860 Safefree(PL_exitlist);
865 if (destruct_level == 0){
867 DEBUG_P(debprofdump());
869 #if defined(PERLIO_LAYERS)
870 /* No more IO - including error messages ! */
871 PerlIO_cleanup(aTHX);
874 /* The exit() function will do everything that needs doing. */
875 return STATUS_NATIVE_EXPORT;
878 /* jettison our possibly duplicated environment */
879 /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
880 * so we certainly shouldn't free it here
883 #if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
884 if (environ != PL_origenviron && !PL_use_safe_putenv
886 /* only main thread can free environ[0] contents */
887 && PL_curinterp == aTHX
893 for (i = 0; environ[i]; i++)
894 safesysfree(environ[i]);
896 /* Must use safesysfree() when working with environ. */
897 safesysfree(environ);
899 environ = PL_origenviron;
902 #endif /* !PERL_MICRO */
904 /* reset so print() ends up where we expect */
908 /* the syntax tree is shared between clones
909 * so op_free(PL_main_root) only ReREFCNT_dec's
910 * REGEXPs in the parent interpreter
911 * we need to manually ReREFCNT_dec for the clones
914 I32 i = AvFILLp(PL_regex_padav) + 1;
915 SV **ary = AvARRAY(PL_regex_padav);
920 if (SvFLAGS(resv) & SVf_BREAK) {
921 /* this is PL_reg_curpm, already freed
922 * flag is set in regexec.c:S_regtry
924 SvFLAGS(resv) &= ~SVf_BREAK;
926 else if(SvREPADTMP(resv)) {
927 SvREPADTMP_off(resv);
929 else if(SvIOKp(resv)) {
930 REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv));
935 SvREFCNT_dec(PL_regex_padav);
936 PL_regex_padav = Nullav;
940 SvREFCNT_dec((SV*) PL_stashcache);
941 PL_stashcache = NULL;
943 /* loosen bonds of global variables */
946 (void)PerlIO_close(PL_rsfp);
950 /* Filters for program text */
951 SvREFCNT_dec(PL_rsfp_filters);
952 PL_rsfp_filters = Nullav;
955 PL_preprocess = FALSE;
961 PL_doswitches = FALSE;
962 PL_dowarn = G_WARN_OFF;
963 PL_doextract = FALSE;
964 PL_sawampersand = FALSE; /* must save all match strings */
967 Safefree(PL_inplace);
969 SvREFCNT_dec(PL_patchlevel);
972 SvREFCNT_dec(PL_e_script);
973 PL_e_script = Nullsv;
978 /* magical thingies */
980 SvREFCNT_dec(PL_ofs_sv); /* $, */
983 SvREFCNT_dec(PL_ors_sv); /* $\ */
986 SvREFCNT_dec(PL_rs); /* $/ */
989 PL_multiline = 0; /* $* */
990 Safefree(PL_osname); /* $^O */
993 SvREFCNT_dec(PL_statname);
994 PL_statname = Nullsv;
997 /* defgv, aka *_ should be taken care of elsewhere */
999 /* clean up after study() */
1000 SvREFCNT_dec(PL_lastscream);
1001 PL_lastscream = Nullsv;
1002 Safefree(PL_screamfirst);
1004 Safefree(PL_screamnext);
1008 Safefree(PL_efloatbuf);
1009 PL_efloatbuf = Nullch;
1012 /* startup and shutdown function lists */
1013 SvREFCNT_dec(PL_beginav);
1014 SvREFCNT_dec(PL_beginav_save);
1015 SvREFCNT_dec(PL_endav);
1016 SvREFCNT_dec(PL_checkav);
1017 SvREFCNT_dec(PL_checkav_save);
1018 SvREFCNT_dec(PL_initav);
1019 PL_beginav = Nullav;
1020 PL_beginav_save = Nullav;
1022 PL_checkav = Nullav;
1023 PL_checkav_save = Nullav;
1026 /* shortcuts just get cleared */
1032 PL_argvoutgv = Nullgv;
1033 PL_stdingv = Nullgv;
1034 PL_stderrgv = Nullgv;
1035 PL_last_in_gv = Nullgv;
1040 PL_DBsingle = Nullsv;
1041 PL_DBtrace = Nullsv;
1042 PL_DBsignal = Nullsv;
1045 PL_debstash = Nullhv;
1047 SvREFCNT_dec(PL_argvout_stack);
1048 PL_argvout_stack = Nullav;
1050 SvREFCNT_dec(PL_modglobal);
1051 PL_modglobal = Nullhv;
1052 SvREFCNT_dec(PL_preambleav);
1053 PL_preambleav = Nullav;
1054 SvREFCNT_dec(PL_subname);
1055 PL_subname = Nullsv;
1056 SvREFCNT_dec(PL_linestr);
1057 PL_linestr = Nullsv;
1058 SvREFCNT_dec(PL_pidstatus);
1059 PL_pidstatus = Nullhv;
1060 SvREFCNT_dec(PL_toptarget);
1061 PL_toptarget = Nullsv;
1062 SvREFCNT_dec(PL_bodytarget);
1063 PL_bodytarget = Nullsv;
1064 PL_formtarget = Nullsv;
1066 /* free locale stuff */
1067 #ifdef USE_LOCALE_COLLATE
1068 Safefree(PL_collation_name);
1069 PL_collation_name = Nullch;
1072 #ifdef USE_LOCALE_NUMERIC
1073 Safefree(PL_numeric_name);
1074 PL_numeric_name = Nullch;
1075 SvREFCNT_dec(PL_numeric_radix_sv);
1076 PL_numeric_radix_sv = Nullsv;
1079 /* clear utf8 character classes */
1080 SvREFCNT_dec(PL_utf8_alnum);
1081 SvREFCNT_dec(PL_utf8_alnumc);
1082 SvREFCNT_dec(PL_utf8_ascii);
1083 SvREFCNT_dec(PL_utf8_alpha);
1084 SvREFCNT_dec(PL_utf8_space);
1085 SvREFCNT_dec(PL_utf8_cntrl);
1086 SvREFCNT_dec(PL_utf8_graph);
1087 SvREFCNT_dec(PL_utf8_digit);
1088 SvREFCNT_dec(PL_utf8_upper);
1089 SvREFCNT_dec(PL_utf8_lower);
1090 SvREFCNT_dec(PL_utf8_print);
1091 SvREFCNT_dec(PL_utf8_punct);
1092 SvREFCNT_dec(PL_utf8_xdigit);
1093 SvREFCNT_dec(PL_utf8_mark);
1094 SvREFCNT_dec(PL_utf8_toupper);
1095 SvREFCNT_dec(PL_utf8_totitle);
1096 SvREFCNT_dec(PL_utf8_tolower);
1097 SvREFCNT_dec(PL_utf8_tofold);
1098 SvREFCNT_dec(PL_utf8_idstart);
1099 SvREFCNT_dec(PL_utf8_idcont);
1100 PL_utf8_alnum = Nullsv;
1101 PL_utf8_alnumc = Nullsv;
1102 PL_utf8_ascii = Nullsv;
1103 PL_utf8_alpha = Nullsv;
1104 PL_utf8_space = Nullsv;
1105 PL_utf8_cntrl = Nullsv;
1106 PL_utf8_graph = Nullsv;
1107 PL_utf8_digit = Nullsv;
1108 PL_utf8_upper = Nullsv;
1109 PL_utf8_lower = Nullsv;
1110 PL_utf8_print = Nullsv;
1111 PL_utf8_punct = Nullsv;
1112 PL_utf8_xdigit = Nullsv;
1113 PL_utf8_mark = Nullsv;
1114 PL_utf8_toupper = Nullsv;
1115 PL_utf8_totitle = Nullsv;
1116 PL_utf8_tolower = Nullsv;
1117 PL_utf8_tofold = Nullsv;
1118 PL_utf8_idstart = Nullsv;
1119 PL_utf8_idcont = Nullsv;
1121 if (!specialWARN(PL_compiling.cop_warnings))
1122 SvREFCNT_dec(PL_compiling.cop_warnings);
1123 PL_compiling.cop_warnings = Nullsv;
1124 if (!specialCopIO(PL_compiling.cop_io))
1125 SvREFCNT_dec(PL_compiling.cop_io);
1126 PL_compiling.cop_io = Nullsv;
1127 CopFILE_free(&PL_compiling);
1128 CopSTASH_free(&PL_compiling);
1130 /* Prepare to destruct main symbol table. */
1135 SvREFCNT_dec(PL_curstname);
1136 PL_curstname = Nullsv;
1138 /* clear queued errors */
1139 SvREFCNT_dec(PL_errors);
1143 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
1144 if (PL_scopestack_ix != 0)
1145 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1146 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
1147 (long)PL_scopestack_ix);
1148 if (PL_savestack_ix != 0)
1149 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1150 "Unbalanced saves: %ld more saves than restores\n",
1151 (long)PL_savestack_ix);
1152 if (PL_tmps_floor != -1)
1153 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
1154 (long)PL_tmps_floor + 1);
1155 if (cxstack_ix != -1)
1156 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
1157 (long)cxstack_ix + 1);
1160 /* Now absolutely destruct everything, somehow or other, loops or no. */
1161 SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */
1162 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
1164 /* the 2 is for PL_fdpid and PL_strtab */
1165 while (PL_sv_count > 2 && sv_clean_all())
1168 SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
1169 SvFLAGS(PL_fdpid) |= SVt_PVAV;
1170 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
1171 SvFLAGS(PL_strtab) |= SVt_PVHV;
1173 AvREAL_off(PL_fdpid); /* no surviving entries */
1174 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
1177 #ifdef HAVE_INTERP_INTERN
1181 /* Destruct the global string table. */
1183 /* Yell and reset the HeVAL() slots that are still holding refcounts,
1184 * so that sv_free() won't fail on them.
1187 const I32 max = HvMAX(PL_strtab);
1188 HE ** const array = HvARRAY(PL_strtab);
1189 HE *hent = array[0];
1192 if (hent && ckWARN_d(WARN_INTERNAL)) {
1193 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1194 "Unbalanced string table refcount: (%ld) for \"%s\"",
1195 (long)(HeVAL(hent) - Nullsv), HeKEY(hent));
1196 HeVAL(hent) = Nullsv;
1197 hent = HeNEXT(hent);
1202 hent = array[riter];
1206 SvREFCNT_dec(PL_strtab);
1209 /* free the pointer table used for cloning */
1210 ptr_table_free(PL_ptr_table);
1211 PL_ptr_table = (PTR_TBL_t*)NULL;
1214 /* free special SVs */
1216 SvREFCNT(&PL_sv_yes) = 0;
1217 sv_clear(&PL_sv_yes);
1218 SvANY(&PL_sv_yes) = NULL;
1219 SvFLAGS(&PL_sv_yes) = 0;
1221 SvREFCNT(&PL_sv_no) = 0;
1222 sv_clear(&PL_sv_no);
1223 SvANY(&PL_sv_no) = NULL;
1224 SvFLAGS(&PL_sv_no) = 0;
1228 for (i=0; i<=2; i++) {
1229 SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
1230 sv_clear(PERL_DEBUG_PAD(i));
1231 SvANY(PERL_DEBUG_PAD(i)) = NULL;
1232 SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
1236 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
1237 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
1239 #ifdef DEBUG_LEAKING_SCALARS
1240 if (PL_sv_count != 0) {
1245 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
1246 svend = &sva[SvREFCNT(sva)];
1247 for (sv = sva + 1; sv < svend; ++sv) {
1248 if (SvTYPE(sv) != SVTYPEMASK) {
1249 PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
1251 " refcnt=%"UVuf pTHX__FORMAT "\n",
1252 sv, sv->sv_flags, sv->sv_refcnt pTHX__VALUE);
1253 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1254 Perl_dump_sv_child(aTHX_ sv);
1260 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1264 /* Wait for up to 4 seconds for child to terminate.
1265 This seems to be the least effort way of timing out on reaping
1267 struct timeval waitfor = {4, 0};
1268 int sock = PL_dumper_fd;
1272 FD_SET(sock, &rset);
1273 select(sock + 1, &rset, NULL, NULL, &waitfor);
1274 waitpid(child, &status, WNOHANG);
1282 #if defined(PERLIO_LAYERS)
1283 /* No more IO - including error messages ! */
1284 PerlIO_cleanup(aTHX);
1287 /* sv_undef needs to stay immortal until after PerlIO_cleanup
1288 as currently layers use it rather than Nullsv as a marker
1289 for no arg - and will try and SvREFCNT_dec it.
1291 SvREFCNT(&PL_sv_undef) = 0;
1292 SvREADONLY_off(&PL_sv_undef);
1294 Safefree(PL_origfilename);
1295 PL_origfilename = Nullch;
1296 Safefree(PL_reg_start_tmp);
1297 PL_reg_start_tmp = (char**)NULL;
1298 PL_reg_start_tmpl = 0;
1299 Safefree(PL_reg_curpm);
1300 Safefree(PL_reg_poscache);
1301 free_tied_hv_pool();
1302 Safefree(PL_op_mask);
1303 Safefree(PL_psig_ptr);
1304 PL_psig_ptr = (SV**)NULL;
1305 Safefree(PL_psig_name);
1306 PL_psig_name = (SV**)NULL;
1307 Safefree(PL_bitcount);
1308 PL_bitcount = Nullch;
1309 Safefree(PL_psig_pend);
1310 PL_psig_pend = (int*)NULL;
1311 PL_formfeed = Nullsv;
1315 PL_tainting = FALSE;
1316 PL_taint_warn = FALSE;
1317 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
1320 DEBUG_P(debprofdump());
1321 #ifdef USE_5005THREADS
1322 MUTEX_DESTROY(&PL_strtab_mutex);
1323 MUTEX_DESTROY(&PL_sv_mutex);
1324 MUTEX_DESTROY(&PL_eval_mutex);
1325 MUTEX_DESTROY(&PL_cred_mutex);
1326 MUTEX_DESTROY(&PL_fdpid_mutex);
1327 COND_DESTROY(&PL_eval_cond);
1328 #ifdef EMULATE_ATOMIC_REFCOUNTS
1329 MUTEX_DESTROY(&PL_svref_mutex);
1330 #endif /* EMULATE_ATOMIC_REFCOUNTS */
1332 /* As the penultimate thing, free the non-arena SV for thrsv */
1333 Safefree(SvPVX(PL_thrsv));
1334 Safefree(SvANY(PL_thrsv));
1337 #endif /* USE_5005THREADS */
1339 #ifdef USE_REENTRANT_API
1340 Perl_reentrant_free(aTHX);
1345 /* As the absolutely last thing, free the non-arena SV for mess() */
1348 /* we know that type == SVt_PVMG */
1350 /* it could have accumulated taint magic */
1353 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
1354 moremagic = mg->mg_moremagic;
1355 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
1357 Safefree(mg->mg_ptr);
1361 /* we know that type >= SVt_PV */
1362 SvPV_free(PL_mess_sv);
1363 Safefree(SvANY(PL_mess_sv));
1364 Safefree(PL_mess_sv);
1365 PL_mess_sv = Nullsv;
1367 return STATUS_NATIVE_EXPORT;
1371 =for apidoc perl_free
1373 Releases a Perl interpreter. See L<perlembed>.
1381 #if defined(WIN32) || defined(NETWARE)
1382 # if defined(PERL_IMPLICIT_SYS)
1384 void *host = nw_internal_host;
1386 void *host = w32_internal_host;
1388 PerlMem_free(aTHXx);
1390 nw_delete_internal_host(host);
1392 win32_delete_internal_host(host);
1395 PerlMem_free(aTHXx);
1398 PerlMem_free(aTHXx);
1402 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
1403 /* provide destructors to clean up the thread key when libperl is unloaded */
1404 #ifndef WIN32 /* handled during DLL_PROCESS_DETACH in win32/perllib.c */
1406 #if defined(__hpux) && __ux_version > 1020 && !defined(__GNUC__)
1407 #pragma fini "perl_fini"
1411 #if defined(__GNUC__)
1412 __attribute__((destructor))
1421 #endif /* THREADS */
1424 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
1426 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
1427 PL_exitlist[PL_exitlistlen].fn = fn;
1428 PL_exitlist[PL_exitlistlen].ptr = ptr;
1433 =for apidoc perl_parse
1435 Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
1441 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
1446 #ifdef USE_5005THREADS
1450 PERL_UNUSED_VAR(my_perl);
1452 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
1455 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
1456 setuid perl scripts securely.\n");
1457 #endif /* IAMSUID */
1460 #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
1461 /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0
1462 * This MUST be done before any hash stores or fetches take place.
1463 * If you set PL_rehash_seed (and assumedly also PL_rehash_seed_set)
1464 * yourself, it is your responsibility to provide a good random seed!
1465 * You can also define PERL_HASH_SEED in compile time, see hv.h. */
1466 if (!PL_rehash_seed_set)
1467 PL_rehash_seed = get_hash_seed();
1469 const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
1471 if (s && (atoi(s) == 1))
1472 PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n", PL_rehash_seed);
1474 #endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
1480 /* Set PL_origalen be the sum of the contiguous argv[]
1481 * elements plus the size of the env in case that it is
1482 * contiguous with the argv[]. This is used in mg.c:Perl_magic_set()
1483 * as the maximum modifiable length of $0. In the worst case
1484 * the area we are able to modify is limited to the size of
1485 * the original argv[0]. (See below for 'contiguous', though.)
1487 const char *s = NULL;
1490 ~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0);
1491 /* Do the mask check only if the args seem like aligned. */
1493 (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
1495 /* See if all the arguments are contiguous in memory. Note
1496 * that 'contiguous' is a loose term because some platforms
1497 * align the argv[] and the envp[]. If the arguments look
1498 * like non-aligned, assume that they are 'strictly' or
1499 * 'traditionally' contiguous. If the arguments look like
1500 * aligned, we just check that they are within aligned
1501 * PTRSIZE bytes. As long as no system has something bizarre
1502 * like the argv[] interleaved with some other data, we are
1503 * fine. (Did I just evoke Murphy's Law?) --jhi */
1504 if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) {
1506 for (i = 1; i < PL_origargc; i++) {
1507 if ((PL_origargv[i] == s + 1
1509 || PL_origargv[i] == s + 2
1514 (PL_origargv[i] > s &&
1516 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1526 /* Can we grab env area too to be used as the area for $0? */
1527 if (PL_origenviron) {
1528 if ((PL_origenviron[0] == s + 1
1530 || (PL_origenviron[0] == s + 9 && (s += 8))
1535 (PL_origenviron[0] > s &&
1536 PL_origenviron[0] <=
1537 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1541 s = PL_origenviron[0];
1544 my_setenv("NoNe SuCh", Nullch);
1545 /* Force copy of environment. */
1546 for (i = 1; PL_origenviron[i]; i++) {
1547 if (PL_origenviron[i] == s + 1
1550 (PL_origenviron[i] > s &&
1551 PL_origenviron[i] <=
1552 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1555 s = PL_origenviron[i];
1563 PL_origalen = s - PL_origargv[0];
1568 /* Come here if running an undumped a.out. */
1570 PL_origfilename = savepv(argv[0]);
1571 PL_do_undump = FALSE;
1572 cxstack_ix = -1; /* start label stack again */
1574 init_postdump_symbols(argc,argv,env);
1579 op_free(PL_main_root);
1580 PL_main_root = Nullop;
1582 PL_main_start = Nullop;
1583 SvREFCNT_dec(PL_main_cv);
1584 PL_main_cv = Nullcv;
1587 oldscope = PL_scopestack_ix;
1588 PL_dowarn = G_WARN_OFF;
1590 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1591 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vparse_body), env, xsinit);
1597 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1598 parse_body(env,xsinit);
1601 call_list(oldscope, PL_checkav);
1608 /* my_exit() was called */
1609 while (PL_scopestack_ix > oldscope)
1612 PL_curstash = PL_defstash;
1614 call_list(oldscope, PL_checkav);
1615 ret = STATUS_NATIVE_EXPORT;
1618 PerlIO_printf(Perl_error_log, "panic: top_env\n");
1626 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1628 S_vparse_body(pTHX_ va_list args)
1630 char **env = va_arg(args, char**);
1631 XSINIT_t xsinit = va_arg(args, XSINIT_t);
1633 return parse_body(env, xsinit);
1638 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
1640 int argc = PL_origargc;
1641 char **argv = PL_origargv;
1642 const char *scriptname = NULL;
1643 VOL bool dosearch = FALSE;
1644 const char *validarg = "";
1647 const char *cddir = Nullch;
1648 #ifdef USE_SITECUSTOMIZE
1649 bool minus_f = FALSE;
1654 sv_setpvn(PL_linestr,"",0);
1655 sv = newSVpvn("",0); /* first used for -I flags */
1659 for (argc--,argv++; argc > 0; argc--,argv++) {
1660 if (argv[0][0] != '-' || !argv[0][1])
1664 validarg = " PHOOEY ";
1668 * Can we rely on the kernel to start scripts with argv[1] set to
1669 * contain all #! line switches (the whole line)? (argv[0] is set to
1670 * the interpreter name, argv[2] to the script name; argv[3] and
1671 * above may contain other arguments.)
1678 #ifndef PERL_STRICT_CR
1702 if ((s = moreswitches(s)))
1707 CHECK_MALLOC_TOO_LATE_FOR('t');
1708 if( !PL_tainting ) {
1709 PL_taint_warn = TRUE;
1715 CHECK_MALLOC_TOO_LATE_FOR('T');
1717 PL_taint_warn = FALSE;
1722 #ifdef MACOS_TRADITIONAL
1723 /* ignore -e for Dev:Pseudo argument */
1724 if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
1729 PL_e_script = newSVpvn("",0);
1730 filter_add(read_e_script, NULL);
1733 sv_catpv(PL_e_script, s);
1735 sv_catpv(PL_e_script, argv[1]);
1739 Perl_croak(aTHX_ "No code specified for -e");
1740 sv_catpv(PL_e_script, "\n");
1744 #ifdef USE_SITECUSTOMIZE
1750 case 'I': /* -I handled both here and in moreswitches() */
1752 if (!*++s && (s=argv[1]) != Nullch) {
1756 STRLEN len = strlen(s);
1757 const char * const p = savepvn(s, len);
1758 incpush(p, TRUE, TRUE, FALSE);
1759 sv_catpvn(sv, "-I", 2);
1760 sv_catpvn(sv, p, len);
1761 sv_catpvn(sv, " ", 1);
1765 Perl_croak(aTHX_ "No directory specified for -I");
1769 PL_preprocess = TRUE;
1782 PL_preambleav = newAV();
1783 av_push(PL_preambleav,
1784 newSVpv("use Config;",0));
1788 opts_prog = newSVpv("print Config::myconfig(),",0);
1790 sv_catpv(opts_prog,"\"\\nCharacteristics of this PERLSHR image: \\n\",");
1792 sv_catpv(opts_prog,"\"\\nCharacteristics of this binary (from libperl): \\n\",");
1794 opts = SvCUR(opts_prog);
1796 Perl_sv_catpv(aTHX_ opts_prog,"\" Compile-time options:"
1800 # ifdef DEBUG_LEAKING_SCALARS
1801 " DEBUG_LEAKING_SCALARS"
1803 # ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1804 " DEBUG_LEAKING_SCALARS_FORK_DUMP"
1806 # ifdef FAKE_THREADS
1809 # ifdef MULTIPLICITY
1818 # ifdef PERL_DONT_CREATE_GVSV
1819 " PERL_DONT_CREATE_GVSV"
1821 # ifdef PERL_GLOBAL_STRUCT
1822 " PERL_GLOBAL_STRUCT"
1824 # ifdef PERL_IMPLICIT_CONTEXT
1825 " PERL_IMPLICIT_CONTEXT"
1827 # ifdef PERL_IMPLICIT_SYS
1828 " PERL_IMPLICIT_SYS"
1830 # ifdef PERL_MALLOC_WRAP
1833 # ifdef PERL_NEED_APPCTX
1836 # ifdef PERL_NEED_TIMESBASE
1837 " PERL_NEED_TIMESBASE"
1839 # ifdef PERL_OLD_COPY_ON_WRITE
1840 " PERL_OLD_COPY_ON_WRITE"
1842 # ifdef PERL_TRACK_MEMPOOL
1843 " PERL_TRACK_MEMPOOL"
1845 # ifdef PERL_USE_SAFE_PUTENV
1846 " PERL_USE_SAFE_PUTENV"
1848 # ifdef PL_OP_SLAB_ALLOC
1851 # ifdef THREADS_HAVE_PIDS
1852 " THREADS_HAVE_PIDS"
1854 # ifdef USE_5005THREADS
1857 # ifdef USE_64_BIT_ALL
1860 # ifdef USE_64_BIT_INT
1863 # ifdef USE_ITHREADS
1866 # ifdef USE_LARGE_FILES
1869 # ifdef USE_LONG_DOUBLE
1875 # ifdef USE_REENTRANT_API
1876 " USE_REENTRANT_API"
1881 # ifdef USE_SITECUSTOMIZE
1882 " USE_SITECUSTOMIZE"
1889 while (SvCUR(opts_prog) > opts+76) {
1890 /* find last space after "options: " and before col 76
1894 char *pv = SvPV_nolen(opts_prog);
1895 const char c = pv[opts+76];
1897 space = strrchr(pv+opts+26, ' ');
1899 if (!space) break; /* "Can't happen" */
1901 /* break the line before that space */
1904 sv_insert(opts_prog, opts, 0,
1908 sv_catpv(opts_prog,"\\n\",");
1910 #if defined(LOCAL_PATCH_COUNT)
1911 if (LOCAL_PATCH_COUNT > 0) {
1914 "\" Locally applied patches:\\n\",");
1915 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
1916 if (PL_localpatches[i])
1917 Perl_sv_catpvf(aTHX_ opts_prog,"q%c\t%s\n%c,",
1918 0, PL_localpatches[i], 0);
1922 Perl_sv_catpvf(aTHX_ opts_prog,
1923 "\" Built under %s\\n\"",OSNAME);
1926 Perl_sv_catpvf(aTHX_ opts_prog,
1927 ",\" Compiled at %s %s\\n\"",__DATE__,
1930 Perl_sv_catpvf(aTHX_ opts_prog,",\" Compiled on %s\\n\"",
1934 sv_catpv(opts_prog, "; $\"=\"\\n \"; "
1935 "@env = map { \"$_=\\\"$ENV{$_}\\\"\" } "
1936 "sort grep {/^PERL/} keys %ENV; ");
1939 "push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1942 "print \" \\%ENV:\\n @env\\n\" if @env;"
1943 "print \" \\@INC:\\n @INC\\n\";");
1947 opts_prog = Perl_newSVpvf(aTHX_
1948 "Config::config_vars(qw%c%s%c)",
1952 av_push(PL_preambleav, opts_prog);
1953 /* don't look for script or read stdin */
1954 scriptname = BIT_BUCKET;
1958 PL_doextract = TRUE;
1966 if (!*++s || isSPACE(*s)) {
1970 /* catch use of gnu style long options */
1971 if (strEQ(s, "version")) {
1975 if (strEQ(s, "help")) {
1982 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
1988 #ifndef SECURE_INTERNAL_GETENV
1991 (s = PerlEnv_getenv("PERL5OPT")))
1993 const char *popt = s;
1996 if (*s == '-' && *(s+1) == 'T') {
1997 CHECK_MALLOC_TOO_LATE_FOR('T');
1999 PL_taint_warn = FALSE;
2002 char *popt_copy = Nullch;
2015 if (!strchr("DIMUdmtw", *s))
2016 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
2020 popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
2021 s = popt_copy + (s - popt);
2022 d = popt_copy + (d - popt);
2029 if( !PL_tainting ) {
2030 PL_taint_warn = TRUE;
2040 #ifdef USE_SITECUSTOMIZE
2043 PL_preambleav = newAV();
2044 av_unshift(PL_preambleav, 1);
2045 (void)av_store(PL_preambleav, 0, Perl_newSVpvf(aTHX_ "BEGIN { do '%s/sitecustomize.pl' }", SITELIB_EXP));
2049 if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
2050 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
2054 scriptname = argv[0];
2057 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
2059 else if (scriptname == Nullch) {
2061 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
2069 open_script(scriptname,dosearch,sv);
2071 validate_suid(validarg, scriptname);
2074 #if defined(SIGCHLD) || defined(SIGCLD)
2077 # define SIGCHLD SIGCLD
2079 Sighandler_t sigstate = rsignal_state(SIGCHLD);
2080 if (sigstate == SIG_IGN) {
2081 if (ckWARN(WARN_SIGNAL))
2082 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
2083 "Can't ignore signal CHLD, forcing to default");
2084 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
2090 #ifdef MACOS_TRADITIONAL
2091 if (PL_doextract || gMacPerl_AlwaysExtract) {
2096 if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
2097 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
2101 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
2102 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2103 CvUNIQUE_on(PL_compcv);
2105 CvPADLIST(PL_compcv) = pad_new(0);
2106 #ifdef USE_5005THREADS
2107 CvOWNER(PL_compcv) = 0;
2108 Newx(CvMUTEXP(PL_compcv), 1, perl_mutex);
2109 MUTEX_INIT(CvMUTEXP(PL_compcv));
2110 #endif /* USE_5005THREADS */
2113 boot_core_UNIVERSAL();
2114 boot_core_xsutils();
2117 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
2119 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
2125 # ifdef HAS_SOCKS5_INIT
2126 socks5_init(argv[0]);
2132 init_predump_symbols();
2133 /* init_postdump_symbols not currently designed to be called */
2134 /* more than once (ENV isn't cleared first, for example) */
2135 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
2137 init_postdump_symbols(argc,argv,env);
2139 /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE},
2140 * or explicitly in some platforms.
2141 * locale.c:Perl_init_i18nl10n() if the environment
2142 * look like the user wants to use UTF-8. */
2143 #if defined(SYMBIAN)
2144 PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */
2147 /* Requires init_predump_symbols(). */
2148 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
2153 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
2154 * and the default open disciplines. */
2155 if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
2156 PL_stdingv && (io = GvIO(PL_stdingv)) &&
2158 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2159 if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
2160 PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
2162 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2163 if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
2164 PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
2166 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2167 if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
2168 (sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
2169 U32 in = PL_unicode & PERL_UNICODE_IN_FLAG;
2170 U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
2173 sv_setpvn(sv, ":utf8\0:utf8", 11);
2175 sv_setpvn(sv, ":utf8\0", 6);
2178 sv_setpvn(sv, "\0:utf8", 6);
2184 if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
2185 if (strEQ(s, "unsafe"))
2186 PL_signals |= PERL_SIGNALS_UNSAFE_FLAG;
2187 else if (strEQ(s, "safe"))
2188 PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
2190 Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
2195 /* now parse the script */
2197 SETERRNO(0,SS_NORMAL);
2199 #ifdef MACOS_TRADITIONAL
2200 if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
2202 Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
2204 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
2205 MacPerl_MPWFileName(PL_origfilename));
2209 if (yyparse() || PL_error_count) {
2211 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
2213 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
2218 CopLINE_set(PL_curcop, 0);
2219 PL_curstash = PL_defstash;
2220 PL_preprocess = FALSE;
2222 SvREFCNT_dec(PL_e_script);
2223 PL_e_script = Nullsv;
2230 SAVECOPFILE(PL_curcop);
2231 SAVECOPLINE(PL_curcop);
2232 gv_check(PL_defstash);
2239 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
2240 dump_mstats("after compilation:");
2249 =for apidoc perl_run
2251 Tells a Perl interpreter to run. See L<perlembed>.
2262 #ifdef USE_5005THREADS
2266 PERL_UNUSED_ARG(my_perl);
2268 oldscope = PL_scopestack_ix;
2273 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2275 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
2281 cxstack_ix = -1; /* start context stack again */
2283 case 0: /* normal completion */
2284 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2289 case 2: /* my_exit() */
2290 while (PL_scopestack_ix > oldscope)
2293 PL_curstash = PL_defstash;
2294 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
2295 PL_endav && !PL_minus_c)
2296 call_list(oldscope, PL_endav);
2298 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
2299 dump_mstats("after execution: ");
2301 ret = STATUS_NATIVE_EXPORT;
2305 POPSTACK_TO(PL_mainstack);
2308 PerlIO_printf(Perl_error_log, "panic: restartop\n");
2318 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2320 S_vrun_body(pTHX_ va_list args)
2322 I32 oldscope = va_arg(args, I32);
2324 return run_body(oldscope);
2330 S_run_body(pTHX_ I32 oldscope)
2332 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
2333 PL_sawampersand ? "Enabling" : "Omitting"));
2335 if (!PL_restartop) {
2336 DEBUG_x(dump_all());
2338 PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
2340 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
2344 #ifdef MACOS_TRADITIONAL
2345 PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
2346 (gMacPerl_ErrorFormat ? "# " : ""),
2347 MacPerl_MPWFileName(PL_origfilename));
2349 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
2353 if (PERLDB_SINGLE && PL_DBsingle)
2354 sv_setiv(PL_DBsingle, 1);
2356 call_list(oldscope, PL_initav);
2362 PL_op = PL_restartop;
2366 else if (PL_main_start) {
2367 CvDEPTH(PL_main_cv) = 1;
2368 PL_op = PL_main_start;
2376 =head1 SV Manipulation Functions
2378 =for apidoc p||get_sv
2380 Returns the SV of the specified Perl scalar. If C<create> is set and the
2381 Perl variable does not exist then it will be created. If C<create> is not
2382 set and the variable does not exist then NULL is returned.
2388 Perl_get_sv(pTHX_ const char *name, I32 create)
2391 #ifdef USE_5005THREADS
2392 if (name[1] == '\0' && !isALPHA(name[0])) {
2393 PADOFFSET tmp = find_threadsv(name);
2394 if (tmp != NOT_IN_PAD)
2395 return THREADSV(tmp);
2397 #endif /* USE_5005THREADS */
2398 gv = gv_fetchpv(name, create, SVt_PV);
2405 =head1 Array Manipulation Functions
2407 =for apidoc p||get_av
2409 Returns the AV of the specified Perl array. If C<create> is set and the
2410 Perl variable does not exist then it will be created. If C<create> is not
2411 set and the variable does not exist then NULL is returned.
2417 Perl_get_av(pTHX_ const char *name, I32 create)
2419 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
2428 =head1 Hash Manipulation Functions
2430 =for apidoc p||get_hv
2432 Returns the HV of the specified Perl hash. If C<create> is set and the
2433 Perl variable does not exist then it will be created. If C<create> is not
2434 set and the variable does not exist then NULL is returned.
2440 Perl_get_hv(pTHX_ const char *name, I32 create)
2442 GV* const gv = gv_fetchpv(name, create, SVt_PVHV);
2451 =head1 CV Manipulation Functions
2453 =for apidoc p||get_cv
2455 Returns the CV of the specified Perl subroutine. If C<create> is set and
2456 the Perl subroutine does not exist then it will be declared (which has the
2457 same effect as saying C<sub name;>). If C<create> is not set and the
2458 subroutine does not exist then NULL is returned.
2464 Perl_get_cv(pTHX_ const char *name, I32 create)
2466 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
2467 /* XXX unsafe for threads if eval_owner isn't held */
2468 /* XXX this is probably not what they think they're getting.
2469 * It has the same effect as "sub name;", i.e. just a forward
2471 if (create && !GvCVu(gv))
2472 return newSUB(start_subparse(FALSE, 0),
2473 newSVOP(OP_CONST, 0, newSVpv(name,0)),
2481 /* Be sure to refetch the stack pointer after calling these routines. */
2485 =head1 Callback Functions
2487 =for apidoc p||call_argv
2489 Performs a callback to the specified Perl sub. See L<perlcall>.
2495 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
2497 /* See G_* flags in cop.h */
2498 /* null terminated arg list */
2505 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
2510 return call_pv(sub_name, flags);
2514 =for apidoc p||call_pv
2516 Performs a callback to the specified Perl sub. See L<perlcall>.
2522 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
2523 /* name of the subroutine */
2524 /* See G_* flags in cop.h */
2526 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
2530 =for apidoc p||call_method
2532 Performs a callback to the specified Perl method. The blessed object must
2533 be on the stack. See L<perlcall>.
2539 Perl_call_method(pTHX_ const char *methname, I32 flags)
2540 /* name of the subroutine */
2541 /* See G_* flags in cop.h */
2543 return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
2546 /* May be called with any of a CV, a GV, or an SV containing the name. */
2548 =for apidoc p||call_sv
2550 Performs a callback to the Perl sub whose name is in the SV. See
2557 Perl_call_sv(pTHX_ SV *sv, I32 flags)
2558 /* See G_* flags in cop.h */
2561 LOGOP myop; /* fake syntax tree node */
2564 volatile I32 retval = 0;
2566 bool oldcatch = CATCH_GET;
2571 if (flags & G_DISCARD) {
2576 Zero(&myop, 1, LOGOP);
2577 myop.op_next = Nullop;
2578 if (!(flags & G_NOARGS))
2579 myop.op_flags |= OPf_STACKED;
2580 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2581 (flags & G_ARRAY) ? OPf_WANT_LIST :
2586 EXTEND(PL_stack_sp, 1);
2587 *++PL_stack_sp = sv;
2589 oldscope = PL_scopestack_ix;
2591 if (PERLDB_SUB && PL_curstash != PL_debstash
2592 /* Handle first BEGIN of -d. */
2593 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
2594 /* Try harder, since this may have been a sighandler, thus
2595 * curstash may be meaningless. */
2596 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
2597 && !(flags & G_NODEBUG))
2598 PL_op->op_private |= OPpENTERSUB_DB;
2600 if (flags & G_METHOD) {
2601 Zero(&method_op, 1, UNOP);
2602 method_op.op_next = PL_op;
2603 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
2604 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
2605 PL_op = (OP*)&method_op;
2608 if (!(flags & G_EVAL)) {
2610 call_body((OP*)&myop, FALSE);
2611 retval = PL_stack_sp - (PL_stack_base + oldmark);
2612 CATCH_SET(oldcatch);
2615 myop.op_other = (OP*)&myop;
2617 /* we're trying to emulate pp_entertry() here */
2619 register PERL_CONTEXT *cx;
2620 const I32 gimme = GIMME_V;
2625 push_return(Nullop);
2626 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
2628 PL_eval_root = PL_op; /* Only needed so that goto works right. */
2630 PL_in_eval = EVAL_INEVAL;
2631 if (flags & G_KEEPERR)
2632 PL_in_eval |= EVAL_KEEPERR;
2634 sv_setpvn(ERRSV,"",0);
2638 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2640 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
2647 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2649 call_body((OP*)&myop, FALSE);
2651 retval = PL_stack_sp - (PL_stack_base + oldmark);
2652 if (!(flags & G_KEEPERR))
2653 sv_setpvn(ERRSV,"",0);
2659 /* my_exit() was called */
2660 PL_curstash = PL_defstash;
2663 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2664 Perl_croak(aTHX_ "Callback called exit");
2669 PL_op = PL_restartop;
2673 PL_stack_sp = PL_stack_base + oldmark;
2674 if (flags & G_ARRAY)
2678 *++PL_stack_sp = &PL_sv_undef;
2683 if (PL_scopestack_ix > oldscope) {
2687 register PERL_CONTEXT *cx;
2695 PERL_UNUSED_VAR(newsp);
2696 PERL_UNUSED_VAR(gimme);
2697 PERL_UNUSED_VAR(optype);
2702 if (flags & G_DISCARD) {
2703 PL_stack_sp = PL_stack_base + oldmark;
2712 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2714 S_vcall_body(pTHX_ va_list args)
2716 OP *myop = va_arg(args, OP*);
2717 int is_eval = va_arg(args, int);
2719 call_body(myop, is_eval);
2725 S_call_body(pTHX_ const OP *myop, bool is_eval)
2727 if (PL_op == myop) {
2729 PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
2731 PL_op = Perl_pp_entersub(aTHX); /* this does */
2737 /* Eval a string. The G_EVAL flag is always assumed. */
2740 =for apidoc p||eval_sv
2742 Tells Perl to C<eval> the string in the SV.
2748 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
2750 /* See G_* flags in cop.h */
2753 UNOP myop; /* fake syntax tree node */
2754 volatile I32 oldmark = SP - PL_stack_base;
2755 volatile I32 retval = 0;
2760 if (flags & G_DISCARD) {
2767 Zero(PL_op, 1, UNOP);
2768 EXTEND(PL_stack_sp, 1);
2769 *++PL_stack_sp = sv;
2771 if (!(flags & G_NOARGS))
2772 myop.op_flags = OPf_STACKED;
2773 myop.op_next = Nullop;
2774 myop.op_type = OP_ENTEREVAL;
2775 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2776 (flags & G_ARRAY) ? OPf_WANT_LIST :
2778 if (flags & G_KEEPERR)
2779 myop.op_flags |= OPf_SPECIAL;
2781 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2783 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
2786 /* fail now; otherwise we could fail after the JMPENV_PUSH but
2787 * before a PUSHEVAL, which corrupts the stack after a croak */
2788 TAINT_PROPER("eval_sv()");
2794 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2796 call_body((OP*)&myop,TRUE);
2798 retval = PL_stack_sp - (PL_stack_base + oldmark);
2799 if (!(flags & G_KEEPERR))
2800 sv_setpvn(ERRSV,"",0);
2806 /* my_exit() was called */
2807 PL_curstash = PL_defstash;
2810 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2811 Perl_croak(aTHX_ "Callback called exit");
2816 PL_op = PL_restartop;
2820 PL_stack_sp = PL_stack_base + oldmark;
2821 if (flags & G_ARRAY)
2825 *++PL_stack_sp = &PL_sv_undef;
2831 if (flags & G_DISCARD) {
2832 PL_stack_sp = PL_stack_base + oldmark;
2842 =for apidoc p||eval_pv
2844 Tells Perl to C<eval> the given string and return an SV* result.
2850 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2853 SV* sv = newSVpv(p, 0);
2855 eval_sv(sv, G_SCALAR);
2862 if (croak_on_error && SvTRUE(ERRSV)) {
2863 Perl_croak(aTHX_ SvPVx_nolen_const(ERRSV));
2869 /* Require a module. */
2872 =head1 Embedding Functions
2874 =for apidoc p||require_pv
2876 Tells Perl to C<require> the file named by the string argument. It is
2877 analogous to the Perl code C<eval "require '$file'">. It's even
2878 implemented that way; consider using load_module instead.
2883 Perl_require_pv(pTHX_ const char *pv)
2887 PUSHSTACKi(PERLSI_REQUIRE);
2889 sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0);
2890 eval_sv(sv_2mortal(sv), G_DISCARD);
2896 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
2900 if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
2901 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
2905 S_usage(pTHX_ const char *name) /* XXX move this out into a module ? */
2907 /* This message really ought to be max 23 lines.
2908 * Removed -h because the user already knows that option. Others? */
2910 static const char * const usage_msg[] = {
2911 "-0[octal] specify record separator (\\0, if no argument)",
2912 "-a autosplit mode with -n or -p (splits $_ into @F)",
2913 "-C[number/list] enables the listed Unicode features",
2914 "-c check syntax only (runs BEGIN and CHECK blocks)",
2915 "-d[:debugger] run program under debugger",
2916 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
2917 "-e program one line of program (several -e's allowed, omit programfile)",
2918 "-f don't do $sitelib/sitecustomize.pl at startup",
2919 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
2920 "-i[extension] edit <> files in place (makes backup if extension supplied)",
2921 "-Idirectory specify @INC/#include directory (several -I's allowed)",
2922 "-l[octal] enable line ending processing, specifies line terminator",
2923 "-[mM][-]module execute \"use/no module...\" before executing program",
2924 "-n assume \"while (<>) { ... }\" loop around program",
2925 "-p assume loop like -n but print line also, like sed",
2926 "-P run program through C preprocessor before compilation",
2927 "-s enable rudimentary parsing for switches after programfile",
2928 "-S look for programfile using PATH environment variable",
2929 "-t enable tainting warnings",
2930 "-T enable tainting checks",
2931 "-u dump core after parsing program",
2932 "-U allow unsafe operations",
2933 "-v print version, subversion (includes VERY IMPORTANT perl info)",
2934 "-V[:variable] print configuration summary (or a single Config.pm variable)",
2935 "-w enable many useful warnings (RECOMMENDED)",
2936 "-W enable all warnings",
2937 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
2938 "-X disable all warnings",
2942 const char * const *p = usage_msg;
2944 PerlIO_printf(PerlIO_stdout(),
2945 "\nUsage: %s [switches] [--] [programfile] [arguments]",
2948 PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
2951 /* convert a string of -D options (or digits) into an int.
2952 * sets *s to point to the char after the options */
2956 Perl_get_debug_opts(pTHX_ char **s)
2958 return get_debug_opts_flags(s, 1);
2962 Perl_get_debug_opts_flags(pTHX_ char **s, int flags)
2964 static const char * const usage_msgd[] = {
2965 " Debugging flag values: (see also -d)",
2966 " p Tokenizing and parsing (with v, displays parse stack)",
2967 " s Stack snapshots (with v, displays all stacks)",
2968 " l Context (loop) stack processing",
2969 " t Trace execution",
2970 " o Method and overloading resolution",
2971 " c String/numeric conversions",
2972 " P Print profiling info, preprocessor command for -P, source file input state",
2973 " m Memory allocation",
2974 " f Format processing",
2975 " r Regular expression parsing and execution",
2976 " x Syntax tree dump",
2977 " u Tainting checks",
2978 " H Hash dump -- usurps values()",
2979 " X Scratchpad allocation",
2981 " S Thread synchronization",
2983 " R Include reference counts of dumped variables (eg when using -Ds)",
2984 " J Do not s,t,P-debug (Jump over) opcodes within package DB",
2985 " v Verbose: use in conjunction with other flags",
2987 " A Consistency checks on internal structures",
2988 " q quiet - currently only suppresses the 'EXECUTING' message",
2993 /* if adding extra options, remember to update DEBUG_MASK */
2994 static const char debopts[] = "psltocPmfrxu HXDSTRJvC";
2996 for (; isALNUM(**s); (*s)++) {
2997 const char *d = strchr(debopts,**s);
2999 i |= 1 << (d - debopts);
3000 else if (ckWARN_d(WARN_DEBUGGING))
3001 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3002 "invalid option -D%c, use -D'' to see choices\n", **s);
3005 else if (isDIGIT(**s)) {
3007 for (; isALNUM(**s); (*s)++) ;
3009 else if (flags & 1) {
3011 const char *const *p = usage_msgd;
3012 while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++);
3015 if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
3016 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3017 "-Dp not implemented on this platform\n");
3023 /* This routine handles any switches that can be given during run */
3026 Perl_moreswitches(pTHX_ char *s)
3036 SvREFCNT_dec(PL_rs);
3037 if (s[1] == 'x' && s[2]) {
3038 const char *e = s+=2;
3044 flags = PERL_SCAN_SILENT_ILLDIGIT;
3045 rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
3046 if (s + numlen < e) {
3047 rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
3051 PL_rs = newSVpvn("", 0);
3052 SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
3053 tmps = (U8*)SvPVX(PL_rs);
3054 uvchr_to_utf8(tmps, rschar);
3055 SvCUR_set(PL_rs, UNISKIP(rschar));
3060 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
3061 if (rschar & ~((U8)~0))
3062 PL_rs = &PL_sv_undef;
3063 else if (!rschar && numlen >= 2)
3064 PL_rs = newSVpvn("", 0);
3066 char ch = (char)rschar;
3067 PL_rs = newSVpvn(&ch, 1);
3070 sv_setsv(get_sv("/", TRUE), PL_rs);
3075 PL_unicode = parse_unicode_opts(&s);
3080 while (*s && !isSPACE(*s)) ++s;
3082 PL_splitstr = savepv(PL_splitstr);
3096 /* -dt indicates to the debugger that threads will be used */
3097 if (*s == 't' && !isALNUM(s[1])) {
3099 my_setenv("PERL5DB_THREADED", "1");
3102 /* The following permits -d:Mod to accepts arguments following an =
3103 in the fashion that -MSome::Mod does. */
3104 if (*s == ':' || *s == '=') {
3107 sv = newSVpv("use Devel::", 0);
3109 /* We now allow -d:Module=Foo,Bar */
3110 while(isALNUM(*s) || *s==':') ++s;
3112 sv_catpv(sv, start);
3114 sv_catpvn(sv, start, s-start);
3115 Perl_sv_catpvf(aTHX_ sv, " split(/,/,q%c%s%c)", 0, ++s, 0);
3118 my_setenv("PERL5DB", (char *)SvPV_nolen_const(sv));
3121 PL_perldb = PERLDB_ALL;
3130 PL_debug = get_debug_opts_flags( &s, 1) | DEBUG_TOP_FLAG;
3131 #else /* !DEBUGGING */
3132 if (ckWARN_d(WARN_DEBUGGING))
3133 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3134 "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
3135 for (s++; isALNUM(*s); s++) ;
3140 usage(PL_origargv[0]);
3143 Safefree(PL_inplace);
3144 #if defined(__CYGWIN__) /* do backup extension automagically */
3145 if (*(s+1) == '\0') {
3146 PL_inplace = savepv(".bak");
3149 #endif /* __CYGWIN__ */
3150 PL_inplace = savepv(s+1);
3151 for (s = PL_inplace; *s && !isSPACE(*s); s++)
3155 if (*s == '-') /* Additional switches on #! line. */
3159 case 'I': /* -I handled both here and in parse_body() */
3162 while (*s && isSPACE(*s))
3167 /* ignore trailing spaces (possibly followed by other switches) */
3169 for (e = p; *e && !isSPACE(*e); e++) ;
3173 } while (*p && *p != '-');
3174 e = savepvn(s, e-s);
3175 incpush(e, TRUE, TRUE, FALSE);
3182 Perl_croak(aTHX_ "No directory specified for -I");
3188 SvREFCNT_dec(PL_ors_sv);
3194 PL_ors_sv = newSVpvn("\n",1);
3195 numlen = 3 + (*s == '0');
3196 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
3200 if (RsPARA(PL_rs)) {
3201 PL_ors_sv = newSVpvn("\n\n",2);
3204 PL_ors_sv = newSVsv(PL_rs);
3209 forbid_setid("-M"); /* XXX ? */
3212 forbid_setid("-m"); /* XXX ? */
3216 const char *use = "use ";
3217 /* -M-foo == 'no foo' */
3218 /* Leading space on " no " is deliberate, to make both
3219 possibilities the same length. */
3220 if (*s == '-') { use = " no "; ++s; }
3221 sv = newSVpvn(use,4);
3223 /* We allow -M'Module qw(Foo Bar)' */
3224 while(isALNUM(*s) || *s==':') ++s;
3226 sv_catpv(sv, start);
3227 if (*(start-1) == 'm') {
3229 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
3230 sv_catpv( sv, " ()");
3234 Perl_croak(aTHX_ "Module name required with -%c option",
3236 sv_catpvn(sv, start, s-start);
3237 sv_catpv(sv, " split(/,/,q");
3238 sv_catpvn(sv, "\0)", 1); /* Use NUL as q//-delimiter. */
3240 sv_catpvn(sv, "\0)", 2);
3244 PL_preambleav = newAV();
3245 av_push(PL_preambleav, sv);
3248 Perl_croak(aTHX_ "Missing argument to -%c", *(s-1));
3260 PL_doswitches = TRUE;
3274 #ifdef MACOS_TRADITIONAL
3275 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
3277 PL_do_undump = TRUE;
3286 PerlIO_printf(PerlIO_stdout(),
3287 Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
3288 PL_patchlevel, ARCHNAME));
3290 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
3291 PerlIO_printf(PerlIO_stdout(),
3292 Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel));
3293 PerlIO_printf(PerlIO_stdout(),
3294 Perl_form(aTHX_ " built under %s at %s %s\n",
3295 OSNAME, __DATE__, __TIME__));
3296 PerlIO_printf(PerlIO_stdout(),
3297 Perl_form(aTHX_ " OS Specific Release: %s\n",
3301 #if defined(LOCAL_PATCH_COUNT)
3302 if (LOCAL_PATCH_COUNT > 0)
3303 PerlIO_printf(PerlIO_stdout(),
3304 "\n(with %d registered patch%s, "
3305 "see perl -V for more detail)",
3306 (int)LOCAL_PATCH_COUNT,
3307 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
3310 PerlIO_printf(PerlIO_stdout(),
3311 "\n\nCopyright 1987-2006, Larry Wall\n");
3312 #ifdef MACOS_TRADITIONAL
3313 PerlIO_printf(PerlIO_stdout(),
3314 "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
3315 "maintained by Chris Nandor\n");
3318 PerlIO_printf(PerlIO_stdout(),
3319 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
3322 PerlIO_printf(PerlIO_stdout(),
3323 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
3324 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
3327 PerlIO_printf(PerlIO_stdout(),
3328 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
3329 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
3332 PerlIO_printf(PerlIO_stdout(),
3333 "atariST series port, ++jrb bammi@cadence.com\n");
3336 PerlIO_printf(PerlIO_stdout(),
3337 "BeOS port Copyright Tom Spindler, 1997-1999\n");
3340 PerlIO_printf(PerlIO_stdout(),
3341 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2003\n");
3344 PerlIO_printf(PerlIO_stdout(),
3345 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
3348 PerlIO_printf(PerlIO_stdout(),
3349 "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
3352 PerlIO_printf(PerlIO_stdout(),
3353 "VM/ESA port by Neale Ferguson, 1998-1999\n");
3356 PerlIO_printf(PerlIO_stdout(),
3357 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
3360 PerlIO_printf(PerlIO_stdout(),
3361 "MiNT port by Guido Flohr, 1997-1999\n");
3364 PerlIO_printf(PerlIO_stdout(),
3365 "EPOC port by Olaf Flebbe, 1999-2002\n");
3368 PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
3369 PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
3372 #ifdef BINARY_BUILD_NOTICE
3373 BINARY_BUILD_NOTICE;
3375 PerlIO_printf(PerlIO_stdout(),
3377 Perl may be copied only under the terms of either the Artistic License or the\n\
3378 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
3379 Complete documentation for Perl, including FAQ lists, should be found on\n\
3380 this system using \"man perl\" or \"perldoc perl\". If you have access to the\n\
3381 Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
3384 if (! (PL_dowarn & G_WARN_ALL_MASK))
3385 PL_dowarn |= G_WARN_ON;
3389 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
3390 if (!specialWARN(PL_compiling.cop_warnings))
3391 SvREFCNT_dec(PL_compiling.cop_warnings);
3392 PL_compiling.cop_warnings = pWARN_ALL ;
3396 PL_dowarn = G_WARN_ALL_OFF;
3397 if (!specialWARN(PL_compiling.cop_warnings))
3398 SvREFCNT_dec(PL_compiling.cop_warnings);
3399 PL_compiling.cop_warnings = pWARN_NONE ;
3404 if (s[1] == '-') /* Additional switches on #! line. */
3409 #if defined(WIN32) || !defined(PERL_STRICT_CR)
3415 #ifdef ALTERNATE_SHEBANG
3416 case 'S': /* OS/2 needs -S on "extproc" line. */
3424 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
3429 /* compliments of Tom Christiansen */
3431 /* unexec() can be found in the Gnu emacs distribution */
3432 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
3435 Perl_my_unexec(pTHX)
3443 prog = newSVpv(BIN_EXP, 0);
3444 sv_catpv(prog, "/perl");
3445 file = newSVpv(PL_origfilename, 0);
3446 sv_catpv(file, ".perldump");
3448 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
3449 /* unexec prints msg to stderr in case of failure */
3450 PerlProc_exit(status);
3453 # include <lib$routines.h>
3454 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
3456 ABORT(); /* for use with undump */
3461 /* initialize curinterp */
3467 # define PERLVAR(var,type)
3468 # define PERLVARA(var,n,type)
3469 # if defined(PERL_IMPLICIT_CONTEXT)
3470 # if defined(USE_5005THREADS)
3471 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
3472 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
3473 # else /* !USE_5005THREADS */
3474 # define PERLVARI(var,type,init) aTHX->var = init;
3475 # define PERLVARIC(var,type,init) aTHX->var = init;
3476 # endif /* USE_5005THREADS */
3478 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
3479 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
3481 # include "intrpvar.h"
3482 # ifndef USE_5005THREADS
3483 # include "thrdvar.h"
3490 # define PERLVAR(var,type)
3491 # define PERLVARA(var,n,type)
3492 # define PERLVARI(var,type,init) PL_##var = init;
3493 # define PERLVARIC(var,type,init) PL_##var = init;
3494 # include "intrpvar.h"
3495 # ifndef USE_5005THREADS
3496 # include "thrdvar.h"
3507 S_init_main_stash(pTHX)
3511 PL_curstash = PL_defstash = newHV();
3512 PL_curstname = newSVpvn("main",4);
3513 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
3514 SvREFCNT_dec(GvHV(gv));
3515 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
3517 hv_name_set(PL_defstash, "main", 4, 0);
3518 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
3519 GvMULTI_on(PL_incgv);
3520 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
3521 GvMULTI_on(PL_hintgv);
3522 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
3523 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
3524 GvMULTI_on(PL_errgv);
3525 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
3526 GvMULTI_on(PL_replgv);
3527 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
3528 #ifdef PERL_DONT_CREATE_GVSV
3531 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
3532 sv_setpvn(ERRSV, "", 0);
3533 PL_curstash = PL_defstash;
3534 CopSTASH_set(&PL_compiling, PL_defstash);
3535 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
3536 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
3537 PL_nullstash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
3538 /* We must init $/ before switches are processed. */
3539 sv_setpvn(get_sv("/", TRUE), "\n", 1);
3542 /* PSz 18 Nov 03 fdscript now global but do not change prototype */
3544 S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv)
3549 const char *cpp_discard_flag;
3557 PL_origfilename = savepv("-e");
3560 /* if find_script() returns, it returns a malloc()-ed value */
3561 scriptname = PL_origfilename = find_script((char *)scriptname, dosearch, NULL, 1);
3563 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
3564 const char *s = scriptname + 8;
3565 PL_fdscript = atoi(s);
3570 * Tell apart "normal" usage of fdscript, e.g.
3571 * with bash on FreeBSD:
3572 * perl <( echo '#!perl -DA'; echo 'print "$0\n"')
3573 * from usage in suidperl.
3574 * Does any "normal" usage leave garbage after the number???
3575 * Is it a mistake to use a similar /dev/fd/ construct for
3580 * Be supersafe and do some sanity-checks.
3581 * Still, can we be sure we got the right thing?
3584 Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
3587 Perl_croak(aTHX_ "Missing (suid) fd script name\n");
3589 scriptname = savepv(s + 1);
3590 Safefree(PL_origfilename);
3591 PL_origfilename = (char *)scriptname;
3596 CopFILE_free(PL_curcop);
3597 CopFILE_set(PL_curcop, PL_origfilename);
3598 if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
3599 scriptname = (char *)"";
3600 if (PL_fdscript >= 0) {
3601 PL_rsfp = PerlIO_fdopen(PL_fdscript,PERL_SCRIPT_MODE);
3602 # if defined(HAS_FCNTL) && defined(F_SETFD)
3604 /* ensure close-on-exec */
3605 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
3610 Perl_croak(aTHX_ "sperl needs fd script\n"
3611 "You should not call sperl directly; do you need to "
3612 "change a #! line\nfrom sperl to perl?\n");
3615 * Do not open (or do other fancy stuff) while setuid.
3616 * Perl does the open, and hands script to suidperl on a fd;
3617 * suidperl only does some checks, sets up UIDs and re-execs
3618 * perl with that fd as it has always done.
3621 if (PL_suidscript != 1) {
3622 Perl_croak(aTHX_ "suidperl needs (suid) fd script\n");
3625 else if (PL_preprocess) {
3626 const char *cpp_cfg = CPPSTDIN;
3627 SV *cpp = newSVpvn("",0);
3628 SV *cmd = NEWSV(0,0);
3630 if (cpp_cfg[0] == 0) /* PERL_MICRO? */
3631 Perl_croak(aTHX_ "Can't run with cpp -P with CPPSTDIN undefined");
3632 if (strEQ(cpp_cfg, "cppstdin"))
3633 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
3634 sv_catpv(cpp, cpp_cfg);
3637 sv_catpvn(sv, "-I", 2);
3638 sv_catpv(sv,PRIVLIB_EXP);
3641 DEBUG_P(PerlIO_printf(Perl_debug_log,
3642 "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
3643 scriptname, SvPVX_const (cpp), SvPVX_const (sv),
3646 # if defined(MSDOS) || defined(WIN32) || defined(VMS)
3653 cpp_discard_flag = "";
3655 cpp_discard_flag = "-C";
3659 perl = os2_execname(aTHX);
3661 perl = PL_origargv[0];
3665 /* This strips off Perl comments which might interfere with
3666 the C pre-processor, including #!. #line directives are
3667 deliberately stripped to avoid confusion with Perl's version
3668 of #line. FWP played some golf with it so it will fit
3669 into VMS's 255 character buffer.
3672 code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3674 code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3676 Perl_sv_setpvf(aTHX_ cmd, "\
3677 %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
3678 perl, quote, code, quote, scriptname, cpp,
3679 cpp_discard_flag, sv, CPPMINUS);
3681 PL_doextract = FALSE;
3683 DEBUG_P(PerlIO_printf(Perl_debug_log,
3684 "PL_preprocess: cmd=\"%s\"\n",
3687 PL_rsfp = PerlProc_popen((char *)SvPVX_const(cmd), (char *)"r");
3691 else if (!*scriptname) {
3692 forbid_setid("program input from stdin");
3693 PL_rsfp = PerlIO_stdin();
3696 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
3697 # if defined(HAS_FCNTL) && defined(F_SETFD)
3699 /* ensure close-on-exec */
3700 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
3703 #endif /* IAMSUID */
3705 /* PSz 16 Sep 03 Keep neat error message */
3707 Perl_croak(aTHX_ "Can't open "BIT_BUCKET": %s\n", Strerror(errno));
3709 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3710 CopFILE(PL_curcop), Strerror(errno));
3715 * I_SYSSTATVFS HAS_FSTATVFS
3717 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
3718 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
3719 * here so that metaconfig picks them up. */
3723 S_fd_on_nosuid_fs(pTHX_ int fd)
3726 * We used to do this as "plain" user (after swapping UIDs with setreuid);
3727 * but is needed also on machines without setreuid.
3728 * Seems safe enough to run as root.
3730 int check_okay = 0; /* able to do all the required sys/libcalls */
3731 int on_nosuid = 0; /* the fd is on a nosuid fs */
3733 * Need to check noexec also: nosuid might not be set, the average
3734 * sysadmin would say that nosuid is irrelevant once he sets noexec.
3736 int on_noexec = 0; /* the fd is on a noexec fs */
3739 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
3740 * fstatvfs() is UNIX98.
3741 * fstatfs() is 4.3 BSD.
3742 * ustat()+getmnt() is pre-4.3 BSD.
3743 * getmntent() is O(number-of-mounted-filesystems) and can hang on
3744 * an irrelevant filesystem while trying to reach the right one.
3747 #undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
3749 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3750 defined(HAS_FSTATVFS)
3751 # define FD_ON_NOSUID_CHECK_OKAY
3752 struct statvfs stfs;
3754 check_okay = fstatvfs(fd, &stfs) == 0;
3755 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
3757 /* ST_NOEXEC certainly absent on AIX 5.1, and doesn't seem to be documented
3758 on platforms where it is present. */
3759 on_noexec = check_okay && (stfs.f_flag & ST_NOEXEC);
3761 # endif /* fstatvfs */
3763 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3764 defined(PERL_MOUNT_NOSUID) && \
3765 defined(PERL_MOUNT_NOEXEC) && \
3766 defined(HAS_FSTATFS) && \
3767 defined(HAS_STRUCT_STATFS) && \
3768 defined(HAS_STRUCT_STATFS_F_FLAGS)
3769 # define FD_ON_NOSUID_CHECK_OKAY
3772 check_okay = fstatfs(fd, &stfs) == 0;
3773 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
3774 on_noexec = check_okay && (stfs.f_flags & PERL_MOUNT_NOEXEC);
3775 # endif /* fstatfs */
3777 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3778 defined(PERL_MOUNT_NOSUID) && \
3779 defined(PERL_MOUNT_NOEXEC) && \
3780 defined(HAS_FSTAT) && \
3781 defined(HAS_USTAT) && \
3782 defined(HAS_GETMNT) && \
3783 defined(HAS_STRUCT_FS_DATA) && \
3785 # define FD_ON_NOSUID_CHECK_OKAY
3788 if (fstat(fd, &fdst) == 0) {
3790 if (ustat(fdst.st_dev, &us) == 0) {
3792 /* NOSTAT_ONE here because we're not examining fields which
3793 * vary between that case and STAT_ONE. */
3794 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
3795 size_t cmplen = sizeof(us.f_fname);
3796 if (sizeof(fsd.fd_req.path) < cmplen)
3797 cmplen = sizeof(fsd.fd_req.path);
3798 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
3799 fdst.st_dev == fsd.fd_req.dev) {
3801 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
3802 on_noexec = fsd.fd_req.flags & PERL_MOUNT_NOEXEC;
3807 # endif /* fstat+ustat+getmnt */
3809 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3810 defined(HAS_GETMNTENT) && \
3811 defined(HAS_HASMNTOPT) && \
3812 defined(MNTOPT_NOSUID) && \
3813 defined(MNTOPT_NOEXEC)
3814 # define FD_ON_NOSUID_CHECK_OKAY
3815 FILE *mtab = fopen("/etc/mtab", "r");
3816 struct mntent *entry;
3819 if (mtab && (fstat(fd, &stb) == 0)) {
3820 while (entry = getmntent(mtab)) {
3821 if (stat(entry->mnt_dir, &fsb) == 0
3822 && fsb.st_dev == stb.st_dev)
3824 /* found the filesystem */
3826 if (hasmntopt(entry, MNTOPT_NOSUID))
3828 if (hasmntopt(entry, MNTOPT_NOEXEC))
3831 } /* A single fs may well fail its stat(). */
3836 # endif /* getmntent+hasmntopt */
3839 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid/noexec", PL_origfilename);
3841 Perl_croak(aTHX_ "Setuid script \"%s\" on nosuid filesystem", PL_origfilename);
3843 Perl_croak(aTHX_ "Setuid script \"%s\" on noexec filesystem", PL_origfilename);
3844 return ((!check_okay) || on_nosuid || on_noexec);
3846 #endif /* IAMSUID */
3849 S_validate_suid(pTHX_ const char *validarg, const char *scriptname)
3853 #endif /* IAMSUID */
3855 /* do we need to emulate setuid on scripts? */
3857 /* This code is for those BSD systems that have setuid #! scripts disabled
3858 * in the kernel because of a security problem. Merely defining DOSUID
3859 * in perl will not fix that problem, but if you have disabled setuid
3860 * scripts in the kernel, this will attempt to emulate setuid and setgid
3861 * on scripts that have those now-otherwise-useless bits set. The setuid
3862 * root version must be called suidperl or sperlN.NNN. If regular perl
3863 * discovers that it has opened a setuid script, it calls suidperl with
3864 * the same argv that it had. If suidperl finds that the script it has
3865 * just opened is NOT setuid root, it sets the effective uid back to the
3866 * uid. We don't just make perl setuid root because that loses the
3867 * effective uid we had before invoking perl, if it was different from the
3870 * Description/comments above do not match current workings:
3871 * suidperl must be hardlinked to sperlN.NNN (that is what we exec);
3872 * suidperl called with script open and name changed to /dev/fd/N/X;
3873 * suidperl croaks if script is not setuid;
3874 * making perl setuid would be a huge security risk (and yes, that
3875 * would lose any euid we might have had).
3877 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3878 * be defined in suidperl only. suidperl must be setuid root. The
3879 * Configure script will set this up for you if you want it.
3885 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
3886 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
3887 if (PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
3889 const char *linestr;
3892 if (PL_fdscript < 0 || PL_suidscript != 1)
3893 Perl_croak(aTHX_ "Need (suid) fdscript in suidperl\n"); /* We already checked this */
3895 * Since the script is opened by perl, not suidperl, some of these
3896 * checks are superfluous. Leaving them in probably does not lower
3900 * Do checks even for systems with no HAS_SETREUID.
3901 * We used to swap, then re-swap UIDs with
3903 if (setreuid(PL_euid,PL_uid) < 0
3904 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
3905 Perl_croak(aTHX_ "Can't swap uid and euid");
3908 if (setreuid(PL_uid,PL_euid) < 0
3909 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3910 Perl_croak(aTHX_ "Can't reswap uid and euid");
3914 /* On this access check to make sure the directories are readable,
3915 * there is actually a small window that the user could use to make
3916 * filename point to an accessible directory. So there is a faint
3917 * chance that someone could execute a setuid script down in a
3918 * non-accessible directory. I don't know what to do about that.
3919 * But I don't think it's too important. The manual lies when
3920 * it says access() is useful in setuid programs.
3922 * So, access() is pretty useless... but not harmful... do anyway.
3924 if (PerlLIO_access(CopFILE(PL_curcop),1)) { /*double check*/
3925 Perl_croak(aTHX_ "Can't access() script\n");
3928 /* If we can swap euid and uid, then we can determine access rights
3929 * with a simple stat of the file, and then compare device and
3930 * inode to make sure we did stat() on the same file we opened.
3931 * Then we just have to make sure he or she can execute it.
3934 * As the script is opened by perl, not suidperl, we do not need to
3935 * care much about access rights.
3937 * The 'script changed' check is needed, or we can get lied to
3938 * about $0 with e.g.
3939 * suidperl /dev/fd/4//bin/x 4<setuidscript
3940 * Without HAS_SETREUID, is it safe to stat() as root?
3942 * Are there any operating systems that pass /dev/fd/xxx for setuid
3943 * scripts, as suggested/described in perlsec(1)? Surely they do not
3944 * pass the script name as we do, so the "script changed" test would
3945 * fail for them... but we never get here with
3946 * SETUID_SCRIPTS_ARE_SECURE_NOW defined.
3948 * This is one place where we must "lie" about return status: not
3949 * say if the stat() failed. We are doing this as root, and could
3950 * be tricked into reporting existence or not of files that the
3951 * "plain" user cannot even see.
3955 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0 ||
3956 tmpstatbuf.st_dev != PL_statbuf.st_dev ||
3957 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
3958 Perl_croak(aTHX_ "Setuid script changed\n");
3962 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
3963 Perl_croak(aTHX_ "Real UID cannot exec script\n");
3966 * We used to do this check as the "plain" user (after swapping
3967 * UIDs). But the check for nosuid and noexec filesystem is needed,
3968 * and should be done even without HAS_SETREUID. (Maybe those
3969 * operating systems do not have such mount options anyway...)
3970 * Seems safe enough to do as root.
3972 #if !defined(NO_NOSUID_CHECK)
3973 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp))) {
3974 Perl_croak(aTHX_ "Setuid script on nosuid or noexec filesystem\n");
3977 #endif /* IAMSUID */
3979 if (!S_ISREG(PL_statbuf.st_mode)) {
3980 Perl_croak(aTHX_ "Setuid script not plain file\n");
3982 if (PL_statbuf.st_mode & S_IWOTH)
3983 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
3984 PL_doswitches = FALSE; /* -s is insecure in suid */
3985 /* PSz 13 Nov 03 But -s was caught elsewhere ... so unsetting it here is useless(?!) */
3986 CopLINE_inc(PL_curcop);
3987 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch)
3988 Perl_croak(aTHX_ "No #! line");
3989 linestr = SvPV_nolen_const(PL_linestr);
3990 /* required even on Sys V */
3991 if (!*linestr || !linestr[1] || strnNE(linestr,"#!",2))
3992 Perl_croak(aTHX_ "No #! line");
3996 /* Sanity check on line length */
3997 if (strlen(s) < 1 || strlen(s) > 4000)
3998 Perl_croak(aTHX_ "Very long #! line");
3999 /* Allow more than a single space after #! */
4000 while (isSPACE(*s)) s++;
4001 /* Sanity check on buffer end */
4002 while ((*s) && !isSPACE(*s)) s++;
4003 for (s2 = s; (s2 > linestr &&
4004 (isDIGIT(s2[-1]) || s2[-1] == '.' || s2[-1] == '_'
4005 || s2[-1] == '-')); s2--) ;
4006 /* Sanity check on buffer start */
4007 if ( (s2-4 < linestr || strnNE(s2-4,"perl",4)) &&
4008 (s-9 < linestr || strnNE(s-9,"perl",4)) )
4009 Perl_croak(aTHX_ "Not a perl script");
4010 while (*s == ' ' || *s == '\t') s++;
4012 * #! arg must be what we saw above. They can invoke it by
4013 * mentioning suidperl explicitly, but they may not add any strange
4014 * arguments beyond what #! says if they do invoke suidperl that way.
4017 * The way validarg was set up, we rely on the kernel to start
4018 * scripts with argv[1] set to contain all #! line switches (the
4022 * Check that we got all the arguments listed in the #! line (not
4023 * just that there are no extraneous arguments). Might not matter
4024 * much, as switches from #! line seem to be acted upon (also), and
4025 * so may be checked and trapped in perl. But, security checks must
4026 * be done in suidperl and not deferred to perl. Note that suidperl
4027 * does not get around to parsing (and checking) the switches on
4028 * the #! line (but execs perl sooner).
4029 * Allow (require) a trailing newline (which may be of two
4030 * characters on some architectures?) (but no other trailing
4033 len = strlen(validarg);
4034 if (strEQ(validarg," PHOOEY ") ||
4035 strnNE(s,validarg,len) || !isSPACE(s[len]) ||
4036 !(strlen(s) == len+1 || (strlen(s) == len+2 && isSPACE(s[len+1]))))
4037 Perl_croak(aTHX_ "Args must match #! line");
4040 if (PL_fdscript < 0 &&
4041 PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
4042 PL_euid == PL_statbuf.st_uid)
4044 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
4045 FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
4046 #endif /* IAMSUID */
4048 if (PL_fdscript < 0 &&
4049 PL_euid) { /* oops, we're not the setuid root perl */
4051 * When root runs a setuid script, we do not go through the same
4052 * steps of execing sperl and then perl with fd scripts, but
4053 * simply set up UIDs within the same perl invocation; so do
4054 * not have the same checks (on options, whatever) that we have
4055 * for plain users. No problem really: would have to be a script
4056 * that does not actually work for plain users; and if root is
4057 * foolish and can be persuaded to run such an unsafe script, he
4058 * might run also non-setuid ones, and deserves what he gets.
4060 * Or, we might drop the PL_euid check above (and rely just on
4061 * PL_fdscript to avoid loops), and do the execs
4067 * Pass fd script to suidperl.
4068 * Exec suidperl, substituting fd script for scriptname.
4069 * Pass script name as "subdir" of fd, which perl will grok;
4070 * in fact will use that to distinguish this from "normal"
4071 * usage, see comments above.
4073 PerlIO_rewind(PL_rsfp);
4074 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
4075 /* PSz 27 Feb 04 Sanity checks on scriptname */
4076 if ((!scriptname) || (!*scriptname) ) {
4077 Perl_croak(aTHX_ "No setuid script name\n");
4079 if (*scriptname == '-') {
4080 Perl_croak(aTHX_ "Setuid script name may not begin with dash\n");
4081 /* Or we might confuse it with an option when replacing
4082 * name in argument list, below (though we do pointer, not
4083 * string, comparisons).
4086 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
4087 if (!PL_origargv[which]) {
4088 Perl_croak(aTHX_ "Can't change argv to have fd script\n");
4090 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
4091 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
4092 #if defined(HAS_FCNTL) && defined(F_SETFD)
4093 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
4096 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
4097 (int)PERL_REVISION, (int)PERL_VERSION,
4098 (int)PERL_SUBVERSION), PL_origargv);
4100 #endif /* IAMSUID */
4101 Perl_croak(aTHX_ "Can't do setuid (cannot exec sperl)\n");
4104 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
4106 * This seems back to front: we try HAS_SETEGID first; if not available
4107 * then try HAS_SETREGID; as a last chance we try HAS_SETRESGID. May be OK
4108 * in the sense that we only want to set EGID; but are there any machines
4109 * with either of the latter, but not the former? Same with UID, later.
4112 (void)setegid(PL_statbuf.st_gid);
4115 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
4117 #ifdef HAS_SETRESGID
4118 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
4120 PerlProc_setgid(PL_statbuf.st_gid);
4124 if (PerlProc_getegid() != PL_statbuf.st_gid)
4125 Perl_croak(aTHX_ "Can't do setegid!\n");
4127 if (PL_statbuf.st_mode & S_ISUID) {
4128 if (PL_statbuf.st_uid != PL_euid)
4130 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
4133 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
4135 #ifdef HAS_SETRESUID
4136 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
4138 PerlProc_setuid(PL_statbuf.st_uid);
4142 if (PerlProc_geteuid() != PL_statbuf.st_uid)
4143 Perl_croak(aTHX_ "Can't do seteuid!\n");
4145 else if (PL_uid) { /* oops, mustn't run as root */
4147 (void)seteuid((Uid_t)PL_uid);
4150 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
4152 #ifdef HAS_SETRESUID
4153 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
4155 PerlProc_setuid((Uid_t)PL_uid);
4159 if (PerlProc_geteuid() != PL_uid)
4160 Perl_croak(aTHX_ "Can't do seteuid!\n");
4163 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
4164 Perl_croak(aTHX_ "Effective UID cannot exec script\n"); /* they can't do this */
4167 else if (PL_preprocess) /* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */
4168 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
4169 else if (PL_fdscript < 0 || PL_suidscript != 1)
4170 /* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */
4171 Perl_croak(aTHX_ "(suid) fdscript needed in suidperl\n");
4173 /* PSz 16 Sep 03 Keep neat error message */
4174 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
4177 /* We absolutely must clear out any saved ids here, so we */
4178 /* exec the real perl, substituting fd script for scriptname. */
4179 /* (We pass script name as "subdir" of fd, which perl will grok.) */
4181 * It might be thought that using setresgid and/or setresuid (changed to
4182 * set the saved IDs) above might obviate the need to exec, and we could
4183 * go on to "do the perl thing".
4185 * Is there such a thing as "saved GID", and is that set for setuid (but
4186 * not setgid) execution like suidperl? Without exec, it would not be
4187 * cleared for setuid (but not setgid) scripts (or might need a dummy
4190 * We need suidperl to do the exact same argument checking that perl
4191 * does. Thus it cannot be very small; while it could be significantly
4192 * smaller, it is safer (simpler?) to make it essentially the same
4193 * binary as perl (but they are not identical). - Maybe could defer that
4194 * check to the invoked perl, and suidperl be a tiny wrapper instead;
4195 * but prefer to do thorough checks in suidperl itself. Such deferral
4196 * would make suidperl security rely on perl, a design no-no.
4198 * Setuid things should be short and simple, thus easy to understand and
4199 * verify. They should do their "own thing", without influence by
4200 * attackers. It may help if their internal execution flow is fixed,
4201 * regardless of platform: it may be best to exec anyway.
4203 * Suidperl should at least be conceptually simple: a wrapper only,
4204 * never to do any real perl. Maybe we should put
4206 * Perl_croak(aTHX_ "Suidperl should never do real perl\n");
4208 * into the perly bits.
4210 PerlIO_rewind(PL_rsfp);
4211 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
4213 * Keep original arguments: suidperl already has fd script.
4215 /* for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ; */
4216 /* if (!PL_origargv[which]) { */
4217 /* errno = EPERM; */
4218 /* Perl_croak(aTHX_ "Permission denied\n"); */
4220 /* PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s", */
4221 /* PerlIO_fileno(PL_rsfp), PL_origargv[which])); */
4222 #if defined(HAS_FCNTL) && defined(F_SETFD)
4223 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
4226 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
4227 (int)PERL_REVISION, (int)PERL_VERSION,
4228 (int)PERL_SUBVERSION), PL_origargv);/* try again */
4230 Perl_croak(aTHX_ "Can't do setuid (suidperl cannot exec perl)\n");
4231 #endif /* IAMSUID */
4233 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
4234 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
4235 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
4236 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
4238 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
4241 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
4242 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
4243 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4244 /* not set-id, must be wrapped */
4252 S_find_beginning(pTHX)
4255 register const char *s2;
4256 #ifdef MACOS_TRADITIONAL
4260 /* skip forward in input to the real script? */
4263 #ifdef MACOS_TRADITIONAL
4264 /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
4266 while (PL_doextract || gMacPerl_AlwaysExtract) {
4267 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
4268 if (!gMacPerl_AlwaysExtract)
4269 Perl_croak(aTHX_ "No Perl script found in input\n");
4271 if (PL_doextract) /* require explicit override ? */
4272 if (!OverrideExtract(PL_origfilename))
4273 Perl_croak(aTHX_ "User aborted script\n");
4275 PL_doextract = FALSE;
4277 /* Pater peccavi, file does not have #! */
4278 PerlIO_rewind(PL_rsfp);
4283 while (PL_doextract) {
4284 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
4285 Perl_croak(aTHX_ "No Perl script found in input\n");
4288 if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
4289 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
4290 PL_doextract = FALSE;
4291 while (*s && !(isSPACE (*s) || *s == '#')) s++;
4293 while (*s == ' ' || *s == '\t') s++;
4295 while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
4296 || s2[-1] == '_') s2--;
4297 if (strnEQ(s2-4,"perl",4))
4298 while ((s = moreswitches(s)))
4301 #ifdef MACOS_TRADITIONAL
4302 /* We are always searching for the #!perl line in MacPerl,
4303 * so if we find it, still keep the line count correct
4304 * by counting lines we already skipped over
4306 for (; maclines > 0 ; maclines--)
4307 PerlIO_ungetc(PL_rsfp, '\n');
4311 /* gMacPerl_AlwaysExtract is false in MPW tool */
4312 } else if (gMacPerl_AlwaysExtract) {
4323 PL_uid = PerlProc_getuid();
4324 PL_euid = PerlProc_geteuid();
4325 PL_gid = PerlProc_getgid();
4326 PL_egid = PerlProc_getegid();
4328 PL_uid |= PL_gid << 16;
4329 PL_euid |= PL_egid << 16;
4331 /* Should not happen: */
4332 CHECK_MALLOC_TAINT(PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
4333 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
4336 * Should go by suidscript, not uid!=euid: why disallow
4337 * system("ls") in scripts run from setuid things?
4338 * Or, is this run before we check arguments and set suidscript?
4339 * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
4340 * (We never have suidscript, can we be sure to have fdscript?)
4341 * Or must then go by UID checks? See comments in forbid_setid also.
4345 /* This is used very early in the lifetime of the program,
4346 * before even the options are parsed, so PL_tainting has
4347 * not been initialized properly. */
4349 Perl_doing_taint(int argc, char *argv[], char *envp[])
4351 #ifndef PERL_IMPLICIT_SYS
4352 /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
4353 * before we have an interpreter-- and the whole point of this
4354 * function is to be called at such an early stage. If you are on
4355 * a system with PERL_IMPLICIT_SYS but you do have a concept of
4356 * "tainted because running with altered effective ids', you'll
4357 * have to add your own checks somewhere in here. The two most
4358 * known samples of 'implicitness' are Win32 and NetWare, neither
4359 * of which has much of concept of 'uids'. */
4360 int uid = PerlProc_getuid();
4361 int euid = PerlProc_geteuid();
4362 int gid = PerlProc_getgid();
4363 int egid = PerlProc_getegid();
4370 if (uid && (euid != uid || egid != gid))
4372 #endif /* !PERL_IMPLICIT_SYS */
4373 /* This is a really primitive check; environment gets ignored only
4374 * if -T are the first chars together; otherwise one gets
4375 * "Too late" message. */
4376 if ( argc > 1 && argv[1][0] == '-'
4377 && (argv[1][1] == 't' || argv[1][1] == 'T') )
4383 S_forbid_setid(pTHX_ const char *s)
4385 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
4386 if (PL_euid != PL_uid)
4387 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
4388 if (PL_egid != PL_gid)
4389 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
4390 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4392 * Checks for UID/GID above "wrong": why disallow
4393 * perl -e 'print "Hello\n"'
4394 * from within setuid things?? Simply drop them: replaced by
4395 * fdscript/suidscript and #ifdef IAMSUID checks below.
4397 * This may be too late for command-line switches. Will catch those on
4398 * the #! line, after finding the script name and setting up
4399 * fdscript/suidscript. Note that suidperl does not get around to
4400 * parsing (and checking) the switches on the #! line, but checks that
4401 * the two sets are identical.
4403 * With SETUID_SCRIPTS_ARE_SECURE_NOW, could we use fdscript, also or
4404 * instead, or would that be "too late"? (We never have suidscript, can
4405 * we be sure to have fdscript?)
4407 * Catch things with suidscript (in descendant of suidperl), even with
4408 * right UID/GID. Was already checked in suidperl, with #ifdef IAMSUID,
4409 * below; but I am paranoid.
4411 * Also see comments about root running a setuid script, elsewhere.
4413 if (PL_suidscript >= 0)
4414 Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", s);
4416 /* PSz 11 Nov 03 Catch it in suidperl, always! */
4417 Perl_croak(aTHX_ "No %s allowed in suidperl", s);
4418 #endif /* IAMSUID */
4422 Perl_init_debugger(pTHX)
4424 HV *ostash = PL_curstash;
4426 PL_curstash = PL_debstash;
4427 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("DB::args", GV_ADDMULTI, SVt_PVAV))));
4428 AvREAL_off(PL_dbargs);
4429 PL_DBgv = gv_fetchpv("DB::DB", GV_ADDMULTI, SVt_PVGV);
4430 PL_DBline = gv_fetchpv("DB::dbline", GV_ADDMULTI, SVt_PVAV);
4431 PL_DBsub = gv_HVadd(gv_fetchpv("DB::sub", GV_ADDMULTI, SVt_PVHV));
4432 PL_DBsingle = GvSV((gv_fetchpv("DB::single", GV_ADDMULTI, SVt_PV)));
4433 sv_setiv(PL_DBsingle, 0);
4434 PL_DBtrace = GvSV((gv_fetchpv("DB::trace", GV_ADDMULTI, SVt_PV)));
4435 sv_setiv(PL_DBtrace, 0);
4436 PL_DBsignal = GvSV((gv_fetchpv("DB::signal", GV_ADDMULTI, SVt_PV)));
4437 sv_setiv(PL_DBsignal, 0);
4438 PL_curstash = ostash;
4441 #ifndef STRESS_REALLOC
4442 #define REASONABLE(size) (size)
4444 #define REASONABLE(size) (1) /* unreasonable */
4448 Perl_init_stacks(pTHX)
4450 /* start with 128-item stack and 8K cxstack */
4451 PL_curstackinfo = new_stackinfo(REASONABLE(128),
4452 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
4453 PL_curstackinfo->si_type = PERLSI_MAIN;
4454 PL_curstack = PL_curstackinfo->si_stack;
4455 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
4457 PL_stack_base = AvARRAY(PL_curstack);
4458 PL_stack_sp = PL_stack_base;
4459 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
4461 Newx(PL_tmps_stack,REASONABLE(128),SV*);
4464 PL_tmps_max = REASONABLE(128);
4466 Newx(PL_markstack,REASONABLE(32),I32);
4467 PL_markstack_ptr = PL_markstack;
4468 PL_markstack_max = PL_markstack + REASONABLE(32);
4472 Newx(PL_scopestack,REASONABLE(32),I32);
4473 PL_scopestack_ix = 0;
4474 PL_scopestack_max = REASONABLE(32);
4476 Newx(PL_savestack,REASONABLE(128),ANY);
4477 PL_savestack_ix = 0;
4478 PL_savestack_max = REASONABLE(128);
4480 New(54,PL_retstack,REASONABLE(16),OP*);
4482 PL_retstack_max = REASONABLE(16);
4490 while (PL_curstackinfo->si_next)
4491 PL_curstackinfo = PL_curstackinfo->si_next;
4492 while (PL_curstackinfo) {
4493 PERL_SI *p = PL_curstackinfo->si_prev;
4494 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
4495 Safefree(PL_curstackinfo->si_cxstack);
4496 Safefree(PL_curstackinfo);
4497 PL_curstackinfo = p;
4499 Safefree(PL_tmps_stack);
4500 Safefree(PL_markstack);
4501 Safefree(PL_scopestack);
4502 Safefree(PL_savestack);
4503 Safefree(PL_retstack);
4512 lex_start(PL_linestr);
4514 PL_subname = newSVpvn("main",4);
4518 S_init_predump_symbols(pTHX)
4523 sv_setpvn(get_sv("\"", TRUE), " ", 1);
4524 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
4525 GvMULTI_on(PL_stdingv);
4526 io = GvIOp(PL_stdingv);
4527 IoTYPE(io) = IoTYPE_RDONLY;
4528 IoIFP(io) = PerlIO_stdin();
4529 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
4531 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
4533 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
4536 IoTYPE(io) = IoTYPE_WRONLY;
4537 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4539 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
4541 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
4543 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
4544 GvMULTI_on(PL_stderrgv);
4545 io = GvIOp(PL_stderrgv);
4546 IoTYPE(io) = IoTYPE_WRONLY;
4547 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
4548 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
4550 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
4552 PL_statname = NEWSV(66,0); /* last filename we did stat on */
4554 Safefree(PL_osname);
4555 PL_osname = savepv(OSNAME);
4559 Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
4561 argc--,argv++; /* skip name of script */
4562 if (PL_doswitches) {
4563 for (; argc > 0 && **argv == '-'; argc--,argv++) {
4567 if (argv[0][1] == '-' && !argv[0][2]) {
4571 if ((s = strchr(argv[0], '='))) {
4573 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
4576 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
4579 if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
4580 GvMULTI_on(PL_argvgv);
4581 (void)gv_AVadd(PL_argvgv);
4582 av_clear(GvAVn(PL_argvgv));
4583 for (; argc > 0; argc--,argv++) {
4584 SV * const sv = newSVpv(argv[0],0);
4585 av_push(GvAVn(PL_argvgv),sv);
4586 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
4587 if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
4590 if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
4591 (void)sv_utf8_decode(sv);
4596 #ifdef HAS_PROCSELFEXE
4597 /* This is a function so that we don't hold on to MAXPATHLEN
4598 bytes of stack longer than necessary
4601 S_procself_val(pTHX_ SV *sv, char *arg0)
4603 char buf[MAXPATHLEN];
4604 int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
4606 /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
4607 includes a spurious NUL which will cause $^X to fail in system
4608 or backticks (this will prevent extensions from being built and
4609 many tests from working). readlink is not meant to add a NUL.
4610 Normal readlink works fine.
4612 if (len > 0 && buf[len-1] == '\0') {
4616 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
4617 returning the text "unknown" from the readlink rather than the path
4618 to the executable (or returning an error from the readlink). Any valid
4619 path has a '/' in it somewhere, so use that to validate the result.
4620 See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
4622 if (len > 0 && memchr(buf, '/', len)) {
4623 sv_setpvn(sv,buf,len);
4629 #endif /* HAS_PROCSELFEXE */
4632 S_set_caret_X(pTHX) {
4633 GV* tmpgv = gv_fetchpv("\030",TRUE, SVt_PV); /* $^X */
4635 #ifdef HAS_PROCSELFEXE
4636 S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
4639 sv_setpv(GvSVn(tmpgv), os2_execname(aTHX));
4641 sv_setpv(GvSVn(tmpgv),PL_origargv[0]);
4648 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
4652 PL_toptarget = NEWSV(0,0);
4653 sv_upgrade(PL_toptarget, SVt_PVFM);
4654 sv_setpvn(PL_toptarget, "", 0);
4655 PL_bodytarget = NEWSV(0,0);
4656 sv_upgrade(PL_bodytarget, SVt_PVFM);
4657 sv_setpvn(PL_bodytarget, "", 0);
4658 PL_formtarget = PL_bodytarget;
4662 init_argv_symbols(argc,argv);
4664 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
4665 #ifdef MACOS_TRADITIONAL
4666 /* $0 is not majick on a Mac */
4667 sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
4669 sv_setpv(GvSV(tmpgv),PL_origfilename);
4670 magicname("0", "0", 1);
4673 S_set_caret_X(aTHX);
4674 if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
4676 GvMULTI_on(PL_envgv);
4677 hv = GvHVn(PL_envgv);
4678 hv_magic(hv, Nullgv, PERL_MAGIC_env);
4680 #ifdef USE_ENVIRON_ARRAY
4681 /* Note that if the supplied env parameter is actually a copy
4682 of the global environ then it may now point to free'd memory
4683 if the environment has been modified since. To avoid this
4684 problem we treat env==NULL as meaning 'use the default'
4689 # ifdef USE_ITHREADS
4690 && PL_curinterp == aTHX
4694 environ[0] = Nullch;
4697 char** origenv = environ;
4700 for (; *env; env++) {
4701 if (!(s = strchr(*env,'=')) || s == *env)
4703 #if defined(MSDOS) && !defined(DJGPP)
4708 sv = newSVpv(s+1, 0);
4709 (void)hv_store(hv, *env, s - *env, sv, 0);
4712 if (origenv != environ) {
4713 /* realloc has shifted us */
4714 env = (env - origenv) + environ;
4719 #endif /* USE_ENVIRON_ARRAY */
4720 #endif /* !PERL_MICRO */
4723 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
4724 SvREADONLY_off(GvSV(tmpgv));
4725 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
4726 SvREADONLY_on(GvSV(tmpgv));
4728 #ifdef THREADS_HAVE_PIDS
4729 PL_ppid = (IV)getppid();
4732 /* touch @F array to prevent spurious warnings 20020415 MJD */
4734 (void) get_av("main::F", TRUE | GV_ADDMULTI);
4736 /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */
4737 (void) get_av("main::-", TRUE | GV_ADDMULTI);
4738 (void) get_av("main::+", TRUE | GV_ADDMULTI);
4742 S_init_perllib(pTHX)
4747 s = PerlEnv_getenv("PERL5LIB");
4749 * It isn't possible to delete an environment variable with
4750 * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4751 * case we treat PERL5LIB as undefined if it has a zero-length value.
4753 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
4754 if (s && *s != '\0')
4758 incpush(s, TRUE, TRUE, TRUE);
4760 incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE);
4762 /* Treat PERL5?LIB as a possible search list logical name -- the
4763 * "natural" VMS idiom for a Unix path string. We allow each
4764 * element to be a set of |-separated directories for compatibility.
4768 if (my_trnlnm("PERL5LIB",buf,0))
4769 do { incpush(buf,TRUE,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
4771 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE,TRUE);
4775 /* Use the ~-expanded versions of APPLLIB (undocumented),
4776 ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
4779 incpush(APPLLIB_EXP, TRUE, TRUE, TRUE);
4783 incpush(ARCHLIB_EXP, FALSE, FALSE, TRUE);
4785 #ifdef MACOS_TRADITIONAL
4788 SV * privdir = NEWSV(55, 0);
4789 char * macperl = PerlEnv_getenv("MACPERL");
4794 Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
4795 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
4796 incpush(SvPVX(privdir), TRUE, FALSE, TRUE);
4797 Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
4798 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
4799 incpush(SvPVX(privdir), TRUE, FALSE, TRUE);
4801 SvREFCNT_dec(privdir);
4804 incpush(":", FALSE, FALSE, TRUE);
4807 # define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
4810 incpush(PRIVLIB_EXP, TRUE, FALSE, TRUE);
4812 incpush(PRIVLIB_EXP, FALSE, FALSE, TRUE);
4816 /* sitearch is always relative to sitelib on Windows for
4817 * DLL-based path intuition to work correctly */
4818 # if !defined(WIN32)
4819 incpush(SITEARCH_EXP, FALSE, FALSE, TRUE);
4825 /* this picks up sitearch as well */
4826 incpush(SITELIB_EXP, TRUE, FALSE, TRUE);
4828 incpush(SITELIB_EXP, FALSE, FALSE, TRUE);
4832 #ifdef SITELIB_STEM /* Search for version-specific dirs below here */
4833 incpush(SITELIB_STEM, FALSE, TRUE, TRUE);
4836 #ifdef PERL_VENDORARCH_EXP
4837 /* vendorarch is always relative to vendorlib on Windows for
4838 * DLL-based path intuition to work correctly */
4839 # if !defined(WIN32)
4840 incpush(PERL_VENDORARCH_EXP, FALSE, FALSE, TRUE);
4844 #ifdef PERL_VENDORLIB_EXP
4846 incpush(PERL_VENDORLIB_EXP, TRUE, FALSE, TRUE); /* this picks up vendorarch as well */
4848 incpush(PERL_VENDORLIB_EXP, FALSE, FALSE, TRUE);
4852 #ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
4853 incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE);
4856 #ifdef PERL_OTHERLIBDIRS
4857 incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE);
4861 incpush(".", FALSE, FALSE, TRUE);
4862 #endif /* MACOS_TRADITIONAL */
4865 #if defined(DOSISH) || defined(EPOC) || defined(SYMBIAN)
4866 # define PERLLIB_SEP ';'
4869 # define PERLLIB_SEP '|'
4871 # if defined(MACOS_TRADITIONAL)
4872 # define PERLLIB_SEP ','
4874 # define PERLLIB_SEP ':'
4878 #ifndef PERLLIB_MANGLE
4879 # define PERLLIB_MANGLE(s,n) (s)
4882 /* Push a directory onto @INC if it exists.
4883 Generate a new SV if we do this, to save needing to copy the SV we push
4886 S_incpush_if_exists(pTHX_ SV *dir)
4889 if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
4890 S_ISDIR(tmpstatbuf.st_mode)) {
4891 av_push(GvAVn(PL_incgv), dir);
4898 S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep)
4900 SV *subdir = Nullsv;
4901 const char *p = dir;
4906 if (addsubdirs || addoldvers) {
4907 subdir = NEWSV(0,0);
4910 /* Break at all separators */
4912 SV *libdir = NEWSV(55,0);
4915 /* skip any consecutive separators */
4917 while ( *p == PERLLIB_SEP ) {
4918 /* Uncomment the next line for PATH semantics */
4919 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
4924 if ( usesep && (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
4925 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
4930 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
4931 p = Nullch; /* break out */
4933 #ifdef MACOS_TRADITIONAL
4934 if (!strchr(SvPVX(libdir), ':')) {
4937 sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
4939 if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
4940 sv_catpv(libdir, ":");
4944 * BEFORE pushing libdir onto @INC we may first push version- and
4945 * archname-specific sub-directories.
4947 if (addsubdirs || addoldvers) {
4948 #ifdef PERL_INC_VERSION_LIST
4949 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
4950 const char *incverlist[] = { PERL_INC_VERSION_LIST };
4951 const char **incver;
4957 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
4959 while (unix[len-1] == '/') len--; /* Cosmetic */
4960 sv_usepvn(libdir,unix,len);
4963 PerlIO_printf(Perl_error_log,
4964 "Failed to unixify @INC element \"%s\"\n",
4968 #ifdef MACOS_TRADITIONAL
4969 #define PERL_AV_SUFFIX_FMT ""
4970 #define PERL_ARCH_FMT "%s:"
4971 #define PERL_ARCH_FMT_PATH PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
4973 #define PERL_AV_SUFFIX_FMT "/"
4974 #define PERL_ARCH_FMT "/%s"
4975 #define PERL_ARCH_FMT_PATH PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
4977 /* .../version/archname if -d .../version/archname */
4978 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
4980 (int)PERL_REVISION, (int)PERL_VERSION,
4981 (int)PERL_SUBVERSION, ARCHNAME);
4982 subdir = S_incpush_if_exists(aTHX_ subdir);
4984 /* .../version if -d .../version */
4985 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
4986 (int)PERL_REVISION, (int)PERL_VERSION,
4987 (int)PERL_SUBVERSION);
4988 subdir = S_incpush_if_exists(aTHX_ subdir);
4990 /* .../archname if -d .../archname */
4991 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
4992 subdir = S_incpush_if_exists(aTHX_ subdir);
4996 #ifdef PERL_INC_VERSION_LIST
4998 for (incver = incverlist; *incver; incver++) {
4999 /* .../xxx if -d .../xxx */
5000 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
5001 subdir = S_incpush_if_exists(aTHX_ subdir);
5007 /* finally push this lib directory on the end of @INC */
5008 av_push(GvAVn(PL_incgv), libdir);
5011 assert (SvREFCNT(subdir) == 1);
5012 SvREFCNT_dec(subdir);
5016 #ifdef USE_5005THREADS
5017 STATIC struct perl_thread *
5018 S_init_main_thread(pTHX)
5020 #if !defined(PERL_IMPLICIT_CONTEXT)
5021 struct perl_thread *thr;
5025 Newxz(thr, 1, struct perl_thread);
5026 PL_curcop = &PL_compiling;
5027 thr->interp = PERL_GET_INTERP;
5028 thr->cvcache = newHV();
5029 thr->threadsv = newAV();
5030 /* thr->threadsvp is set when find_threadsv is called */
5031 thr->specific = newAV();
5032 thr->flags = THRf_R_JOINABLE;
5033 MUTEX_INIT(&thr->mutex);
5034 /* Handcraft thrsv similarly to mess_sv */
5035 Newx(PL_thrsv, 1, SV);
5037 SvFLAGS(PL_thrsv) = SVt_PV;
5038 SvANY(PL_thrsv) = (void*)xpv;
5039 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
5040 SvPV_set(PL_thrsv, (char*)thr);
5041 SvCUR_set(PL_thrsv, sizeof(thr));
5042 SvLEN_set(PL_thrsv, sizeof(thr));
5043 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
5044 thr->oursv = PL_thrsv;
5045 PL_chopset = " \n-";
5048 MUTEX_LOCK(&PL_threads_mutex);
5054 MUTEX_UNLOCK(&PL_threads_mutex);
5056 #ifdef HAVE_THREAD_INTERN
5057 Perl_init_thread_intern(thr);
5060 #ifdef SET_THREAD_SELF
5061 SET_THREAD_SELF(thr);
5063 thr->self = pthread_self();
5064 #endif /* SET_THREAD_SELF */
5068 * These must come after the thread self setting
5069 * because sv_setpvn does SvTAINT and the taint
5070 * fields thread selfness being set.
5072 PL_toptarget = NEWSV(0,0);
5073 sv_upgrade(PL_toptarget, SVt_PVFM);
5074 sv_setpvn(PL_toptarget, "", 0);
5075 PL_bodytarget = NEWSV(0,0);
5076 sv_upgrade(PL_bodytarget, SVt_PVFM);
5077 sv_setpvn(PL_bodytarget, "", 0);
5078 PL_formtarget = PL_bodytarget;
5079 thr->errsv = newSVpvn("", 0);
5080 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
5083 PL_peepp = MEMBER_TO_FPTR(Perl_peep);
5084 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
5085 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
5086 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
5087 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
5088 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
5090 PL_reginterp_cnt = 0;
5094 #endif /* USE_5005THREADS */
5097 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
5100 const line_t oldline = CopLINE(PL_curcop);
5106 while (av_len(paramList) >= 0) {
5107 cv = (CV*)av_shift(paramList);
5109 if (paramList == PL_beginav) {
5110 /* save PL_beginav for compiler */
5111 if (! PL_beginav_save)
5112 PL_beginav_save = newAV();
5113 av_push(PL_beginav_save, (SV*)cv);
5115 else if (paramList == PL_checkav) {
5116 /* save PL_checkav for compiler */
5117 if (! PL_checkav_save)
5118 PL_checkav_save = newAV();
5119 av_push(PL_checkav_save, (SV*)cv);
5124 #ifdef PERL_FLEXIBLE_EXCEPTIONS
5125 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
5131 #ifndef PERL_FLEXIBLE_EXCEPTIONS
5135 (void)SvPV_const(atsv, len);
5137 PL_curcop = &PL_compiling;
5138 CopLINE_set(PL_curcop, oldline);
5139 if (paramList == PL_beginav)
5140 sv_catpv(atsv, "BEGIN failed--compilation aborted");
5142 Perl_sv_catpvf(aTHX_ atsv,
5143 "%s failed--call queue aborted",
5144 paramList == PL_checkav ? "CHECK"
5145 : paramList == PL_initav ? "INIT"
5147 while (PL_scopestack_ix > oldscope)
5150 Perl_croak(aTHX_ "%"SVf"", atsv);
5157 /* my_exit() was called */
5158 while (PL_scopestack_ix > oldscope)
5161 PL_curstash = PL_defstash;
5162 PL_curcop = &PL_compiling;
5163 CopLINE_set(PL_curcop, oldline);
5165 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
5166 if (paramList == PL_beginav)
5167 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
5169 Perl_croak(aTHX_ "%s failed--call queue aborted",
5170 paramList == PL_checkav ? "CHECK"
5171 : paramList == PL_initav ? "INIT"
5178 PL_curcop = &PL_compiling;
5179 CopLINE_set(PL_curcop, oldline);
5182 PerlIO_printf(Perl_error_log, "panic: restartop\n");
5190 #ifdef PERL_FLEXIBLE_EXCEPTIONS
5192 S_vcall_list_body(pTHX_ va_list args)
5194 CV *cv = va_arg(args, CV*);
5195 return call_list_body(cv);
5200 S_call_list_body(pTHX_ CV *cv)
5202 PUSHMARK(PL_stack_sp);
5203 call_sv((SV*)cv, G_EVAL|G_DISCARD);
5208 Perl_my_exit(pTHX_ U32 status)
5210 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
5211 thr, (unsigned long) status));
5220 STATUS_NATIVE_SET(status);
5227 Perl_my_failure_exit(pTHX)
5230 if (vaxc$errno & 1) {
5231 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
5232 STATUS_NATIVE_SET(44);
5235 if (!vaxc$errno) /* unlikely */
5236 STATUS_NATIVE_SET(44);
5238 STATUS_NATIVE_SET(vaxc$errno);
5243 STATUS_POSIX_SET(errno);
5245 exitstatus = STATUS_POSIX >> 8;
5246 if (exitstatus & 255)
5247 STATUS_POSIX_SET(exitstatus);
5249 STATUS_POSIX_SET(255);
5256 S_my_exit_jump(pTHX)
5258 register PERL_CONTEXT *cx;
5263 SvREFCNT_dec(PL_e_script);
5264 PL_e_script = Nullsv;
5267 POPSTACK_TO(PL_mainstack);
5268 if (cxstack_ix >= 0) {
5271 POPBLOCK(cx,PL_curpm);
5276 PERL_UNUSED_VAR(gimme);
5277 PERL_UNUSED_VAR(newsp);
5281 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
5283 const char * const p = SvPVX_const(PL_e_script);
5284 const char *nl = strchr(p, '\n');
5286 PERL_UNUSED_ARG(idx);
5287 PERL_UNUSED_ARG(maxlen);
5289 nl = (nl) ? nl+1 : SvEND(PL_e_script);
5291 filter_del(read_e_script);
5294 sv_catpvn(buf_sv, p, nl-p);
5295 sv_chop(PL_e_script, (char *) nl);
5301 * c-indentation-style: bsd
5303 * indent-tabs-mode: t
5306 * ex: set ts=8 sts=4 sw=4 noet: