3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 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>
113 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
114 char *getenv (char *); /* Usually in <stdlib.h> */
117 static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
125 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
132 S_init_tls_and_interp(PerlInterpreter *my_perl)
136 PERL_SET_INTERP(my_perl);
137 #if defined(USE_ITHREADS)
140 PERL_SET_THX(my_perl);
142 MUTEX_INIT(&PL_dollarzero_mutex);
146 PERL_SET_THX(my_perl);
150 #ifdef PERL_IMPLICIT_SYS
152 perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
153 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
154 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
155 struct IPerlDir* ipD, struct IPerlSock* ipS,
156 struct IPerlProc* ipP)
158 PerlInterpreter *my_perl;
159 /* New() needs interpreter, so call malloc() instead */
160 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
161 S_init_tls_and_interp(my_perl);
162 Zero(my_perl, 1, PerlInterpreter);
178 =head1 Embedding Functions
180 =for apidoc perl_alloc
182 Allocates a new Perl interpreter. See L<perlembed>.
190 PerlInterpreter *my_perl;
192 /* New() needs interpreter, so call malloc() instead */
193 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
195 S_init_tls_and_interp(my_perl);
196 return (PerlInterpreter *) ZeroD(my_perl, 1, PerlInterpreter);
198 #endif /* PERL_IMPLICIT_SYS */
201 =for apidoc perl_construct
203 Initializes a new Perl interpreter. See L<perlembed>.
209 perl_construct(pTHXx)
214 PL_perl_destruct_level = 1;
216 if (PL_perl_destruct_level > 0)
219 /* Init the real globals (and main thread)? */
221 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
223 PL_linestr = NEWSV(65,79);
224 sv_upgrade(PL_linestr,SVt_PVIV);
226 if (!SvREADONLY(&PL_sv_undef)) {
227 /* set read-only and try to insure than we wont see REFCNT==0
230 SvREADONLY_on(&PL_sv_undef);
231 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
233 sv_setpv(&PL_sv_no,PL_No);
234 /* value lookup in void context - happens to have the side effect
235 of caching the numeric forms. */
238 SvREADONLY_on(&PL_sv_no);
239 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
241 sv_setpv(&PL_sv_yes,PL_Yes);
244 SvREADONLY_on(&PL_sv_yes);
245 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
247 SvREADONLY_on(&PL_sv_placeholder);
248 SvREFCNT(&PL_sv_placeholder) = (~(U32)0)/2;
251 PL_sighandlerp = Perl_sighandler;
252 PL_pidstatus = newHV();
255 PL_rs = newSVpvn("\n", 1);
260 PL_lex_state = LEX_NOTPARSING;
266 SET_NUMERIC_STANDARD();
268 #if defined(LOCAL_PATCH_COUNT)
269 PL_localpatches = local_patches; /* For possible -v */
272 #ifdef HAVE_INTERP_INTERN
276 PerlIO_init(aTHX); /* Hook to IO system */
278 PL_fdpid = newAV(); /* for remembering popen pids by fd */
279 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
280 PL_errors = newSVpvn("",0);
281 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
282 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
283 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
285 PL_regex_padav = newAV();
286 av_push(PL_regex_padav,(SV*)newAV()); /* First entry is an array of empty elements */
287 PL_regex_pad = AvARRAY(PL_regex_padav);
289 #ifdef USE_REENTRANT_API
290 Perl_reentrant_init(aTHX);
293 /* Note that strtab is a rather special HV. Assumptions are made
294 about not iterating on it, and not adding tie magic to it.
295 It is properly deallocated in perl_destruct() */
298 HvSHAREKEYS_off(PL_strtab); /* mandatory */
299 hv_ksplit(PL_strtab, 512);
301 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
302 _dyld_lookup_and_bind
303 ("__environ", (unsigned long *) &environ_pointer, NULL);
307 # ifdef USE_ENVIRON_ARRAY
308 PL_origenviron = environ;
312 /* Use sysconf(_SC_CLK_TCK) if available, if not
313 * available or if the sysconf() fails, use the HZ.
314 * BeOS has those, but returns the wrong value.
315 * The HZ if not originally defined has been by now
316 * been defined as CLK_TCK, if available. */
317 #if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK) && !defined(__BEOS__)
318 PL_clocktick = sysconf(_SC_CLK_TCK);
319 if (PL_clocktick <= 0)
323 PL_stashcache = newHV();
325 PL_patchlevel = newSVpv(
326 Perl_form(aTHX_ "%d.%d.%d",
329 (int)PERL_SUBVERSION ), 0
333 if (!PL_mmap_page_size) {
334 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_MMAP_PAGE_SIZE))
336 SETERRNO(0, SS_NORMAL);
338 PL_mmap_page_size = sysconf(_SC_PAGESIZE);
340 PL_mmap_page_size = sysconf(_SC_MMAP_PAGE_SIZE);
342 if ((long) PL_mmap_page_size < 0) {
345 (void) SvUPGRADE(error, SVt_PV);
346 Perl_croak(aTHX_ "panic: sysconf: %s", SvPV_nolen_const(error));
349 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
353 # ifdef HAS_GETPAGESIZE
354 PL_mmap_page_size = getpagesize();
356 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
357 PL_mmap_page_size = PAGESIZE; /* compiletime, bad */
361 if (PL_mmap_page_size <= 0)
362 Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
363 (IV) PL_mmap_page_size);
365 #endif /* HAS_MMAP */
367 #if defined(HAS_TIMES) && defined(PERL_NEED_TIMESBASE)
368 PL_timesbase.tms_utime = 0;
369 PL_timesbase.tms_stime = 0;
370 PL_timesbase.tms_cutime = 0;
371 PL_timesbase.tms_cstime = 0;
378 =for apidoc nothreadhook
380 Stub that provides thread hook for perl_destruct when there are
387 Perl_nothreadhook(pTHX)
393 =for apidoc perl_destruct
395 Shuts down a Perl interpreter. See L<perlembed>.
404 volatile int destruct_level; /* 0=none, 1=full, 2=full with checks */
406 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
411 /* wait for all pseudo-forked children to finish */
412 PERL_WAIT_FOR_CHILDREN;
414 destruct_level = PL_perl_destruct_level;
418 if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) {
419 const int i = atoi(s);
420 if (destruct_level < i)
426 if (PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
432 if (PL_endav && !PL_minus_c)
433 call_list(PL_scopestack_ix, PL_endav);
439 /* Need to flush since END blocks can produce output */
442 if (CALL_FPTR(PL_threadhook)(aTHX)) {
443 /* Threads hook has vetoed further cleanup */
444 return STATUS_NATIVE_EXPORT;
447 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
448 if (destruct_level != 0) {
449 /* Fork here to create a child. Our child's job is to preserve the
450 state of scalars prior to destruction, so that we can instruct it
451 to dump any scalars that we later find have leaked.
452 There's no subtlety in this code - it assumes POSIX, and it doesn't
456 if(socketpair(AF_UNIX, SOCK_STREAM, 0, fd)) {
457 perror("Debug leaking scalars socketpair failed");
463 perror("Debug leaking scalars fork failed");
467 /* We are the child */
473 ssize_t got = read(sock, &target, sizeof(target));
478 perror("Debug leaking scalars child read failed");
481 if(got < sizeof(target)) {
482 perror("Debug leaking scalars child short read");
486 PerlIO_flush(Perl_debug_log);
488 /* Write something back as synchronisation. */
489 got = write(sock, &target, sizeof(target));
492 perror("Debug leaking scalars child write failed");
495 if(got < sizeof(target)) {
496 perror("Debug leaking scalars child short write");
507 /* We must account for everything. */
509 /* Destroy the main CV and syntax tree */
510 /* Do this now, because destroying ops can cause new SVs to be generated
511 in Perl_pad_swipe, and when running with -DDEBUG_LEAKING_SCALARS they
512 PL_curcop to point to a valid op from which the filename structure
514 PL_curcop = &PL_compiling;
516 /* ensure comppad/curpad to refer to main's pad */
517 if (CvPADLIST(PL_main_cv)) {
518 PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1);
520 op_free(PL_main_root);
521 PL_main_root = Nullop;
523 PL_main_start = Nullop;
524 SvREFCNT_dec(PL_main_cv);
528 /* Tell PerlIO we are about to tear things apart in case
529 we have layers which are using resources that should
533 PerlIO_destruct(aTHX);
535 if (PL_sv_objcount) {
537 * Try to destruct global references. We do this first so that the
538 * destructors and destructees still exist. Some sv's might remain.
539 * Non-referenced objects are on their own.
545 /* unhook hooks which will soon be, or use, destroyed data */
546 SvREFCNT_dec(PL_warnhook);
547 PL_warnhook = Nullsv;
548 SvREFCNT_dec(PL_diehook);
551 /* call exit list functions */
552 while (PL_exitlistlen-- > 0)
553 PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
555 Safefree(PL_exitlist);
560 if (destruct_level == 0){
562 DEBUG_P(debprofdump());
564 #if defined(PERLIO_LAYERS)
565 /* No more IO - including error messages ! */
566 PerlIO_cleanup(aTHX);
569 /* The exit() function will do everything that needs doing. */
570 return STATUS_NATIVE_EXPORT;
573 /* jettison our possibly duplicated environment */
574 /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
575 * so we certainly shouldn't free it here
578 #if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
579 if (environ != PL_origenviron && !PL_use_safe_putenv
581 /* only main thread can free environ[0] contents */
582 && PL_curinterp == aTHX
588 for (i = 0; environ[i]; i++)
589 safesysfree(environ[i]);
591 /* Must use safesysfree() when working with environ. */
592 safesysfree(environ);
594 environ = PL_origenviron;
597 #endif /* !PERL_MICRO */
599 /* reset so print() ends up where we expect */
603 /* the syntax tree is shared between clones
604 * so op_free(PL_main_root) only ReREFCNT_dec's
605 * REGEXPs in the parent interpreter
606 * we need to manually ReREFCNT_dec for the clones
609 I32 i = AvFILLp(PL_regex_padav) + 1;
610 SV **ary = AvARRAY(PL_regex_padav);
615 if (SvFLAGS(resv) & SVf_BREAK) {
616 /* this is PL_reg_curpm, already freed
617 * flag is set in regexec.c:S_regtry
619 SvFLAGS(resv) &= ~SVf_BREAK;
621 else if(SvREPADTMP(resv)) {
622 SvREPADTMP_off(resv);
624 else if(SvIOKp(resv)) {
625 REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv));
630 SvREFCNT_dec(PL_regex_padav);
631 PL_regex_padav = Nullav;
635 SvREFCNT_dec((SV*) PL_stashcache);
636 PL_stashcache = NULL;
638 /* loosen bonds of global variables */
641 (void)PerlIO_close(PL_rsfp);
645 /* Filters for program text */
646 SvREFCNT_dec(PL_rsfp_filters);
647 PL_rsfp_filters = Nullav;
650 PL_preprocess = FALSE;
656 PL_doswitches = FALSE;
657 PL_dowarn = G_WARN_OFF;
658 PL_doextract = FALSE;
659 PL_sawampersand = FALSE; /* must save all match strings */
662 Safefree(PL_inplace);
664 SvREFCNT_dec(PL_patchlevel);
667 SvREFCNT_dec(PL_e_script);
668 PL_e_script = Nullsv;
673 /* magical thingies */
675 SvREFCNT_dec(PL_ofs_sv); /* $, */
678 SvREFCNT_dec(PL_ors_sv); /* $\ */
681 SvREFCNT_dec(PL_rs); /* $/ */
684 PL_multiline = 0; /* $* */
685 Safefree(PL_osname); /* $^O */
688 SvREFCNT_dec(PL_statname);
689 PL_statname = Nullsv;
692 /* defgv, aka *_ should be taken care of elsewhere */
694 /* clean up after study() */
695 SvREFCNT_dec(PL_lastscream);
696 PL_lastscream = Nullsv;
697 Safefree(PL_screamfirst);
699 Safefree(PL_screamnext);
703 Safefree(PL_efloatbuf);
704 PL_efloatbuf = Nullch;
707 /* startup and shutdown function lists */
708 SvREFCNT_dec(PL_beginav);
709 SvREFCNT_dec(PL_beginav_save);
710 SvREFCNT_dec(PL_endav);
711 SvREFCNT_dec(PL_checkav);
712 SvREFCNT_dec(PL_checkav_save);
713 SvREFCNT_dec(PL_initav);
715 PL_beginav_save = Nullav;
718 PL_checkav_save = Nullav;
721 /* shortcuts just get cleared */
727 PL_argvoutgv = Nullgv;
729 PL_stderrgv = Nullgv;
730 PL_last_in_gv = Nullgv;
735 PL_DBsingle = Nullsv;
737 PL_DBsignal = Nullsv;
738 PL_DBassertion = Nullsv;
741 PL_debstash = Nullhv;
743 SvREFCNT_dec(PL_argvout_stack);
744 PL_argvout_stack = Nullav;
746 SvREFCNT_dec(PL_modglobal);
747 PL_modglobal = Nullhv;
748 SvREFCNT_dec(PL_preambleav);
749 PL_preambleav = Nullav;
750 SvREFCNT_dec(PL_subname);
752 SvREFCNT_dec(PL_linestr);
754 SvREFCNT_dec(PL_pidstatus);
755 PL_pidstatus = Nullhv;
756 SvREFCNT_dec(PL_toptarget);
757 PL_toptarget = Nullsv;
758 SvREFCNT_dec(PL_bodytarget);
759 PL_bodytarget = Nullsv;
760 PL_formtarget = Nullsv;
762 /* free locale stuff */
763 #ifdef USE_LOCALE_COLLATE
764 Safefree(PL_collation_name);
765 PL_collation_name = Nullch;
768 #ifdef USE_LOCALE_NUMERIC
769 Safefree(PL_numeric_name);
770 PL_numeric_name = Nullch;
771 SvREFCNT_dec(PL_numeric_radix_sv);
772 PL_numeric_radix_sv = Nullsv;
775 /* clear utf8 character classes */
776 SvREFCNT_dec(PL_utf8_alnum);
777 SvREFCNT_dec(PL_utf8_alnumc);
778 SvREFCNT_dec(PL_utf8_ascii);
779 SvREFCNT_dec(PL_utf8_alpha);
780 SvREFCNT_dec(PL_utf8_space);
781 SvREFCNT_dec(PL_utf8_cntrl);
782 SvREFCNT_dec(PL_utf8_graph);
783 SvREFCNT_dec(PL_utf8_digit);
784 SvREFCNT_dec(PL_utf8_upper);
785 SvREFCNT_dec(PL_utf8_lower);
786 SvREFCNT_dec(PL_utf8_print);
787 SvREFCNT_dec(PL_utf8_punct);
788 SvREFCNT_dec(PL_utf8_xdigit);
789 SvREFCNT_dec(PL_utf8_mark);
790 SvREFCNT_dec(PL_utf8_toupper);
791 SvREFCNT_dec(PL_utf8_totitle);
792 SvREFCNT_dec(PL_utf8_tolower);
793 SvREFCNT_dec(PL_utf8_tofold);
794 SvREFCNT_dec(PL_utf8_idstart);
795 SvREFCNT_dec(PL_utf8_idcont);
796 PL_utf8_alnum = Nullsv;
797 PL_utf8_alnumc = Nullsv;
798 PL_utf8_ascii = Nullsv;
799 PL_utf8_alpha = Nullsv;
800 PL_utf8_space = Nullsv;
801 PL_utf8_cntrl = Nullsv;
802 PL_utf8_graph = Nullsv;
803 PL_utf8_digit = Nullsv;
804 PL_utf8_upper = Nullsv;
805 PL_utf8_lower = Nullsv;
806 PL_utf8_print = Nullsv;
807 PL_utf8_punct = Nullsv;
808 PL_utf8_xdigit = Nullsv;
809 PL_utf8_mark = Nullsv;
810 PL_utf8_toupper = Nullsv;
811 PL_utf8_totitle = Nullsv;
812 PL_utf8_tolower = Nullsv;
813 PL_utf8_tofold = Nullsv;
814 PL_utf8_idstart = Nullsv;
815 PL_utf8_idcont = Nullsv;
817 if (!specialWARN(PL_compiling.cop_warnings))
818 SvREFCNT_dec(PL_compiling.cop_warnings);
819 PL_compiling.cop_warnings = Nullsv;
820 if (!specialCopIO(PL_compiling.cop_io))
821 SvREFCNT_dec(PL_compiling.cop_io);
822 PL_compiling.cop_io = Nullsv;
823 CopFILE_free(&PL_compiling);
824 CopSTASH_free(&PL_compiling);
826 /* Prepare to destruct main symbol table. */
831 SvREFCNT_dec(PL_curstname);
832 PL_curstname = Nullsv;
834 /* clear queued errors */
835 SvREFCNT_dec(PL_errors);
839 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
840 if (PL_scopestack_ix != 0)
841 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
842 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
843 (long)PL_scopestack_ix);
844 if (PL_savestack_ix != 0)
845 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
846 "Unbalanced saves: %ld more saves than restores\n",
847 (long)PL_savestack_ix);
848 if (PL_tmps_floor != -1)
849 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
850 (long)PL_tmps_floor + 1);
851 if (cxstack_ix != -1)
852 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
853 (long)cxstack_ix + 1);
856 /* Now absolutely destruct everything, somehow or other, loops or no. */
857 SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */
858 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
860 /* the 2 is for PL_fdpid and PL_strtab */
861 while (PL_sv_count > 2 && sv_clean_all())
864 SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
865 SvFLAGS(PL_fdpid) |= SVt_PVAV;
866 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
867 SvFLAGS(PL_strtab) |= SVt_PVHV;
869 AvREAL_off(PL_fdpid); /* no surviving entries */
870 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
873 #ifdef HAVE_INTERP_INTERN
877 /* Destruct the global string table. */
879 /* Yell and reset the HeVAL() slots that are still holding refcounts,
880 * so that sv_free() won't fail on them.
881 * Now that the global string table is using a single hunk of memory
882 * for both HE and HEK, we either need to explicitly unshare it the
883 * correct way, or actually free things here.
886 const I32 max = HvMAX(PL_strtab);
887 HE **array = HvARRAY(PL_strtab);
891 if (hent && ckWARN_d(WARN_INTERNAL)) {
892 HE *next = HeNEXT(hent);
893 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
894 "Unbalanced string table refcount: (%d) for \"%s\"",
895 HeVAL(hent) - Nullsv, HeKEY(hent));
907 HvARRAY(PL_strtab) = 0;
908 HvTOTALKEYS(PL_strtab) = 0;
909 HvFILL(PL_strtab) = 0;
911 SvREFCNT_dec(PL_strtab);
914 /* free the pointer tables used for cloning */
915 ptr_table_free(PL_ptr_table);
916 PL_ptr_table = (PTR_TBL_t*)NULL;
919 /* free special SVs */
921 SvREFCNT(&PL_sv_yes) = 0;
922 sv_clear(&PL_sv_yes);
923 SvANY(&PL_sv_yes) = NULL;
924 SvFLAGS(&PL_sv_yes) = 0;
926 SvREFCNT(&PL_sv_no) = 0;
928 SvANY(&PL_sv_no) = NULL;
929 SvFLAGS(&PL_sv_no) = 0;
933 for (i=0; i<=2; i++) {
934 SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
935 sv_clear(PERL_DEBUG_PAD(i));
936 SvANY(PERL_DEBUG_PAD(i)) = NULL;
937 SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
941 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
942 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
944 #ifdef DEBUG_LEAKING_SCALARS
945 if (PL_sv_count != 0) {
950 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
951 svend = &sva[SvREFCNT(sva)];
952 for (sv = sva + 1; sv < svend; ++sv) {
953 if (SvTYPE(sv) != SVTYPEMASK) {
954 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
959 PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
961 " refcnt=%"UVuf pTHX__FORMAT "\n"
962 "\tallocated at %s:%d %s %s%s\n",
963 sv, sv->sv_flags, sv->sv_refcnt pTHX__VALUE,
964 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
966 sv->sv_debug_inpad ? "for" : "by",
967 sv->sv_debug_optype ?
968 PL_op_name[sv->sv_debug_optype]: "(none)",
969 sv->sv_debug_cloned ? " (cloned)" : ""
972 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
973 PerlIO_flush(Perl_debug_log);
975 got = write(sock, &sv, sizeof(sv));
978 perror("Debug leaking scalars parent write failed");
981 if(got < sizeof(target)) {
982 perror("Debug leaking scalars parent short write");
986 got = read(sock, &target, sizeof(target));
989 perror("Debug leaking scalars parent read failed");
992 if(got < sizeof(target)) {
993 perror("Debug leaking scalars parent short read");
1001 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1005 /* Wait for up to 4 seconds for child to terminate.
1006 This seems to be the least effort way of timing out on reaping
1008 struct timeval waitfor = {4, 0};
1012 FD_SET(sock, &rset);
1013 select(sock + 1, &rset, NULL, NULL, &waitfor);
1014 waitpid(child, &status, WNOHANG);
1022 #if defined(PERLIO_LAYERS)
1023 /* No more IO - including error messages ! */
1024 PerlIO_cleanup(aTHX);
1027 /* sv_undef needs to stay immortal until after PerlIO_cleanup
1028 as currently layers use it rather than Nullsv as a marker
1029 for no arg - and will try and SvREFCNT_dec it.
1031 SvREFCNT(&PL_sv_undef) = 0;
1032 SvREADONLY_off(&PL_sv_undef);
1034 Safefree(PL_origfilename);
1035 PL_origfilename = Nullch;
1036 Safefree(PL_reg_start_tmp);
1037 PL_reg_start_tmp = (char**)NULL;
1038 PL_reg_start_tmpl = 0;
1040 Safefree(PL_reg_curpm);
1041 Safefree(PL_reg_poscache);
1042 free_tied_hv_pool();
1043 Safefree(PL_op_mask);
1044 Safefree(PL_psig_ptr);
1045 PL_psig_ptr = (SV**)NULL;
1046 Safefree(PL_psig_name);
1047 PL_psig_name = (SV**)NULL;
1048 Safefree(PL_bitcount);
1049 PL_bitcount = Nullch;
1050 Safefree(PL_psig_pend);
1051 PL_psig_pend = (int*)NULL;
1052 PL_formfeed = Nullsv;
1054 PL_tainting = FALSE;
1055 PL_taint_warn = FALSE;
1056 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
1059 DEBUG_P(debprofdump());
1061 #ifdef USE_REENTRANT_API
1062 Perl_reentrant_free(aTHX);
1067 /* As the absolutely last thing, free the non-arena SV for mess() */
1070 /* we know that type == SVt_PVMG */
1072 /* it could have accumulated taint magic */
1075 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
1076 moremagic = mg->mg_moremagic;
1077 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
1079 Safefree(mg->mg_ptr);
1083 /* we know that type >= SVt_PV */
1084 SvPV_free(PL_mess_sv);
1085 Safefree(SvANY(PL_mess_sv));
1086 Safefree(PL_mess_sv);
1087 PL_mess_sv = Nullsv;
1089 return STATUS_NATIVE_EXPORT;
1093 =for apidoc perl_free
1095 Releases a Perl interpreter. See L<perlembed>.
1103 #if defined(WIN32) || defined(NETWARE)
1104 # if defined(PERL_IMPLICIT_SYS)
1106 void *host = nw_internal_host;
1108 void *host = w32_internal_host;
1110 PerlMem_free(aTHXx);
1112 nw_delete_internal_host(host);
1114 win32_delete_internal_host(host);
1117 PerlMem_free(aTHXx);
1120 PerlMem_free(aTHXx);
1124 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
1125 /* provide destructors to clean up the thread key when libperl is unloaded */
1126 #ifndef WIN32 /* handled during DLL_PROCESS_DETACH in win32/perllib.c */
1128 #if defined(__hpux) && __ux_version > 1020 && !defined(__GNUC__)
1129 #pragma fini "perl_fini"
1133 #if defined(__GNUC__)
1134 __attribute__((destructor))
1144 #endif /* THREADS */
1147 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
1149 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
1150 PL_exitlist[PL_exitlistlen].fn = fn;
1151 PL_exitlist[PL_exitlistlen].ptr = ptr;
1155 #ifdef HAS_PROCSELFEXE
1156 /* This is a function so that we don't hold on to MAXPATHLEN
1157 bytes of stack longer than necessary
1160 S_procself_val(pTHX_ SV *sv, const char *arg0)
1162 char buf[MAXPATHLEN];
1163 int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
1165 /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
1166 includes a spurious NUL which will cause $^X to fail in system
1167 or backticks (this will prevent extensions from being built and
1168 many tests from working). readlink is not meant to add a NUL.
1169 Normal readlink works fine.
1171 if (len > 0 && buf[len-1] == '\0') {
1175 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
1176 returning the text "unknown" from the readlink rather than the path
1177 to the executable (or returning an error from the readlink). Any valid
1178 path has a '/' in it somewhere, so use that to validate the result.
1179 See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
1181 if (len > 0 && memchr(buf, '/', len)) {
1182 sv_setpvn(sv,buf,len);
1188 #endif /* HAS_PROCSELFEXE */
1191 S_set_caret_X(pTHX) {
1192 GV* tmpgv = gv_fetchpv("\030",TRUE, SVt_PV); /* $^X */
1194 #ifdef HAS_PROCSELFEXE
1195 S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
1198 sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
1200 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
1207 =for apidoc perl_parse
1209 Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
1215 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
1222 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
1225 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
1226 setuid perl scripts securely.\n");
1227 #endif /* IAMSUID */
1230 #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
1231 /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0
1232 * This MUST be done before any hash stores or fetches take place.
1233 * If you set PL_rehash_seed (and assumedly also PL_rehash_seed_set)
1234 * yourself, it is your responsibility to provide a good random seed!
1235 * You can also define PERL_HASH_SEED in compile time, see hv.h. */
1236 if (!PL_rehash_seed_set)
1237 PL_rehash_seed = get_hash_seed();
1239 const char *s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
1241 if (s && (atoi(s) == 1))
1242 PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n", PL_rehash_seed);
1244 #endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
1250 /* Set PL_origalen be the sum of the contiguous argv[]
1251 * elements plus the size of the env in case that it is
1252 * contiguous with the argv[]. This is used in mg.c:Perl_magic_set()
1253 * as the maximum modifiable length of $0. In the worst case
1254 * the area we are able to modify is limited to the size of
1255 * the original argv[0]. (See below for 'contiguous', though.)
1257 const char *s = NULL;
1260 ~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0);
1261 /* Do the mask check only if the args seem like aligned. */
1263 (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
1265 /* See if all the arguments are contiguous in memory. Note
1266 * that 'contiguous' is a loose term because some platforms
1267 * align the argv[] and the envp[]. If the arguments look
1268 * like non-aligned, assume that they are 'strictly' or
1269 * 'traditionally' contiguous. If the arguments look like
1270 * aligned, we just check that they are within aligned
1271 * PTRSIZE bytes. As long as no system has something bizarre
1272 * like the argv[] interleaved with some other data, we are
1273 * fine. (Did I just evoke Murphy's Law?) --jhi */
1274 if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) {
1276 for (i = 1; i < PL_origargc; i++) {
1277 if ((PL_origargv[i] == s + 1
1279 || PL_origargv[i] == s + 2
1284 (PL_origargv[i] > s &&
1286 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1296 /* Can we grab env area too to be used as the area for $0? */
1297 if (PL_origenviron) {
1298 if ((PL_origenviron[0] == s + 1
1300 || (PL_origenviron[0] == s + 9 && (s += 8))
1305 (PL_origenviron[0] > s &&
1306 PL_origenviron[0] <=
1307 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1311 s = PL_origenviron[0];
1314 my_setenv("NoNe SuCh", Nullch);
1315 /* Force copy of environment. */
1316 for (i = 1; PL_origenviron[i]; i++) {
1317 if (PL_origenviron[i] == s + 1
1320 (PL_origenviron[i] > s &&
1321 PL_origenviron[i] <=
1322 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1325 s = PL_origenviron[i];
1333 PL_origalen = s - PL_origargv[0] + 1;
1338 /* Come here if running an undumped a.out. */
1340 PL_origfilename = savepv(argv[0]);
1341 PL_do_undump = FALSE;
1342 cxstack_ix = -1; /* start label stack again */
1344 assert (!PL_tainted);
1346 S_set_caret_X(aTHX);
1348 init_postdump_symbols(argc,argv,env);
1353 op_free(PL_main_root);
1354 PL_main_root = Nullop;
1356 PL_main_start = Nullop;
1357 SvREFCNT_dec(PL_main_cv);
1358 PL_main_cv = Nullcv;
1361 oldscope = PL_scopestack_ix;
1362 PL_dowarn = G_WARN_OFF;
1367 parse_body(env,xsinit);
1369 call_list(oldscope, PL_checkav);
1376 /* my_exit() was called */
1377 while (PL_scopestack_ix > oldscope)
1380 PL_curstash = PL_defstash;
1382 call_list(oldscope, PL_checkav);
1383 ret = STATUS_NATIVE_EXPORT;
1386 PerlIO_printf(Perl_error_log, "panic: top_env\n");
1395 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
1398 int argc = PL_origargc;
1399 char **argv = PL_origargv;
1400 const char *scriptname = NULL;
1401 VOL bool dosearch = FALSE;
1402 const char *validarg = "";
1405 const char *cddir = Nullch;
1406 #ifdef USE_SITECUSTOMIZE
1407 bool minus_f = FALSE;
1412 sv_setpvn(PL_linestr,"",0);
1413 sv = newSVpvn("",0); /* first used for -I flags */
1417 for (argc--,argv++; argc > 0; argc--,argv++) {
1418 if (argv[0][0] != '-' || !argv[0][1])
1422 validarg = " PHOOEY ";
1426 * Can we rely on the kernel to start scripts with argv[1] set to
1427 * contain all #! line switches (the whole line)? (argv[0] is set to
1428 * the interpreter name, argv[2] to the script name; argv[3] and
1429 * above may contain other arguments.)
1436 #ifndef PERL_STRICT_CR
1461 if ((s = moreswitches(s)))
1466 CHECK_MALLOC_TOO_LATE_FOR('t');
1467 if( !PL_tainting ) {
1468 PL_taint_warn = TRUE;
1474 CHECK_MALLOC_TOO_LATE_FOR('T');
1476 PL_taint_warn = FALSE;
1481 #ifdef MACOS_TRADITIONAL
1482 /* ignore -e for Dev:Pseudo argument */
1483 if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
1488 PL_e_script = newSVpvn("",0);
1489 filter_add(read_e_script, NULL);
1492 sv_catpv(PL_e_script, s);
1494 sv_catpv(PL_e_script, argv[1]);
1498 Perl_croak(aTHX_ "No code specified for -e");
1499 sv_catpv(PL_e_script, "\n");
1503 #ifdef USE_SITECUSTOMIZE
1509 case 'I': /* -I handled both here and in moreswitches() */
1511 if (!*++s && (s=argv[1]) != Nullch) {
1516 STRLEN len = strlen(s);
1517 p = savepvn(s, len);
1518 incpush(p, TRUE, TRUE, FALSE, FALSE);
1519 sv_catpvn(sv, "-I", 2);
1520 sv_catpvn(sv, p, len);
1521 sv_catpvn(sv, " ", 1);
1525 Perl_croak(aTHX_ "No directory specified for -I");
1529 PL_preprocess = TRUE;
1539 PL_preambleav = newAV();
1540 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
1544 PL_Sv = newSVpv("print myconfig();",0);
1546 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
1548 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
1550 opts = SvCUR(PL_Sv);
1552 sv_catpv(PL_Sv,"\" Compile-time options:");
1554 sv_catpv(PL_Sv," DEBUGGING");
1556 # ifdef MULTIPLICITY
1557 sv_catpv(PL_Sv," MULTIPLICITY");
1559 # ifdef USE_5005THREADS
1560 sv_catpv(PL_Sv," USE_5005THREADS");
1562 # ifdef USE_ITHREADS
1563 sv_catpv(PL_Sv," USE_ITHREADS");
1565 # ifdef USE_64_BIT_INT
1566 sv_catpv(PL_Sv," USE_64_BIT_INT");
1568 # ifdef USE_64_BIT_ALL
1569 sv_catpv(PL_Sv," USE_64_BIT_ALL");
1571 # ifdef USE_LONG_DOUBLE
1572 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
1574 # ifdef USE_LARGE_FILES
1575 sv_catpv(PL_Sv," USE_LARGE_FILES");
1578 sv_catpv(PL_Sv," USE_SOCKS");
1580 # ifdef USE_SITECUSTOMIZE
1581 sv_catpv(PL_Sv," USE_SITECUSTOMIZE");
1583 # ifdef PERL_IMPLICIT_CONTEXT
1584 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
1586 # ifdef PERL_IMPLICIT_SYS
1587 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
1590 while (SvCUR(PL_Sv) > opts+76) {
1591 /* find last space after "options: " and before col 76 */
1594 char *pv = SvPV_nolen(PL_Sv);
1595 const char c = pv[opts+76];
1597 space = strrchr(pv+opts+26, ' ');
1599 if (!space) break; /* "Can't happen" */
1601 /* break the line before that space */
1604 sv_insert(PL_Sv, opts, 0,
1608 sv_catpv(PL_Sv,"\\n\",");
1610 #if defined(LOCAL_PATCH_COUNT)
1611 if (LOCAL_PATCH_COUNT > 0) {
1613 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
1614 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
1615 if (PL_localpatches[i])
1616 Perl_sv_catpvf(aTHX_ PL_Sv,"q%c\t%s\n%c,",
1617 0, PL_localpatches[i], 0);
1621 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
1624 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
1626 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
1629 sv_catpv(PL_Sv, "; \
1631 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; ");
1634 push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1637 print \" \\%ENV:\\n @env\\n\" if @env; \
1638 print \" \\@INC:\\n @INC\\n\";");
1641 PL_Sv = newSVpv("config_vars(qw(",0);
1642 sv_catpv(PL_Sv, ++s);
1643 sv_catpv(PL_Sv, "))");
1646 av_push(PL_preambleav, PL_Sv);
1647 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1650 PL_doextract = TRUE;
1658 if (!*++s || isSPACE(*s)) {
1662 /* catch use of gnu style long options */
1663 if (strEQ(s, "version")) {
1667 if (strEQ(s, "help")) {
1674 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
1680 #ifndef SECURE_INTERNAL_GETENV
1683 (s = PerlEnv_getenv("PERL5OPT")))
1685 const char *popt = s;
1688 if (*s == '-' && *(s+1) == 'T') {
1689 CHECK_MALLOC_TOO_LATE_FOR('T');
1691 PL_taint_warn = FALSE;
1694 char *popt_copy = Nullch;
1707 if (!strchr("DIMUdmtwA", *s))
1708 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
1712 popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
1713 s = popt_copy + (s - popt);
1714 d = popt_copy + (d - popt);
1721 if( !PL_tainting ) {
1722 PL_taint_warn = TRUE;
1732 #ifdef USE_SITECUSTOMIZE
1735 PL_preambleav = newAV();
1736 av_unshift(PL_preambleav, 1);
1737 (void)av_store(PL_preambleav, 0, Perl_newSVpvf(aTHX_ "BEGIN { do '%s/sitecustomize.pl' }", SITELIB_EXP));
1741 if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
1742 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
1746 scriptname = argv[0];
1749 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1751 else if (scriptname == Nullch) {
1753 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1759 /* Set $^X early so that it can be used for relocatable paths in @INC */
1760 assert (!PL_tainted);
1762 S_set_caret_X(aTHX);
1766 open_script(scriptname,dosearch,sv);
1768 validate_suid(validarg, scriptname);
1771 #if defined(SIGCHLD) || defined(SIGCLD)
1774 # define SIGCHLD SIGCLD
1776 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1777 if (sigstate == SIG_IGN) {
1778 if (ckWARN(WARN_SIGNAL))
1779 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
1780 "Can't ignore signal CHLD, forcing to default");
1781 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1787 #ifdef MACOS_TRADITIONAL
1788 if (PL_doextract || gMacPerl_AlwaysExtract) {
1793 if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
1794 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1798 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1799 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1800 CvUNIQUE_on(PL_compcv);
1802 CvPADLIST(PL_compcv) = pad_new(0);
1803 #ifdef USE_5005THREADS
1804 CvOWNER(PL_compcv) = 0;
1805 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1806 MUTEX_INIT(CvMUTEXP(PL_compcv));
1807 #endif /* USE_5005THREADS */
1810 boot_core_UNIVERSAL();
1811 boot_core_xsutils();
1814 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
1816 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
1822 # ifdef HAS_SOCKS5_INIT
1823 socks5_init(argv[0]);
1829 init_predump_symbols();
1830 /* init_postdump_symbols not currently designed to be called */
1831 /* more than once (ENV isn't cleared first, for example) */
1832 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
1834 init_postdump_symbols(argc,argv,env);
1836 /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE},
1837 * or explicitly in some platforms.
1838 * locale.c:Perl_init_i18nl10n() if the environment
1839 * look like the user wants to use UTF-8. */
1840 #if defined(SYMBIAN)
1841 PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */
1844 /* Requires init_predump_symbols(). */
1845 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
1850 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
1851 * and the default open disciplines. */
1852 if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
1853 PL_stdingv && (io = GvIO(PL_stdingv)) &&
1855 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1856 if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
1857 PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
1859 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1860 if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
1861 PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
1863 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1864 if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
1865 (sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
1866 U32 in = PL_unicode & PERL_UNICODE_IN_FLAG;
1867 U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
1870 sv_setpvn(sv, ":utf8\0:utf8", 11);
1872 sv_setpvn(sv, ":utf8\0", 6);
1875 sv_setpvn(sv, "\0:utf8", 6);
1881 if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
1882 if (strEQ(s, "unsafe"))
1883 PL_signals |= PERL_SIGNALS_UNSAFE_FLAG;
1884 else if (strEQ(s, "safe"))
1885 PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
1887 Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
1892 /* now parse the script */
1894 SETERRNO(0,SS_NORMAL);
1896 #ifdef MACOS_TRADITIONAL
1897 if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
1899 Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
1901 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1902 MacPerl_MPWFileName(PL_origfilename));
1906 if (yyparse() || PL_error_count) {
1908 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1910 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1915 CopLINE_set(PL_curcop, 0);
1916 PL_curstash = PL_defstash;
1917 PL_preprocess = FALSE;
1919 SvREFCNT_dec(PL_e_script);
1920 PL_e_script = Nullsv;
1927 SAVECOPFILE(PL_curcop);
1928 SAVECOPLINE(PL_curcop);
1929 gv_check(PL_defstash);
1936 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1937 dump_mstats("after compilation:");
1946 =for apidoc perl_run
1948 Tells a Perl interpreter to run. See L<perlembed>.
1960 oldscope = PL_scopestack_ix;
1968 cxstack_ix = -1; /* start context stack again */
1970 case 0: /* normal completion */
1974 case 2: /* my_exit() */
1975 while (PL_scopestack_ix > oldscope)
1978 PL_curstash = PL_defstash;
1979 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
1980 PL_endav && !PL_minus_c)
1981 call_list(oldscope, PL_endav);
1983 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1984 dump_mstats("after execution: ");
1986 ret = STATUS_NATIVE_EXPORT;
1990 POPSTACK_TO(PL_mainstack);
1993 PerlIO_printf(Perl_error_log, "panic: restartop\n");
2005 S_run_body(pTHX_ I32 oldscope)
2007 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
2008 PL_sawampersand ? "Enabling" : "Omitting"));
2010 if (!PL_restartop) {
2011 DEBUG_x(dump_all());
2013 PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
2014 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
2018 #ifdef MACOS_TRADITIONAL
2019 PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
2020 (gMacPerl_ErrorFormat ? "# " : ""),
2021 MacPerl_MPWFileName(PL_origfilename));
2023 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
2027 if (PERLDB_SINGLE && PL_DBsingle)
2028 sv_setiv(PL_DBsingle, 1);
2030 call_list(oldscope, PL_initav);
2036 PL_op = PL_restartop;
2040 else if (PL_main_start) {
2041 CvDEPTH(PL_main_cv) = 1;
2042 PL_op = PL_main_start;
2050 =head1 SV Manipulation Functions
2052 =for apidoc p||get_sv
2054 Returns the SV of the specified Perl scalar. If C<create> is set and the
2055 Perl variable does not exist then it will be created. If C<create> is not
2056 set and the variable does not exist then NULL is returned.
2062 Perl_get_sv(pTHX_ const char *name, I32 create)
2065 #ifdef USE_5005THREADS
2066 if (name[1] == '\0' && !isALPHA(name[0])) {
2067 PADOFFSET tmp = find_threadsv(name);
2068 if (tmp != NOT_IN_PAD)
2069 return THREADSV(tmp);
2071 #endif /* USE_5005THREADS */
2072 gv = gv_fetchpv(name, create, SVt_PV);
2079 =head1 Array Manipulation Functions
2081 =for apidoc p||get_av
2083 Returns the AV of the specified Perl array. If C<create> is set and the
2084 Perl variable does not exist then it will be created. If C<create> is not
2085 set and the variable does not exist then NULL is returned.
2091 Perl_get_av(pTHX_ const char *name, I32 create)
2093 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
2102 =head1 Hash Manipulation Functions
2104 =for apidoc p||get_hv
2106 Returns the HV of the specified Perl hash. If C<create> is set and the
2107 Perl variable does not exist then it will be created. If C<create> is not
2108 set and the variable does not exist then NULL is returned.
2114 Perl_get_hv(pTHX_ const char *name, I32 create)
2116 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
2125 =head1 CV Manipulation Functions
2127 =for apidoc p||get_cv
2129 Returns the CV of the specified Perl subroutine. If C<create> is set and
2130 the Perl subroutine does not exist then it will be declared (which has the
2131 same effect as saying C<sub name;>). If C<create> is not set and the
2132 subroutine does not exist then NULL is returned.
2138 Perl_get_cv(pTHX_ const char *name, I32 create)
2140 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
2141 /* XXX unsafe for threads if eval_owner isn't held */
2142 /* XXX this is probably not what they think they're getting.
2143 * It has the same effect as "sub name;", i.e. just a forward
2145 if (create && !GvCVu(gv))
2146 return newSUB(start_subparse(FALSE, 0),
2147 newSVOP(OP_CONST, 0, newSVpv(name,0)),
2155 /* Be sure to refetch the stack pointer after calling these routines. */
2159 =head1 Callback Functions
2161 =for apidoc p||call_argv
2163 Performs a callback to the specified Perl sub. See L<perlcall>.
2169 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
2171 /* See G_* flags in cop.h */
2172 /* null terminated arg list */
2179 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
2184 return call_pv(sub_name, flags);
2188 =for apidoc p||call_pv
2190 Performs a callback to the specified Perl sub. See L<perlcall>.
2196 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
2197 /* name of the subroutine */
2198 /* See G_* flags in cop.h */
2200 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
2204 =for apidoc p||call_method
2206 Performs a callback to the specified Perl method. The blessed object must
2207 be on the stack. See L<perlcall>.
2213 Perl_call_method(pTHX_ const char *methname, I32 flags)
2214 /* name of the subroutine */
2215 /* See G_* flags in cop.h */
2217 return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
2220 /* May be called with any of a CV, a GV, or an SV containing the name. */
2222 =for apidoc p||call_sv
2224 Performs a callback to the Perl sub whose name is in the SV. See
2231 Perl_call_sv(pTHX_ SV *sv, I32 flags)
2232 /* See G_* flags in cop.h */
2235 LOGOP myop; /* fake syntax tree node */
2238 volatile I32 retval = 0;
2240 bool oldcatch = CATCH_GET;
2245 if (flags & G_DISCARD) {
2250 Zero(&myop, 1, LOGOP);
2251 myop.op_next = Nullop;
2252 if (!(flags & G_NOARGS))
2253 myop.op_flags |= OPf_STACKED;
2254 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2255 (flags & G_ARRAY) ? OPf_WANT_LIST :
2260 EXTEND(PL_stack_sp, 1);
2261 *++PL_stack_sp = sv;
2263 oldscope = PL_scopestack_ix;
2265 if (PERLDB_SUB && PL_curstash != PL_debstash
2266 /* Handle first BEGIN of -d. */
2267 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
2268 /* Try harder, since this may have been a sighandler, thus
2269 * curstash may be meaningless. */
2270 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
2271 && !(flags & G_NODEBUG))
2272 PL_op->op_private |= OPpENTERSUB_DB;
2274 if (flags & G_METHOD) {
2275 Zero(&method_op, 1, UNOP);
2276 method_op.op_next = PL_op;
2277 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
2278 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
2279 PL_op = (OP*)&method_op;
2282 if (!(flags & G_EVAL)) {
2284 call_body((OP*)&myop, FALSE);
2285 retval = PL_stack_sp - (PL_stack_base + oldmark);
2286 CATCH_SET(oldcatch);
2289 myop.op_other = (OP*)&myop;
2291 /* we're trying to emulate pp_entertry() here */
2293 register PERL_CONTEXT *cx;
2294 const I32 gimme = GIMME_V;
2299 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
2301 PL_eval_root = PL_op; /* Only needed so that goto works right. */
2303 PL_in_eval = EVAL_INEVAL;
2304 if (flags & G_KEEPERR)
2305 PL_in_eval |= EVAL_KEEPERR;
2307 sv_setpvn(ERRSV,"",0);
2315 call_body((OP*)&myop, FALSE);
2316 retval = PL_stack_sp - (PL_stack_base + oldmark);
2317 if (!(flags & G_KEEPERR))
2318 sv_setpvn(ERRSV,"",0);
2324 /* my_exit() was called */
2325 PL_curstash = PL_defstash;
2328 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2329 Perl_croak(aTHX_ "Callback called exit");
2334 PL_op = PL_restartop;
2338 PL_stack_sp = PL_stack_base + oldmark;
2339 if (flags & G_ARRAY)
2343 *++PL_stack_sp = &PL_sv_undef;
2348 if (PL_scopestack_ix > oldscope) {
2352 register PERL_CONTEXT *cx;
2363 if (flags & G_DISCARD) {
2364 PL_stack_sp = PL_stack_base + oldmark;
2374 S_call_body(pTHX_ const OP *myop, bool is_eval)
2376 if (PL_op == myop) {
2378 PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
2380 PL_op = Perl_pp_entersub(aTHX); /* this does */
2386 /* Eval a string. The G_EVAL flag is always assumed. */
2389 =for apidoc p||eval_sv
2391 Tells Perl to C<eval> the string in the SV.
2397 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
2399 /* See G_* flags in cop.h */
2402 UNOP myop; /* fake syntax tree node */
2403 volatile I32 oldmark = SP - PL_stack_base;
2404 volatile I32 retval = 0;
2409 if (flags & G_DISCARD) {
2416 Zero(PL_op, 1, UNOP);
2417 EXTEND(PL_stack_sp, 1);
2418 *++PL_stack_sp = sv;
2420 if (!(flags & G_NOARGS))
2421 myop.op_flags = OPf_STACKED;
2422 myop.op_next = Nullop;
2423 myop.op_type = OP_ENTEREVAL;
2424 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2425 (flags & G_ARRAY) ? OPf_WANT_LIST :
2427 if (flags & G_KEEPERR)
2428 myop.op_flags |= OPf_SPECIAL;
2430 /* fail now; otherwise we could fail after the JMPENV_PUSH but
2431 * before a PUSHEVAL, which corrupts the stack after a croak */
2432 TAINT_PROPER("eval_sv()");
2438 call_body((OP*)&myop,TRUE);
2439 retval = PL_stack_sp - (PL_stack_base + oldmark);
2440 if (!(flags & G_KEEPERR))
2441 sv_setpvn(ERRSV,"",0);
2447 /* my_exit() was called */
2448 PL_curstash = PL_defstash;
2451 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2452 Perl_croak(aTHX_ "Callback called exit");
2457 PL_op = PL_restartop;
2461 PL_stack_sp = PL_stack_base + oldmark;
2462 if (flags & G_ARRAY)
2466 *++PL_stack_sp = &PL_sv_undef;
2472 if (flags & G_DISCARD) {
2473 PL_stack_sp = PL_stack_base + oldmark;
2483 =for apidoc p||eval_pv
2485 Tells Perl to C<eval> the given string and return an SV* result.
2491 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2494 SV* sv = newSVpv(p, 0);
2496 eval_sv(sv, G_SCALAR);
2503 if (croak_on_error && SvTRUE(ERRSV)) {
2504 Perl_croak(aTHX_ SvPVx_nolen_const(ERRSV));
2510 /* Require a module. */
2513 =head1 Embedding Functions
2515 =for apidoc p||require_pv
2517 Tells Perl to C<require> the file named by the string argument. It is
2518 analogous to the Perl code C<eval "require '$file'">. It's even
2519 implemented that way; consider using load_module instead.
2524 Perl_require_pv(pTHX_ const char *pv)
2528 PUSHSTACKi(PERLSI_REQUIRE);
2530 sv = sv_newmortal();
2531 sv_setpv(sv, "require '");
2534 eval_sv(sv, G_DISCARD);
2540 Perl_magicname(pTHX_ const char *sym, const char *name, I32 namlen)
2544 if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
2545 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
2549 S_usage(pTHX_ const char *name) /* XXX move this out into a module ? */
2551 /* This message really ought to be max 23 lines.
2552 * Removed -h because the user already knows that option. Others? */
2554 static const char * const usage_msg[] = {
2555 "-0[octal] specify record separator (\\0, if no argument)",
2556 "-A[mod][=pattern] activate all/given assertions",
2557 "-a autosplit mode with -n or -p (splits $_ into @F)",
2558 "-C[number/list] enables the listed Unicode features",
2559 "-c check syntax only (runs BEGIN and CHECK blocks)",
2560 "-d[:debugger] run program under debugger",
2561 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
2562 "-e program one line of program (several -e's allowed, omit programfile)",
2563 "-f don't do $sitelib/sitecustomize.pl at startup",
2564 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
2565 "-i[extension] edit <> files in place (makes backup if extension supplied)",
2566 "-Idirectory specify @INC/#include directory (several -I's allowed)",
2567 "-l[octal] enable line ending processing, specifies line terminator",
2568 "-[mM][-]module execute \"use/no module...\" before executing program",
2569 "-n assume \"while (<>) { ... }\" loop around program",
2570 "-p assume loop like -n but print line also, like sed",
2571 "-P run program through C preprocessor before compilation",
2572 "-s enable rudimentary parsing for switches after programfile",
2573 "-S look for programfile using PATH environment variable",
2574 "-t enable tainting warnings",
2575 "-T enable tainting checks",
2576 "-u dump core after parsing program",
2577 "-U allow unsafe operations",
2578 "-v print version, subversion (includes VERY IMPORTANT perl info)",
2579 "-V[:variable] print configuration summary (or a single Config.pm variable)",
2580 "-w enable many useful warnings (RECOMMENDED)",
2581 "-W enable all warnings",
2582 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
2583 "-X disable all warnings",
2587 const char * const *p = usage_msg;
2589 PerlIO_printf(PerlIO_stdout(),
2590 "\nUsage: %s [switches] [--] [programfile] [arguments]",
2593 PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
2596 /* convert a string of -D options (or digits) into an int.
2597 * sets *s to point to the char after the options */
2601 Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
2603 static const char * const usage_msgd[] = {
2604 " Debugging flag values: (see also -d)",
2605 " p Tokenizing and parsing (with v, displays parse stack)",
2606 " s Stack snapshots (with v, displays all stacks)",
2607 " l Context (loop) stack processing",
2608 " t Trace execution",
2609 " o Method and overloading resolution",
2610 " c String/numeric conversions",
2611 " P Print profiling info, preprocessor command for -P, source file input state",
2612 " m Memory allocation",
2613 " f Format processing",
2614 " r Regular expression parsing and execution",
2615 " x Syntax tree dump",
2616 " u Tainting checks",
2617 " H Hash dump -- usurps values()",
2618 " X Scratchpad allocation",
2620 " S Thread synchronization",
2622 " R Include reference counts of dumped variables (eg when using -Ds)",
2623 " J Do not s,t,P-debug (Jump over) opcodes within package DB",
2624 " v Verbose: use in conjunction with other flags",
2626 " A Consistency checks on internal structures",
2627 " q quiet - currently only suppresses the 'EXECUTING' message",
2632 /* if adding extra options, remember to update DEBUG_MASK */
2633 static const char debopts[] = "psltocPmfrxu HXDSTRJvCAq";
2635 for (; isALNUM(**s); (*s)++) {
2636 const char *d = strchr(debopts,**s);
2638 i |= 1 << (d - debopts);
2639 else if (ckWARN_d(WARN_DEBUGGING))
2640 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2641 "invalid option -D%c, use -D'' to see choices\n", **s);
2644 else if (isDIGIT(**s)) {
2646 for (; isALNUM(**s); (*s)++) ;
2648 else if (givehelp) {
2649 char **p = (char **)usage_msgd;
2650 while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++);
2653 if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
2654 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2655 "-Dp not implemented on this platform\n");
2661 /* This routine handles any switches that can be given during run */
2664 Perl_moreswitches(pTHX_ char *s)
2675 SvREFCNT_dec(PL_rs);
2676 if (s[1] == 'x' && s[2]) {
2677 const char *e = s+=2;
2683 flags = PERL_SCAN_SILENT_ILLDIGIT;
2684 rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
2685 if (s + numlen < e) {
2686 rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
2690 PL_rs = newSVpvn("", 0);
2691 SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
2692 tmps = (U8*)SvPVX(PL_rs);
2693 uvchr_to_utf8(tmps, rschar);
2694 SvCUR_set(PL_rs, UNISKIP(rschar));
2699 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
2700 if (rschar & ~((U8)~0))
2701 PL_rs = &PL_sv_undef;
2702 else if (!rschar && numlen >= 2)
2703 PL_rs = newSVpvn("", 0);
2705 char ch = (char)rschar;
2706 PL_rs = newSVpvn(&ch, 1);
2709 sv_setsv(get_sv("/", TRUE), PL_rs);
2714 PL_unicode = parse_unicode_opts( (const char **)&s );
2719 while (*s && !isSPACE(*s)) ++s;
2721 PL_splitstr = savepv(PL_splitstr);
2735 /* -dt indicates to the debugger that threads will be used */
2736 if (*s == 't' && !isALNUM(s[1])) {
2738 my_setenv("PERL5DB_THREADED", "1");
2741 /* The following permits -d:Mod to accepts arguments following an =
2742 in the fashion that -MSome::Mod does. */
2743 if (*s == ':' || *s == '=') {
2746 sv = newSVpv("use Devel::", 0);
2748 /* We now allow -d:Module=Foo,Bar */
2749 while(isALNUM(*s) || *s==':') ++s;
2751 sv_catpv(sv, start);
2753 sv_catpvn(sv, start, s-start);
2754 sv_catpv(sv, " split(/,/,q{");
2759 my_setenv("PERL5DB", SvPV(sv, PL_na));
2762 PL_perldb = PERLDB_ALL;
2771 PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
2772 #else /* !DEBUGGING */
2773 if (ckWARN_d(WARN_DEBUGGING))
2774 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2775 "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
2776 for (s++; isALNUM(*s); s++) ;
2781 usage(PL_origargv[0]);
2785 Safefree(PL_inplace);
2786 #if defined(__CYGWIN__) /* do backup extension automagically */
2787 if (*(s+1) == '\0') {
2788 PL_inplace = savepv(".bak");
2791 #endif /* __CYGWIN__ */
2792 PL_inplace = savepv(s+1);
2793 for (s = PL_inplace; *s && !isSPACE(*s); s++)
2797 if (*s == '-') /* Additional switches on #! line. */
2801 case 'I': /* -I handled both here and in parse_body() */
2804 while (*s && isSPACE(*s))
2809 /* ignore trailing spaces (possibly followed by other switches) */
2811 for (e = p; *e && !isSPACE(*e); e++) ;
2815 } while (*p && *p != '-');
2816 e = savepvn(s, e-s);
2817 incpush(e, TRUE, TRUE, FALSE, FALSE);
2824 Perl_croak(aTHX_ "No directory specified for -I");
2830 SvREFCNT_dec(PL_ors_sv);
2836 PL_ors_sv = newSVpvn("\n",1);
2837 numlen = 3 + (*s == '0');
2838 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
2842 if (RsPARA(PL_rs)) {
2843 PL_ors_sv = newSVpvn("\n\n",2);
2846 PL_ors_sv = newSVsv(PL_rs);
2853 PL_preambleav = newAV();
2857 SV *sv = newSVpv("use assertions::activate", 24);
2858 while(isALNUM(*s) || *s == ':') ++s;
2860 sv_catpvn(sv, "::", 2);
2861 sv_catpvn(sv, start, s-start);
2864 sv_catpvn(sv, " split(/,/,q\0", 13);
2866 sv_catpvn(sv, "\0)", 2);
2869 else if (*s != '\0') {
2870 Perl_croak(aTHX_ "Can't use '%c' after -A%.*s", *s, s-start, start);
2872 av_push(PL_preambleav, sv);
2876 forbid_setid("-M"); /* XXX ? */
2879 forbid_setid("-m"); /* XXX ? */
2883 const char *use = "use ";
2884 /* -M-foo == 'no foo' */
2885 if (*s == '-') { use = "no "; ++s; }
2886 sv = newSVpv(use,0);
2888 /* We allow -M'Module qw(Foo Bar)' */
2889 while(isALNUM(*s) || *s==':') ++s;
2891 sv_catpv(sv, start);
2892 if (*(start-1) == 'm') {
2894 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
2895 sv_catpv( sv, " ()");
2899 Perl_croak(aTHX_ "Module name required with -%c option",
2901 sv_catpvn(sv, start, s-start);
2902 sv_catpv(sv, " split(/,/,q");
2903 sv_catpvn(sv, "\0)", 1); /* Use NUL as q//-delimiter. */
2905 sv_catpvn(sv, "\0)", 2);
2909 PL_preambleav = newAV();
2910 av_push(PL_preambleav, sv);
2913 Perl_croak(aTHX_ "Missing argument to -%c", *(s-1));
2925 PL_doswitches = TRUE;
2939 #ifdef MACOS_TRADITIONAL
2940 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2942 PL_do_undump = TRUE;
2950 if (!sv_derived_from(PL_patchlevel, "version"))
2951 (void *)upg_version(PL_patchlevel);
2953 PerlIO_printf(PerlIO_stdout(),
2954 Perl_form(aTHX_ "\nThis is perl, %"SVf" built for %s",
2955 vstringify(PL_patchlevel),
2958 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
2959 PerlIO_printf(PerlIO_stdout(),
2960 Perl_form(aTHX_ "\nThis is perl, %"SVf"\n",
2961 vstringify(PL_patchlevel)));
2962 PerlIO_printf(PerlIO_stdout(),
2963 Perl_form(aTHX_ " built under %s at %s %s\n",
2964 OSNAME, __DATE__, __TIME__));
2965 PerlIO_printf(PerlIO_stdout(),
2966 Perl_form(aTHX_ " OS Specific Release: %s\n",
2970 #if defined(LOCAL_PATCH_COUNT)
2971 if (LOCAL_PATCH_COUNT > 0)
2972 PerlIO_printf(PerlIO_stdout(),
2973 "\n(with %d registered patch%s, "
2974 "see perl -V for more detail)",
2975 (int)LOCAL_PATCH_COUNT,
2976 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
2979 PerlIO_printf(PerlIO_stdout(),
2980 "\n\nCopyright 1987-2005, Larry Wall\n");
2981 #ifdef MACOS_TRADITIONAL
2982 PerlIO_printf(PerlIO_stdout(),
2983 "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
2984 "maintained by Chris Nandor\n");
2987 PerlIO_printf(PerlIO_stdout(),
2988 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
2991 PerlIO_printf(PerlIO_stdout(),
2992 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2993 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
2996 PerlIO_printf(PerlIO_stdout(),
2997 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
2998 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
3001 PerlIO_printf(PerlIO_stdout(),
3002 "atariST series port, ++jrb bammi@cadence.com\n");
3005 PerlIO_printf(PerlIO_stdout(),
3006 "BeOS port Copyright Tom Spindler, 1997-1999\n");
3009 PerlIO_printf(PerlIO_stdout(),
3010 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2003\n");
3013 PerlIO_printf(PerlIO_stdout(),
3014 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
3017 PerlIO_printf(PerlIO_stdout(),
3018 "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
3021 PerlIO_printf(PerlIO_stdout(),
3022 "VM/ESA port by Neale Ferguson, 1998-1999\n");
3025 PerlIO_printf(PerlIO_stdout(),
3026 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
3029 PerlIO_printf(PerlIO_stdout(),
3030 "MiNT port by Guido Flohr, 1997-1999\n");
3033 PerlIO_printf(PerlIO_stdout(),
3034 "EPOC port by Olaf Flebbe, 1999-2002\n");
3037 PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
3038 PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
3042 PerlIO_printf(PerlIO_stdout(),
3043 "Symbian port by Nokia, 2004-2005\n");
3045 #ifdef BINARY_BUILD_NOTICE
3046 BINARY_BUILD_NOTICE;
3048 PerlIO_printf(PerlIO_stdout(),
3050 Perl may be copied only under the terms of either the Artistic License or the\n\
3051 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
3052 Complete documentation for Perl, including FAQ lists, should be found on\n\
3053 this system using \"man perl\" or \"perldoc perl\". If you have access to the\n\
3054 Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
3057 if (! (PL_dowarn & G_WARN_ALL_MASK))
3058 PL_dowarn |= G_WARN_ON;
3062 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
3063 if (!specialWARN(PL_compiling.cop_warnings))
3064 SvREFCNT_dec(PL_compiling.cop_warnings);
3065 PL_compiling.cop_warnings = pWARN_ALL ;
3069 PL_dowarn = G_WARN_ALL_OFF;
3070 if (!specialWARN(PL_compiling.cop_warnings))
3071 SvREFCNT_dec(PL_compiling.cop_warnings);
3072 PL_compiling.cop_warnings = pWARN_NONE ;
3077 if (s[1] == '-') /* Additional switches on #! line. */
3082 #if defined(WIN32) || !defined(PERL_STRICT_CR)
3088 #ifdef ALTERNATE_SHEBANG
3089 case 'S': /* OS/2 needs -S on "extproc" line. */
3097 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
3102 /* compliments of Tom Christiansen */
3104 /* unexec() can be found in the Gnu emacs distribution */
3105 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
3108 Perl_my_unexec(pTHX)
3116 prog = newSVpv(BIN_EXP, 0);
3117 sv_catpv(prog, "/perl");
3118 file = newSVpv(PL_origfilename, 0);
3119 sv_catpv(file, ".perldump");
3121 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
3122 /* unexec prints msg to stderr in case of failure */
3123 PerlProc_exit(status);
3126 # include <lib$routines.h>
3127 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
3129 ABORT(); /* for use with undump */
3134 /* initialize curinterp */
3140 # define PERLVAR(var,type)
3141 # define PERLVARA(var,n,type)
3142 # if defined(PERL_IMPLICIT_CONTEXT)
3143 # if defined(USE_5005THREADS)
3144 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
3145 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
3146 # else /* !USE_5005THREADS */
3147 # define PERLVARI(var,type,init) aTHX->var = init;
3148 # define PERLVARIC(var,type,init) aTHX->var = init;
3149 # endif /* USE_5005THREADS */
3151 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
3152 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
3154 # include "intrpvar.h"
3155 # ifndef USE_5005THREADS
3156 # include "thrdvar.h"
3163 # define PERLVAR(var,type)
3164 # define PERLVARA(var,n,type)
3165 # define PERLVARI(var,type,init) PL_##var = init;
3166 # define PERLVARIC(var,type,init) PL_##var = init;
3167 # include "intrpvar.h"
3168 # ifndef USE_5005THREADS
3169 # include "thrdvar.h"
3180 S_init_main_stash(pTHX)
3184 PL_curstash = PL_defstash = newHV();
3185 PL_curstname = newSVpvn("main",4);
3186 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
3187 SvREFCNT_dec(GvHV(gv));
3188 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
3190 Perl_hv_name_set(aTHX_ PL_defstash, "main", 4, 0);
3191 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
3192 GvMULTI_on(PL_incgv);
3193 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
3194 GvMULTI_on(PL_hintgv);
3195 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
3196 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
3197 GvMULTI_on(PL_errgv);
3198 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
3199 GvMULTI_on(PL_replgv);
3200 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
3201 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
3202 sv_setpvn(ERRSV, "", 0);
3203 PL_curstash = PL_defstash;
3204 CopSTASH_set(&PL_compiling, PL_defstash);
3205 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
3206 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
3207 /* We must init $/ before switches are processed. */
3208 sv_setpvn(get_sv("/", TRUE), "\n", 1);
3211 /* PSz 18 Nov 03 fdscript now global but do not change prototype */
3213 S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv)
3218 const char *cpp_discard_flag;
3227 PL_origfilename = savepvn("-e", 2);
3230 /* if find_script() returns, it returns a malloc()-ed value */
3231 scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
3233 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
3234 const char *s = scriptname + 8;
3235 PL_fdscript = atoi(s);
3240 * Tell apart "normal" usage of fdscript, e.g.
3241 * with bash on FreeBSD:
3242 * perl <( echo '#!perl -DA'; echo 'print "$0\n"')
3243 * from usage in suidperl.
3244 * Does any "normal" usage leave garbage after the number???
3245 * Is it a mistake to use a similar /dev/fd/ construct for
3250 * Be supersafe and do some sanity-checks.
3251 * Still, can we be sure we got the right thing?
3254 Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
3257 Perl_croak(aTHX_ "Missing (suid) fd script name\n");
3259 scriptname = savepv(s + 1);
3260 Safefree(PL_origfilename);
3261 PL_origfilename = (char *)scriptname;
3266 CopFILE_free(PL_curcop);
3267 CopFILE_set(PL_curcop, PL_origfilename);
3268 if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
3269 scriptname = (char *)"";
3270 if (PL_fdscript >= 0) {
3271 PL_rsfp = PerlIO_fdopen(PL_fdscript,PERL_SCRIPT_MODE);
3272 # if defined(HAS_FCNTL) && defined(F_SETFD)
3274 /* ensure close-on-exec */
3275 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
3280 Perl_croak(aTHX_ "sperl needs fd script\n"
3281 "You should not call sperl directly; do you need to "
3282 "change a #! line\nfrom sperl to perl?\n");
3285 * Do not open (or do other fancy stuff) while setuid.
3286 * Perl does the open, and hands script to suidperl on a fd;
3287 * suidperl only does some checks, sets up UIDs and re-execs
3288 * perl with that fd as it has always done.
3291 if (PL_suidscript != 1) {
3292 Perl_croak(aTHX_ "suidperl needs (suid) fd script\n");
3295 else if (PL_preprocess) {
3296 const char *cpp_cfg = CPPSTDIN;
3297 SV *cpp = newSVpvn("",0);
3298 SV *cmd = NEWSV(0,0);
3300 if (cpp_cfg[0] == 0) /* PERL_MICRO? */
3301 Perl_croak(aTHX_ "Can't run with cpp -P with CPPSTDIN undefined");
3302 if (strEQ(cpp_cfg, "cppstdin"))
3303 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
3304 sv_catpv(cpp, cpp_cfg);
3307 sv_catpvn(sv, "-I", 2);
3308 sv_catpv(sv,PRIVLIB_EXP);
3311 DEBUG_P(PerlIO_printf(Perl_debug_log,
3312 "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
3313 scriptname, SvPVX_const (cpp), SvPVX_const (sv),
3316 # if defined(MSDOS) || defined(WIN32) || defined(VMS)
3323 cpp_discard_flag = "";
3325 cpp_discard_flag = "-C";
3329 perl = os2_execname(aTHX);
3331 perl = PL_origargv[0];
3335 /* This strips off Perl comments which might interfere with
3336 the C pre-processor, including #!. #line directives are
3337 deliberately stripped to avoid confusion with Perl's version
3338 of #line. FWP played some golf with it so it will fit
3339 into VMS's 255 character buffer.
3342 code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3344 code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3346 Perl_sv_setpvf(aTHX_ cmd, "\
3347 %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
3348 perl, quote, code, quote, scriptname, cpp,
3349 cpp_discard_flag, sv, CPPMINUS);
3351 PL_doextract = FALSE;
3353 DEBUG_P(PerlIO_printf(Perl_debug_log,
3354 "PL_preprocess: cmd=\"%s\"\n",
3357 PL_rsfp = PerlProc_popen((char *)SvPVX_const(cmd), (char *)"r");
3361 else if (!*scriptname) {
3362 forbid_setid("program input from stdin");
3363 PL_rsfp = PerlIO_stdin();
3366 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
3367 # if defined(HAS_FCNTL) && defined(F_SETFD)
3369 /* ensure close-on-exec */
3370 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
3373 #endif /* IAMSUID */
3375 /* PSz 16 Sep 03 Keep neat error message */
3376 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3377 CopFILE(PL_curcop), Strerror(errno));
3382 * I_SYSSTATVFS HAS_FSTATVFS
3384 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
3385 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
3386 * here so that metaconfig picks them up. */
3390 S_fd_on_nosuid_fs(pTHX_ int fd)
3393 * We used to do this as "plain" user (after swapping UIDs with setreuid);
3394 * but is needed also on machines without setreuid.
3395 * Seems safe enough to run as root.
3397 int check_okay = 0; /* able to do all the required sys/libcalls */
3398 int on_nosuid = 0; /* the fd is on a nosuid fs */
3400 * Need to check noexec also: nosuid might not be set, the average
3401 * sysadmin would say that nosuid is irrelevant once he sets noexec.
3403 int on_noexec = 0; /* the fd is on a noexec fs */
3406 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
3407 * fstatvfs() is UNIX98.
3408 * fstatfs() is 4.3 BSD.
3409 * ustat()+getmnt() is pre-4.3 BSD.
3410 * getmntent() is O(number-of-mounted-filesystems) and can hang on
3411 * an irrelevant filesystem while trying to reach the right one.
3414 #undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
3416 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3417 defined(HAS_FSTATVFS)
3418 # define FD_ON_NOSUID_CHECK_OKAY
3419 struct statvfs stfs;
3421 check_okay = fstatvfs(fd, &stfs) == 0;
3422 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
3424 /* ST_NOEXEC certainly absent on AIX 5.1, and doesn't seem to be documented
3425 on platforms where it is present. */
3426 on_noexec = check_okay && (stfs.f_flag & ST_NOEXEC);
3428 # endif /* fstatvfs */
3430 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3431 defined(PERL_MOUNT_NOSUID) && \
3432 defined(PERL_MOUNT_NOEXEC) && \
3433 defined(HAS_FSTATFS) && \
3434 defined(HAS_STRUCT_STATFS) && \
3435 defined(HAS_STRUCT_STATFS_F_FLAGS)
3436 # define FD_ON_NOSUID_CHECK_OKAY
3439 check_okay = fstatfs(fd, &stfs) == 0;
3440 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
3441 on_noexec = check_okay && (stfs.f_flags & PERL_MOUNT_NOEXEC);
3442 # endif /* fstatfs */
3444 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3445 defined(PERL_MOUNT_NOSUID) && \
3446 defined(PERL_MOUNT_NOEXEC) && \
3447 defined(HAS_FSTAT) && \
3448 defined(HAS_USTAT) && \
3449 defined(HAS_GETMNT) && \
3450 defined(HAS_STRUCT_FS_DATA) && \
3452 # define FD_ON_NOSUID_CHECK_OKAY
3455 if (fstat(fd, &fdst) == 0) {
3457 if (ustat(fdst.st_dev, &us) == 0) {
3459 /* NOSTAT_ONE here because we're not examining fields which
3460 * vary between that case and STAT_ONE. */
3461 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
3462 size_t cmplen = sizeof(us.f_fname);
3463 if (sizeof(fsd.fd_req.path) < cmplen)
3464 cmplen = sizeof(fsd.fd_req.path);
3465 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
3466 fdst.st_dev == fsd.fd_req.dev) {
3468 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
3469 on_noexec = fsd.fd_req.flags & PERL_MOUNT_NOEXEC;
3475 # endif /* fstat+ustat+getmnt */
3477 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3478 defined(HAS_GETMNTENT) && \
3479 defined(HAS_HASMNTOPT) && \
3480 defined(MNTOPT_NOSUID) && \
3481 defined(MNTOPT_NOEXEC)
3482 # define FD_ON_NOSUID_CHECK_OKAY
3483 FILE *mtab = fopen("/etc/mtab", "r");
3484 struct mntent *entry;
3487 if (mtab && (fstat(fd, &stb) == 0)) {
3488 while (entry = getmntent(mtab)) {
3489 if (stat(entry->mnt_dir, &fsb) == 0
3490 && fsb.st_dev == stb.st_dev)
3492 /* found the filesystem */
3494 if (hasmntopt(entry, MNTOPT_NOSUID))
3496 if (hasmntopt(entry, MNTOPT_NOEXEC))
3499 } /* A single fs may well fail its stat(). */
3504 # endif /* getmntent+hasmntopt */
3507 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid/noexec", PL_origfilename);
3509 Perl_croak(aTHX_ "Setuid script \"%s\" on nosuid filesystem", PL_origfilename);
3511 Perl_croak(aTHX_ "Setuid script \"%s\" on noexec filesystem", PL_origfilename);
3512 return ((!check_okay) || on_nosuid || on_noexec);
3514 #endif /* IAMSUID */
3517 S_validate_suid(pTHX_ const char *validarg, const char *scriptname)
3522 #endif /* IAMSUID */
3524 /* do we need to emulate setuid on scripts? */
3526 /* This code is for those BSD systems that have setuid #! scripts disabled
3527 * in the kernel because of a security problem. Merely defining DOSUID
3528 * in perl will not fix that problem, but if you have disabled setuid
3529 * scripts in the kernel, this will attempt to emulate setuid and setgid
3530 * on scripts that have those now-otherwise-useless bits set. The setuid
3531 * root version must be called suidperl or sperlN.NNN. If regular perl
3532 * discovers that it has opened a setuid script, it calls suidperl with
3533 * the same argv that it had. If suidperl finds that the script it has
3534 * just opened is NOT setuid root, it sets the effective uid back to the
3535 * uid. We don't just make perl setuid root because that loses the
3536 * effective uid we had before invoking perl, if it was different from the
3539 * Description/comments above do not match current workings:
3540 * suidperl must be hardlinked to sperlN.NNN (that is what we exec);
3541 * suidperl called with script open and name changed to /dev/fd/N/X;
3542 * suidperl croaks if script is not setuid;
3543 * making perl setuid would be a huge security risk (and yes, that
3544 * would lose any euid we might have had).
3546 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3547 * be defined in suidperl only. suidperl must be setuid root. The
3548 * Configure script will set this up for you if you want it.
3554 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
3555 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
3556 if (PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
3558 const char *linestr;
3561 if (PL_fdscript < 0 || PL_suidscript != 1)
3562 Perl_croak(aTHX_ "Need (suid) fdscript in suidperl\n"); /* We already checked this */
3564 * Since the script is opened by perl, not suidperl, some of these
3565 * checks are superfluous. Leaving them in probably does not lower
3569 * Do checks even for systems with no HAS_SETREUID.
3570 * We used to swap, then re-swap UIDs with
3572 if (setreuid(PL_euid,PL_uid) < 0
3573 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
3574 Perl_croak(aTHX_ "Can't swap uid and euid");
3577 if (setreuid(PL_uid,PL_euid) < 0
3578 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3579 Perl_croak(aTHX_ "Can't reswap uid and euid");
3583 /* On this access check to make sure the directories are readable,
3584 * there is actually a small window that the user could use to make
3585 * filename point to an accessible directory. So there is a faint
3586 * chance that someone could execute a setuid script down in a
3587 * non-accessible directory. I don't know what to do about that.
3588 * But I don't think it's too important. The manual lies when
3589 * it says access() is useful in setuid programs.
3591 * So, access() is pretty useless... but not harmful... do anyway.
3593 if (PerlLIO_access(CopFILE(PL_curcop),1)) { /*double check*/
3594 Perl_croak(aTHX_ "Can't access() script\n");
3597 /* If we can swap euid and uid, then we can determine access rights
3598 * with a simple stat of the file, and then compare device and
3599 * inode to make sure we did stat() on the same file we opened.
3600 * Then we just have to make sure he or she can execute it.
3603 * As the script is opened by perl, not suidperl, we do not need to
3604 * care much about access rights.
3606 * The 'script changed' check is needed, or we can get lied to
3607 * about $0 with e.g.
3608 * suidperl /dev/fd/4//bin/x 4<setuidscript
3609 * Without HAS_SETREUID, is it safe to stat() as root?
3611 * Are there any operating systems that pass /dev/fd/xxx for setuid
3612 * scripts, as suggested/described in perlsec(1)? Surely they do not
3613 * pass the script name as we do, so the "script changed" test would
3614 * fail for them... but we never get here with
3615 * SETUID_SCRIPTS_ARE_SECURE_NOW defined.
3617 * This is one place where we must "lie" about return status: not
3618 * say if the stat() failed. We are doing this as root, and could
3619 * be tricked into reporting existence or not of files that the
3620 * "plain" user cannot even see.
3624 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0 ||
3625 tmpstatbuf.st_dev != PL_statbuf.st_dev ||
3626 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
3627 Perl_croak(aTHX_ "Setuid script changed\n");
3631 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
3632 Perl_croak(aTHX_ "Real UID cannot exec script\n");
3635 * We used to do this check as the "plain" user (after swapping
3636 * UIDs). But the check for nosuid and noexec filesystem is needed,
3637 * and should be done even without HAS_SETREUID. (Maybe those
3638 * operating systems do not have such mount options anyway...)
3639 * Seems safe enough to do as root.
3641 #if !defined(NO_NOSUID_CHECK)
3642 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp))) {
3643 Perl_croak(aTHX_ "Setuid script on nosuid or noexec filesystem\n");
3646 #endif /* IAMSUID */
3648 if (!S_ISREG(PL_statbuf.st_mode)) {
3649 Perl_croak(aTHX_ "Setuid script not plain file\n");
3651 if (PL_statbuf.st_mode & S_IWOTH)
3652 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
3653 PL_doswitches = FALSE; /* -s is insecure in suid */
3654 /* PSz 13 Nov 03 But -s was caught elsewhere ... so unsetting it here is useless(?!) */
3655 CopLINE_inc(PL_curcop);
3656 linestr = SvPV_nolen_const(PL_linestr);
3657 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
3658 strnNE(linestr,"#!",2) ) /* required even on Sys V */
3659 Perl_croak(aTHX_ "No #! line");
3663 /* Sanity check on line length */
3664 if (strlen(s) < 1 || strlen(s) > 4000)
3665 Perl_croak(aTHX_ "Very long #! line");
3666 /* Allow more than a single space after #! */
3667 while (isSPACE(*s)) s++;
3668 /* Sanity check on buffer end */
3669 while ((*s) && !isSPACE(*s)) s++;
3670 for (s2 = s; (s2 > linestr &&
3671 (isDIGIT(s2[-1]) || s2[-1] == '.' || s2[-1] == '_'
3672 || s2[-1] == '-')); s2--) ;
3673 /* Sanity check on buffer start */
3674 if ( (s2-4 < linestr || strnNE(s2-4,"perl",4)) &&
3675 (s-9 < linestr || strnNE(s-9,"perl",4)) )
3676 Perl_croak(aTHX_ "Not a perl script");
3677 while (*s == ' ' || *s == '\t') s++;
3679 * #! arg must be what we saw above. They can invoke it by
3680 * mentioning suidperl explicitly, but they may not add any strange
3681 * arguments beyond what #! says if they do invoke suidperl that way.
3684 * The way validarg was set up, we rely on the kernel to start
3685 * scripts with argv[1] set to contain all #! line switches (the
3689 * Check that we got all the arguments listed in the #! line (not
3690 * just that there are no extraneous arguments). Might not matter
3691 * much, as switches from #! line seem to be acted upon (also), and
3692 * so may be checked and trapped in perl. But, security checks must
3693 * be done in suidperl and not deferred to perl. Note that suidperl
3694 * does not get around to parsing (and checking) the switches on
3695 * the #! line (but execs perl sooner).
3696 * Allow (require) a trailing newline (which may be of two
3697 * characters on some architectures?) (but no other trailing
3700 len = strlen(validarg);
3701 if (strEQ(validarg," PHOOEY ") ||
3702 strnNE(s,validarg,len) || !isSPACE(s[len]) ||
3703 !(strlen(s) == len+1 || (strlen(s) == len+2 && isSPACE(s[len+1]))))
3704 Perl_croak(aTHX_ "Args must match #! line");
3707 if (PL_fdscript < 0 &&
3708 PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
3709 PL_euid == PL_statbuf.st_uid)
3711 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3712 FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
3713 #endif /* IAMSUID */
3715 if (PL_fdscript < 0 &&
3716 PL_euid) { /* oops, we're not the setuid root perl */
3718 * When root runs a setuid script, we do not go through the same
3719 * steps of execing sperl and then perl with fd scripts, but
3720 * simply set up UIDs within the same perl invocation; so do
3721 * not have the same checks (on options, whatever) that we have
3722 * for plain users. No problem really: would have to be a script
3723 * that does not actually work for plain users; and if root is
3724 * foolish and can be persuaded to run such an unsafe script, he
3725 * might run also non-setuid ones, and deserves what he gets.
3727 * Or, we might drop the PL_euid check above (and rely just on
3728 * PL_fdscript to avoid loops), and do the execs
3734 * Pass fd script to suidperl.
3735 * Exec suidperl, substituting fd script for scriptname.
3736 * Pass script name as "subdir" of fd, which perl will grok;
3737 * in fact will use that to distinguish this from "normal"
3738 * usage, see comments above.
3740 PerlIO_rewind(PL_rsfp);
3741 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
3742 /* PSz 27 Feb 04 Sanity checks on scriptname */
3743 if ((!scriptname) || (!*scriptname) ) {
3744 Perl_croak(aTHX_ "No setuid script name\n");
3746 if (*scriptname == '-') {
3747 Perl_croak(aTHX_ "Setuid script name may not begin with dash\n");
3748 /* Or we might confuse it with an option when replacing
3749 * name in argument list, below (though we do pointer, not
3750 * string, comparisons).
3753 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3754 if (!PL_origargv[which]) {
3755 Perl_croak(aTHX_ "Can't change argv to have fd script\n");
3757 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
3758 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
3759 #if defined(HAS_FCNTL) && defined(F_SETFD)
3760 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
3763 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
3764 (int)PERL_REVISION, (int)PERL_VERSION,
3765 (int)PERL_SUBVERSION), PL_origargv);
3767 #endif /* IAMSUID */
3768 Perl_croak(aTHX_ "Can't do setuid (cannot exec sperl)\n");
3771 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
3773 * This seems back to front: we try HAS_SETEGID first; if not available
3774 * then try HAS_SETREGID; as a last chance we try HAS_SETRESGID. May be OK
3775 * in the sense that we only want to set EGID; but are there any machines
3776 * with either of the latter, but not the former? Same with UID, later.
3779 (void)setegid(PL_statbuf.st_gid);
3782 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
3784 #ifdef HAS_SETRESGID
3785 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
3787 PerlProc_setgid(PL_statbuf.st_gid);
3791 if (PerlProc_getegid() != PL_statbuf.st_gid)
3792 Perl_croak(aTHX_ "Can't do setegid!\n");
3794 if (PL_statbuf.st_mode & S_ISUID) {
3795 if (PL_statbuf.st_uid != PL_euid)
3797 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
3800 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
3802 #ifdef HAS_SETRESUID
3803 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
3805 PerlProc_setuid(PL_statbuf.st_uid);
3809 if (PerlProc_geteuid() != PL_statbuf.st_uid)
3810 Perl_croak(aTHX_ "Can't do seteuid!\n");
3812 else if (PL_uid) { /* oops, mustn't run as root */
3814 (void)seteuid((Uid_t)PL_uid);
3817 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
3819 #ifdef HAS_SETRESUID
3820 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
3822 PerlProc_setuid((Uid_t)PL_uid);
3826 if (PerlProc_geteuid() != PL_uid)
3827 Perl_croak(aTHX_ "Can't do seteuid!\n");
3830 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
3831 Perl_croak(aTHX_ "Effective UID cannot exec script\n"); /* they can't do this */
3834 else if (PL_preprocess) /* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */
3835 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
3836 else if (PL_fdscript < 0 || PL_suidscript != 1)
3837 /* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */
3838 Perl_croak(aTHX_ "(suid) fdscript needed in suidperl\n");
3840 /* PSz 16 Sep 03 Keep neat error message */
3841 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
3844 /* We absolutely must clear out any saved ids here, so we */
3845 /* exec the real perl, substituting fd script for scriptname. */
3846 /* (We pass script name as "subdir" of fd, which perl will grok.) */
3848 * It might be thought that using setresgid and/or setresuid (changed to
3849 * set the saved IDs) above might obviate the need to exec, and we could
3850 * go on to "do the perl thing".
3852 * Is there such a thing as "saved GID", and is that set for setuid (but
3853 * not setgid) execution like suidperl? Without exec, it would not be
3854 * cleared for setuid (but not setgid) scripts (or might need a dummy
3857 * We need suidperl to do the exact same argument checking that perl
3858 * does. Thus it cannot be very small; while it could be significantly
3859 * smaller, it is safer (simpler?) to make it essentially the same
3860 * binary as perl (but they are not identical). - Maybe could defer that
3861 * check to the invoked perl, and suidperl be a tiny wrapper instead;
3862 * but prefer to do thorough checks in suidperl itself. Such deferral
3863 * would make suidperl security rely on perl, a design no-no.
3865 * Setuid things should be short and simple, thus easy to understand and
3866 * verify. They should do their "own thing", without influence by
3867 * attackers. It may help if their internal execution flow is fixed,
3868 * regardless of platform: it may be best to exec anyway.
3870 * Suidperl should at least be conceptually simple: a wrapper only,
3871 * never to do any real perl. Maybe we should put
3873 * Perl_croak(aTHX_ "Suidperl should never do real perl\n");
3875 * into the perly bits.
3877 PerlIO_rewind(PL_rsfp);
3878 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
3880 * Keep original arguments: suidperl already has fd script.
3882 /* for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ; */
3883 /* if (!PL_origargv[which]) { */
3884 /* errno = EPERM; */
3885 /* Perl_croak(aTHX_ "Permission denied\n"); */
3887 /* PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s", */
3888 /* PerlIO_fileno(PL_rsfp), PL_origargv[which])); */
3889 #if defined(HAS_FCNTL) && defined(F_SETFD)
3890 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
3893 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
3894 (int)PERL_REVISION, (int)PERL_VERSION,
3895 (int)PERL_SUBVERSION), PL_origargv);/* try again */
3897 Perl_croak(aTHX_ "Can't do setuid (suidperl cannot exec perl)\n");
3898 #endif /* IAMSUID */
3900 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
3901 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
3902 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
3903 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
3905 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
3908 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3909 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3910 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3911 /* not set-id, must be wrapped */
3919 S_find_beginning(pTHX)
3922 register const char *s2;
3923 #ifdef MACOS_TRADITIONAL
3927 /* skip forward in input to the real script? */
3930 #ifdef MACOS_TRADITIONAL
3931 /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
3933 while (PL_doextract || gMacPerl_AlwaysExtract) {
3934 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3935 if (!gMacPerl_AlwaysExtract)
3936 Perl_croak(aTHX_ "No Perl script found in input\n");
3938 if (PL_doextract) /* require explicit override ? */
3939 if (!OverrideExtract(PL_origfilename))
3940 Perl_croak(aTHX_ "User aborted script\n");
3942 PL_doextract = FALSE;
3944 /* Pater peccavi, file does not have #! */
3945 PerlIO_rewind(PL_rsfp);
3950 while (PL_doextract) {
3951 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
3952 Perl_croak(aTHX_ "No Perl script found in input\n");
3955 if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3956 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
3957 PL_doextract = FALSE;
3958 while (*s && !(isSPACE (*s) || *s == '#')) s++;
3960 while (*s == ' ' || *s == '\t') s++;
3962 while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
3963 || s2[-1] == '_') s2--;
3964 if (strnEQ(s2-4,"perl",4))
3965 while ((s = moreswitches(s)))
3968 #ifdef MACOS_TRADITIONAL
3969 /* We are always searching for the #!perl line in MacPerl,
3970 * so if we find it, still keep the line count correct
3971 * by counting lines we already skipped over
3973 for (; maclines > 0 ; maclines--)
3974 PerlIO_ungetc(PL_rsfp, '\n');
3978 /* gMacPerl_AlwaysExtract is false in MPW tool */
3979 } else if (gMacPerl_AlwaysExtract) {
3990 PL_uid = PerlProc_getuid();
3991 PL_euid = PerlProc_geteuid();
3992 PL_gid = PerlProc_getgid();
3993 PL_egid = PerlProc_getegid();
3995 PL_uid |= PL_gid << 16;
3996 PL_euid |= PL_egid << 16;
3998 /* Should not happen: */
3999 CHECK_MALLOC_TAINT(PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
4000 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
4003 * Should go by suidscript, not uid!=euid: why disallow
4004 * system("ls") in scripts run from setuid things?
4005 * Or, is this run before we check arguments and set suidscript?
4006 * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
4007 * (We never have suidscript, can we be sure to have fdscript?)
4008 * Or must then go by UID checks? See comments in forbid_setid also.
4012 /* This is used very early in the lifetime of the program,
4013 * before even the options are parsed, so PL_tainting has
4014 * not been initialized properly. */
4016 Perl_doing_taint(int argc, char *argv[], char *envp[])
4018 #ifndef PERL_IMPLICIT_SYS
4019 /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
4020 * before we have an interpreter-- and the whole point of this
4021 * function is to be called at such an early stage. If you are on
4022 * a system with PERL_IMPLICIT_SYS but you do have a concept of
4023 * "tainted because running with altered effective ids', you'll
4024 * have to add your own checks somewhere in here. The two most
4025 * known samples of 'implicitness' are Win32 and NetWare, neither
4026 * of which has much of concept of 'uids'. */
4027 int uid = PerlProc_getuid();
4028 int euid = PerlProc_geteuid();
4029 int gid = PerlProc_getgid();
4030 int egid = PerlProc_getegid();
4037 if (uid && (euid != uid || egid != gid))
4039 #endif /* !PERL_IMPLICIT_SYS */
4040 /* This is a really primitive check; environment gets ignored only
4041 * if -T are the first chars together; otherwise one gets
4042 * "Too late" message. */
4043 if ( argc > 1 && argv[1][0] == '-'
4044 && (argv[1][1] == 't' || argv[1][1] == 'T') )
4050 S_forbid_setid(pTHX_ const char *s)
4052 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
4053 if (PL_euid != PL_uid)
4054 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
4055 if (PL_egid != PL_gid)
4056 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
4057 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4059 * Checks for UID/GID above "wrong": why disallow
4060 * perl -e 'print "Hello\n"'
4061 * from within setuid things?? Simply drop them: replaced by
4062 * fdscript/suidscript and #ifdef IAMSUID checks below.
4064 * This may be too late for command-line switches. Will catch those on
4065 * the #! line, after finding the script name and setting up
4066 * fdscript/suidscript. Note that suidperl does not get around to
4067 * parsing (and checking) the switches on the #! line, but checks that
4068 * the two sets are identical.
4070 * With SETUID_SCRIPTS_ARE_SECURE_NOW, could we use fdscript, also or
4071 * instead, or would that be "too late"? (We never have suidscript, can
4072 * we be sure to have fdscript?)
4074 * Catch things with suidscript (in descendant of suidperl), even with
4075 * right UID/GID. Was already checked in suidperl, with #ifdef IAMSUID,
4076 * below; but I am paranoid.
4078 * Also see comments about root running a setuid script, elsewhere.
4080 if (PL_suidscript >= 0)
4081 Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", s);
4083 /* PSz 11 Nov 03 Catch it in suidperl, always! */
4084 Perl_croak(aTHX_ "No %s allowed in suidperl", s);
4085 #endif /* IAMSUID */
4089 Perl_init_debugger(pTHX)
4091 HV *ostash = PL_curstash;
4093 PL_curstash = PL_debstash;
4094 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("DB::args", GV_ADDMULTI, SVt_PVAV))));
4095 AvREAL_off(PL_dbargs);
4096 PL_DBgv = gv_fetchpv("DB::DB", GV_ADDMULTI, SVt_PVGV);
4097 PL_DBline = gv_fetchpv("DB::dbline", GV_ADDMULTI, SVt_PVAV);
4098 PL_DBsub = gv_HVadd(gv_fetchpv("DB::sub", GV_ADDMULTI, SVt_PVHV));
4099 PL_DBsingle = GvSV((gv_fetchpv("DB::single", GV_ADDMULTI, SVt_PV)));
4100 sv_setiv(PL_DBsingle, 0);
4101 PL_DBtrace = GvSV((gv_fetchpv("DB::trace", GV_ADDMULTI, SVt_PV)));
4102 sv_setiv(PL_DBtrace, 0);
4103 PL_DBsignal = GvSV((gv_fetchpv("DB::signal", GV_ADDMULTI, SVt_PV)));
4104 sv_setiv(PL_DBsignal, 0);
4105 PL_DBassertion = GvSV((gv_fetchpv("DB::assertion", GV_ADDMULTI, SVt_PV)));
4106 sv_setiv(PL_DBassertion, 0);
4107 PL_curstash = ostash;
4110 #ifndef STRESS_REALLOC
4111 #define REASONABLE(size) (size)
4113 #define REASONABLE(size) (1) /* unreasonable */
4117 Perl_init_stacks(pTHX)
4119 /* start with 128-item stack and 8K cxstack */
4120 PL_curstackinfo = new_stackinfo(REASONABLE(128),
4121 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
4122 PL_curstackinfo->si_type = PERLSI_MAIN;
4123 PL_curstack = PL_curstackinfo->si_stack;
4124 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
4126 PL_stack_base = AvARRAY(PL_curstack);
4127 PL_stack_sp = PL_stack_base;
4128 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
4130 New(50,PL_tmps_stack,REASONABLE(128),SV*);
4133 PL_tmps_max = REASONABLE(128);
4135 New(54,PL_markstack,REASONABLE(32),I32);
4136 PL_markstack_ptr = PL_markstack;
4137 PL_markstack_max = PL_markstack + REASONABLE(32);
4141 New(54,PL_scopestack,REASONABLE(32),I32);
4142 PL_scopestack_ix = 0;
4143 PL_scopestack_max = REASONABLE(32);
4145 New(54,PL_savestack,REASONABLE(128),ANY);
4146 PL_savestack_ix = 0;
4147 PL_savestack_max = REASONABLE(128);
4155 while (PL_curstackinfo->si_next)
4156 PL_curstackinfo = PL_curstackinfo->si_next;
4157 while (PL_curstackinfo) {
4158 PERL_SI *p = PL_curstackinfo->si_prev;
4159 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
4160 Safefree(PL_curstackinfo->si_cxstack);
4161 Safefree(PL_curstackinfo);
4162 PL_curstackinfo = p;
4164 Safefree(PL_tmps_stack);
4165 Safefree(PL_markstack);
4166 Safefree(PL_scopestack);
4167 Safefree(PL_savestack);
4176 lex_start(PL_linestr);
4178 PL_subname = newSVpvn("main",4);
4182 S_init_predump_symbols(pTHX)
4187 sv_setpvn(get_sv("\"", TRUE), " ", 1);
4188 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
4189 GvMULTI_on(PL_stdingv);
4190 io = GvIOp(PL_stdingv);
4191 IoTYPE(io) = IoTYPE_RDONLY;
4192 IoIFP(io) = PerlIO_stdin();
4193 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
4195 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
4197 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
4200 IoTYPE(io) = IoTYPE_WRONLY;
4201 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4203 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
4205 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
4207 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
4208 GvMULTI_on(PL_stderrgv);
4209 io = GvIOp(PL_stderrgv);
4210 IoTYPE(io) = IoTYPE_WRONLY;
4211 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
4212 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
4214 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
4216 PL_statname = NEWSV(66,0); /* last filename we did stat on */
4219 Safefree(PL_osname);
4220 PL_osname = savepv(OSNAME);
4224 Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
4227 argc--,argv++; /* skip name of script */
4228 if (PL_doswitches) {
4229 for (; argc > 0 && **argv == '-'; argc--,argv++) {
4232 if (argv[0][1] == '-' && !argv[0][2]) {
4236 if ((s = strchr(argv[0], '='))) {
4238 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
4241 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
4244 if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
4245 GvMULTI_on(PL_argvgv);
4246 (void)gv_AVadd(PL_argvgv);
4247 av_clear(GvAVn(PL_argvgv));
4248 for (; argc > 0; argc--,argv++) {
4249 SV *sv = newSVpv(argv[0],0);
4250 av_push(GvAVn(PL_argvgv),sv);
4251 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
4252 if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
4255 if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
4256 (void)sv_utf8_decode(sv);
4262 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
4267 PL_toptarget = NEWSV(0,0);
4268 sv_upgrade(PL_toptarget, SVt_PVFM);
4269 sv_setpvn(PL_toptarget, "", 0);
4270 PL_bodytarget = NEWSV(0,0);
4271 sv_upgrade(PL_bodytarget, SVt_PVFM);
4272 sv_setpvn(PL_bodytarget, "", 0);
4273 PL_formtarget = PL_bodytarget;
4277 init_argv_symbols(argc,argv);
4279 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
4280 #ifdef MACOS_TRADITIONAL
4281 /* $0 is not majick on a Mac */
4282 sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
4284 sv_setpv(GvSV(tmpgv),PL_origfilename);
4285 magicname("0", "0", 1);
4288 if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
4290 GvMULTI_on(PL_envgv);
4291 hv = GvHVn(PL_envgv);
4292 hv_magic(hv, Nullgv, PERL_MAGIC_env);
4294 #ifdef USE_ENVIRON_ARRAY
4295 /* Note that if the supplied env parameter is actually a copy
4296 of the global environ then it may now point to free'd memory
4297 if the environment has been modified since. To avoid this
4298 problem we treat env==NULL as meaning 'use the default'
4303 # ifdef USE_ITHREADS
4304 && PL_curinterp == aTHX
4308 environ[0] = Nullch;
4311 char** origenv = environ;
4314 for (; *env; env++) {
4315 if (!(s = strchr(*env,'=')) || s == *env)
4317 #if defined(MSDOS) && !defined(DJGPP)
4322 sv = newSVpv(s+1, 0);
4323 (void)hv_store(hv, *env, s - *env, sv, 0);
4326 if (origenv != environ) {
4327 /* realloc has shifted us */
4328 env = (env - origenv) + environ;
4333 #endif /* USE_ENVIRON_ARRAY */
4334 #endif /* !PERL_MICRO */
4337 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
4338 SvREADONLY_off(GvSV(tmpgv));
4339 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
4340 SvREADONLY_on(GvSV(tmpgv));
4342 #ifdef THREADS_HAVE_PIDS
4343 PL_ppid = (IV)getppid();
4346 /* touch @F array to prevent spurious warnings 20020415 MJD */
4348 (void) get_av("main::F", TRUE | GV_ADDMULTI);
4350 /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */
4351 (void) get_av("main::-", TRUE | GV_ADDMULTI);
4352 (void) get_av("main::+", TRUE | GV_ADDMULTI);
4356 S_init_perllib(pTHX)
4361 s = PerlEnv_getenv("PERL5LIB");
4363 incpush(s, TRUE, TRUE, TRUE, FALSE);
4365 incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE, FALSE);
4367 /* Treat PERL5?LIB as a possible search list logical name -- the
4368 * "natural" VMS idiom for a Unix path string. We allow each
4369 * element to be a set of |-separated directories for compatibility.
4373 if (my_trnlnm("PERL5LIB",buf,0))
4374 do { incpush(buf,TRUE,TRUE,TRUE,FALSE); } while (my_trnlnm("PERL5LIB",buf,++idx));
4376 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE,TRUE,FALSE);
4380 /* Use the ~-expanded versions of APPLLIB (undocumented),
4381 ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
4384 incpush(APPLLIB_EXP, TRUE, TRUE, TRUE, TRUE);
4388 incpush(ARCHLIB_EXP, FALSE, FALSE, TRUE, TRUE);
4390 #ifdef MACOS_TRADITIONAL
4393 SV * privdir = NEWSV(55, 0);
4394 char * macperl = PerlEnv_getenv("MACPERL");
4399 Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
4400 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
4401 incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE);
4402 Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
4403 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
4404 incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE);
4406 SvREFCNT_dec(privdir);
4409 incpush(":", FALSE, FALSE, TRUE, FALSE);
4412 # define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
4415 incpush(PRIVLIB_EXP, TRUE, FALSE, TRUE, TRUE);
4417 incpush(PRIVLIB_EXP, FALSE, FALSE, TRUE, TRUE);
4421 /* sitearch is always relative to sitelib on Windows for
4422 * DLL-based path intuition to work correctly */
4423 # if !defined(WIN32)
4424 incpush(SITEARCH_EXP, FALSE, FALSE, TRUE, TRUE);
4430 /* this picks up sitearch as well */
4431 incpush(SITELIB_EXP, TRUE, FALSE, TRUE, TRUE);
4433 incpush(SITELIB_EXP, FALSE, FALSE, TRUE, TRUE);
4437 #ifdef SITELIB_STEM /* Search for version-specific dirs below here */
4438 incpush(SITELIB_STEM, FALSE, TRUE, TRUE, TRUE);
4441 #ifdef PERL_VENDORARCH_EXP
4442 /* vendorarch is always relative to vendorlib on Windows for
4443 * DLL-based path intuition to work correctly */
4444 # if !defined(WIN32)
4445 incpush(PERL_VENDORARCH_EXP, FALSE, FALSE, TRUE, TRUE);
4449 #ifdef PERL_VENDORLIB_EXP
4451 incpush(PERL_VENDORLIB_EXP, TRUE, FALSE, TRUE, TRUE); /* this picks up vendorarch as well */
4453 incpush(PERL_VENDORLIB_EXP, FALSE, FALSE, TRUE, TRUE);
4457 #ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
4458 incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE, TRUE);
4461 #ifdef PERL_OTHERLIBDIRS
4462 incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE, TRUE);
4466 incpush(".", FALSE, FALSE, TRUE, FALSE);
4467 #endif /* MACOS_TRADITIONAL */
4470 #if defined(DOSISH) || defined(EPOC) || defined(SYMBIAN)
4471 # define PERLLIB_SEP ';'
4474 # define PERLLIB_SEP '|'
4476 # if defined(MACOS_TRADITIONAL)
4477 # define PERLLIB_SEP ','
4479 # define PERLLIB_SEP ':'
4483 #ifndef PERLLIB_MANGLE
4484 # define PERLLIB_MANGLE(s,n) (s)
4487 /* Push a directory onto @INC if it exists.
4488 Generate a new SV if we do this, to save needing to copy the SV we push
4491 S_incpush_if_exists(pTHX_ SV *dir)
4494 if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
4495 S_ISDIR(tmpstatbuf.st_mode)) {
4496 av_push(GvAVn(PL_incgv), dir);
4503 S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep,
4506 SV *subdir = Nullsv;
4507 const char *p = dir;
4512 if (addsubdirs || addoldvers) {
4513 subdir = NEWSV(0,0);
4516 /* Break at all separators */
4518 SV *libdir = NEWSV(55,0);
4521 /* skip any consecutive separators */
4523 while ( *p == PERLLIB_SEP ) {
4524 /* Uncomment the next line for PATH semantics */
4525 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
4530 if ( usesep && (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
4531 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
4536 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
4537 p = Nullch; /* break out */
4539 #ifdef MACOS_TRADITIONAL
4540 if (!strchr(SvPVX(libdir), ':')) {
4543 sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
4545 if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
4546 sv_catpv(libdir, ":");
4549 /* Do the if() outside the #ifdef to avoid warnings about an unused
4552 #ifdef PERL_RELOCATABLE_INC
4554 * Relocatable include entries are marked with a leading .../
4557 * 0: Remove that leading ".../"
4558 * 1: Remove trailing executable name (anything after the last '/')
4559 * from the perl path to give a perl prefix
4561 * While the @INC element starts "../" and the prefix ends with a real
4562 * directory (ie not . or ..) chop that real directory off the prefix
4563 * and the leading "../" from the @INC element. ie a logical "../"
4565 * Finally concatenate the prefix and the remainder of the @INC element
4566 * The intent is that /usr/local/bin/perl and .../../lib/perl5
4567 * generates /usr/local/lib/perl5
4569 char *libpath = SvPVX(libdir);
4570 STRLEN libpath_len = SvCUR(libdir);
4571 if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) {
4573 SV *caret_X = get_sv("\030", 0);
4574 /* Going to use the SV just as a scratch buffer holding a C
4580 /* $^X is *the* source of taint if tainting is on, hence
4581 SvPOK() won't be true. */
4583 assert(SvPOKp(caret_X));
4584 prefix_sv = newSVpvn(SvPVX(caret_X), SvCUR(caret_X));
4585 /* Firstly take off the leading .../
4586 If all else fail we'll do the paths relative to the current
4588 sv_chop(libdir, libpath + 4);
4589 /* Don't use SvPV as we're intentionally bypassing taining,
4590 mortal copies that the mg_get of tainting creates, and
4591 corruption that seems to come via the save stack.
4592 I guess that the save stack isn't correctly set up yet. */
4593 libpath = SvPVX(libdir);
4594 libpath_len = SvCUR(libdir);
4596 /* This would work more efficiently with memrchr, but as it's
4597 only a GNU extension we'd need to probe for it and
4598 implement our own. Not hard, but maybe not worth it? */
4600 prefix = SvPVX(prefix_sv);
4601 lastslash = strrchr(prefix, '/');
4603 /* First time in with the *lastslash = '\0' we just wipe off
4604 the trailing /perl from (say) /usr/foo/bin/perl
4608 while ((*lastslash = '\0'), /* Do that, come what may. */
4609 (libpath_len >= 3 && memEQ(libpath, "../", 3)
4610 && (lastslash = strrchr(prefix, '/')))) {
4611 if (lastslash[1] == '\0'
4612 || (lastslash[1] == '.'
4613 && (lastslash[2] == '/' /* ends "/." */
4614 || (lastslash[2] == '/'
4615 && lastslash[3] == '/' /* or "/.." */
4617 /* Prefix ends "/" or "/." or "/..", any of which
4618 are fishy, so don't do any more logical cleanup.
4622 /* Remove leading "../" from path */
4625 /* Next iteration round the loop removes the last
4626 directory name from prefix by writing a '\0' in
4627 the while clause. */
4629 /* prefix has been terminated with a '\0' to the correct
4630 length. libpath points somewhere into the libdir SV.
4631 We need to join the 2 with '/' and drop the result into
4633 tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath);
4634 SvREFCNT_dec(libdir);
4635 /* And this is the new libdir. */
4638 (PL_uid != PL_euid || PL_gid != PL_egid)) {
4639 /* Need to taint reloccated paths if running set ID */
4640 SvTAINTED_on(libdir);
4643 SvREFCNT_dec(prefix_sv);
4648 * BEFORE pushing libdir onto @INC we may first push version- and
4649 * archname-specific sub-directories.
4651 if (addsubdirs || addoldvers) {
4652 #ifdef PERL_INC_VERSION_LIST
4653 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
4654 const char *incverlist[] = { PERL_INC_VERSION_LIST };
4655 const char **incver;
4661 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
4663 while (unix[len-1] == '/') len--; /* Cosmetic */
4664 sv_usepvn(libdir,unix,len);
4667 PerlIO_printf(Perl_error_log,
4668 "Failed to unixify @INC element \"%s\"\n",
4672 #ifdef MACOS_TRADITIONAL
4673 #define PERL_AV_SUFFIX_FMT ""
4674 #define PERL_ARCH_FMT "%s:"
4675 #define PERL_ARCH_FMT_PATH PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
4677 #define PERL_AV_SUFFIX_FMT "/"
4678 #define PERL_ARCH_FMT "/%s"
4679 #define PERL_ARCH_FMT_PATH PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
4681 /* .../version/archname if -d .../version/archname */
4682 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
4684 (int)PERL_REVISION, (int)PERL_VERSION,
4685 (int)PERL_SUBVERSION, ARCHNAME);
4686 subdir = S_incpush_if_exists(aTHX_ subdir);
4688 /* .../version if -d .../version */
4689 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
4690 (int)PERL_REVISION, (int)PERL_VERSION,
4691 (int)PERL_SUBVERSION);
4692 subdir = S_incpush_if_exists(aTHX_ subdir);
4694 /* .../archname if -d .../archname */
4695 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
4696 subdir = S_incpush_if_exists(aTHX_ subdir);
4700 #ifdef PERL_INC_VERSION_LIST
4702 for (incver = incverlist; *incver; incver++) {
4703 /* .../xxx if -d .../xxx */
4704 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
4705 subdir = S_incpush_if_exists(aTHX_ subdir);
4711 /* finally push this lib directory on the end of @INC */
4712 av_push(GvAVn(PL_incgv), libdir);
4715 assert (SvREFCNT(subdir) == 1);
4716 SvREFCNT_dec(subdir);
4720 #ifdef USE_5005THREADS
4721 STATIC struct perl_thread *
4722 S_init_main_thread(pTHX)
4724 #if !defined(PERL_IMPLICIT_CONTEXT)
4725 struct perl_thread *thr;
4729 Newz(53, thr, 1, struct perl_thread);
4730 PL_curcop = &PL_compiling;
4731 thr->interp = PERL_GET_INTERP;
4732 thr->cvcache = newHV();
4733 thr->threadsv = newAV();
4734 /* thr->threadsvp is set when find_threadsv is called */
4735 thr->specific = newAV();
4736 thr->flags = THRf_R_JOINABLE;
4737 MUTEX_INIT(&thr->mutex);
4738 /* Handcraft thrsv similarly to mess_sv */
4739 New(53, PL_thrsv, 1, SV);
4740 Newz(53, xpv, 1, XPV);
4741 SvFLAGS(PL_thrsv) = SVt_PV;
4742 SvANY(PL_thrsv) = (void*)xpv;
4743 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
4744 SvPV_set(PL_thrsvr, (char*)thr);
4745 SvCUR_set(PL_thrsv, sizeof(thr));
4746 SvLEN_set(PL_thrsv, sizeof(thr));
4747 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
4748 thr->oursv = PL_thrsv;
4749 PL_chopset = " \n-";
4752 MUTEX_LOCK(&PL_threads_mutex);
4758 MUTEX_UNLOCK(&PL_threads_mutex);
4760 #ifdef HAVE_THREAD_INTERN
4761 Perl_init_thread_intern(thr);
4764 #ifdef SET_THREAD_SELF
4765 SET_THREAD_SELF(thr);
4767 thr->self = pthread_self();
4768 #endif /* SET_THREAD_SELF */
4772 * These must come after the thread self setting
4773 * because sv_setpvn does SvTAINT and the taint
4774 * fields thread selfness being set.
4776 PL_toptarget = NEWSV(0,0);
4777 sv_upgrade(PL_toptarget, SVt_PVFM);
4778 sv_setpvn(PL_toptarget, "", 0);
4779 PL_bodytarget = NEWSV(0,0);
4780 sv_upgrade(PL_bodytarget, SVt_PVFM);
4781 sv_setpvn(PL_bodytarget, "", 0);
4782 PL_formtarget = PL_bodytarget;
4783 thr->errsv = newSVpvn("", 0);
4784 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
4787 PL_peepp = MEMBER_TO_FPTR(Perl_peep);
4788 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
4789 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
4790 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
4791 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
4792 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
4794 PL_reginterp_cnt = 0;
4798 #endif /* USE_5005THREADS */
4801 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
4805 const line_t oldline = CopLINE(PL_curcop);
4811 while (av_len(paramList) >= 0) {
4812 cv = (CV*)av_shift(paramList);
4814 if (paramList == PL_beginav) {
4815 /* save PL_beginav for compiler */
4816 if (! PL_beginav_save)
4817 PL_beginav_save = newAV();
4818 av_push(PL_beginav_save, (SV*)cv);
4820 else if (paramList == PL_checkav) {
4821 /* save PL_checkav for compiler */
4822 if (! PL_checkav_save)
4823 PL_checkav_save = newAV();
4824 av_push(PL_checkav_save, (SV*)cv);
4834 (void)SvPV_const(atsv, len);
4836 PL_curcop = &PL_compiling;
4837 CopLINE_set(PL_curcop, oldline);
4838 if (paramList == PL_beginav)
4839 sv_catpv(atsv, "BEGIN failed--compilation aborted");
4841 Perl_sv_catpvf(aTHX_ atsv,
4842 "%s failed--call queue aborted",
4843 paramList == PL_checkav ? "CHECK"
4844 : paramList == PL_initav ? "INIT"
4846 while (PL_scopestack_ix > oldscope)
4849 Perl_croak(aTHX_ "%"SVf"", atsv);
4856 /* my_exit() was called */
4857 while (PL_scopestack_ix > oldscope)
4860 PL_curstash = PL_defstash;
4861 PL_curcop = &PL_compiling;
4862 CopLINE_set(PL_curcop, oldline);
4864 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
4865 if (paramList == PL_beginav)
4866 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
4868 Perl_croak(aTHX_ "%s failed--call queue aborted",
4869 paramList == PL_checkav ? "CHECK"
4870 : paramList == PL_initav ? "INIT"
4877 PL_curcop = &PL_compiling;
4878 CopLINE_set(PL_curcop, oldline);
4881 PerlIO_printf(Perl_error_log, "panic: restartop\n");
4890 S_call_list_body(pTHX_ CV *cv)
4892 PUSHMARK(PL_stack_sp);
4893 call_sv((SV*)cv, G_EVAL|G_DISCARD);
4898 Perl_my_exit(pTHX_ U32 status)
4900 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
4901 thr, (unsigned long) status));
4910 STATUS_NATIVE_SET(status);
4917 Perl_my_failure_exit(pTHX)
4920 if (vaxc$errno & 1) {
4921 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
4922 STATUS_NATIVE_SET(44);
4925 if (!vaxc$errno) /* unlikely */
4926 STATUS_NATIVE_SET(44);
4928 STATUS_NATIVE_SET(vaxc$errno);
4933 STATUS_UNIX_SET(errno);
4935 exitstatus = STATUS_UNIX >> 8;
4936 if (exitstatus & 255)
4937 STATUS_UNIX_SET(exitstatus);
4939 STATUS_UNIX_SET(255);
4946 S_my_exit_jump(pTHX)
4949 register PERL_CONTEXT *cx;
4954 SvREFCNT_dec(PL_e_script);
4955 PL_e_script = Nullsv;
4958 POPSTACK_TO(PL_mainstack);
4959 if (cxstack_ix >= 0) {
4962 POPBLOCK(cx,PL_curpm);
4970 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
4976 p = SvPVX_const(PL_e_script);
4977 nl = strchr(p, '\n');
4978 nl = (nl) ? nl+1 : SvEND(PL_e_script);
4980 filter_del(read_e_script);
4983 sv_catpvn(buf_sv, p, nl-p);
4984 sv_chop(PL_e_script, nl);
4990 * c-indentation-style: bsd
4992 * indent-tabs-mode: t
4995 * ex: set ts=8 sts=4 sw=4 noet: