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);
36 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
43 #define perl_construct Perl_construct
44 #define perl_parse Perl_parse
45 #define perl_run Perl_run
46 #define perl_destruct Perl_destruct
47 #define perl_free Perl_free
50 #ifdef PERL_IMPLICIT_SYS
52 perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
53 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
54 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
55 struct IPerlDir* ipD, struct IPerlSock* ipS,
56 struct IPerlProc* ipP)
58 PerlInterpreter *my_perl;
60 my_perl = (PerlInterpreter*)new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd,
61 ipLIO, ipD, ipS, ipP);
62 PERL_SET_INTERP(my_perl);
64 /* New() needs interpreter, so call malloc() instead */
65 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
66 PERL_SET_INTERP(my_perl);
67 Zero(my_perl, 1, PerlInterpreter);
84 =for apidoc perl_alloc
86 Allocates a new Perl interpreter. See L<perlembed>.
94 PerlInterpreter *my_perl;
96 /* New() needs interpreter, so call malloc() instead */
97 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
98 PERL_SET_INTERP(my_perl);
99 Zero(my_perl, 1, PerlInterpreter);
102 #endif /* PERL_IMPLICIT_SYS */
105 =for apidoc perl_construct
107 Initializes a new Perl interpreter. See L<perlembed>.
113 perl_construct(pTHXx)
118 struct perl_thread *thr = NULL;
119 #endif /* FAKE_THREADS */
120 #endif /* USE_THREADS */
124 PL_perl_destruct_level = 1;
126 if (PL_perl_destruct_level > 0)
130 /* Init the real globals (and main thread)? */
134 #ifdef ALLOC_THREAD_KEY
137 if (pthread_key_create(&PL_thr_key, 0))
138 Perl_croak(aTHX_ "panic: pthread_key_create");
140 MUTEX_INIT(&PL_sv_mutex);
142 * Safe to use basic SV functions from now on (though
143 * not things like mortals or tainting yet).
145 MUTEX_INIT(&PL_eval_mutex);
146 COND_INIT(&PL_eval_cond);
147 MUTEX_INIT(&PL_threads_mutex);
148 COND_INIT(&PL_nthreads_cond);
149 #ifdef EMULATE_ATOMIC_REFCOUNTS
150 MUTEX_INIT(&PL_svref_mutex);
151 #endif /* EMULATE_ATOMIC_REFCOUNTS */
153 MUTEX_INIT(&PL_cred_mutex);
155 thr = init_main_thread();
156 #endif /* USE_THREADS */
158 PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
160 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
162 PL_linestr = NEWSV(65,79);
163 sv_upgrade(PL_linestr,SVt_PVIV);
165 if (!SvREADONLY(&PL_sv_undef)) {
166 /* set read-only and try to insure than we wont see REFCNT==0
169 SvREADONLY_on(&PL_sv_undef);
170 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
172 sv_setpv(&PL_sv_no,PL_No);
174 SvREADONLY_on(&PL_sv_no);
175 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
177 sv_setpv(&PL_sv_yes,PL_Yes);
179 SvREADONLY_on(&PL_sv_yes);
180 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
185 /* PL_sighandlerp = sighandler; */
187 PL_sighandlerp = Perl_sighandler;
189 PL_pidstatus = newHV();
193 * There is no way we can refer to them from Perl so close them to save
194 * space. The other alternative would be to provide STDAUX and STDPRN
197 (void)fclose(stdaux);
198 (void)fclose(stdprn);
202 PL_nrs = newSVpvn("\n", 1);
203 PL_rs = SvREFCNT_inc(PL_nrs);
208 PL_lex_state = LEX_NOTPARSING;
214 SET_NUMERIC_STANDARD();
218 PL_patchlevel = NEWSV(0,4);
219 SvUPGRADE(PL_patchlevel, SVt_PVNV);
220 if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
221 SvGROW(PL_patchlevel,24);
222 s = (U8*)SvPVX(PL_patchlevel);
223 s = uv_to_utf8(s, (UV)PERL_REVISION);
224 s = uv_to_utf8(s, (UV)PERL_VERSION);
225 s = uv_to_utf8(s, (UV)PERL_SUBVERSION);
227 SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel));
228 SvPOK_on(PL_patchlevel);
229 SvNVX(PL_patchlevel) = (NV)PERL_REVISION
230 + ((NV)PERL_VERSION / (NV)1000)
231 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
232 + ((NV)PERL_SUBVERSION / (NV)1000000)
235 SvNOK_on(PL_patchlevel); /* dual valued */
236 SvUTF8_on(PL_patchlevel);
237 SvREADONLY_on(PL_patchlevel);
240 #if defined(LOCAL_PATCH_COUNT)
241 PL_localpatches = local_patches; /* For possible -v */
244 PerlIO_init(); /* Hook to IO system */
246 PL_fdpid = newAV(); /* for remembering popen pids by fd */
247 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
253 =for apidoc perl_destruct
255 Shuts down a Perl interpreter. See L<perlembed>.
264 int destruct_level; /* 0=none, 1=full, 2=full with checks */
270 #endif /* USE_THREADS */
272 /* wait for all pseudo-forked children to finish */
273 PERL_WAIT_FOR_CHILDREN;
277 /* Pass 1 on any remaining threads: detach joinables, join zombies */
279 MUTEX_LOCK(&PL_threads_mutex);
280 DEBUG_S(PerlIO_printf(Perl_debug_log,
281 "perl_destruct: waiting for %d threads...\n",
283 for (t = thr->next; t != thr; t = t->next) {
284 MUTEX_LOCK(&t->mutex);
285 switch (ThrSTATE(t)) {
288 DEBUG_S(PerlIO_printf(Perl_debug_log,
289 "perl_destruct: joining zombie %p\n", t));
290 ThrSETSTATE(t, THRf_DEAD);
291 MUTEX_UNLOCK(&t->mutex);
294 * The SvREFCNT_dec below may take a long time (e.g. av
295 * may contain an object scalar whose destructor gets
296 * called) so we have to unlock threads_mutex and start
299 MUTEX_UNLOCK(&PL_threads_mutex);
301 SvREFCNT_dec((SV*)av);
302 DEBUG_S(PerlIO_printf(Perl_debug_log,
303 "perl_destruct: joined zombie %p OK\n", t));
305 case THRf_R_JOINABLE:
306 DEBUG_S(PerlIO_printf(Perl_debug_log,
307 "perl_destruct: detaching thread %p\n", t));
308 ThrSETSTATE(t, THRf_R_DETACHED);
310 * We unlock threads_mutex and t->mutex in the opposite order
311 * from which we locked them just so that DETACH won't
312 * deadlock if it panics. It's only a breach of good style
313 * not a bug since they are unlocks not locks.
315 MUTEX_UNLOCK(&PL_threads_mutex);
317 MUTEX_UNLOCK(&t->mutex);
320 DEBUG_S(PerlIO_printf(Perl_debug_log,
321 "perl_destruct: ignoring %p (state %u)\n",
323 MUTEX_UNLOCK(&t->mutex);
324 /* fall through and out */
327 /* We leave the above "Pass 1" loop with threads_mutex still locked */
329 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
330 while (PL_nthreads > 1)
332 DEBUG_S(PerlIO_printf(Perl_debug_log,
333 "perl_destruct: final wait for %d threads\n",
335 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
337 /* At this point, we're the last thread */
338 MUTEX_UNLOCK(&PL_threads_mutex);
339 DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
340 MUTEX_DESTROY(&PL_threads_mutex);
341 COND_DESTROY(&PL_nthreads_cond);
342 #endif /* !defined(FAKE_THREADS) */
343 #endif /* USE_THREADS */
345 destruct_level = PL_perl_destruct_level;
349 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
351 if (destruct_level < i)
360 /* We must account for everything. */
362 /* Destroy the main CV and syntax tree */
364 PL_curpad = AvARRAY(PL_comppad);
365 op_free(PL_main_root);
366 PL_main_root = Nullop;
368 PL_curcop = &PL_compiling;
369 PL_main_start = Nullop;
370 SvREFCNT_dec(PL_main_cv);
374 if (PL_sv_objcount) {
376 * Try to destruct global references. We do this first so that the
377 * destructors and destructees still exist. Some sv's might remain.
378 * Non-referenced objects are on their own.
383 /* unhook hooks which will soon be, or use, destroyed data */
384 SvREFCNT_dec(PL_warnhook);
385 PL_warnhook = Nullsv;
386 SvREFCNT_dec(PL_diehook);
389 /* call exit list functions */
390 while (PL_exitlistlen-- > 0)
391 PL_exitlist[PL_exitlistlen].fn(aTHXo_ PL_exitlist[PL_exitlistlen].ptr);
393 Safefree(PL_exitlist);
395 if (destruct_level == 0){
397 DEBUG_P(debprofdump());
399 /* The exit() function will do everything that needs doing. */
403 /* loosen bonds of global variables */
406 (void)PerlIO_close(PL_rsfp);
410 /* Filters for program text */
411 SvREFCNT_dec(PL_rsfp_filters);
412 PL_rsfp_filters = Nullav;
415 PL_preprocess = FALSE;
421 PL_doswitches = FALSE;
422 PL_dowarn = G_WARN_OFF;
423 PL_doextract = FALSE;
424 PL_sawampersand = FALSE; /* must save all match strings */
427 Safefree(PL_inplace);
429 SvREFCNT_dec(PL_patchlevel);
432 SvREFCNT_dec(PL_e_script);
433 PL_e_script = Nullsv;
436 /* magical thingies */
438 Safefree(PL_ofs); /* $, */
441 Safefree(PL_ors); /* $\ */
444 SvREFCNT_dec(PL_rs); /* $/ */
447 SvREFCNT_dec(PL_nrs); /* $/ helper */
450 PL_multiline = 0; /* $* */
451 Safefree(PL_osname); /* $^O */
454 SvREFCNT_dec(PL_statname);
455 PL_statname = Nullsv;
458 /* defgv, aka *_ should be taken care of elsewhere */
460 /* clean up after study() */
461 SvREFCNT_dec(PL_lastscream);
462 PL_lastscream = Nullsv;
463 Safefree(PL_screamfirst);
465 Safefree(PL_screamnext);
469 Safefree(PL_efloatbuf);
470 PL_efloatbuf = Nullch;
473 /* startup and shutdown function lists */
474 SvREFCNT_dec(PL_beginav);
475 SvREFCNT_dec(PL_endav);
476 SvREFCNT_dec(PL_checkav);
477 SvREFCNT_dec(PL_initav);
483 /* shortcuts just get cleared */
489 PL_argvoutgv = Nullgv;
491 PL_stderrgv = Nullgv;
492 PL_last_in_gv = Nullgv;
494 PL_debstash = Nullhv;
496 /* reset so print() ends up where we expect */
499 SvREFCNT_dec(PL_argvout_stack);
500 PL_argvout_stack = Nullav;
502 SvREFCNT_dec(PL_modglobal);
503 PL_modglobal = Nullhv;
504 SvREFCNT_dec(PL_preambleav);
505 PL_preambleav = Nullav;
506 SvREFCNT_dec(PL_subname);
508 SvREFCNT_dec(PL_linestr);
510 SvREFCNT_dec(PL_pidstatus);
511 PL_pidstatus = Nullhv;
512 SvREFCNT_dec(PL_toptarget);
513 PL_toptarget = Nullsv;
514 SvREFCNT_dec(PL_bodytarget);
515 PL_bodytarget = Nullsv;
516 PL_formtarget = Nullsv;
518 /* free locale stuff */
519 #ifdef USE_LOCALE_COLLATE
520 Safefree(PL_collation_name);
521 PL_collation_name = Nullch;
524 #ifdef USE_LOCALE_NUMERIC
525 Safefree(PL_numeric_name);
526 PL_numeric_name = Nullch;
529 /* clear utf8 character classes */
530 SvREFCNT_dec(PL_utf8_alnum);
531 SvREFCNT_dec(PL_utf8_alnumc);
532 SvREFCNT_dec(PL_utf8_ascii);
533 SvREFCNT_dec(PL_utf8_alpha);
534 SvREFCNT_dec(PL_utf8_space);
535 SvREFCNT_dec(PL_utf8_cntrl);
536 SvREFCNT_dec(PL_utf8_graph);
537 SvREFCNT_dec(PL_utf8_digit);
538 SvREFCNT_dec(PL_utf8_upper);
539 SvREFCNT_dec(PL_utf8_lower);
540 SvREFCNT_dec(PL_utf8_print);
541 SvREFCNT_dec(PL_utf8_punct);
542 SvREFCNT_dec(PL_utf8_xdigit);
543 SvREFCNT_dec(PL_utf8_mark);
544 SvREFCNT_dec(PL_utf8_toupper);
545 SvREFCNT_dec(PL_utf8_tolower);
546 PL_utf8_alnum = Nullsv;
547 PL_utf8_alnumc = Nullsv;
548 PL_utf8_ascii = Nullsv;
549 PL_utf8_alpha = Nullsv;
550 PL_utf8_space = Nullsv;
551 PL_utf8_cntrl = Nullsv;
552 PL_utf8_graph = Nullsv;
553 PL_utf8_digit = Nullsv;
554 PL_utf8_upper = Nullsv;
555 PL_utf8_lower = Nullsv;
556 PL_utf8_print = Nullsv;
557 PL_utf8_punct = Nullsv;
558 PL_utf8_xdigit = Nullsv;
559 PL_utf8_mark = Nullsv;
560 PL_utf8_toupper = Nullsv;
561 PL_utf8_totitle = Nullsv;
562 PL_utf8_tolower = Nullsv;
564 if (!specialWARN(PL_compiling.cop_warnings))
565 SvREFCNT_dec(PL_compiling.cop_warnings);
566 PL_compiling.cop_warnings = Nullsv;
568 /* Prepare to destruct main symbol table. */
573 SvREFCNT_dec(PL_curstname);
574 PL_curstname = Nullsv;
576 /* clear queued errors */
577 SvREFCNT_dec(PL_errors);
581 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
582 if (PL_scopestack_ix != 0)
583 Perl_warner(aTHX_ WARN_INTERNAL,
584 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
585 (long)PL_scopestack_ix);
586 if (PL_savestack_ix != 0)
587 Perl_warner(aTHX_ WARN_INTERNAL,
588 "Unbalanced saves: %ld more saves than restores\n",
589 (long)PL_savestack_ix);
590 if (PL_tmps_floor != -1)
591 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
592 (long)PL_tmps_floor + 1);
593 if (cxstack_ix != -1)
594 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
595 (long)cxstack_ix + 1);
598 /* Now absolutely destruct everything, somehow or other, loops or no. */
600 SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */
601 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
602 while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
603 last_sv_count = PL_sv_count;
606 SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
607 SvFLAGS(PL_fdpid) |= SVt_PVAV;
608 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
609 SvFLAGS(PL_strtab) |= SVt_PVHV;
611 AvREAL_off(PL_fdpid); /* no surviving entries */
612 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
615 /* Destruct the global string table. */
617 /* Yell and reset the HeVAL() slots that are still holding refcounts,
618 * so that sv_free() won't fail on them.
626 max = HvMAX(PL_strtab);
627 array = HvARRAY(PL_strtab);
630 if (hent && ckWARN_d(WARN_INTERNAL)) {
631 Perl_warner(aTHX_ WARN_INTERNAL,
632 "Unbalanced string table refcount: (%d) for \"%s\"",
633 HeVAL(hent) - Nullsv, HeKEY(hent));
634 HeVAL(hent) = Nullsv;
644 SvREFCNT_dec(PL_strtab);
646 /* free special SVs */
648 SvREFCNT(&PL_sv_yes) = 0;
649 sv_clear(&PL_sv_yes);
650 SvANY(&PL_sv_yes) = NULL;
652 SvREFCNT(&PL_sv_no) = 0;
654 SvANY(&PL_sv_no) = NULL;
656 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
657 Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
661 /* No SVs have survived, need to clean out */
662 Safefree(PL_origfilename);
663 Safefree(PL_reg_start_tmp);
665 Safefree(PL_reg_curpm);
666 Safefree(PL_reg_poscache);
667 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
668 Safefree(PL_op_mask);
670 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
672 DEBUG_P(debprofdump());
674 MUTEX_DESTROY(&PL_strtab_mutex);
675 MUTEX_DESTROY(&PL_sv_mutex);
676 MUTEX_DESTROY(&PL_eval_mutex);
677 MUTEX_DESTROY(&PL_cred_mutex);
678 COND_DESTROY(&PL_eval_cond);
679 #ifdef EMULATE_ATOMIC_REFCOUNTS
680 MUTEX_DESTROY(&PL_svref_mutex);
681 #endif /* EMULATE_ATOMIC_REFCOUNTS */
683 /* As the penultimate thing, free the non-arena SV for thrsv */
684 Safefree(SvPVX(PL_thrsv));
685 Safefree(SvANY(PL_thrsv));
688 #endif /* USE_THREADS */
690 /* As the absolutely last thing, free the non-arena SV for mess() */
693 /* it could have accumulated taint magic */
694 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
697 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
698 moremagic = mg->mg_moremagic;
699 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
700 Safefree(mg->mg_ptr);
704 /* we know that type >= SVt_PV */
705 SvOOK_off(PL_mess_sv);
706 Safefree(SvPVX(PL_mess_sv));
707 Safefree(SvANY(PL_mess_sv));
708 Safefree(PL_mess_sv);
714 =for apidoc perl_free
716 Releases a Perl interpreter. See L<perlembed>.
724 #if defined(PERL_OBJECT)
732 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
734 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
735 PL_exitlist[PL_exitlistlen].fn = fn;
736 PL_exitlist[PL_exitlistlen].ptr = ptr;
741 =for apidoc perl_parse
743 Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
749 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
759 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
762 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
763 setuid perl scripts securely.\n");
767 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
768 _dyld_lookup_and_bind
769 ("__environ", (unsigned long *) &environ_pointer, NULL);
774 #ifndef VMS /* VMS doesn't have environ array */
775 PL_origenviron = environ;
780 /* Come here if running an undumped a.out. */
782 PL_origfilename = savepv(argv[0]);
783 PL_do_undump = FALSE;
784 cxstack_ix = -1; /* start label stack again */
786 init_postdump_symbols(argc,argv,env);
791 PL_curpad = AvARRAY(PL_comppad);
792 op_free(PL_main_root);
793 PL_main_root = Nullop;
795 PL_main_start = Nullop;
796 SvREFCNT_dec(PL_main_cv);
800 oldscope = PL_scopestack_ix;
801 PL_dowarn = G_WARN_OFF;
803 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_parse_body),
808 call_list(oldscope, PL_checkav);
814 /* my_exit() was called */
815 while (PL_scopestack_ix > oldscope)
818 PL_curstash = PL_defstash;
820 call_list(oldscope, PL_checkav);
821 return STATUS_NATIVE_EXPORT;
823 PerlIO_printf(Perl_error_log, "panic: top_env\n");
830 S_parse_body(pTHX_ va_list args)
833 int argc = PL_origargc;
834 char **argv = PL_origargv;
835 char **env = va_arg(args, char**);
836 char *scriptname = NULL;
838 VOL bool dosearch = FALSE;
843 char *cddir = Nullch;
845 XSINIT_t xsinit = va_arg(args, XSINIT_t);
847 sv_setpvn(PL_linestr,"",0);
848 sv = newSVpvn("",0); /* first used for -I flags */
852 for (argc--,argv++; argc > 0; argc--,argv++) {
853 if (argv[0][0] != '-' || !argv[0][1])
857 validarg = " PHOOEY ";
864 #ifndef PERL_STRICT_CR
889 if (s = moreswitches(s))
899 if (PL_euid != PL_uid || PL_egid != PL_gid)
900 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
902 PL_e_script = newSVpvn("",0);
903 filter_add(read_e_script, NULL);
906 sv_catpv(PL_e_script, s);
908 sv_catpv(PL_e_script, argv[1]);
912 Perl_croak(aTHX_ "No code specified for -e");
913 sv_catpv(PL_e_script, "\n");
916 case 'I': /* -I handled both here and in moreswitches() */
918 if (!*++s && (s=argv[1]) != Nullch) {
923 STRLEN len = strlen(s);
926 sv_catpvn(sv, "-I", 2);
927 sv_catpvn(sv, p, len);
928 sv_catpvn(sv, " ", 1);
932 Perl_croak(aTHX_ "No directory specified for -I");
936 PL_preprocess = TRUE;
946 PL_preambleav = newAV();
947 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
949 PL_Sv = newSVpv("print myconfig();",0);
951 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
953 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
955 sv_catpv(PL_Sv,"\" Compile-time options:");
957 sv_catpv(PL_Sv," DEBUGGING");
960 sv_catpv(PL_Sv," MULTIPLICITY");
963 sv_catpv(PL_Sv," USE_THREADS");
966 sv_catpv(PL_Sv," USE_ITHREADS");
969 sv_catpv(PL_Sv," USE_64_BITS");
971 # ifdef USE_LONG_DOUBLE
972 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
974 # ifdef USE_LARGE_FILES
975 sv_catpv(PL_Sv," USE_LARGE_FILES");
978 sv_catpv(PL_Sv," USE_SOCKS");
981 sv_catpv(PL_Sv," PERL_OBJECT");
983 # ifdef PERL_IMPLICIT_CONTEXT
984 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
986 # ifdef PERL_IMPLICIT_SYS
987 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
989 sv_catpv(PL_Sv,"\\n\",");
991 #if defined(LOCAL_PATCH_COUNT)
992 if (LOCAL_PATCH_COUNT > 0) {
994 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
995 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
996 if (PL_localpatches[i])
997 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
1001 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
1004 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
1006 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
1009 sv_catpv(PL_Sv, "; \
1011 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
1012 print \" \\%ENV:\\n @env\\n\" if @env; \
1013 print \" \\@INC:\\n @INC\\n\";");
1016 PL_Sv = newSVpv("config_vars(qw(",0);
1017 sv_catpv(PL_Sv, ++s);
1018 sv_catpv(PL_Sv, "))");
1021 av_push(PL_preambleav, PL_Sv);
1022 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1025 PL_doextract = TRUE;
1033 if (!*++s || isSPACE(*s)) {
1037 /* catch use of gnu style long options */
1038 if (strEQ(s, "version")) {
1042 if (strEQ(s, "help")) {
1049 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
1055 #ifndef SECURE_INTERNAL_GETENV
1058 (s = PerlEnv_getenv("PERL5OPT")))
1062 if (*s == '-' && *(s+1) == 'T')
1075 if (!strchr("DIMUdmw", *s))
1076 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
1077 s = moreswitches(s);
1083 scriptname = argv[0];
1086 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1088 else if (scriptname == Nullch) {
1090 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1098 open_script(scriptname,dosearch,sv,&fdscript);
1100 validate_suid(validarg, scriptname,fdscript);
1102 #if defined(SIGCHLD) || defined(SIGCLD)
1105 # define SIGCHLD SIGCLD
1107 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1108 if (sigstate == SIG_IGN) {
1109 if (ckWARN(WARN_SIGNAL))
1110 Perl_warner(aTHX_ WARN_SIGNAL,
1111 "Can't ignore signal CHLD, forcing to default");
1112 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1119 if (cddir && PerlDir_chdir(cddir) < 0)
1120 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1124 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1125 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1126 CvUNIQUE_on(PL_compcv);
1128 PL_comppad = newAV();
1129 av_push(PL_comppad, Nullsv);
1130 PL_curpad = AvARRAY(PL_comppad);
1131 PL_comppad_name = newAV();
1132 PL_comppad_name_fill = 0;
1133 PL_min_intro_pending = 0;
1136 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
1137 PL_curpad[0] = (SV*)newAV();
1138 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
1139 CvOWNER(PL_compcv) = 0;
1140 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1141 MUTEX_INIT(CvMUTEXP(PL_compcv));
1142 #endif /* USE_THREADS */
1144 comppadlist = newAV();
1145 AvREAL_off(comppadlist);
1146 av_store(comppadlist, 0, (SV*)PL_comppad_name);
1147 av_store(comppadlist, 1, (SV*)PL_comppad);
1148 CvPADLIST(PL_compcv) = comppadlist;
1150 boot_core_UNIVERSAL();
1152 boot_core_xsutils();
1156 (*xsinit)(aTHXo); /* in case linked C routines want magical variables */
1157 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
1165 init_predump_symbols();
1166 /* init_postdump_symbols not currently designed to be called */
1167 /* more than once (ENV isn't cleared first, for example) */
1168 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
1170 init_postdump_symbols(argc,argv,env);
1174 /* now parse the script */
1176 SETERRNO(0,SS$_NORMAL);
1178 if (yyparse() || PL_error_count) {
1180 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1182 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1186 CopLINE_set(PL_curcop, 0);
1187 PL_curstash = PL_defstash;
1188 PL_preprocess = FALSE;
1190 SvREFCNT_dec(PL_e_script);
1191 PL_e_script = Nullsv;
1194 /* now that script is parsed, we can modify record separator */
1195 SvREFCNT_dec(PL_rs);
1196 PL_rs = SvREFCNT_inc(PL_nrs);
1197 sv_setsv(get_sv("/", TRUE), PL_rs);
1202 SAVECOPFILE(PL_curcop);
1203 SAVECOPLINE(PL_curcop);
1204 gv_check(PL_defstash);
1211 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1212 dump_mstats("after compilation:");
1221 =for apidoc perl_run
1223 Tells a Perl interpreter to run. See L<perlembed>.
1239 oldscope = PL_scopestack_ix;
1242 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
1245 cxstack_ix = -1; /* start context stack again */
1247 case 0: /* normal completion */
1248 case 2: /* my_exit() */
1249 while (PL_scopestack_ix > oldscope)
1252 PL_curstash = PL_defstash;
1253 if (PL_endav && !PL_minus_c)
1254 call_list(oldscope, PL_endav);
1256 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1257 dump_mstats("after execution: ");
1259 return STATUS_NATIVE_EXPORT;
1262 POPSTACK_TO(PL_mainstack);
1265 PerlIO_printf(Perl_error_log, "panic: restartop\n");
1275 S_run_body(pTHX_ va_list args)
1278 I32 oldscope = va_arg(args, I32);
1280 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1281 PL_sawampersand ? "Enabling" : "Omitting"));
1283 if (!PL_restartop) {
1284 DEBUG_x(dump_all());
1285 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1286 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1290 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1293 if (PERLDB_SINGLE && PL_DBsingle)
1294 sv_setiv(PL_DBsingle, 1);
1296 call_list(oldscope, PL_initav);
1302 PL_op = PL_restartop;
1306 else if (PL_main_start) {
1307 CvDEPTH(PL_main_cv) = 1;
1308 PL_op = PL_main_start;
1318 =for apidoc p||get_sv
1320 Returns the SV of the specified Perl scalar. If C<create> is set and the
1321 Perl variable does not exist then it will be created. If C<create> is not
1322 set and the variable does not exist then NULL is returned.
1328 Perl_get_sv(pTHX_ const char *name, I32 create)
1332 if (name[1] == '\0' && !isALPHA(name[0])) {
1333 PADOFFSET tmp = find_threadsv(name);
1334 if (tmp != NOT_IN_PAD) {
1336 return THREADSV(tmp);
1339 #endif /* USE_THREADS */
1340 gv = gv_fetchpv(name, create, SVt_PV);
1347 =for apidoc p||get_av
1349 Returns the AV of the specified Perl array. If C<create> is set and the
1350 Perl variable does not exist then it will be created. If C<create> is not
1351 set and the variable does not exist then NULL is returned.
1357 Perl_get_av(pTHX_ const char *name, I32 create)
1359 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1368 =for apidoc p||get_hv
1370 Returns the HV of the specified Perl hash. If C<create> is set and the
1371 Perl variable does not exist then it will be created. If C<create> is not
1372 set and the variable does not exist then NULL is returned.
1378 Perl_get_hv(pTHX_ const char *name, I32 create)
1380 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1389 =for apidoc p||get_cv
1391 Returns the CV of the specified Perl subroutine. If C<create> is set and
1392 the Perl subroutine does not exist then it will be declared (which has the
1393 same effect as saying C<sub name;>). If C<create> is not set and the
1394 subroutine does not exist then NULL is returned.
1400 Perl_get_cv(pTHX_ const char *name, I32 create)
1402 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1403 /* XXX unsafe for threads if eval_owner isn't held */
1404 /* XXX this is probably not what they think they're getting.
1405 * It has the same effect as "sub name;", i.e. just a forward
1407 if (create && !GvCVu(gv))
1408 return newSUB(start_subparse(FALSE, 0),
1409 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1417 /* Be sure to refetch the stack pointer after calling these routines. */
1420 =for apidoc p||call_argv
1422 Performs a callback to the specified Perl sub. See L<perlcall>.
1428 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1430 /* See G_* flags in cop.h */
1431 /* null terminated arg list */
1438 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1443 return call_pv(sub_name, flags);
1447 =for apidoc p||call_pv
1449 Performs a callback to the specified Perl sub. See L<perlcall>.
1455 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1456 /* name of the subroutine */
1457 /* See G_* flags in cop.h */
1459 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1463 =for apidoc p||call_method
1465 Performs a callback to the specified Perl method. The blessed object must
1466 be on the stack. See L<perlcall>.
1472 Perl_call_method(pTHX_ const char *methname, I32 flags)
1473 /* name of the subroutine */
1474 /* See G_* flags in cop.h */
1482 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1487 return call_sv(*PL_stack_sp--, flags);
1490 /* May be called with any of a CV, a GV, or an SV containing the name. */
1492 =for apidoc p||call_sv
1494 Performs a callback to the Perl sub whose name is in the SV. See
1501 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1503 /* See G_* flags in cop.h */
1506 LOGOP myop; /* fake syntax tree node */
1510 bool oldcatch = CATCH_GET;
1515 if (flags & G_DISCARD) {
1520 Zero(&myop, 1, LOGOP);
1521 myop.op_next = Nullop;
1522 if (!(flags & G_NOARGS))
1523 myop.op_flags |= OPf_STACKED;
1524 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1525 (flags & G_ARRAY) ? OPf_WANT_LIST :
1530 EXTEND(PL_stack_sp, 1);
1531 *++PL_stack_sp = sv;
1533 oldscope = PL_scopestack_ix;
1535 if (PERLDB_SUB && PL_curstash != PL_debstash
1536 /* Handle first BEGIN of -d. */
1537 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1538 /* Try harder, since this may have been a sighandler, thus
1539 * curstash may be meaningless. */
1540 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1541 && !(flags & G_NODEBUG))
1542 PL_op->op_private |= OPpENTERSUB_DB;
1544 if (!(flags & G_EVAL)) {
1546 call_xbody((OP*)&myop, FALSE);
1547 retval = PL_stack_sp - (PL_stack_base + oldmark);
1548 CATCH_SET(oldcatch);
1551 cLOGOP->op_other = PL_op;
1553 /* we're trying to emulate pp_entertry() here */
1555 register PERL_CONTEXT *cx;
1556 I32 gimme = GIMME_V;
1561 push_return(PL_op->op_next);
1562 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1564 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1566 PL_in_eval = EVAL_INEVAL;
1567 if (flags & G_KEEPERR)
1568 PL_in_eval |= EVAL_KEEPERR;
1575 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1579 retval = PL_stack_sp - (PL_stack_base + oldmark);
1580 if (!(flags & G_KEEPERR))
1587 /* my_exit() was called */
1588 PL_curstash = PL_defstash;
1590 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1591 Perl_croak(aTHX_ "Callback called exit");
1596 PL_op = PL_restartop;
1600 PL_stack_sp = PL_stack_base + oldmark;
1601 if (flags & G_ARRAY)
1605 *++PL_stack_sp = &PL_sv_undef;
1610 if (PL_scopestack_ix > oldscope) {
1614 register PERL_CONTEXT *cx;
1625 if (flags & G_DISCARD) {
1626 PL_stack_sp = PL_stack_base + oldmark;
1636 S_call_body(pTHX_ va_list args)
1638 OP *myop = va_arg(args, OP*);
1639 int is_eval = va_arg(args, int);
1641 call_xbody(myop, is_eval);
1646 S_call_xbody(pTHX_ OP *myop, int is_eval)
1650 if (PL_op == myop) {
1652 PL_op = Perl_pp_entereval(aTHX);
1654 PL_op = Perl_pp_entersub(aTHX);
1660 /* Eval a string. The G_EVAL flag is always assumed. */
1663 =for apidoc p||eval_sv
1665 Tells Perl to C<eval> the string in the SV.
1671 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1673 /* See G_* flags in cop.h */
1676 UNOP myop; /* fake syntax tree node */
1677 I32 oldmark = SP - PL_stack_base;
1684 if (flags & G_DISCARD) {
1691 Zero(PL_op, 1, UNOP);
1692 EXTEND(PL_stack_sp, 1);
1693 *++PL_stack_sp = sv;
1694 oldscope = PL_scopestack_ix;
1696 if (!(flags & G_NOARGS))
1697 myop.op_flags = OPf_STACKED;
1698 myop.op_next = Nullop;
1699 myop.op_type = OP_ENTEREVAL;
1700 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1701 (flags & G_ARRAY) ? OPf_WANT_LIST :
1703 if (flags & G_KEEPERR)
1704 myop.op_flags |= OPf_SPECIAL;
1707 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1711 retval = PL_stack_sp - (PL_stack_base + oldmark);
1712 if (!(flags & G_KEEPERR))
1719 /* my_exit() was called */
1720 PL_curstash = PL_defstash;
1722 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1723 Perl_croak(aTHX_ "Callback called exit");
1728 PL_op = PL_restartop;
1732 PL_stack_sp = PL_stack_base + oldmark;
1733 if (flags & G_ARRAY)
1737 *++PL_stack_sp = &PL_sv_undef;
1742 if (flags & G_DISCARD) {
1743 PL_stack_sp = PL_stack_base + oldmark;
1753 =for apidoc p||eval_pv
1755 Tells Perl to C<eval> the given string and return an SV* result.
1761 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1764 SV* sv = newSVpv(p, 0);
1767 eval_sv(sv, G_SCALAR);
1774 if (croak_on_error && SvTRUE(ERRSV)) {
1776 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1782 /* Require a module. */
1785 =for apidoc p||require_pv
1787 Tells Perl to C<require> a module.
1793 Perl_require_pv(pTHX_ const char *pv)
1797 PUSHSTACKi(PERLSI_REQUIRE);
1799 sv = sv_newmortal();
1800 sv_setpv(sv, "require '");
1803 eval_sv(sv, G_DISCARD);
1809 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1813 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1814 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1818 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
1820 /* This message really ought to be max 23 lines.
1821 * Removed -h because the user already knows that opton. Others? */
1823 static char *usage_msg[] = {
1824 "-0[octal] specify record separator (\\0, if no argument)",
1825 "-a autosplit mode with -n or -p (splits $_ into @F)",
1826 "-C enable native wide character system interfaces",
1827 "-c check syntax only (runs BEGIN and END blocks)",
1828 "-d[:debugger] run program under debugger",
1829 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1830 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1831 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1832 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1833 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1834 "-l[octal] enable line ending processing, specifies line terminator",
1835 "-[mM][-]module execute `use/no module...' before executing program",
1836 "-n assume 'while (<>) { ... }' loop around program",
1837 "-p assume loop like -n but print line also, like sed",
1838 "-P run program through C preprocessor before compilation",
1839 "-s enable rudimentary parsing for switches after programfile",
1840 "-S look for programfile using PATH environment variable",
1841 "-T enable tainting checks",
1842 "-u dump core after parsing program",
1843 "-U allow unsafe operations",
1844 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1845 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1846 "-w enable many useful warnings (RECOMMENDED)",
1847 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1851 char **p = usage_msg;
1853 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1855 printf("\n %s", *p++);
1858 /* This routine handles any switches that can be given during run */
1861 Perl_moreswitches(pTHX_ char *s)
1870 rschar = (U32)scan_oct(s, 4, &numlen);
1871 SvREFCNT_dec(PL_nrs);
1872 if (rschar & ~((U8)~0))
1873 PL_nrs = &PL_sv_undef;
1874 else if (!rschar && numlen >= 2)
1875 PL_nrs = newSVpvn("", 0);
1878 PL_nrs = newSVpvn(&ch, 1);
1883 PL_widesyscalls = TRUE;
1888 PL_splitstr = savepv(s + 1);
1902 if (*s == ':' || *s == '=') {
1903 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1907 PL_perldb = PERLDB_ALL;
1915 if (isALPHA(s[1])) {
1916 static char debopts[] = "psltocPmfrxuLHXDS";
1919 for (s++; *s && (d = strchr(debopts,*s)); s++)
1920 PL_debug |= 1 << (d - debopts);
1923 PL_debug = atoi(s+1);
1924 for (s++; isDIGIT(*s); s++) ;
1926 PL_debug |= 0x80000000;
1929 if (ckWARN_d(WARN_DEBUGGING))
1930 Perl_warner(aTHX_ WARN_DEBUGGING,
1931 "Recompile perl with -DDEBUGGING to use -D switch\n");
1932 for (s++; isALNUM(*s); s++) ;
1938 usage(PL_origargv[0]);
1942 Safefree(PL_inplace);
1943 PL_inplace = savepv(s+1);
1945 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1948 if (*s == '-') /* Additional switches on #! line. */
1952 case 'I': /* -I handled both here and in parse_perl() */
1955 while (*s && isSPACE(*s))
1960 /* ignore trailing spaces (possibly followed by other switches) */
1962 for (e = p; *e && !isSPACE(*e); e++) ;
1966 } while (*p && *p != '-');
1967 e = savepvn(s, e-s);
1975 Perl_croak(aTHX_ "No directory specified for -I");
1983 PL_ors = savepv("\n");
1985 *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
1990 if (RsPARA(PL_nrs)) {
1995 PL_ors = SvPV(PL_nrs, PL_orslen);
1996 PL_ors = savepvn(PL_ors, PL_orslen);
2000 forbid_setid("-M"); /* XXX ? */
2003 forbid_setid("-m"); /* XXX ? */
2008 /* -M-foo == 'no foo' */
2009 if (*s == '-') { use = "no "; ++s; }
2010 sv = newSVpv(use,0);
2012 /* We allow -M'Module qw(Foo Bar)' */
2013 while(isALNUM(*s) || *s==':') ++s;
2015 sv_catpv(sv, start);
2016 if (*(start-1) == 'm') {
2018 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
2019 sv_catpv( sv, " ()");
2022 sv_catpvn(sv, start, s-start);
2023 sv_catpv(sv, " split(/,/,q{");
2029 PL_preambleav = newAV();
2030 av_push(PL_preambleav, sv);
2033 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
2045 PL_doswitches = TRUE;
2050 Perl_croak(aTHX_ "Too late for \"-T\" option");
2054 PL_do_undump = TRUE;
2062 printf(Perl_form(aTHX_ "\nThis is perl, v%v built for %s",
2063 PL_patchlevel, ARCHNAME));
2064 #if defined(LOCAL_PATCH_COUNT)
2065 if (LOCAL_PATCH_COUNT > 0)
2066 printf("\n(with %d registered patch%s, see perl -V for more detail)",
2067 (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
2070 printf("\n\nCopyright 1987-2000, Larry Wall\n");
2072 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
2075 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
2076 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
2079 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
2080 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
2083 printf("atariST series port, ++jrb bammi@cadence.com\n");
2086 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
2089 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
2092 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
2095 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
2098 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
2101 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
2104 printf("MiNT port by Guido Flohr, 1997-1999\n");
2106 #ifdef BINARY_BUILD_NOTICE
2107 BINARY_BUILD_NOTICE;
2110 Perl may be copied only under the terms of either the Artistic License or the\n\
2111 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
2112 Complete documentation for Perl, including FAQ lists, should be found on\n\
2113 this system using `man perl' or `perldoc perl'. If you have access to the\n\
2114 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
2117 if (! (PL_dowarn & G_WARN_ALL_MASK))
2118 PL_dowarn |= G_WARN_ON;
2122 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
2123 PL_compiling.cop_warnings = WARN_ALL ;
2127 PL_dowarn = G_WARN_ALL_OFF;
2128 PL_compiling.cop_warnings = WARN_NONE ;
2133 if (s[1] == '-') /* Additional switches on #! line. */
2138 #if defined(WIN32) || !defined(PERL_STRICT_CR)
2144 #ifdef ALTERNATE_SHEBANG
2145 case 'S': /* OS/2 needs -S on "extproc" line. */
2153 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
2158 /* compliments of Tom Christiansen */
2160 /* unexec() can be found in the Gnu emacs distribution */
2161 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
2164 Perl_my_unexec(pTHX)
2172 prog = newSVpv(BIN_EXP, 0);
2173 sv_catpv(prog, "/perl");
2174 file = newSVpv(PL_origfilename, 0);
2175 sv_catpv(file, ".perldump");
2177 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2178 /* unexec prints msg to stderr in case of failure */
2179 PerlProc_exit(status);
2182 # include <lib$routines.h>
2183 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
2185 ABORT(); /* for use with undump */
2190 /* initialize curinterp */
2195 #ifdef PERL_OBJECT /* XXX kludge */
2198 PL_chopset = " \n-"; \
2199 PL_copline = NOLINE; \
2200 PL_curcop = &PL_compiling;\
2201 PL_curcopdb = NULL; \
2203 PL_dumpindent = 4; \
2204 PL_laststatval = -1; \
2205 PL_laststype = OP_STAT; \
2206 PL_maxscream = -1; \
2207 PL_maxsysfd = MAXSYSFD; \
2208 PL_statname = Nullsv; \
2209 PL_tmps_floor = -1; \
2211 PL_op_mask = NULL; \
2212 PL_laststatval = -1; \
2213 PL_laststype = OP_STAT; \
2214 PL_mess_sv = Nullsv; \
2215 PL_splitstr = " "; \
2216 PL_generation = 100; \
2217 PL_exitlist = NULL; \
2218 PL_exitlistlen = 0; \
2220 PL_in_clean_objs = FALSE; \
2221 PL_in_clean_all = FALSE; \
2222 PL_profiledata = NULL; \
2224 PL_rsfp_filters = Nullav; \
2229 # ifdef MULTIPLICITY
2230 # define PERLVAR(var,type)
2231 # define PERLVARA(var,n,type)
2232 # if defined(PERL_IMPLICIT_CONTEXT)
2233 # if defined(USE_THREADS)
2234 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2235 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2236 # else /* !USE_THREADS */
2237 # define PERLVARI(var,type,init) aTHX->var = init;
2238 # define PERLVARIC(var,type,init) aTHX->var = init;
2239 # endif /* USE_THREADS */
2241 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2242 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2244 # include "intrpvar.h"
2245 # ifndef USE_THREADS
2246 # include "thrdvar.h"
2253 # define PERLVAR(var,type)
2254 # define PERLVARA(var,n,type)
2255 # define PERLVARI(var,type,init) PL_##var = init;
2256 # define PERLVARIC(var,type,init) PL_##var = init;
2257 # include "intrpvar.h"
2258 # ifndef USE_THREADS
2259 # include "thrdvar.h"
2271 S_init_main_stash(pTHX)
2276 /* Note that strtab is a rather special HV. Assumptions are made
2277 about not iterating on it, and not adding tie magic to it.
2278 It is properly deallocated in perl_destruct() */
2279 PL_strtab = newHV();
2281 MUTEX_INIT(&PL_strtab_mutex);
2283 HvSHAREKEYS_off(PL_strtab); /* mandatory */
2284 hv_ksplit(PL_strtab, 512);
2286 PL_curstash = PL_defstash = newHV();
2287 PL_curstname = newSVpvn("main",4);
2288 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2289 SvREFCNT_dec(GvHV(gv));
2290 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2292 HvNAME(PL_defstash) = savepv("main");
2293 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2294 GvMULTI_on(PL_incgv);
2295 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2296 GvMULTI_on(PL_hintgv);
2297 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2298 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2299 GvMULTI_on(PL_errgv);
2300 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2301 GvMULTI_on(PL_replgv);
2302 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
2303 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2304 sv_setpvn(ERRSV, "", 0);
2305 PL_curstash = PL_defstash;
2306 CopSTASH_set(&PL_compiling, PL_defstash);
2307 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2308 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2309 /* We must init $/ before switches are processed. */
2310 sv_setpvn(get_sv("/", TRUE), "\n", 1);
2314 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2322 PL_origfilename = savepv("-e");
2325 /* if find_script() returns, it returns a malloc()-ed value */
2326 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2328 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2329 char *s = scriptname + 8;
2330 *fdscript = atoi(s);
2334 scriptname = savepv(s + 1);
2335 Safefree(PL_origfilename);
2336 PL_origfilename = scriptname;
2341 CopFILE_set(PL_curcop, PL_origfilename);
2342 if (strEQ(PL_origfilename,"-"))
2344 if (*fdscript >= 0) {
2345 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2346 #if defined(HAS_FCNTL) && defined(F_SETFD)
2348 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2351 else if (PL_preprocess) {
2352 char *cpp_cfg = CPPSTDIN;
2353 SV *cpp = newSVpvn("",0);
2354 SV *cmd = NEWSV(0,0);
2356 if (strEQ(cpp_cfg, "cppstdin"))
2357 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2358 sv_catpv(cpp, cpp_cfg);
2360 sv_catpvn(sv, "-I", 2);
2361 sv_catpv(sv,PRIVLIB_EXP);
2364 Perl_sv_setpvf(aTHX_ cmd, "\
2365 sed %s -e \"/^[^#]/b\" \
2366 -e \"/^#[ ]*include[ ]/b\" \
2367 -e \"/^#[ ]*define[ ]/b\" \
2368 -e \"/^#[ ]*if[ ]/b\" \
2369 -e \"/^#[ ]*ifdef[ ]/b\" \
2370 -e \"/^#[ ]*ifndef[ ]/b\" \
2371 -e \"/^#[ ]*else/b\" \
2372 -e \"/^#[ ]*elif[ ]/b\" \
2373 -e \"/^#[ ]*undef[ ]/b\" \
2374 -e \"/^#[ ]*endif/b\" \
2376 %s | %"SVf" -C %"SVf" %s",
2377 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2380 Perl_sv_setpvf(aTHX_ cmd, "\
2381 %s %s -e '/^[^#]/b' \
2382 -e '/^#[ ]*include[ ]/b' \
2383 -e '/^#[ ]*define[ ]/b' \
2384 -e '/^#[ ]*if[ ]/b' \
2385 -e '/^#[ ]*ifdef[ ]/b' \
2386 -e '/^#[ ]*ifndef[ ]/b' \
2387 -e '/^#[ ]*else/b' \
2388 -e '/^#[ ]*elif[ ]/b' \
2389 -e '/^#[ ]*undef[ ]/b' \
2390 -e '/^#[ ]*endif/b' \
2392 %s | %"SVf" %"SVf" %s",
2394 Perl_sv_setpvf(aTHX_ cmd, "\
2395 %s %s -e '/^[^#]/b' \
2396 -e '/^#[ ]*include[ ]/b' \
2397 -e '/^#[ ]*define[ ]/b' \
2398 -e '/^#[ ]*if[ ]/b' \
2399 -e '/^#[ ]*ifdef[ ]/b' \
2400 -e '/^#[ ]*ifndef[ ]/b' \
2401 -e '/^#[ ]*else/b' \
2402 -e '/^#[ ]*elif[ ]/b' \
2403 -e '/^#[ ]*undef[ ]/b' \
2404 -e '/^#[ ]*endif/b' \
2406 %s | %"SVf" -C %"SVf" %s",
2413 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2415 scriptname, cpp, sv, CPPMINUS);
2416 PL_doextract = FALSE;
2417 #ifdef IAMSUID /* actually, this is caught earlier */
2418 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2420 (void)seteuid(PL_uid); /* musn't stay setuid root */
2423 (void)setreuid((Uid_t)-1, PL_uid);
2425 #ifdef HAS_SETRESUID
2426 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2428 PerlProc_setuid(PL_uid);
2432 if (PerlProc_geteuid() != PL_uid)
2433 Perl_croak(aTHX_ "Can't do seteuid!\n");
2435 #endif /* IAMSUID */
2436 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2440 else if (!*scriptname) {
2441 forbid_setid("program input from stdin");
2442 PL_rsfp = PerlIO_stdin();
2445 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2446 #if defined(HAS_FCNTL) && defined(F_SETFD)
2448 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2453 #ifndef IAMSUID /* in case script is not readable before setuid */
2455 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2456 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2459 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
2460 (int)PERL_REVISION, (int)PERL_VERSION,
2461 (int)PERL_SUBVERSION), PL_origargv);
2462 Perl_croak(aTHX_ "Can't do setuid\n");
2466 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2467 CopFILE(PL_curcop), Strerror(errno));
2472 * I_SYSSTATVFS HAS_FSTATVFS
2474 * I_STATFS HAS_FSTATFS
2475 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2476 * here so that metaconfig picks them up. */
2480 S_fd_on_nosuid_fs(pTHX_ int fd)
2482 int check_okay = 0; /* able to do all the required sys/libcalls */
2483 int on_nosuid = 0; /* the fd is on a nosuid fs */
2485 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2486 * fstatvfs() is UNIX98.
2487 * fstatfs() is 4.3 BSD.
2488 * ustat()+getmnt() is pre-4.3 BSD.
2489 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2490 * an irrelevant filesystem while trying to reach the right one.
2493 # ifdef HAS_FSTATVFS
2494 struct statvfs stfs;
2495 check_okay = fstatvfs(fd, &stfs) == 0;
2496 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2498 # ifdef PERL_MOUNT_NOSUID
2499 # if defined(HAS_FSTATFS) && \
2500 defined(HAS_STRUCT_STATFS) && \
2501 defined(HAS_STRUCT_STATFS_F_FLAGS)
2503 check_okay = fstatfs(fd, &stfs) == 0;
2504 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2506 # if defined(HAS_FSTAT) && \
2507 defined(HAS_USTAT) && \
2508 defined(HAS_GETMNT) && \
2509 defined(HAS_STRUCT_FS_DATA) && \
2512 if (fstat(fd, &fdst) == 0) {
2514 if (ustat(fdst.st_dev, &us) == 0) {
2516 /* NOSTAT_ONE here because we're not examining fields which
2517 * vary between that case and STAT_ONE. */
2518 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2519 size_t cmplen = sizeof(us.f_fname);
2520 if (sizeof(fsd.fd_req.path) < cmplen)
2521 cmplen = sizeof(fsd.fd_req.path);
2522 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2523 fdst.st_dev == fsd.fd_req.dev) {
2525 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2531 # endif /* fstat+ustat+getmnt */
2532 # endif /* fstatfs */
2534 # if defined(HAS_GETMNTENT) && \
2535 defined(HAS_HASMNTOPT) && \
2536 defined(MNTOPT_NOSUID)
2537 FILE *mtab = fopen("/etc/mtab", "r");
2538 struct mntent *entry;
2539 struct stat stb, fsb;
2541 if (mtab && (fstat(fd, &stb) == 0)) {
2542 while (entry = getmntent(mtab)) {
2543 if (stat(entry->mnt_dir, &fsb) == 0
2544 && fsb.st_dev == stb.st_dev)
2546 /* found the filesystem */
2548 if (hasmntopt(entry, MNTOPT_NOSUID))
2551 } /* A single fs may well fail its stat(). */
2556 # endif /* getmntent+hasmntopt */
2557 # endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */
2558 # endif /* statvfs */
2561 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
2564 #endif /* IAMSUID */
2567 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2571 /* do we need to emulate setuid on scripts? */
2573 /* This code is for those BSD systems that have setuid #! scripts disabled
2574 * in the kernel because of a security problem. Merely defining DOSUID
2575 * in perl will not fix that problem, but if you have disabled setuid
2576 * scripts in the kernel, this will attempt to emulate setuid and setgid
2577 * on scripts that have those now-otherwise-useless bits set. The setuid
2578 * root version must be called suidperl or sperlN.NNN. If regular perl
2579 * discovers that it has opened a setuid script, it calls suidperl with
2580 * the same argv that it had. If suidperl finds that the script it has
2581 * just opened is NOT setuid root, it sets the effective uid back to the
2582 * uid. We don't just make perl setuid root because that loses the
2583 * effective uid we had before invoking perl, if it was different from the
2586 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2587 * be defined in suidperl only. suidperl must be setuid root. The
2588 * Configure script will set this up for you if you want it.
2595 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2596 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2597 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2602 #ifndef HAS_SETREUID
2603 /* On this access check to make sure the directories are readable,
2604 * there is actually a small window that the user could use to make
2605 * filename point to an accessible directory. So there is a faint
2606 * chance that someone could execute a setuid script down in a
2607 * non-accessible directory. I don't know what to do about that.
2608 * But I don't think it's too important. The manual lies when
2609 * it says access() is useful in setuid programs.
2611 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
2612 Perl_croak(aTHX_ "Permission denied");
2614 /* If we can swap euid and uid, then we can determine access rights
2615 * with a simple stat of the file, and then compare device and
2616 * inode to make sure we did stat() on the same file we opened.
2617 * Then we just have to make sure he or she can execute it.
2620 struct stat tmpstatbuf;
2624 setreuid(PL_euid,PL_uid) < 0
2627 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2630 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2631 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2632 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
2633 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2634 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2635 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2636 Perl_croak(aTHX_ "Permission denied");
2638 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2639 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2640 (void)PerlIO_close(PL_rsfp);
2641 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2642 PerlIO_printf(PL_rsfp,
2643 "User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2644 (Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n",
2645 PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2646 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2648 PL_statbuf.st_uid, PL_statbuf.st_gid);
2649 (void)PerlProc_pclose(PL_rsfp);
2651 Perl_croak(aTHX_ "Permission denied\n");
2655 setreuid(PL_uid,PL_euid) < 0
2657 # if defined(HAS_SETRESUID)
2658 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2661 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2662 Perl_croak(aTHX_ "Can't reswap uid and euid");
2663 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2664 Perl_croak(aTHX_ "Permission denied\n");
2666 #endif /* HAS_SETREUID */
2667 #endif /* IAMSUID */
2669 if (!S_ISREG(PL_statbuf.st_mode))
2670 Perl_croak(aTHX_ "Permission denied");
2671 if (PL_statbuf.st_mode & S_IWOTH)
2672 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2673 PL_doswitches = FALSE; /* -s is insecure in suid */
2674 CopLINE_inc(PL_curcop);
2675 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2676 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2677 Perl_croak(aTHX_ "No #! line");
2678 s = SvPV(PL_linestr,n_a)+2;
2680 while (!isSPACE(*s)) s++;
2681 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2682 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2683 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2684 Perl_croak(aTHX_ "Not a perl script");
2685 while (*s == ' ' || *s == '\t') s++;
2687 * #! arg must be what we saw above. They can invoke it by
2688 * mentioning suidperl explicitly, but they may not add any strange
2689 * arguments beyond what #! says if they do invoke suidperl that way.
2691 len = strlen(validarg);
2692 if (strEQ(validarg," PHOOEY ") ||
2693 strnNE(s,validarg,len) || !isSPACE(s[len]))
2694 Perl_croak(aTHX_ "Args must match #! line");
2697 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2698 PL_euid == PL_statbuf.st_uid)
2700 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2701 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2702 #endif /* IAMSUID */
2704 if (PL_euid) { /* oops, we're not the setuid root perl */
2705 (void)PerlIO_close(PL_rsfp);
2708 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
2709 (int)PERL_REVISION, (int)PERL_VERSION,
2710 (int)PERL_SUBVERSION), PL_origargv);
2712 Perl_croak(aTHX_ "Can't do setuid\n");
2715 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2717 (void)setegid(PL_statbuf.st_gid);
2720 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2722 #ifdef HAS_SETRESGID
2723 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2725 PerlProc_setgid(PL_statbuf.st_gid);
2729 if (PerlProc_getegid() != PL_statbuf.st_gid)
2730 Perl_croak(aTHX_ "Can't do setegid!\n");
2732 if (PL_statbuf.st_mode & S_ISUID) {
2733 if (PL_statbuf.st_uid != PL_euid)
2735 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2738 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2740 #ifdef HAS_SETRESUID
2741 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2743 PerlProc_setuid(PL_statbuf.st_uid);
2747 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2748 Perl_croak(aTHX_ "Can't do seteuid!\n");
2750 else if (PL_uid) { /* oops, mustn't run as root */
2752 (void)seteuid((Uid_t)PL_uid);
2755 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2757 #ifdef HAS_SETRESUID
2758 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2760 PerlProc_setuid((Uid_t)PL_uid);
2764 if (PerlProc_geteuid() != PL_uid)
2765 Perl_croak(aTHX_ "Can't do seteuid!\n");
2768 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2769 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
2772 else if (PL_preprocess)
2773 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2774 else if (fdscript >= 0)
2775 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2777 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2779 /* We absolutely must clear out any saved ids here, so we */
2780 /* exec the real perl, substituting fd script for scriptname. */
2781 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2782 PerlIO_rewind(PL_rsfp);
2783 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2784 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2785 if (!PL_origargv[which])
2786 Perl_croak(aTHX_ "Permission denied");
2787 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2788 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2789 #if defined(HAS_FCNTL) && defined(F_SETFD)
2790 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2792 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
2793 (int)PERL_REVISION, (int)PERL_VERSION,
2794 (int)PERL_SUBVERSION), PL_origargv);/* try again */
2795 Perl_croak(aTHX_ "Can't do setuid\n");
2796 #endif /* IAMSUID */
2798 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2799 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2801 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2802 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2804 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2807 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2808 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2809 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2810 /* not set-id, must be wrapped */
2816 S_find_beginning(pTHX)
2818 register char *s, *s2;
2820 /* skip forward in input to the real script? */
2823 while (PL_doextract) {
2824 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2825 Perl_croak(aTHX_ "No Perl script found in input\n");
2826 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2827 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2828 PL_doextract = FALSE;
2829 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2831 while (*s == ' ' || *s == '\t') s++;
2833 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2834 if (strnEQ(s2-4,"perl",4))
2836 while (s = moreswitches(s)) ;
2846 PL_uid = PerlProc_getuid();
2847 PL_euid = PerlProc_geteuid();
2848 PL_gid = PerlProc_getgid();
2849 PL_egid = PerlProc_getegid();
2851 PL_uid |= PL_gid << 16;
2852 PL_euid |= PL_egid << 16;
2854 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2858 S_forbid_setid(pTHX_ char *s)
2860 if (PL_euid != PL_uid)
2861 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2862 if (PL_egid != PL_gid)
2863 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2867 Perl_init_debugger(pTHX)
2870 HV *ostash = PL_curstash;
2872 PL_curstash = PL_debstash;
2873 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2874 AvREAL_off(PL_dbargs);
2875 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2876 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2877 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2878 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
2879 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2880 sv_setiv(PL_DBsingle, 0);
2881 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2882 sv_setiv(PL_DBtrace, 0);
2883 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2884 sv_setiv(PL_DBsignal, 0);
2885 PL_curstash = ostash;
2888 #ifndef STRESS_REALLOC
2889 #define REASONABLE(size) (size)
2891 #define REASONABLE(size) (1) /* unreasonable */
2895 Perl_init_stacks(pTHX)
2897 /* start with 128-item stack and 8K cxstack */
2898 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2899 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2900 PL_curstackinfo->si_type = PERLSI_MAIN;
2901 PL_curstack = PL_curstackinfo->si_stack;
2902 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2904 PL_stack_base = AvARRAY(PL_curstack);
2905 PL_stack_sp = PL_stack_base;
2906 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2908 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2911 PL_tmps_max = REASONABLE(128);
2913 New(54,PL_markstack,REASONABLE(32),I32);
2914 PL_markstack_ptr = PL_markstack;
2915 PL_markstack_max = PL_markstack + REASONABLE(32);
2919 New(54,PL_scopestack,REASONABLE(32),I32);
2920 PL_scopestack_ix = 0;
2921 PL_scopestack_max = REASONABLE(32);
2923 New(54,PL_savestack,REASONABLE(128),ANY);
2924 PL_savestack_ix = 0;
2925 PL_savestack_max = REASONABLE(128);
2927 New(54,PL_retstack,REASONABLE(16),OP*);
2929 PL_retstack_max = REASONABLE(16);
2938 while (PL_curstackinfo->si_next)
2939 PL_curstackinfo = PL_curstackinfo->si_next;
2940 while (PL_curstackinfo) {
2941 PERL_SI *p = PL_curstackinfo->si_prev;
2942 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2943 Safefree(PL_curstackinfo->si_cxstack);
2944 Safefree(PL_curstackinfo);
2945 PL_curstackinfo = p;
2947 Safefree(PL_tmps_stack);
2948 Safefree(PL_markstack);
2949 Safefree(PL_scopestack);
2950 Safefree(PL_savestack);
2951 Safefree(PL_retstack);
2955 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2966 lex_start(PL_linestr);
2968 PL_subname = newSVpvn("main",4);
2972 S_init_predump_symbols(pTHX)
2979 sv_setpvn(get_sv("\"", TRUE), " ", 1);
2980 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2981 GvMULTI_on(PL_stdingv);
2982 io = GvIOp(PL_stdingv);
2983 IoIFP(io) = PerlIO_stdin();
2984 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2986 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2988 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2991 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
2993 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2995 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2997 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2998 GvMULTI_on(PL_stderrgv);
2999 io = GvIOp(PL_stderrgv);
3000 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
3001 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
3003 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3005 PL_statname = NEWSV(66,0); /* last filename we did stat on */
3008 PL_osname = savepv(OSNAME);
3012 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3019 argc--,argv++; /* skip name of script */
3020 if (PL_doswitches) {
3021 for (; argc > 0 && **argv == '-'; argc--,argv++) {
3024 if (argv[0][1] == '-' && !argv[0][2]) {
3028 if (s = strchr(argv[0], '=')) {
3030 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
3033 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
3036 PL_toptarget = NEWSV(0,0);
3037 sv_upgrade(PL_toptarget, SVt_PVFM);
3038 sv_setpvn(PL_toptarget, "", 0);
3039 PL_bodytarget = NEWSV(0,0);
3040 sv_upgrade(PL_bodytarget, SVt_PVFM);
3041 sv_setpvn(PL_bodytarget, "", 0);
3042 PL_formtarget = PL_bodytarget;
3045 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
3046 sv_setpv(GvSV(tmpgv),PL_origfilename);
3047 magicname("0", "0", 1);
3049 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
3051 sv_setpv(GvSV(tmpgv), os2_execname());
3053 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
3055 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
3056 GvMULTI_on(PL_argvgv);
3057 (void)gv_AVadd(PL_argvgv);
3058 av_clear(GvAVn(PL_argvgv));
3059 for (; argc > 0; argc--,argv++) {
3060 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
3063 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
3065 GvMULTI_on(PL_envgv);
3066 hv = GvHVn(PL_envgv);
3067 hv_magic(hv, PL_envgv, 'E');
3068 #if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
3069 /* Note that if the supplied env parameter is actually a copy
3070 of the global environ then it may now point to free'd memory
3071 if the environment has been modified since. To avoid this
3072 problem we treat env==NULL as meaning 'use the default'
3077 environ[0] = Nullch;
3078 for (; *env; env++) {
3079 if (!(s = strchr(*env,'=')))
3085 sv = newSVpv(s--,0);
3086 (void)hv_store(hv, *env, s - *env, sv, 0);
3088 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
3089 /* Sins of the RTL. See note in my_setenv(). */
3090 (void)PerlEnv_putenv(savepv(*env));
3094 #ifdef DYNAMIC_ENV_FETCH
3095 HvNAME(hv) = savepv(ENV_HV_NAME);
3099 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
3100 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3104 S_init_perllib(pTHX)
3109 s = PerlEnv_getenv("PERL5LIB");
3113 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
3115 /* Treat PERL5?LIB as a possible search list logical name -- the
3116 * "natural" VMS idiom for a Unix path string. We allow each
3117 * element to be a set of |-separated directories for compatibility.
3121 if (my_trnlnm("PERL5LIB",buf,0))
3122 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
3124 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
3128 /* Use the ~-expanded versions of APPLLIB (undocumented),
3129 ARCHLIB PRIVLIB SITEARCH and SITELIB
3132 incpush(APPLLIB_EXP, TRUE);
3136 incpush(ARCHLIB_EXP, FALSE);
3139 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
3142 incpush(PRIVLIB_EXP, TRUE);
3144 incpush(PRIVLIB_EXP, FALSE);
3148 incpush(SITELIB_EXP, TRUE); /* XXX Win32 needs inc_version_list support */
3152 char *path = SITELIB_EXP;
3157 if (strrchr(buf,'/')) /* XXX Hack, Configure var needed */
3158 *strrchr(buf,'/') = '\0';
3164 #if defined(PERL_VENDORLIB_EXP)
3166 incpush(PERL_VENDORLIB_EXP, TRUE);
3168 incpush(PERL_VENDORLIB_EXP, FALSE);
3172 incpush(".", FALSE);
3176 # define PERLLIB_SEP ';'
3179 # define PERLLIB_SEP '|'
3181 # define PERLLIB_SEP ':'
3184 #ifndef PERLLIB_MANGLE
3185 # define PERLLIB_MANGLE(s,n) (s)
3189 S_incpush(pTHX_ char *p, int addsubdirs)
3191 SV *subdir = Nullsv;
3197 subdir = sv_newmortal();
3200 /* Break at all separators */
3202 SV *libdir = NEWSV(55,0);
3205 /* skip any consecutive separators */
3206 while ( *p == PERLLIB_SEP ) {
3207 /* Uncomment the next line for PATH semantics */
3208 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3212 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3213 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3218 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3219 p = Nullch; /* break out */
3223 * BEFORE pushing libdir onto @INC we may first push version- and
3224 * archname-specific sub-directories.
3227 #ifdef PERL_INC_VERSION_LIST
3228 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3229 const char *incverlist[] = { PERL_INC_VERSION_LIST };
3230 const char **incver;
3232 struct stat tmpstatbuf;
3237 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3239 while (unix[len-1] == '/') len--; /* Cosmetic */
3240 sv_usepvn(libdir,unix,len);
3243 PerlIO_printf(Perl_error_log,
3244 "Failed to unixify @INC element \"%s\"\n",
3247 /* .../version/archname if -d .../version/archname */
3248 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT"/%s", libdir,
3249 (int)PERL_REVISION, (int)PERL_VERSION,
3250 (int)PERL_SUBVERSION, ARCHNAME);
3251 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3252 S_ISDIR(tmpstatbuf.st_mode))
3253 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3255 /* .../version if -d .../version */
3256 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT, libdir,
3257 (int)PERL_REVISION, (int)PERL_VERSION,
3258 (int)PERL_SUBVERSION);
3259 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3260 S_ISDIR(tmpstatbuf.st_mode))
3261 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3263 /* .../archname if -d .../archname */
3264 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, ARCHNAME);
3265 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3266 S_ISDIR(tmpstatbuf.st_mode))
3267 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3269 #ifdef PERL_INC_VERSION_LIST
3270 for (incver = incverlist; *incver; incver++) {
3271 /* .../xxx if -d .../xxx */
3272 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, *incver);
3273 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3274 S_ISDIR(tmpstatbuf.st_mode))
3275 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3280 /* finally push this lib directory on the end of @INC */
3281 av_push(GvAVn(PL_incgv), libdir);
3286 STATIC struct perl_thread *
3287 S_init_main_thread(pTHX)
3289 #if !defined(PERL_IMPLICIT_CONTEXT)
3290 struct perl_thread *thr;
3294 Newz(53, thr, 1, struct perl_thread);
3295 PL_curcop = &PL_compiling;
3296 thr->interp = PERL_GET_INTERP;
3297 thr->cvcache = newHV();
3298 thr->threadsv = newAV();
3299 /* thr->threadsvp is set when find_threadsv is called */
3300 thr->specific = newAV();
3301 thr->flags = THRf_R_JOINABLE;
3302 MUTEX_INIT(&thr->mutex);
3303 /* Handcraft thrsv similarly to mess_sv */
3304 New(53, PL_thrsv, 1, SV);
3305 Newz(53, xpv, 1, XPV);
3306 SvFLAGS(PL_thrsv) = SVt_PV;
3307 SvANY(PL_thrsv) = (void*)xpv;
3308 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3309 SvPVX(PL_thrsv) = (char*)thr;
3310 SvCUR_set(PL_thrsv, sizeof(thr));
3311 SvLEN_set(PL_thrsv, sizeof(thr));
3312 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3313 thr->oursv = PL_thrsv;
3314 PL_chopset = " \n-";
3317 MUTEX_LOCK(&PL_threads_mutex);
3322 MUTEX_UNLOCK(&PL_threads_mutex);
3324 #ifdef HAVE_THREAD_INTERN
3325 Perl_init_thread_intern(thr);
3328 #ifdef SET_THREAD_SELF
3329 SET_THREAD_SELF(thr);
3331 thr->self = pthread_self();
3332 #endif /* SET_THREAD_SELF */
3336 * These must come after the SET_THR because sv_setpvn does
3337 * SvTAINT and the taint fields require dTHR.
3339 PL_toptarget = NEWSV(0,0);
3340 sv_upgrade(PL_toptarget, SVt_PVFM);
3341 sv_setpvn(PL_toptarget, "", 0);
3342 PL_bodytarget = NEWSV(0,0);
3343 sv_upgrade(PL_bodytarget, SVt_PVFM);
3344 sv_setpvn(PL_bodytarget, "", 0);
3345 PL_formtarget = PL_bodytarget;
3346 thr->errsv = newSVpvn("", 0);
3347 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
3350 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3351 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3352 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3353 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3354 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3356 PL_reginterp_cnt = 0;
3360 #endif /* USE_THREADS */
3363 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3367 line_t oldline = CopLINE(PL_curcop);
3373 while (AvFILL(paramList) >= 0) {
3374 cv = (CV*)av_shift(paramList);
3376 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
3380 (void)SvPV(atsv, len);
3383 PL_curcop = &PL_compiling;
3384 CopLINE_set(PL_curcop, oldline);
3385 if (paramList == PL_beginav)
3386 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3388 Perl_sv_catpvf(aTHX_ atsv,
3389 "%s failed--call queue aborted",
3390 paramList == PL_checkav ? "CHECK"
3391 : paramList == PL_initav ? "INIT"
3393 while (PL_scopestack_ix > oldscope)
3395 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
3402 /* my_exit() was called */
3403 while (PL_scopestack_ix > oldscope)
3406 PL_curstash = PL_defstash;
3407 PL_curcop = &PL_compiling;
3408 CopLINE_set(PL_curcop, oldline);
3409 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3410 if (paramList == PL_beginav)
3411 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3413 Perl_croak(aTHX_ "%s failed--call queue aborted",
3414 paramList == PL_checkav ? "CHECK"
3415 : paramList == PL_initav ? "INIT"
3422 PL_curcop = &PL_compiling;
3423 CopLINE_set(PL_curcop, oldline);
3426 PerlIO_printf(Perl_error_log, "panic: restartop\n");
3434 S_call_list_body(pTHX_ va_list args)
3437 CV *cv = va_arg(args, CV*);
3439 PUSHMARK(PL_stack_sp);
3440 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3445 Perl_my_exit(pTHX_ U32 status)
3449 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3450 thr, (unsigned long) status));
3459 STATUS_NATIVE_SET(status);
3466 Perl_my_failure_exit(pTHX)
3469 if (vaxc$errno & 1) {
3470 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3471 STATUS_NATIVE_SET(44);
3474 if (!vaxc$errno && errno) /* unlikely */
3475 STATUS_NATIVE_SET(44);
3477 STATUS_NATIVE_SET(vaxc$errno);
3482 STATUS_POSIX_SET(errno);
3484 exitstatus = STATUS_POSIX >> 8;
3485 if (exitstatus & 255)
3486 STATUS_POSIX_SET(exitstatus);
3488 STATUS_POSIX_SET(255);
3495 S_my_exit_jump(pTHX)
3498 register PERL_CONTEXT *cx;
3503 SvREFCNT_dec(PL_e_script);
3504 PL_e_script = Nullsv;
3507 POPSTACK_TO(PL_mainstack);
3508 if (cxstack_ix >= 0) {
3511 POPBLOCK(cx,PL_curpm);
3523 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3526 p = SvPVX(PL_e_script);
3527 nl = strchr(p, '\n');
3528 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3530 filter_del(read_e_script);
3533 sv_catpvn(buf_sv, p, nl-p);
3534 sv_chop(PL_e_script, nl);