3 * Copyright (c) 1987-2000 Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
15 #define PERL_IN_PERL_C
17 #include "patchlevel.h" /* for local_patches */
19 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
24 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
25 char *getenv (char *); /* Usually in <stdlib.h> */
28 static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen);
43 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
50 #define perl_construct Perl_construct
51 #define perl_parse Perl_parse
52 #define perl_run Perl_run
53 #define perl_destruct Perl_destruct
54 #define perl_free Perl_free
57 #ifdef PERL_IMPLICIT_SYS
59 perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
60 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
61 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
62 struct IPerlDir* ipD, struct IPerlSock* ipS,
63 struct IPerlProc* ipP)
65 PerlInterpreter *my_perl;
67 my_perl = (PerlInterpreter*)new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd,
68 ipLIO, ipD, ipS, ipP);
69 PERL_SET_INTERP(my_perl);
71 /* New() needs interpreter, so call malloc() instead */
72 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
73 PERL_SET_INTERP(my_perl);
74 Zero(my_perl, 1, PerlInterpreter);
91 =for apidoc perl_alloc
93 Allocates a new Perl interpreter. See L<perlembed>.
101 PerlInterpreter *my_perl;
103 /* New() needs interpreter, so call malloc() instead */
104 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
105 PERL_SET_INTERP(my_perl);
106 Zero(my_perl, 1, PerlInterpreter);
109 #endif /* PERL_IMPLICIT_SYS */
112 =for apidoc perl_construct
114 Initializes a new Perl interpreter. See L<perlembed>.
120 perl_construct(pTHXx)
125 struct perl_thread *thr = NULL;
126 #endif /* FAKE_THREADS */
127 #endif /* USE_THREADS */
131 PL_perl_destruct_level = 1;
133 if (PL_perl_destruct_level > 0)
137 /* Init the real globals (and main thread)? */
141 #ifdef ALLOC_THREAD_KEY
144 if (pthread_key_create(&PL_thr_key, 0))
145 Perl_croak(aTHX_ "panic: pthread_key_create");
147 MUTEX_INIT(&PL_sv_mutex);
149 * Safe to use basic SV functions from now on (though
150 * not things like mortals or tainting yet).
152 MUTEX_INIT(&PL_eval_mutex);
153 COND_INIT(&PL_eval_cond);
154 MUTEX_INIT(&PL_threads_mutex);
155 COND_INIT(&PL_nthreads_cond);
156 #ifdef EMULATE_ATOMIC_REFCOUNTS
157 MUTEX_INIT(&PL_svref_mutex);
158 #endif /* EMULATE_ATOMIC_REFCOUNTS */
160 MUTEX_INIT(&PL_cred_mutex);
162 thr = init_main_thread();
163 #endif /* USE_THREADS */
165 PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
167 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
169 PL_linestr = NEWSV(65,79);
170 sv_upgrade(PL_linestr,SVt_PVIV);
172 if (!SvREADONLY(&PL_sv_undef)) {
173 /* set read-only and try to insure than we wont see REFCNT==0
176 SvREADONLY_on(&PL_sv_undef);
177 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
179 sv_setpv(&PL_sv_no,PL_No);
181 SvREADONLY_on(&PL_sv_no);
182 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
184 sv_setpv(&PL_sv_yes,PL_Yes);
186 SvREADONLY_on(&PL_sv_yes);
187 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
192 /* PL_sighandlerp = sighandler; */
194 PL_sighandlerp = Perl_sighandler;
196 PL_pidstatus = newHV();
200 * There is no way we can refer to them from Perl so close them to save
201 * space. The other alternative would be to provide STDAUX and STDPRN
204 (void)fclose(stdaux);
205 (void)fclose(stdprn);
209 PL_nrs = newSVpvn("\n", 1);
210 PL_rs = SvREFCNT_inc(PL_nrs);
215 PL_lex_state = LEX_NOTPARSING;
221 SET_NUMERIC_STANDARD();
225 PL_patchlevel = NEWSV(0,4);
226 SvUPGRADE(PL_patchlevel, SVt_PVNV);
227 if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
228 SvGROW(PL_patchlevel,24);
229 s = (U8*)SvPVX(PL_patchlevel);
230 s = uv_to_utf8(s, (UV)PERL_REVISION);
231 s = uv_to_utf8(s, (UV)PERL_VERSION);
232 s = uv_to_utf8(s, (UV)PERL_SUBVERSION);
234 SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel));
235 SvPOK_on(PL_patchlevel);
236 SvNVX(PL_patchlevel) = (NV)PERL_REVISION
237 + ((NV)PERL_VERSION / (NV)1000)
238 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
239 + ((NV)PERL_SUBVERSION / (NV)1000000)
242 SvNOK_on(PL_patchlevel); /* dual valued */
243 SvUTF8_on(PL_patchlevel);
244 SvREADONLY_on(PL_patchlevel);
247 #if defined(LOCAL_PATCH_COUNT)
248 PL_localpatches = local_patches; /* For possible -v */
251 PerlIO_init(); /* Hook to IO system */
253 PL_fdpid = newAV(); /* for remembering popen pids by fd */
254 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
260 =for apidoc perl_destruct
262 Shuts down a Perl interpreter. See L<perlembed>.
271 int destruct_level; /* 0=none, 1=full, 2=full with checks */
277 #endif /* USE_THREADS */
279 /* wait for all pseudo-forked children to finish */
280 PERL_WAIT_FOR_CHILDREN;
284 /* Pass 1 on any remaining threads: detach joinables, join zombies */
286 MUTEX_LOCK(&PL_threads_mutex);
287 DEBUG_S(PerlIO_printf(Perl_debug_log,
288 "perl_destruct: waiting for %d threads...\n",
290 for (t = thr->next; t != thr; t = t->next) {
291 MUTEX_LOCK(&t->mutex);
292 switch (ThrSTATE(t)) {
295 DEBUG_S(PerlIO_printf(Perl_debug_log,
296 "perl_destruct: joining zombie %p\n", t));
297 ThrSETSTATE(t, THRf_DEAD);
298 MUTEX_UNLOCK(&t->mutex);
301 * The SvREFCNT_dec below may take a long time (e.g. av
302 * may contain an object scalar whose destructor gets
303 * called) so we have to unlock threads_mutex and start
306 MUTEX_UNLOCK(&PL_threads_mutex);
308 SvREFCNT_dec((SV*)av);
309 DEBUG_S(PerlIO_printf(Perl_debug_log,
310 "perl_destruct: joined zombie %p OK\n", t));
312 case THRf_R_JOINABLE:
313 DEBUG_S(PerlIO_printf(Perl_debug_log,
314 "perl_destruct: detaching thread %p\n", t));
315 ThrSETSTATE(t, THRf_R_DETACHED);
317 * We unlock threads_mutex and t->mutex in the opposite order
318 * from which we locked them just so that DETACH won't
319 * deadlock if it panics. It's only a breach of good style
320 * not a bug since they are unlocks not locks.
322 MUTEX_UNLOCK(&PL_threads_mutex);
324 MUTEX_UNLOCK(&t->mutex);
327 DEBUG_S(PerlIO_printf(Perl_debug_log,
328 "perl_destruct: ignoring %p (state %u)\n",
330 MUTEX_UNLOCK(&t->mutex);
331 /* fall through and out */
334 /* We leave the above "Pass 1" loop with threads_mutex still locked */
336 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
337 while (PL_nthreads > 1)
339 DEBUG_S(PerlIO_printf(Perl_debug_log,
340 "perl_destruct: final wait for %d threads\n",
342 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
344 /* At this point, we're the last thread */
345 MUTEX_UNLOCK(&PL_threads_mutex);
346 DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
347 MUTEX_DESTROY(&PL_threads_mutex);
348 COND_DESTROY(&PL_nthreads_cond);
349 #endif /* !defined(FAKE_THREADS) */
350 #endif /* USE_THREADS */
352 destruct_level = PL_perl_destruct_level;
356 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
358 if (destruct_level < i)
367 /* We must account for everything. */
369 /* Destroy the main CV and syntax tree */
371 PL_curpad = AvARRAY(PL_comppad);
372 op_free(PL_main_root);
373 PL_main_root = Nullop;
375 PL_curcop = &PL_compiling;
376 PL_main_start = Nullop;
377 SvREFCNT_dec(PL_main_cv);
381 if (PL_sv_objcount) {
383 * Try to destruct global references. We do this first so that the
384 * destructors and destructees still exist. Some sv's might remain.
385 * Non-referenced objects are on their own.
390 /* unhook hooks which will soon be, or use, destroyed data */
391 SvREFCNT_dec(PL_warnhook);
392 PL_warnhook = Nullsv;
393 SvREFCNT_dec(PL_diehook);
396 /* call exit list functions */
397 while (PL_exitlistlen-- > 0)
398 PL_exitlist[PL_exitlistlen].fn(aTHXo_ PL_exitlist[PL_exitlistlen].ptr);
400 Safefree(PL_exitlist);
402 if (destruct_level == 0){
404 DEBUG_P(debprofdump());
406 /* The exit() function will do everything that needs doing. */
410 /* loosen bonds of global variables */
413 (void)PerlIO_close(PL_rsfp);
417 /* Filters for program text */
418 SvREFCNT_dec(PL_rsfp_filters);
419 PL_rsfp_filters = Nullav;
422 PL_preprocess = FALSE;
428 PL_doswitches = FALSE;
429 PL_dowarn = G_WARN_OFF;
430 PL_doextract = FALSE;
431 PL_sawampersand = FALSE; /* must save all match strings */
434 Safefree(PL_inplace);
436 SvREFCNT_dec(PL_patchlevel);
439 SvREFCNT_dec(PL_e_script);
440 PL_e_script = Nullsv;
443 /* magical thingies */
445 Safefree(PL_ofs); /* $, */
448 Safefree(PL_ors); /* $\ */
451 SvREFCNT_dec(PL_rs); /* $/ */
454 SvREFCNT_dec(PL_nrs); /* $/ helper */
457 PL_multiline = 0; /* $* */
458 Safefree(PL_osname); /* $^O */
461 SvREFCNT_dec(PL_statname);
462 PL_statname = Nullsv;
465 /* defgv, aka *_ should be taken care of elsewhere */
467 /* clean up after study() */
468 SvREFCNT_dec(PL_lastscream);
469 PL_lastscream = Nullsv;
470 Safefree(PL_screamfirst);
472 Safefree(PL_screamnext);
476 Safefree(PL_efloatbuf);
477 PL_efloatbuf = Nullch;
480 /* startup and shutdown function lists */
481 SvREFCNT_dec(PL_beginav);
482 SvREFCNT_dec(PL_endav);
483 SvREFCNT_dec(PL_checkav);
484 SvREFCNT_dec(PL_initav);
490 /* shortcuts just get cleared */
496 PL_argvoutgv = Nullgv;
498 PL_stderrgv = Nullgv;
499 PL_last_in_gv = Nullgv;
501 PL_debstash = Nullhv;
503 /* reset so print() ends up where we expect */
506 SvREFCNT_dec(PL_argvout_stack);
507 PL_argvout_stack = Nullav;
509 SvREFCNT_dec(PL_modglobal);
510 PL_modglobal = Nullhv;
511 SvREFCNT_dec(PL_preambleav);
512 PL_preambleav = Nullav;
513 SvREFCNT_dec(PL_subname);
515 SvREFCNT_dec(PL_linestr);
517 SvREFCNT_dec(PL_pidstatus);
518 PL_pidstatus = Nullhv;
519 SvREFCNT_dec(PL_toptarget);
520 PL_toptarget = Nullsv;
521 SvREFCNT_dec(PL_bodytarget);
522 PL_bodytarget = Nullsv;
523 PL_formtarget = Nullsv;
525 /* free locale stuff */
526 #ifdef USE_LOCALE_COLLATE
527 Safefree(PL_collation_name);
528 PL_collation_name = Nullch;
531 #ifdef USE_LOCALE_NUMERIC
532 Safefree(PL_numeric_name);
533 PL_numeric_name = Nullch;
536 /* clear utf8 character classes */
537 SvREFCNT_dec(PL_utf8_alnum);
538 SvREFCNT_dec(PL_utf8_alnumc);
539 SvREFCNT_dec(PL_utf8_ascii);
540 SvREFCNT_dec(PL_utf8_alpha);
541 SvREFCNT_dec(PL_utf8_space);
542 SvREFCNT_dec(PL_utf8_cntrl);
543 SvREFCNT_dec(PL_utf8_graph);
544 SvREFCNT_dec(PL_utf8_digit);
545 SvREFCNT_dec(PL_utf8_upper);
546 SvREFCNT_dec(PL_utf8_lower);
547 SvREFCNT_dec(PL_utf8_print);
548 SvREFCNT_dec(PL_utf8_punct);
549 SvREFCNT_dec(PL_utf8_xdigit);
550 SvREFCNT_dec(PL_utf8_mark);
551 SvREFCNT_dec(PL_utf8_toupper);
552 SvREFCNT_dec(PL_utf8_tolower);
553 PL_utf8_alnum = Nullsv;
554 PL_utf8_alnumc = Nullsv;
555 PL_utf8_ascii = Nullsv;
556 PL_utf8_alpha = Nullsv;
557 PL_utf8_space = Nullsv;
558 PL_utf8_cntrl = Nullsv;
559 PL_utf8_graph = Nullsv;
560 PL_utf8_digit = Nullsv;
561 PL_utf8_upper = Nullsv;
562 PL_utf8_lower = Nullsv;
563 PL_utf8_print = Nullsv;
564 PL_utf8_punct = Nullsv;
565 PL_utf8_xdigit = Nullsv;
566 PL_utf8_mark = Nullsv;
567 PL_utf8_toupper = Nullsv;
568 PL_utf8_totitle = Nullsv;
569 PL_utf8_tolower = Nullsv;
571 if (!specialWARN(PL_compiling.cop_warnings))
572 SvREFCNT_dec(PL_compiling.cop_warnings);
573 PL_compiling.cop_warnings = Nullsv;
575 /* Prepare to destruct main symbol table. */
580 SvREFCNT_dec(PL_curstname);
581 PL_curstname = Nullsv;
583 /* clear queued errors */
584 SvREFCNT_dec(PL_errors);
588 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
589 if (PL_scopestack_ix != 0)
590 Perl_warner(aTHX_ WARN_INTERNAL,
591 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
592 (long)PL_scopestack_ix);
593 if (PL_savestack_ix != 0)
594 Perl_warner(aTHX_ WARN_INTERNAL,
595 "Unbalanced saves: %ld more saves than restores\n",
596 (long)PL_savestack_ix);
597 if (PL_tmps_floor != -1)
598 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
599 (long)PL_tmps_floor + 1);
600 if (cxstack_ix != -1)
601 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
602 (long)cxstack_ix + 1);
605 /* Now absolutely destruct everything, somehow or other, loops or no. */
607 SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */
608 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
609 while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
610 last_sv_count = PL_sv_count;
613 SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
614 SvFLAGS(PL_fdpid) |= SVt_PVAV;
615 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
616 SvFLAGS(PL_strtab) |= SVt_PVHV;
618 AvREAL_off(PL_fdpid); /* no surviving entries */
619 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
622 /* Destruct the global string table. */
624 /* Yell and reset the HeVAL() slots that are still holding refcounts,
625 * so that sv_free() won't fail on them.
633 max = HvMAX(PL_strtab);
634 array = HvARRAY(PL_strtab);
637 if (hent && ckWARN_d(WARN_INTERNAL)) {
638 Perl_warner(aTHX_ WARN_INTERNAL,
639 "Unbalanced string table refcount: (%d) for \"%s\"",
640 HeVAL(hent) - Nullsv, HeKEY(hent));
641 HeVAL(hent) = Nullsv;
651 SvREFCNT_dec(PL_strtab);
653 /* free special SVs */
655 SvREFCNT(&PL_sv_yes) = 0;
656 sv_clear(&PL_sv_yes);
657 SvANY(&PL_sv_yes) = NULL;
659 SvREFCNT(&PL_sv_no) = 0;
661 SvANY(&PL_sv_no) = NULL;
663 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
664 Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
668 /* No SVs have survived, need to clean out */
669 Safefree(PL_origfilename);
670 Safefree(PL_reg_start_tmp);
672 Safefree(PL_reg_curpm);
673 Safefree(PL_reg_poscache);
674 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
675 Safefree(PL_op_mask);
677 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
679 DEBUG_P(debprofdump());
681 MUTEX_DESTROY(&PL_strtab_mutex);
682 MUTEX_DESTROY(&PL_sv_mutex);
683 MUTEX_DESTROY(&PL_eval_mutex);
684 MUTEX_DESTROY(&PL_cred_mutex);
685 COND_DESTROY(&PL_eval_cond);
686 #ifdef EMULATE_ATOMIC_REFCOUNTS
687 MUTEX_DESTROY(&PL_svref_mutex);
688 #endif /* EMULATE_ATOMIC_REFCOUNTS */
690 /* As the penultimate thing, free the non-arena SV for thrsv */
691 Safefree(SvPVX(PL_thrsv));
692 Safefree(SvANY(PL_thrsv));
695 #endif /* USE_THREADS */
697 /* As the absolutely last thing, free the non-arena SV for mess() */
700 /* it could have accumulated taint magic */
701 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
704 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
705 moremagic = mg->mg_moremagic;
706 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
707 Safefree(mg->mg_ptr);
711 /* we know that type >= SVt_PV */
712 SvOOK_off(PL_mess_sv);
713 Safefree(SvPVX(PL_mess_sv));
714 Safefree(SvANY(PL_mess_sv));
715 Safefree(PL_mess_sv);
721 =for apidoc perl_free
723 Releases a Perl interpreter. See L<perlembed>.
731 #if defined(PERL_OBJECT)
739 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
741 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
742 PL_exitlist[PL_exitlistlen].fn = fn;
743 PL_exitlist[PL_exitlistlen].ptr = ptr;
748 =for apidoc perl_parse
750 Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
756 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
766 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
769 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
770 setuid perl scripts securely.\n");
774 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
775 _dyld_lookup_and_bind
776 ("__environ", (unsigned long *) &environ_pointer, NULL);
781 #ifndef VMS /* VMS doesn't have environ array */
782 PL_origenviron = environ;
787 /* Come here if running an undumped a.out. */
789 PL_origfilename = savepv(argv[0]);
790 PL_do_undump = FALSE;
791 cxstack_ix = -1; /* start label stack again */
793 init_postdump_symbols(argc,argv,env);
798 PL_curpad = AvARRAY(PL_comppad);
799 op_free(PL_main_root);
800 PL_main_root = Nullop;
802 PL_main_start = Nullop;
803 SvREFCNT_dec(PL_main_cv);
807 oldscope = PL_scopestack_ix;
808 PL_dowarn = G_WARN_OFF;
810 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_parse_body),
815 call_list(oldscope, PL_checkav);
821 /* my_exit() was called */
822 while (PL_scopestack_ix > oldscope)
825 PL_curstash = PL_defstash;
827 call_list(oldscope, PL_checkav);
828 return STATUS_NATIVE_EXPORT;
830 PerlIO_printf(Perl_error_log, "panic: top_env\n");
837 S_parse_body(pTHX_ va_list args)
840 int argc = PL_origargc;
841 char **argv = PL_origargv;
842 char **env = va_arg(args, char**);
843 char *scriptname = NULL;
845 VOL bool dosearch = FALSE;
850 char *cddir = Nullch;
852 XSINIT_t xsinit = va_arg(args, XSINIT_t);
854 sv_setpvn(PL_linestr,"",0);
855 sv = newSVpvn("",0); /* first used for -I flags */
859 for (argc--,argv++; argc > 0; argc--,argv++) {
860 if (argv[0][0] != '-' || !argv[0][1])
864 validarg = " PHOOEY ";
871 #ifndef PERL_STRICT_CR
896 if (s = moreswitches(s))
906 if (PL_euid != PL_uid || PL_egid != PL_gid)
907 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
909 PL_e_script = newSVpvn("",0);
910 filter_add(read_e_script, NULL);
913 sv_catpv(PL_e_script, s);
915 sv_catpv(PL_e_script, argv[1]);
919 Perl_croak(aTHX_ "No code specified for -e");
920 sv_catpv(PL_e_script, "\n");
923 case 'I': /* -I handled both here and in moreswitches() */
925 if (!*++s && (s=argv[1]) != Nullch) {
930 STRLEN len = strlen(s);
933 sv_catpvn(sv, "-I", 2);
934 sv_catpvn(sv, p, len);
935 sv_catpvn(sv, " ", 1);
939 Perl_croak(aTHX_ "No directory specified for -I");
943 PL_preprocess = TRUE;
953 PL_preambleav = newAV();
954 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
956 PL_Sv = newSVpv("print myconfig();",0);
958 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
960 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
962 sv_catpv(PL_Sv,"\" Compile-time options:");
964 sv_catpv(PL_Sv," DEBUGGING");
967 sv_catpv(PL_Sv," MULTIPLICITY");
970 sv_catpv(PL_Sv," USE_THREADS");
973 sv_catpv(PL_Sv," USE_ITHREADS");
976 sv_catpv(PL_Sv," USE_64_BITS");
978 # ifdef USE_LONG_DOUBLE
979 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
981 # ifdef USE_LARGE_FILES
982 sv_catpv(PL_Sv," USE_LARGE_FILES");
985 sv_catpv(PL_Sv," USE_SOCKS");
988 sv_catpv(PL_Sv," PERL_OBJECT");
990 # ifdef PERL_IMPLICIT_CONTEXT
991 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
993 # ifdef PERL_IMPLICIT_SYS
994 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
996 sv_catpv(PL_Sv,"\\n\",");
998 #if defined(LOCAL_PATCH_COUNT)
999 if (LOCAL_PATCH_COUNT > 0) {
1001 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
1002 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
1003 if (PL_localpatches[i])
1004 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
1008 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
1011 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
1013 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
1016 sv_catpv(PL_Sv, "; \
1018 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
1019 print \" \\%ENV:\\n @env\\n\" if @env; \
1020 print \" \\@INC:\\n @INC\\n\";");
1023 PL_Sv = newSVpv("config_vars(qw(",0);
1024 sv_catpv(PL_Sv, ++s);
1025 sv_catpv(PL_Sv, "))");
1028 av_push(PL_preambleav, PL_Sv);
1029 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1032 PL_doextract = TRUE;
1040 if (!*++s || isSPACE(*s)) {
1044 /* catch use of gnu style long options */
1045 if (strEQ(s, "version")) {
1049 if (strEQ(s, "help")) {
1056 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
1062 #ifndef SECURE_INTERNAL_GETENV
1065 (s = PerlEnv_getenv("PERL5OPT")))
1069 if (*s == '-' && *(s+1) == 'T')
1082 if (!strchr("DIMUdmw", *s))
1083 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
1084 s = moreswitches(s);
1090 scriptname = argv[0];
1093 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1095 else if (scriptname == Nullch) {
1097 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1105 open_script(scriptname,dosearch,sv,&fdscript);
1107 validate_suid(validarg, scriptname,fdscript);
1109 #if defined(SIGCHLD) || defined(SIGCLD)
1112 # define SIGCHLD SIGCLD
1114 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1115 if (sigstate == SIG_IGN) {
1116 if (ckWARN(WARN_SIGNAL))
1117 Perl_warner(aTHX_ WARN_SIGNAL,
1118 "Can't ignore signal CHLD, forcing to default");
1119 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1126 if (cddir && PerlDir_chdir(cddir) < 0)
1127 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1131 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1132 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1133 CvUNIQUE_on(PL_compcv);
1135 PL_comppad = newAV();
1136 av_push(PL_comppad, Nullsv);
1137 PL_curpad = AvARRAY(PL_comppad);
1138 PL_comppad_name = newAV();
1139 PL_comppad_name_fill = 0;
1140 PL_min_intro_pending = 0;
1143 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
1144 PL_curpad[0] = (SV*)newAV();
1145 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
1146 CvOWNER(PL_compcv) = 0;
1147 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1148 MUTEX_INIT(CvMUTEXP(PL_compcv));
1149 #endif /* USE_THREADS */
1151 comppadlist = newAV();
1152 AvREAL_off(comppadlist);
1153 av_store(comppadlist, 0, (SV*)PL_comppad_name);
1154 av_store(comppadlist, 1, (SV*)PL_comppad);
1155 CvPADLIST(PL_compcv) = comppadlist;
1157 boot_core_UNIVERSAL();
1158 boot_core_xsutils();
1161 (*xsinit)(aTHXo); /* in case linked C routines want magical variables */
1162 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
1170 init_predump_symbols();
1171 /* init_postdump_symbols not currently designed to be called */
1172 /* more than once (ENV isn't cleared first, for example) */
1173 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
1175 init_postdump_symbols(argc,argv,env);
1179 /* now parse the script */
1181 SETERRNO(0,SS$_NORMAL);
1183 if (yyparse() || PL_error_count) {
1185 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1187 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1191 CopLINE_set(PL_curcop, 0);
1192 PL_curstash = PL_defstash;
1193 PL_preprocess = FALSE;
1195 SvREFCNT_dec(PL_e_script);
1196 PL_e_script = Nullsv;
1199 /* now that script is parsed, we can modify record separator */
1200 SvREFCNT_dec(PL_rs);
1201 PL_rs = SvREFCNT_inc(PL_nrs);
1202 sv_setsv(get_sv("/", TRUE), PL_rs);
1207 SAVECOPFILE(PL_curcop);
1208 SAVECOPLINE(PL_curcop);
1209 gv_check(PL_defstash);
1216 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1217 dump_mstats("after compilation:");
1226 =for apidoc perl_run
1228 Tells a Perl interpreter to run. See L<perlembed>.
1244 oldscope = PL_scopestack_ix;
1247 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
1250 cxstack_ix = -1; /* start context stack again */
1252 case 0: /* normal completion */
1253 case 2: /* my_exit() */
1254 while (PL_scopestack_ix > oldscope)
1257 PL_curstash = PL_defstash;
1258 if (PL_endav && !PL_minus_c)
1259 call_list(oldscope, PL_endav);
1261 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1262 dump_mstats("after execution: ");
1264 return STATUS_NATIVE_EXPORT;
1267 POPSTACK_TO(PL_mainstack);
1270 PerlIO_printf(Perl_error_log, "panic: restartop\n");
1280 S_run_body(pTHX_ va_list args)
1283 I32 oldscope = va_arg(args, I32);
1285 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1286 PL_sawampersand ? "Enabling" : "Omitting"));
1288 if (!PL_restartop) {
1289 DEBUG_x(dump_all());
1290 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1291 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1295 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1298 if (PERLDB_SINGLE && PL_DBsingle)
1299 sv_setiv(PL_DBsingle, 1);
1301 call_list(oldscope, PL_initav);
1307 PL_op = PL_restartop;
1311 else if (PL_main_start) {
1312 CvDEPTH(PL_main_cv) = 1;
1313 PL_op = PL_main_start;
1323 =for apidoc p||get_sv
1325 Returns the SV of the specified Perl scalar. If C<create> is set and the
1326 Perl variable does not exist then it will be created. If C<create> is not
1327 set and the variable does not exist then NULL is returned.
1333 Perl_get_sv(pTHX_ const char *name, I32 create)
1337 if (name[1] == '\0' && !isALPHA(name[0])) {
1338 PADOFFSET tmp = find_threadsv(name);
1339 if (tmp != NOT_IN_PAD) {
1341 return THREADSV(tmp);
1344 #endif /* USE_THREADS */
1345 gv = gv_fetchpv(name, create, SVt_PV);
1352 =for apidoc p||get_av
1354 Returns the AV of the specified Perl array. If C<create> is set and the
1355 Perl variable does not exist then it will be created. If C<create> is not
1356 set and the variable does not exist then NULL is returned.
1362 Perl_get_av(pTHX_ const char *name, I32 create)
1364 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1373 =for apidoc p||get_hv
1375 Returns the HV of the specified Perl hash. If C<create> is set and the
1376 Perl variable does not exist then it will be created. If C<create> is not
1377 set and the variable does not exist then NULL is returned.
1383 Perl_get_hv(pTHX_ const char *name, I32 create)
1385 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1394 =for apidoc p||get_cv
1396 Returns the CV of the specified Perl subroutine. If C<create> is set and
1397 the Perl subroutine does not exist then it will be declared (which has the
1398 same effect as saying C<sub name;>). If C<create> is not set and the
1399 subroutine does not exist then NULL is returned.
1405 Perl_get_cv(pTHX_ const char *name, I32 create)
1407 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1408 /* XXX unsafe for threads if eval_owner isn't held */
1409 /* XXX this is probably not what they think they're getting.
1410 * It has the same effect as "sub name;", i.e. just a forward
1412 if (create && !GvCVu(gv))
1413 return newSUB(start_subparse(FALSE, 0),
1414 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1422 /* Be sure to refetch the stack pointer after calling these routines. */
1425 =for apidoc p||call_argv
1427 Performs a callback to the specified Perl sub. See L<perlcall>.
1433 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1435 /* See G_* flags in cop.h */
1436 /* null terminated arg list */
1443 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1448 return call_pv(sub_name, flags);
1452 =for apidoc p||call_pv
1454 Performs a callback to the specified Perl sub. See L<perlcall>.
1460 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1461 /* name of the subroutine */
1462 /* See G_* flags in cop.h */
1464 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1468 =for apidoc p||call_method
1470 Performs a callback to the specified Perl method. The blessed object must
1471 be on the stack. See L<perlcall>.
1477 Perl_call_method(pTHX_ const char *methname, I32 flags)
1478 /* name of the subroutine */
1479 /* See G_* flags in cop.h */
1487 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1492 return call_sv(*PL_stack_sp--, flags);
1495 /* May be called with any of a CV, a GV, or an SV containing the name. */
1497 =for apidoc p||call_sv
1499 Performs a callback to the Perl sub whose name is in the SV. See
1506 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1508 /* See G_* flags in cop.h */
1511 LOGOP myop; /* fake syntax tree node */
1515 bool oldcatch = CATCH_GET;
1520 if (flags & G_DISCARD) {
1525 Zero(&myop, 1, LOGOP);
1526 myop.op_next = Nullop;
1527 if (!(flags & G_NOARGS))
1528 myop.op_flags |= OPf_STACKED;
1529 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1530 (flags & G_ARRAY) ? OPf_WANT_LIST :
1535 EXTEND(PL_stack_sp, 1);
1536 *++PL_stack_sp = sv;
1538 oldscope = PL_scopestack_ix;
1540 if (PERLDB_SUB && PL_curstash != PL_debstash
1541 /* Handle first BEGIN of -d. */
1542 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1543 /* Try harder, since this may have been a sighandler, thus
1544 * curstash may be meaningless. */
1545 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1546 && !(flags & G_NODEBUG))
1547 PL_op->op_private |= OPpENTERSUB_DB;
1549 if (!(flags & G_EVAL)) {
1551 call_xbody((OP*)&myop, FALSE);
1552 retval = PL_stack_sp - (PL_stack_base + oldmark);
1553 CATCH_SET(oldcatch);
1556 cLOGOP->op_other = PL_op;
1558 /* we're trying to emulate pp_entertry() here */
1560 register PERL_CONTEXT *cx;
1561 I32 gimme = GIMME_V;
1566 push_return(PL_op->op_next);
1567 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1569 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1571 PL_in_eval = EVAL_INEVAL;
1572 if (flags & G_KEEPERR)
1573 PL_in_eval |= EVAL_KEEPERR;
1580 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1584 retval = PL_stack_sp - (PL_stack_base + oldmark);
1585 if (!(flags & G_KEEPERR))
1592 /* my_exit() was called */
1593 PL_curstash = PL_defstash;
1595 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1596 Perl_croak(aTHX_ "Callback called exit");
1601 PL_op = PL_restartop;
1605 PL_stack_sp = PL_stack_base + oldmark;
1606 if (flags & G_ARRAY)
1610 *++PL_stack_sp = &PL_sv_undef;
1615 if (PL_scopestack_ix > oldscope) {
1619 register PERL_CONTEXT *cx;
1630 if (flags & G_DISCARD) {
1631 PL_stack_sp = PL_stack_base + oldmark;
1641 S_call_body(pTHX_ va_list args)
1643 OP *myop = va_arg(args, OP*);
1644 int is_eval = va_arg(args, int);
1646 call_xbody(myop, is_eval);
1651 S_call_xbody(pTHX_ OP *myop, int is_eval)
1655 if (PL_op == myop) {
1657 PL_op = Perl_pp_entereval(aTHX);
1659 PL_op = Perl_pp_entersub(aTHX);
1665 /* Eval a string. The G_EVAL flag is always assumed. */
1668 =for apidoc p||eval_sv
1670 Tells Perl to C<eval> the string in the SV.
1676 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1678 /* See G_* flags in cop.h */
1681 UNOP myop; /* fake syntax tree node */
1682 I32 oldmark = SP - PL_stack_base;
1689 if (flags & G_DISCARD) {
1696 Zero(PL_op, 1, UNOP);
1697 EXTEND(PL_stack_sp, 1);
1698 *++PL_stack_sp = sv;
1699 oldscope = PL_scopestack_ix;
1701 if (!(flags & G_NOARGS))
1702 myop.op_flags = OPf_STACKED;
1703 myop.op_next = Nullop;
1704 myop.op_type = OP_ENTEREVAL;
1705 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1706 (flags & G_ARRAY) ? OPf_WANT_LIST :
1708 if (flags & G_KEEPERR)
1709 myop.op_flags |= OPf_SPECIAL;
1712 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1716 retval = PL_stack_sp - (PL_stack_base + oldmark);
1717 if (!(flags & G_KEEPERR))
1724 /* my_exit() was called */
1725 PL_curstash = PL_defstash;
1727 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1728 Perl_croak(aTHX_ "Callback called exit");
1733 PL_op = PL_restartop;
1737 PL_stack_sp = PL_stack_base + oldmark;
1738 if (flags & G_ARRAY)
1742 *++PL_stack_sp = &PL_sv_undef;
1747 if (flags & G_DISCARD) {
1748 PL_stack_sp = PL_stack_base + oldmark;
1758 =for apidoc p||eval_pv
1760 Tells Perl to C<eval> the given string and return an SV* result.
1766 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1769 SV* sv = newSVpv(p, 0);
1772 eval_sv(sv, G_SCALAR);
1779 if (croak_on_error && SvTRUE(ERRSV)) {
1781 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1787 /* Require a module. */
1790 =for apidoc p||require_pv
1792 Tells Perl to C<require> a module.
1798 Perl_require_pv(pTHX_ const char *pv)
1802 PUSHSTACKi(PERLSI_REQUIRE);
1804 sv = sv_newmortal();
1805 sv_setpv(sv, "require '");
1808 eval_sv(sv, G_DISCARD);
1814 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1818 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1819 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1823 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
1825 /* This message really ought to be max 23 lines.
1826 * Removed -h because the user already knows that opton. Others? */
1828 static char *usage_msg[] = {
1829 "-0[octal] specify record separator (\\0, if no argument)",
1830 "-a autosplit mode with -n or -p (splits $_ into @F)",
1831 "-C enable native wide character system interfaces",
1832 "-c check syntax only (runs BEGIN and END blocks)",
1833 "-d[:debugger] run program under debugger",
1834 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1835 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1836 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1837 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1838 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1839 "-l[octal] enable line ending processing, specifies line terminator",
1840 "-[mM][-]module execute `use/no module...' before executing program",
1841 "-n assume 'while (<>) { ... }' loop around program",
1842 "-p assume loop like -n but print line also, like sed",
1843 "-P run program through C preprocessor before compilation",
1844 "-s enable rudimentary parsing for switches after programfile",
1845 "-S look for programfile using PATH environment variable",
1846 "-T enable tainting checks",
1847 "-u dump core after parsing program",
1848 "-U allow unsafe operations",
1849 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1850 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1851 "-w enable many useful warnings (RECOMMENDED)",
1852 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1856 char **p = usage_msg;
1858 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1860 printf("\n %s", *p++);
1863 /* This routine handles any switches that can be given during run */
1866 Perl_moreswitches(pTHX_ char *s)
1875 rschar = (U32)scan_oct(s, 4, &numlen);
1876 SvREFCNT_dec(PL_nrs);
1877 if (rschar & ~((U8)~0))
1878 PL_nrs = &PL_sv_undef;
1879 else if (!rschar && numlen >= 2)
1880 PL_nrs = newSVpvn("", 0);
1883 PL_nrs = newSVpvn(&ch, 1);
1888 PL_widesyscalls = TRUE;
1893 PL_splitstr = savepv(s + 1);
1907 if (*s == ':' || *s == '=') {
1908 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1912 PL_perldb = PERLDB_ALL;
1920 if (isALPHA(s[1])) {
1921 static char debopts[] = "psltocPmfrxuLHXDS";
1924 for (s++; *s && (d = strchr(debopts,*s)); s++)
1925 PL_debug |= 1 << (d - debopts);
1928 PL_debug = atoi(s+1);
1929 for (s++; isDIGIT(*s); s++) ;
1931 PL_debug |= 0x80000000;
1934 if (ckWARN_d(WARN_DEBUGGING))
1935 Perl_warner(aTHX_ WARN_DEBUGGING,
1936 "Recompile perl with -DDEBUGGING to use -D switch\n");
1937 for (s++; isALNUM(*s); s++) ;
1943 usage(PL_origargv[0]);
1947 Safefree(PL_inplace);
1948 PL_inplace = savepv(s+1);
1950 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1953 if (*s == '-') /* Additional switches on #! line. */
1957 case 'I': /* -I handled both here and in parse_perl() */
1960 while (*s && isSPACE(*s))
1965 /* ignore trailing spaces (possibly followed by other switches) */
1967 for (e = p; *e && !isSPACE(*e); e++) ;
1971 } while (*p && *p != '-');
1972 e = savepvn(s, e-s);
1980 Perl_croak(aTHX_ "No directory specified for -I");
1988 PL_ors = savepv("\n");
1990 *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
1995 if (RsPARA(PL_nrs)) {
2000 PL_ors = SvPV(PL_nrs, PL_orslen);
2001 PL_ors = savepvn(PL_ors, PL_orslen);
2005 forbid_setid("-M"); /* XXX ? */
2008 forbid_setid("-m"); /* XXX ? */
2013 /* -M-foo == 'no foo' */
2014 if (*s == '-') { use = "no "; ++s; }
2015 sv = newSVpv(use,0);
2017 /* We allow -M'Module qw(Foo Bar)' */
2018 while(isALNUM(*s) || *s==':') ++s;
2020 sv_catpv(sv, start);
2021 if (*(start-1) == 'm') {
2023 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
2024 sv_catpv( sv, " ()");
2027 sv_catpvn(sv, start, s-start);
2028 sv_catpv(sv, " split(/,/,q{");
2034 PL_preambleav = newAV();
2035 av_push(PL_preambleav, sv);
2038 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
2050 PL_doswitches = TRUE;
2055 Perl_croak(aTHX_ "Too late for \"-T\" option");
2059 PL_do_undump = TRUE;
2067 printf(Perl_form(aTHX_ "\nThis is perl, v%v built for %s",
2068 PL_patchlevel, ARCHNAME));
2069 #if defined(LOCAL_PATCH_COUNT)
2070 if (LOCAL_PATCH_COUNT > 0)
2071 printf("\n(with %d registered patch%s, see perl -V for more detail)",
2072 (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
2075 printf("\n\nCopyright 1987-2000, Larry Wall\n");
2077 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
2080 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
2081 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
2084 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
2085 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
2088 printf("atariST series port, ++jrb bammi@cadence.com\n");
2091 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
2094 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
2097 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
2100 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
2103 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
2106 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
2109 printf("MiNT port by Guido Flohr, 1997-1999\n");
2111 #ifdef BINARY_BUILD_NOTICE
2112 BINARY_BUILD_NOTICE;
2115 Perl may be copied only under the terms of either the Artistic License or the\n\
2116 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
2117 Complete documentation for Perl, including FAQ lists, should be found on\n\
2118 this system using `man perl' or `perldoc perl'. If you have access to the\n\
2119 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
2122 if (! (PL_dowarn & G_WARN_ALL_MASK))
2123 PL_dowarn |= G_WARN_ON;
2127 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
2128 PL_compiling.cop_warnings = WARN_ALL ;
2132 PL_dowarn = G_WARN_ALL_OFF;
2133 PL_compiling.cop_warnings = WARN_NONE ;
2138 if (s[1] == '-') /* Additional switches on #! line. */
2143 #if defined(WIN32) || !defined(PERL_STRICT_CR)
2149 #ifdef ALTERNATE_SHEBANG
2150 case 'S': /* OS/2 needs -S on "extproc" line. */
2158 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
2163 /* compliments of Tom Christiansen */
2165 /* unexec() can be found in the Gnu emacs distribution */
2166 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
2169 Perl_my_unexec(pTHX)
2177 prog = newSVpv(BIN_EXP, 0);
2178 sv_catpv(prog, "/perl");
2179 file = newSVpv(PL_origfilename, 0);
2180 sv_catpv(file, ".perldump");
2182 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2183 /* unexec prints msg to stderr in case of failure */
2184 PerlProc_exit(status);
2187 # include <lib$routines.h>
2188 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
2190 ABORT(); /* for use with undump */
2195 /* initialize curinterp */
2200 #ifdef PERL_OBJECT /* XXX kludge */
2203 PL_chopset = " \n-"; \
2204 PL_copline = NOLINE; \
2205 PL_curcop = &PL_compiling;\
2206 PL_curcopdb = NULL; \
2208 PL_dumpindent = 4; \
2209 PL_laststatval = -1; \
2210 PL_laststype = OP_STAT; \
2211 PL_maxscream = -1; \
2212 PL_maxsysfd = MAXSYSFD; \
2213 PL_statname = Nullsv; \
2214 PL_tmps_floor = -1; \
2216 PL_op_mask = NULL; \
2217 PL_laststatval = -1; \
2218 PL_laststype = OP_STAT; \
2219 PL_mess_sv = Nullsv; \
2220 PL_splitstr = " "; \
2221 PL_generation = 100; \
2222 PL_exitlist = NULL; \
2223 PL_exitlistlen = 0; \
2225 PL_in_clean_objs = FALSE; \
2226 PL_in_clean_all = FALSE; \
2227 PL_profiledata = NULL; \
2229 PL_rsfp_filters = Nullav; \
2234 # ifdef MULTIPLICITY
2235 # define PERLVAR(var,type)
2236 # define PERLVARA(var,n,type)
2237 # if defined(PERL_IMPLICIT_CONTEXT)
2238 # if defined(USE_THREADS)
2239 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2240 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2241 # else /* !USE_THREADS */
2242 # define PERLVARI(var,type,init) aTHX->var = init;
2243 # define PERLVARIC(var,type,init) aTHX->var = init;
2244 # endif /* USE_THREADS */
2246 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2247 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2249 # include "intrpvar.h"
2250 # ifndef USE_THREADS
2251 # include "thrdvar.h"
2258 # define PERLVAR(var,type)
2259 # define PERLVARA(var,n,type)
2260 # define PERLVARI(var,type,init) PL_##var = init;
2261 # define PERLVARIC(var,type,init) PL_##var = init;
2262 # include "intrpvar.h"
2263 # ifndef USE_THREADS
2264 # include "thrdvar.h"
2276 S_init_main_stash(pTHX)
2281 /* Note that strtab is a rather special HV. Assumptions are made
2282 about not iterating on it, and not adding tie magic to it.
2283 It is properly deallocated in perl_destruct() */
2284 PL_strtab = newHV();
2286 MUTEX_INIT(&PL_strtab_mutex);
2288 HvSHAREKEYS_off(PL_strtab); /* mandatory */
2289 hv_ksplit(PL_strtab, 512);
2291 PL_curstash = PL_defstash = newHV();
2292 PL_curstname = newSVpvn("main",4);
2293 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2294 SvREFCNT_dec(GvHV(gv));
2295 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2297 HvNAME(PL_defstash) = savepv("main");
2298 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2299 GvMULTI_on(PL_incgv);
2300 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2301 GvMULTI_on(PL_hintgv);
2302 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2303 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2304 GvMULTI_on(PL_errgv);
2305 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2306 GvMULTI_on(PL_replgv);
2307 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
2308 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2309 sv_setpvn(ERRSV, "", 0);
2310 PL_curstash = PL_defstash;
2311 CopSTASH_set(&PL_compiling, PL_defstash);
2312 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2313 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2314 /* We must init $/ before switches are processed. */
2315 sv_setpvn(get_sv("/", TRUE), "\n", 1);
2319 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2327 PL_origfilename = savepv("-e");
2330 /* if find_script() returns, it returns a malloc()-ed value */
2331 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2333 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2334 char *s = scriptname + 8;
2335 *fdscript = atoi(s);
2339 scriptname = savepv(s + 1);
2340 Safefree(PL_origfilename);
2341 PL_origfilename = scriptname;
2346 CopFILE_set(PL_curcop, PL_origfilename);
2347 if (strEQ(PL_origfilename,"-"))
2349 if (*fdscript >= 0) {
2350 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2351 #if defined(HAS_FCNTL) && defined(F_SETFD)
2353 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2356 else if (PL_preprocess) {
2357 char *cpp_cfg = CPPSTDIN;
2358 SV *cpp = newSVpvn("",0);
2359 SV *cmd = NEWSV(0,0);
2361 if (strEQ(cpp_cfg, "cppstdin"))
2362 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2363 sv_catpv(cpp, cpp_cfg);
2365 sv_catpvn(sv, "-I", 2);
2366 sv_catpv(sv,PRIVLIB_EXP);
2369 Perl_sv_setpvf(aTHX_ cmd, "\
2370 sed %s -e \"/^[^#]/b\" \
2371 -e \"/^#[ ]*include[ ]/b\" \
2372 -e \"/^#[ ]*define[ ]/b\" \
2373 -e \"/^#[ ]*if[ ]/b\" \
2374 -e \"/^#[ ]*ifdef[ ]/b\" \
2375 -e \"/^#[ ]*ifndef[ ]/b\" \
2376 -e \"/^#[ ]*else/b\" \
2377 -e \"/^#[ ]*elif[ ]/b\" \
2378 -e \"/^#[ ]*undef[ ]/b\" \
2379 -e \"/^#[ ]*endif/b\" \
2381 %s | %"SVf" -C %"SVf" %s",
2382 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2385 Perl_sv_setpvf(aTHX_ cmd, "\
2386 %s %s -e '/^[^#]/b' \
2387 -e '/^#[ ]*include[ ]/b' \
2388 -e '/^#[ ]*define[ ]/b' \
2389 -e '/^#[ ]*if[ ]/b' \
2390 -e '/^#[ ]*ifdef[ ]/b' \
2391 -e '/^#[ ]*ifndef[ ]/b' \
2392 -e '/^#[ ]*else/b' \
2393 -e '/^#[ ]*elif[ ]/b' \
2394 -e '/^#[ ]*undef[ ]/b' \
2395 -e '/^#[ ]*endif/b' \
2397 %s | %"SVf" %"SVf" %s",
2399 Perl_sv_setpvf(aTHX_ cmd, "\
2400 %s %s -e '/^[^#]/b' \
2401 -e '/^#[ ]*include[ ]/b' \
2402 -e '/^#[ ]*define[ ]/b' \
2403 -e '/^#[ ]*if[ ]/b' \
2404 -e '/^#[ ]*ifdef[ ]/b' \
2405 -e '/^#[ ]*ifndef[ ]/b' \
2406 -e '/^#[ ]*else/b' \
2407 -e '/^#[ ]*elif[ ]/b' \
2408 -e '/^#[ ]*undef[ ]/b' \
2409 -e '/^#[ ]*endif/b' \
2411 %s | %"SVf" -C %"SVf" %s",
2418 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2420 scriptname, cpp, sv, CPPMINUS);
2421 PL_doextract = FALSE;
2422 #ifdef IAMSUID /* actually, this is caught earlier */
2423 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2425 (void)seteuid(PL_uid); /* musn't stay setuid root */
2428 (void)setreuid((Uid_t)-1, PL_uid);
2430 #ifdef HAS_SETRESUID
2431 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2433 PerlProc_setuid(PL_uid);
2437 if (PerlProc_geteuid() != PL_uid)
2438 Perl_croak(aTHX_ "Can't do seteuid!\n");
2440 #endif /* IAMSUID */
2441 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2445 else if (!*scriptname) {
2446 forbid_setid("program input from stdin");
2447 PL_rsfp = PerlIO_stdin();
2450 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2451 #if defined(HAS_FCNTL) && defined(F_SETFD)
2453 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2458 #ifndef IAMSUID /* in case script is not readable before setuid */
2460 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2461 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2464 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
2465 (int)PERL_REVISION, (int)PERL_VERSION,
2466 (int)PERL_SUBVERSION), PL_origargv);
2467 Perl_croak(aTHX_ "Can't do setuid\n");
2471 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2472 CopFILE(PL_curcop), Strerror(errno));
2477 * I_SYSSTATVFS HAS_FSTATVFS
2479 * I_STATFS HAS_FSTATFS
2480 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2481 * here so that metaconfig picks them up. */
2485 S_fd_on_nosuid_fs(pTHX_ int fd)
2487 int check_okay = 0; /* able to do all the required sys/libcalls */
2488 int on_nosuid = 0; /* the fd is on a nosuid fs */
2490 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2491 * fstatvfs() is UNIX98.
2492 * fstatfs() is 4.3 BSD.
2493 * ustat()+getmnt() is pre-4.3 BSD.
2494 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2495 * an irrelevant filesystem while trying to reach the right one.
2498 # ifdef HAS_FSTATVFS
2499 struct statvfs stfs;
2500 check_okay = fstatvfs(fd, &stfs) == 0;
2501 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2503 # ifdef PERL_MOUNT_NOSUID
2504 # if defined(HAS_FSTATFS) && \
2505 defined(HAS_STRUCT_STATFS) && \
2506 defined(HAS_STRUCT_STATFS_F_FLAGS)
2508 check_okay = fstatfs(fd, &stfs) == 0;
2509 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2511 # if defined(HAS_FSTAT) && \
2512 defined(HAS_USTAT) && \
2513 defined(HAS_GETMNT) && \
2514 defined(HAS_STRUCT_FS_DATA) && \
2517 if (fstat(fd, &fdst) == 0) {
2519 if (ustat(fdst.st_dev, &us) == 0) {
2521 /* NOSTAT_ONE here because we're not examining fields which
2522 * vary between that case and STAT_ONE. */
2523 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2524 size_t cmplen = sizeof(us.f_fname);
2525 if (sizeof(fsd.fd_req.path) < cmplen)
2526 cmplen = sizeof(fsd.fd_req.path);
2527 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2528 fdst.st_dev == fsd.fd_req.dev) {
2530 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2536 # endif /* fstat+ustat+getmnt */
2537 # endif /* fstatfs */
2539 # if defined(HAS_GETMNTENT) && \
2540 defined(HAS_HASMNTOPT) && \
2541 defined(MNTOPT_NOSUID)
2542 FILE *mtab = fopen("/etc/mtab", "r");
2543 struct mntent *entry;
2544 struct stat stb, fsb;
2546 if (mtab && (fstat(fd, &stb) == 0)) {
2547 while (entry = getmntent(mtab)) {
2548 if (stat(entry->mnt_dir, &fsb) == 0
2549 && fsb.st_dev == stb.st_dev)
2551 /* found the filesystem */
2553 if (hasmntopt(entry, MNTOPT_NOSUID))
2556 } /* A single fs may well fail its stat(). */
2561 # endif /* getmntent+hasmntopt */
2562 # endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */
2563 # endif /* statvfs */
2566 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
2569 #endif /* IAMSUID */
2572 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2576 /* do we need to emulate setuid on scripts? */
2578 /* This code is for those BSD systems that have setuid #! scripts disabled
2579 * in the kernel because of a security problem. Merely defining DOSUID
2580 * in perl will not fix that problem, but if you have disabled setuid
2581 * scripts in the kernel, this will attempt to emulate setuid and setgid
2582 * on scripts that have those now-otherwise-useless bits set. The setuid
2583 * root version must be called suidperl or sperlN.NNN. If regular perl
2584 * discovers that it has opened a setuid script, it calls suidperl with
2585 * the same argv that it had. If suidperl finds that the script it has
2586 * just opened is NOT setuid root, it sets the effective uid back to the
2587 * uid. We don't just make perl setuid root because that loses the
2588 * effective uid we had before invoking perl, if it was different from the
2591 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2592 * be defined in suidperl only. suidperl must be setuid root. The
2593 * Configure script will set this up for you if you want it.
2600 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2601 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2602 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2607 #ifndef HAS_SETREUID
2608 /* On this access check to make sure the directories are readable,
2609 * there is actually a small window that the user could use to make
2610 * filename point to an accessible directory. So there is a faint
2611 * chance that someone could execute a setuid script down in a
2612 * non-accessible directory. I don't know what to do about that.
2613 * But I don't think it's too important. The manual lies when
2614 * it says access() is useful in setuid programs.
2616 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
2617 Perl_croak(aTHX_ "Permission denied");
2619 /* If we can swap euid and uid, then we can determine access rights
2620 * with a simple stat of the file, and then compare device and
2621 * inode to make sure we did stat() on the same file we opened.
2622 * Then we just have to make sure he or she can execute it.
2625 struct stat tmpstatbuf;
2629 setreuid(PL_euid,PL_uid) < 0
2632 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2635 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2636 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2637 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
2638 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2639 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2640 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2641 Perl_croak(aTHX_ "Permission denied");
2643 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2644 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2645 (void)PerlIO_close(PL_rsfp);
2646 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2647 PerlIO_printf(PL_rsfp,
2648 "User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2649 (Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n",
2650 PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2651 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2653 PL_statbuf.st_uid, PL_statbuf.st_gid);
2654 (void)PerlProc_pclose(PL_rsfp);
2656 Perl_croak(aTHX_ "Permission denied\n");
2660 setreuid(PL_uid,PL_euid) < 0
2662 # if defined(HAS_SETRESUID)
2663 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2666 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2667 Perl_croak(aTHX_ "Can't reswap uid and euid");
2668 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2669 Perl_croak(aTHX_ "Permission denied\n");
2671 #endif /* HAS_SETREUID */
2672 #endif /* IAMSUID */
2674 if (!S_ISREG(PL_statbuf.st_mode))
2675 Perl_croak(aTHX_ "Permission denied");
2676 if (PL_statbuf.st_mode & S_IWOTH)
2677 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2678 PL_doswitches = FALSE; /* -s is insecure in suid */
2679 CopLINE_inc(PL_curcop);
2680 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2681 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2682 Perl_croak(aTHX_ "No #! line");
2683 s = SvPV(PL_linestr,n_a)+2;
2685 while (!isSPACE(*s)) s++;
2686 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2687 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2688 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2689 Perl_croak(aTHX_ "Not a perl script");
2690 while (*s == ' ' || *s == '\t') s++;
2692 * #! arg must be what we saw above. They can invoke it by
2693 * mentioning suidperl explicitly, but they may not add any strange
2694 * arguments beyond what #! says if they do invoke suidperl that way.
2696 len = strlen(validarg);
2697 if (strEQ(validarg," PHOOEY ") ||
2698 strnNE(s,validarg,len) || !isSPACE(s[len]))
2699 Perl_croak(aTHX_ "Args must match #! line");
2702 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2703 PL_euid == PL_statbuf.st_uid)
2705 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2706 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2707 #endif /* IAMSUID */
2709 if (PL_euid) { /* oops, we're not the setuid root perl */
2710 (void)PerlIO_close(PL_rsfp);
2713 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
2714 (int)PERL_REVISION, (int)PERL_VERSION,
2715 (int)PERL_SUBVERSION), PL_origargv);
2717 Perl_croak(aTHX_ "Can't do setuid\n");
2720 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2722 (void)setegid(PL_statbuf.st_gid);
2725 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2727 #ifdef HAS_SETRESGID
2728 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2730 PerlProc_setgid(PL_statbuf.st_gid);
2734 if (PerlProc_getegid() != PL_statbuf.st_gid)
2735 Perl_croak(aTHX_ "Can't do setegid!\n");
2737 if (PL_statbuf.st_mode & S_ISUID) {
2738 if (PL_statbuf.st_uid != PL_euid)
2740 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2743 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2745 #ifdef HAS_SETRESUID
2746 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2748 PerlProc_setuid(PL_statbuf.st_uid);
2752 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2753 Perl_croak(aTHX_ "Can't do seteuid!\n");
2755 else if (PL_uid) { /* oops, mustn't run as root */
2757 (void)seteuid((Uid_t)PL_uid);
2760 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2762 #ifdef HAS_SETRESUID
2763 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2765 PerlProc_setuid((Uid_t)PL_uid);
2769 if (PerlProc_geteuid() != PL_uid)
2770 Perl_croak(aTHX_ "Can't do seteuid!\n");
2773 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2774 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
2777 else if (PL_preprocess)
2778 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2779 else if (fdscript >= 0)
2780 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2782 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2784 /* We absolutely must clear out any saved ids here, so we */
2785 /* exec the real perl, substituting fd script for scriptname. */
2786 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2787 PerlIO_rewind(PL_rsfp);
2788 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2789 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2790 if (!PL_origargv[which])
2791 Perl_croak(aTHX_ "Permission denied");
2792 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2793 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2794 #if defined(HAS_FCNTL) && defined(F_SETFD)
2795 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2797 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
2798 (int)PERL_REVISION, (int)PERL_VERSION,
2799 (int)PERL_SUBVERSION), PL_origargv);/* try again */
2800 Perl_croak(aTHX_ "Can't do setuid\n");
2801 #endif /* IAMSUID */
2803 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2804 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2806 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2807 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2809 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2812 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2813 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2814 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2815 /* not set-id, must be wrapped */
2821 S_find_beginning(pTHX)
2823 register char *s, *s2;
2825 /* skip forward in input to the real script? */
2828 while (PL_doextract) {
2829 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2830 Perl_croak(aTHX_ "No Perl script found in input\n");
2831 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2832 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2833 PL_doextract = FALSE;
2834 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2836 while (*s == ' ' || *s == '\t') s++;
2838 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2839 if (strnEQ(s2-4,"perl",4))
2841 while (s = moreswitches(s)) ;
2851 PL_uid = PerlProc_getuid();
2852 PL_euid = PerlProc_geteuid();
2853 PL_gid = PerlProc_getgid();
2854 PL_egid = PerlProc_getegid();
2856 PL_uid |= PL_gid << 16;
2857 PL_euid |= PL_egid << 16;
2859 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2863 S_forbid_setid(pTHX_ char *s)
2865 if (PL_euid != PL_uid)
2866 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2867 if (PL_egid != PL_gid)
2868 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2872 Perl_init_debugger(pTHX)
2875 HV *ostash = PL_curstash;
2877 PL_curstash = PL_debstash;
2878 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2879 AvREAL_off(PL_dbargs);
2880 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2881 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2882 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2883 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
2884 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2885 sv_setiv(PL_DBsingle, 0);
2886 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2887 sv_setiv(PL_DBtrace, 0);
2888 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2889 sv_setiv(PL_DBsignal, 0);
2890 PL_curstash = ostash;
2893 #ifndef STRESS_REALLOC
2894 #define REASONABLE(size) (size)
2896 #define REASONABLE(size) (1) /* unreasonable */
2900 Perl_init_stacks(pTHX)
2902 /* start with 128-item stack and 8K cxstack */
2903 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2904 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2905 PL_curstackinfo->si_type = PERLSI_MAIN;
2906 PL_curstack = PL_curstackinfo->si_stack;
2907 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2909 PL_stack_base = AvARRAY(PL_curstack);
2910 PL_stack_sp = PL_stack_base;
2911 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2913 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2916 PL_tmps_max = REASONABLE(128);
2918 New(54,PL_markstack,REASONABLE(32),I32);
2919 PL_markstack_ptr = PL_markstack;
2920 PL_markstack_max = PL_markstack + REASONABLE(32);
2924 New(54,PL_scopestack,REASONABLE(32),I32);
2925 PL_scopestack_ix = 0;
2926 PL_scopestack_max = REASONABLE(32);
2928 New(54,PL_savestack,REASONABLE(128),ANY);
2929 PL_savestack_ix = 0;
2930 PL_savestack_max = REASONABLE(128);
2932 New(54,PL_retstack,REASONABLE(16),OP*);
2934 PL_retstack_max = REASONABLE(16);
2943 while (PL_curstackinfo->si_next)
2944 PL_curstackinfo = PL_curstackinfo->si_next;
2945 while (PL_curstackinfo) {
2946 PERL_SI *p = PL_curstackinfo->si_prev;
2947 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2948 Safefree(PL_curstackinfo->si_cxstack);
2949 Safefree(PL_curstackinfo);
2950 PL_curstackinfo = p;
2952 Safefree(PL_tmps_stack);
2953 Safefree(PL_markstack);
2954 Safefree(PL_scopestack);
2955 Safefree(PL_savestack);
2956 Safefree(PL_retstack);
2960 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2971 lex_start(PL_linestr);
2973 PL_subname = newSVpvn("main",4);
2977 S_init_predump_symbols(pTHX)
2984 sv_setpvn(get_sv("\"", TRUE), " ", 1);
2985 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2986 GvMULTI_on(PL_stdingv);
2987 io = GvIOp(PL_stdingv);
2988 IoIFP(io) = PerlIO_stdin();
2989 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2991 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2993 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2996 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
2998 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
3000 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3002 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3003 GvMULTI_on(PL_stderrgv);
3004 io = GvIOp(PL_stderrgv);
3005 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
3006 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
3008 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3010 PL_statname = NEWSV(66,0); /* last filename we did stat on */
3013 PL_osname = savepv(OSNAME);
3017 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3024 argc--,argv++; /* skip name of script */
3025 if (PL_doswitches) {
3026 for (; argc > 0 && **argv == '-'; argc--,argv++) {
3029 if (argv[0][1] == '-' && !argv[0][2]) {
3033 if (s = strchr(argv[0], '=')) {
3035 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
3038 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
3041 PL_toptarget = NEWSV(0,0);
3042 sv_upgrade(PL_toptarget, SVt_PVFM);
3043 sv_setpvn(PL_toptarget, "", 0);
3044 PL_bodytarget = NEWSV(0,0);
3045 sv_upgrade(PL_bodytarget, SVt_PVFM);
3046 sv_setpvn(PL_bodytarget, "", 0);
3047 PL_formtarget = PL_bodytarget;
3050 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
3051 sv_setpv(GvSV(tmpgv),PL_origfilename);
3052 magicname("0", "0", 1);
3054 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
3056 sv_setpv(GvSV(tmpgv), os2_execname());
3058 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
3060 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
3061 GvMULTI_on(PL_argvgv);
3062 (void)gv_AVadd(PL_argvgv);
3063 av_clear(GvAVn(PL_argvgv));
3064 for (; argc > 0; argc--,argv++) {
3065 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
3068 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
3070 GvMULTI_on(PL_envgv);
3071 hv = GvHVn(PL_envgv);
3072 hv_magic(hv, PL_envgv, 'E');
3073 #if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
3074 /* Note that if the supplied env parameter is actually a copy
3075 of the global environ then it may now point to free'd memory
3076 if the environment has been modified since. To avoid this
3077 problem we treat env==NULL as meaning 'use the default'
3082 environ[0] = Nullch;
3083 for (; *env; env++) {
3084 if (!(s = strchr(*env,'=')))
3090 sv = newSVpv(s--,0);
3091 (void)hv_store(hv, *env, s - *env, sv, 0);
3093 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
3094 /* Sins of the RTL. See note in my_setenv(). */
3095 (void)PerlEnv_putenv(savepv(*env));
3099 #ifdef DYNAMIC_ENV_FETCH
3100 HvNAME(hv) = savepv(ENV_HV_NAME);
3104 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
3105 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3109 S_init_perllib(pTHX)
3114 s = PerlEnv_getenv("PERL5LIB");
3118 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
3120 /* Treat PERL5?LIB as a possible search list logical name -- the
3121 * "natural" VMS idiom for a Unix path string. We allow each
3122 * element to be a set of |-separated directories for compatibility.
3126 if (my_trnlnm("PERL5LIB",buf,0))
3127 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
3129 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
3133 /* Use the ~-expanded versions of APPLLIB (undocumented),
3134 ARCHLIB PRIVLIB SITEARCH and SITELIB
3137 incpush(APPLLIB_EXP, TRUE);
3141 incpush(ARCHLIB_EXP, FALSE);
3144 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
3147 incpush(PRIVLIB_EXP, TRUE);
3149 incpush(PRIVLIB_EXP, FALSE);
3153 incpush(SITELIB_EXP, TRUE); /* XXX Win32 needs inc_version_list support */
3157 char *path = SITELIB_EXP;
3162 if (strrchr(buf,'/')) /* XXX Hack, Configure var needed */
3163 *strrchr(buf,'/') = '\0';
3169 #if defined(PERL_VENDORLIB_EXP)
3171 incpush(PERL_VENDORLIB_EXP, TRUE);
3173 incpush(PERL_VENDORLIB_EXP, FALSE);
3177 incpush(".", FALSE);
3181 # define PERLLIB_SEP ';'
3184 # define PERLLIB_SEP '|'
3186 # define PERLLIB_SEP ':'
3189 #ifndef PERLLIB_MANGLE
3190 # define PERLLIB_MANGLE(s,n) (s)
3194 S_incpush(pTHX_ char *p, int addsubdirs)
3196 SV *subdir = Nullsv;
3202 subdir = sv_newmortal();
3205 /* Break at all separators */
3207 SV *libdir = NEWSV(55,0);
3210 /* skip any consecutive separators */
3211 while ( *p == PERLLIB_SEP ) {
3212 /* Uncomment the next line for PATH semantics */
3213 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3217 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3218 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3223 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3224 p = Nullch; /* break out */
3228 * BEFORE pushing libdir onto @INC we may first push version- and
3229 * archname-specific sub-directories.
3232 #ifdef PERL_INC_VERSION_LIST
3233 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3234 const char *incverlist[] = { PERL_INC_VERSION_LIST };
3235 const char **incver;
3237 struct stat tmpstatbuf;
3242 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3244 while (unix[len-1] == '/') len--; /* Cosmetic */
3245 sv_usepvn(libdir,unix,len);
3248 PerlIO_printf(Perl_error_log,
3249 "Failed to unixify @INC element \"%s\"\n",
3252 /* .../version/archname if -d .../version/archname */
3253 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT"/%s", libdir,
3254 (int)PERL_REVISION, (int)PERL_VERSION,
3255 (int)PERL_SUBVERSION, ARCHNAME);
3256 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3257 S_ISDIR(tmpstatbuf.st_mode))
3258 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3260 /* .../version if -d .../version */
3261 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT, libdir,
3262 (int)PERL_REVISION, (int)PERL_VERSION,
3263 (int)PERL_SUBVERSION);
3264 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3265 S_ISDIR(tmpstatbuf.st_mode))
3266 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3268 /* .../archname if -d .../archname */
3269 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, ARCHNAME);
3270 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3271 S_ISDIR(tmpstatbuf.st_mode))
3272 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3274 #ifdef PERL_INC_VERSION_LIST
3275 for (incver = incverlist; *incver; incver++) {
3276 /* .../xxx if -d .../xxx */
3277 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, *incver);
3278 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3279 S_ISDIR(tmpstatbuf.st_mode))
3280 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3285 /* finally push this lib directory on the end of @INC */
3286 av_push(GvAVn(PL_incgv), libdir);
3291 STATIC struct perl_thread *
3292 S_init_main_thread(pTHX)
3294 #if !defined(PERL_IMPLICIT_CONTEXT)
3295 struct perl_thread *thr;
3299 Newz(53, thr, 1, struct perl_thread);
3300 PL_curcop = &PL_compiling;
3301 thr->interp = PERL_GET_INTERP;
3302 thr->cvcache = newHV();
3303 thr->threadsv = newAV();
3304 /* thr->threadsvp is set when find_threadsv is called */
3305 thr->specific = newAV();
3306 thr->flags = THRf_R_JOINABLE;
3307 MUTEX_INIT(&thr->mutex);
3308 /* Handcraft thrsv similarly to mess_sv */
3309 New(53, PL_thrsv, 1, SV);
3310 Newz(53, xpv, 1, XPV);
3311 SvFLAGS(PL_thrsv) = SVt_PV;
3312 SvANY(PL_thrsv) = (void*)xpv;
3313 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3314 SvPVX(PL_thrsv) = (char*)thr;
3315 SvCUR_set(PL_thrsv, sizeof(thr));
3316 SvLEN_set(PL_thrsv, sizeof(thr));
3317 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3318 thr->oursv = PL_thrsv;
3319 PL_chopset = " \n-";
3322 MUTEX_LOCK(&PL_threads_mutex);
3327 MUTEX_UNLOCK(&PL_threads_mutex);
3329 #ifdef HAVE_THREAD_INTERN
3330 Perl_init_thread_intern(thr);
3333 #ifdef SET_THREAD_SELF
3334 SET_THREAD_SELF(thr);
3336 thr->self = pthread_self();
3337 #endif /* SET_THREAD_SELF */
3341 * These must come after the SET_THR because sv_setpvn does
3342 * SvTAINT and the taint fields require dTHR.
3344 PL_toptarget = NEWSV(0,0);
3345 sv_upgrade(PL_toptarget, SVt_PVFM);
3346 sv_setpvn(PL_toptarget, "", 0);
3347 PL_bodytarget = NEWSV(0,0);
3348 sv_upgrade(PL_bodytarget, SVt_PVFM);
3349 sv_setpvn(PL_bodytarget, "", 0);
3350 PL_formtarget = PL_bodytarget;
3351 thr->errsv = newSVpvn("", 0);
3352 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
3355 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3356 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3357 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3358 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3359 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3361 PL_reginterp_cnt = 0;
3365 #endif /* USE_THREADS */
3368 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3372 line_t oldline = CopLINE(PL_curcop);
3378 while (AvFILL(paramList) >= 0) {
3379 cv = (CV*)av_shift(paramList);
3381 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
3385 (void)SvPV(atsv, len);
3388 PL_curcop = &PL_compiling;
3389 CopLINE_set(PL_curcop, oldline);
3390 if (paramList == PL_beginav)
3391 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3393 Perl_sv_catpvf(aTHX_ atsv,
3394 "%s failed--call queue aborted",
3395 paramList == PL_checkav ? "CHECK"
3396 : paramList == PL_initav ? "INIT"
3398 while (PL_scopestack_ix > oldscope)
3400 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
3407 /* my_exit() was called */
3408 while (PL_scopestack_ix > oldscope)
3411 PL_curstash = PL_defstash;
3412 PL_curcop = &PL_compiling;
3413 CopLINE_set(PL_curcop, oldline);
3414 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3415 if (paramList == PL_beginav)
3416 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3418 Perl_croak(aTHX_ "%s failed--call queue aborted",
3419 paramList == PL_checkav ? "CHECK"
3420 : paramList == PL_initav ? "INIT"
3427 PL_curcop = &PL_compiling;
3428 CopLINE_set(PL_curcop, oldline);
3431 PerlIO_printf(Perl_error_log, "panic: restartop\n");
3439 S_call_list_body(pTHX_ va_list args)
3442 CV *cv = va_arg(args, CV*);
3444 PUSHMARK(PL_stack_sp);
3445 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3450 Perl_my_exit(pTHX_ U32 status)
3454 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3455 thr, (unsigned long) status));
3464 STATUS_NATIVE_SET(status);
3471 Perl_my_failure_exit(pTHX)
3474 if (vaxc$errno & 1) {
3475 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3476 STATUS_NATIVE_SET(44);
3479 if (!vaxc$errno && errno) /* unlikely */
3480 STATUS_NATIVE_SET(44);
3482 STATUS_NATIVE_SET(vaxc$errno);
3487 STATUS_POSIX_SET(errno);
3489 exitstatus = STATUS_POSIX >> 8;
3490 if (exitstatus & 255)
3491 STATUS_POSIX_SET(exitstatus);
3493 STATUS_POSIX_SET(255);
3500 S_my_exit_jump(pTHX)
3503 register PERL_CONTEXT *cx;
3508 SvREFCNT_dec(PL_e_script);
3509 PL_e_script = Nullsv;
3512 POPSTACK_TO(PL_mainstack);
3513 if (cxstack_ix >= 0) {
3516 POPBLOCK(cx,PL_curpm);
3528 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3531 p = SvPVX(PL_e_script);
3532 nl = strchr(p, '\n');
3533 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3535 filter_del(read_e_script);
3538 sv_catpvn(buf_sv, p, nl-p);
3539 sv_chop(PL_e_script, nl);