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 Safefree(PL_collation_name);
527 PL_collation_name = Nullch;
529 Safefree(PL_numeric_name);
530 PL_numeric_name = Nullch;
532 /* clear utf8 character classes */
533 SvREFCNT_dec(PL_utf8_alnum);
534 SvREFCNT_dec(PL_utf8_alnumc);
535 SvREFCNT_dec(PL_utf8_ascii);
536 SvREFCNT_dec(PL_utf8_alpha);
537 SvREFCNT_dec(PL_utf8_space);
538 SvREFCNT_dec(PL_utf8_cntrl);
539 SvREFCNT_dec(PL_utf8_graph);
540 SvREFCNT_dec(PL_utf8_digit);
541 SvREFCNT_dec(PL_utf8_upper);
542 SvREFCNT_dec(PL_utf8_lower);
543 SvREFCNT_dec(PL_utf8_print);
544 SvREFCNT_dec(PL_utf8_punct);
545 SvREFCNT_dec(PL_utf8_xdigit);
546 SvREFCNT_dec(PL_utf8_mark);
547 SvREFCNT_dec(PL_utf8_toupper);
548 SvREFCNT_dec(PL_utf8_tolower);
549 PL_utf8_alnum = Nullsv;
550 PL_utf8_alnumc = Nullsv;
551 PL_utf8_ascii = Nullsv;
552 PL_utf8_alpha = Nullsv;
553 PL_utf8_space = Nullsv;
554 PL_utf8_cntrl = Nullsv;
555 PL_utf8_graph = Nullsv;
556 PL_utf8_digit = Nullsv;
557 PL_utf8_upper = Nullsv;
558 PL_utf8_lower = Nullsv;
559 PL_utf8_print = Nullsv;
560 PL_utf8_punct = Nullsv;
561 PL_utf8_xdigit = Nullsv;
562 PL_utf8_mark = Nullsv;
563 PL_utf8_toupper = Nullsv;
564 PL_utf8_totitle = Nullsv;
565 PL_utf8_tolower = Nullsv;
567 if (!specialWARN(PL_compiling.cop_warnings))
568 SvREFCNT_dec(PL_compiling.cop_warnings);
569 PL_compiling.cop_warnings = Nullsv;
571 /* Prepare to destruct main symbol table. */
576 SvREFCNT_dec(PL_curstname);
577 PL_curstname = Nullsv;
579 /* clear queued errors */
580 SvREFCNT_dec(PL_errors);
584 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
585 if (PL_scopestack_ix != 0)
586 Perl_warner(aTHX_ WARN_INTERNAL,
587 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
588 (long)PL_scopestack_ix);
589 if (PL_savestack_ix != 0)
590 Perl_warner(aTHX_ WARN_INTERNAL,
591 "Unbalanced saves: %ld more saves than restores\n",
592 (long)PL_savestack_ix);
593 if (PL_tmps_floor != -1)
594 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
595 (long)PL_tmps_floor + 1);
596 if (cxstack_ix != -1)
597 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
598 (long)cxstack_ix + 1);
601 /* Now absolutely destruct everything, somehow or other, loops or no. */
603 SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */
604 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
605 while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
606 last_sv_count = PL_sv_count;
609 SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
610 SvFLAGS(PL_fdpid) |= SVt_PVAV;
611 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
612 SvFLAGS(PL_strtab) |= SVt_PVHV;
614 AvREAL_off(PL_fdpid); /* no surviving entries */
615 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
618 /* Destruct the global string table. */
620 /* Yell and reset the HeVAL() slots that are still holding refcounts,
621 * so that sv_free() won't fail on them.
629 max = HvMAX(PL_strtab);
630 array = HvARRAY(PL_strtab);
633 if (hent && ckWARN_d(WARN_INTERNAL)) {
634 Perl_warner(aTHX_ WARN_INTERNAL,
635 "Unbalanced string table refcount: (%d) for \"%s\"",
636 HeVAL(hent) - Nullsv, HeKEY(hent));
637 HeVAL(hent) = Nullsv;
647 SvREFCNT_dec(PL_strtab);
649 /* free special SVs */
651 SvREFCNT(&PL_sv_yes) = 0;
652 sv_clear(&PL_sv_yes);
653 SvANY(&PL_sv_yes) = NULL;
655 SvREFCNT(&PL_sv_no) = 0;
657 SvANY(&PL_sv_no) = NULL;
659 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
660 Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
664 /* No SVs have survived, need to clean out */
665 Safefree(PL_origfilename);
666 Safefree(PL_reg_start_tmp);
668 Safefree(PL_reg_curpm);
669 Safefree(PL_reg_poscache);
670 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
671 Safefree(PL_op_mask);
673 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
675 DEBUG_P(debprofdump());
677 MUTEX_DESTROY(&PL_strtab_mutex);
678 MUTEX_DESTROY(&PL_sv_mutex);
679 MUTEX_DESTROY(&PL_eval_mutex);
680 MUTEX_DESTROY(&PL_cred_mutex);
681 COND_DESTROY(&PL_eval_cond);
682 #ifdef EMULATE_ATOMIC_REFCOUNTS
683 MUTEX_DESTROY(&PL_svref_mutex);
684 #endif /* EMULATE_ATOMIC_REFCOUNTS */
686 /* As the penultimate thing, free the non-arena SV for thrsv */
687 Safefree(SvPVX(PL_thrsv));
688 Safefree(SvANY(PL_thrsv));
691 #endif /* USE_THREADS */
693 /* As the absolutely last thing, free the non-arena SV for mess() */
696 /* it could have accumulated taint magic */
697 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
700 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
701 moremagic = mg->mg_moremagic;
702 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
703 Safefree(mg->mg_ptr);
707 /* we know that type >= SVt_PV */
708 SvOOK_off(PL_mess_sv);
709 Safefree(SvPVX(PL_mess_sv));
710 Safefree(SvANY(PL_mess_sv));
711 Safefree(PL_mess_sv);
717 =for apidoc perl_free
719 Releases a Perl interpreter. See L<perlembed>.
727 #if defined(PERL_OBJECT)
735 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
737 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
738 PL_exitlist[PL_exitlistlen].fn = fn;
739 PL_exitlist[PL_exitlistlen].ptr = ptr;
744 =for apidoc perl_parse
746 Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
752 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
762 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
765 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
766 setuid perl scripts securely.\n");
770 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
771 _dyld_lookup_and_bind
772 ("__environ", (unsigned long *) &environ_pointer, NULL);
777 #ifndef VMS /* VMS doesn't have environ array */
778 PL_origenviron = environ;
783 /* Come here if running an undumped a.out. */
785 PL_origfilename = savepv(argv[0]);
786 PL_do_undump = FALSE;
787 cxstack_ix = -1; /* start label stack again */
789 init_postdump_symbols(argc,argv,env);
794 PL_curpad = AvARRAY(PL_comppad);
795 op_free(PL_main_root);
796 PL_main_root = Nullop;
798 PL_main_start = Nullop;
799 SvREFCNT_dec(PL_main_cv);
803 oldscope = PL_scopestack_ix;
804 PL_dowarn = G_WARN_OFF;
806 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_parse_body),
811 call_list(oldscope, PL_checkav);
817 /* my_exit() was called */
818 while (PL_scopestack_ix > oldscope)
821 PL_curstash = PL_defstash;
823 call_list(oldscope, PL_checkav);
824 return STATUS_NATIVE_EXPORT;
826 PerlIO_printf(Perl_error_log, "panic: top_env\n");
833 S_parse_body(pTHX_ va_list args)
836 int argc = PL_origargc;
837 char **argv = PL_origargv;
838 char **env = va_arg(args, char**);
839 char *scriptname = NULL;
841 VOL bool dosearch = FALSE;
846 char *cddir = Nullch;
848 XSINIT_t xsinit = va_arg(args, XSINIT_t);
850 sv_setpvn(PL_linestr,"",0);
851 sv = newSVpvn("",0); /* first used for -I flags */
855 for (argc--,argv++; argc > 0; argc--,argv++) {
856 if (argv[0][0] != '-' || !argv[0][1])
860 validarg = " PHOOEY ";
867 #ifndef PERL_STRICT_CR
892 if (s = moreswitches(s))
902 if (PL_euid != PL_uid || PL_egid != PL_gid)
903 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
905 PL_e_script = newSVpvn("",0);
906 filter_add(read_e_script, NULL);
909 sv_catpv(PL_e_script, s);
911 sv_catpv(PL_e_script, argv[1]);
915 Perl_croak(aTHX_ "No code specified for -e");
916 sv_catpv(PL_e_script, "\n");
919 case 'I': /* -I handled both here and in moreswitches() */
921 if (!*++s && (s=argv[1]) != Nullch) {
926 STRLEN len = strlen(s);
929 sv_catpvn(sv, "-I", 2);
930 sv_catpvn(sv, p, len);
931 sv_catpvn(sv, " ", 1);
935 Perl_croak(aTHX_ "No directory specified for -I");
939 PL_preprocess = TRUE;
949 PL_preambleav = newAV();
950 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
952 PL_Sv = newSVpv("print myconfig();",0);
954 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
956 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
958 sv_catpv(PL_Sv,"\" Compile-time options:");
960 sv_catpv(PL_Sv," DEBUGGING");
963 sv_catpv(PL_Sv," MULTIPLICITY");
966 sv_catpv(PL_Sv," USE_THREADS");
969 sv_catpv(PL_Sv," USE_ITHREADS");
972 sv_catpv(PL_Sv," USE_64_BITS");
974 # ifdef USE_LONG_DOUBLE
975 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
977 # ifdef USE_LARGE_FILES
978 sv_catpv(PL_Sv," USE_LARGE_FILES");
981 sv_catpv(PL_Sv," USE_SOCKS");
984 sv_catpv(PL_Sv," PERL_OBJECT");
986 # ifdef PERL_IMPLICIT_CONTEXT
987 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
989 # ifdef PERL_IMPLICIT_SYS
990 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
992 sv_catpv(PL_Sv,"\\n\",");
994 #if defined(LOCAL_PATCH_COUNT)
995 if (LOCAL_PATCH_COUNT > 0) {
997 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
998 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
999 if (PL_localpatches[i])
1000 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
1004 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
1007 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
1009 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
1012 sv_catpv(PL_Sv, "; \
1014 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
1015 print \" \\%ENV:\\n @env\\n\" if @env; \
1016 print \" \\@INC:\\n @INC\\n\";");
1019 PL_Sv = newSVpv("config_vars(qw(",0);
1020 sv_catpv(PL_Sv, ++s);
1021 sv_catpv(PL_Sv, "))");
1024 av_push(PL_preambleav, PL_Sv);
1025 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1028 PL_doextract = TRUE;
1036 if (!*++s || isSPACE(*s)) {
1040 /* catch use of gnu style long options */
1041 if (strEQ(s, "version")) {
1045 if (strEQ(s, "help")) {
1052 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
1058 #ifndef SECURE_INTERNAL_GETENV
1061 (s = PerlEnv_getenv("PERL5OPT")))
1065 if (*s == '-' && *(s+1) == 'T')
1078 if (!strchr("DIMUdmw", *s))
1079 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
1080 s = moreswitches(s);
1086 scriptname = argv[0];
1089 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1091 else if (scriptname == Nullch) {
1093 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1101 open_script(scriptname,dosearch,sv,&fdscript);
1103 validate_suid(validarg, scriptname,fdscript);
1105 #if defined(SIGCHLD) || defined(SIGCLD)
1108 # define SIGCHLD SIGCLD
1110 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1111 if (sigstate == SIG_IGN) {
1112 if (ckWARN(WARN_SIGNAL))
1113 Perl_warner(aTHX_ WARN_SIGNAL,
1114 "Can't ignore signal CHLD, forcing to default");
1115 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1122 if (cddir && PerlDir_chdir(cddir) < 0)
1123 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1127 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1128 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1129 CvUNIQUE_on(PL_compcv);
1131 PL_comppad = newAV();
1132 av_push(PL_comppad, Nullsv);
1133 PL_curpad = AvARRAY(PL_comppad);
1134 PL_comppad_name = newAV();
1135 PL_comppad_name_fill = 0;
1136 PL_min_intro_pending = 0;
1139 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
1140 PL_curpad[0] = (SV*)newAV();
1141 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
1142 CvOWNER(PL_compcv) = 0;
1143 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1144 MUTEX_INIT(CvMUTEXP(PL_compcv));
1145 #endif /* USE_THREADS */
1147 comppadlist = newAV();
1148 AvREAL_off(comppadlist);
1149 av_store(comppadlist, 0, (SV*)PL_comppad_name);
1150 av_store(comppadlist, 1, (SV*)PL_comppad);
1151 CvPADLIST(PL_compcv) = comppadlist;
1153 boot_core_UNIVERSAL();
1154 boot_core_xsutils();
1157 (*xsinit)(aTHXo); /* in case linked C routines want magical variables */
1158 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
1166 init_predump_symbols();
1167 /* init_postdump_symbols not currently designed to be called */
1168 /* more than once (ENV isn't cleared first, for example) */
1169 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
1171 init_postdump_symbols(argc,argv,env);
1175 /* now parse the script */
1177 SETERRNO(0,SS$_NORMAL);
1179 if (yyparse() || PL_error_count) {
1181 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1183 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1187 CopLINE_set(PL_curcop, 0);
1188 PL_curstash = PL_defstash;
1189 PL_preprocess = FALSE;
1191 SvREFCNT_dec(PL_e_script);
1192 PL_e_script = Nullsv;
1195 /* now that script is parsed, we can modify record separator */
1196 SvREFCNT_dec(PL_rs);
1197 PL_rs = SvREFCNT_inc(PL_nrs);
1198 sv_setsv(get_sv("/", TRUE), PL_rs);
1203 SAVECOPFILE(PL_curcop);
1204 SAVECOPLINE(PL_curcop);
1205 gv_check(PL_defstash);
1212 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1213 dump_mstats("after compilation:");
1222 =for apidoc perl_run
1224 Tells a Perl interpreter to run. See L<perlembed>.
1240 oldscope = PL_scopestack_ix;
1243 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
1246 cxstack_ix = -1; /* start context stack again */
1248 case 0: /* normal completion */
1249 case 2: /* my_exit() */
1250 while (PL_scopestack_ix > oldscope)
1253 PL_curstash = PL_defstash;
1254 if (PL_endav && !PL_minus_c)
1255 call_list(oldscope, PL_endav);
1257 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1258 dump_mstats("after execution: ");
1260 return STATUS_NATIVE_EXPORT;
1263 POPSTACK_TO(PL_mainstack);
1266 PerlIO_printf(Perl_error_log, "panic: restartop\n");
1276 S_run_body(pTHX_ va_list args)
1279 I32 oldscope = va_arg(args, I32);
1281 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1282 PL_sawampersand ? "Enabling" : "Omitting"));
1284 if (!PL_restartop) {
1285 DEBUG_x(dump_all());
1286 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1287 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1291 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1294 if (PERLDB_SINGLE && PL_DBsingle)
1295 sv_setiv(PL_DBsingle, 1);
1297 call_list(oldscope, PL_initav);
1303 PL_op = PL_restartop;
1307 else if (PL_main_start) {
1308 CvDEPTH(PL_main_cv) = 1;
1309 PL_op = PL_main_start;
1319 =for apidoc p||get_sv
1321 Returns the SV of the specified Perl scalar. If C<create> is set and the
1322 Perl variable does not exist then it will be created. If C<create> is not
1323 set and the variable does not exist then NULL is returned.
1329 Perl_get_sv(pTHX_ const char *name, I32 create)
1333 if (name[1] == '\0' && !isALPHA(name[0])) {
1334 PADOFFSET tmp = find_threadsv(name);
1335 if (tmp != NOT_IN_PAD) {
1337 return THREADSV(tmp);
1340 #endif /* USE_THREADS */
1341 gv = gv_fetchpv(name, create, SVt_PV);
1348 =for apidoc p||get_av
1350 Returns the AV of the specified Perl array. If C<create> is set and the
1351 Perl variable does not exist then it will be created. If C<create> is not
1352 set and the variable does not exist then NULL is returned.
1358 Perl_get_av(pTHX_ const char *name, I32 create)
1360 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1369 =for apidoc p||get_hv
1371 Returns the HV of the specified Perl hash. If C<create> is set and the
1372 Perl variable does not exist then it will be created. If C<create> is not
1373 set and the variable does not exist then NULL is returned.
1379 Perl_get_hv(pTHX_ const char *name, I32 create)
1381 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1390 =for apidoc p||get_cv
1392 Returns the CV of the specified Perl subroutine. If C<create> is set and
1393 the Perl subroutine does not exist then it will be declared (which has the
1394 same effect as saying C<sub name;>). If C<create> is not set and the
1395 subroutine does not exist then NULL is returned.
1401 Perl_get_cv(pTHX_ const char *name, I32 create)
1403 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1404 /* XXX unsafe for threads if eval_owner isn't held */
1405 /* XXX this is probably not what they think they're getting.
1406 * It has the same effect as "sub name;", i.e. just a forward
1408 if (create && !GvCVu(gv))
1409 return newSUB(start_subparse(FALSE, 0),
1410 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1418 /* Be sure to refetch the stack pointer after calling these routines. */
1421 =for apidoc p||call_argv
1423 Performs a callback to the specified Perl sub. See L<perlcall>.
1429 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1431 /* See G_* flags in cop.h */
1432 /* null terminated arg list */
1439 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1444 return call_pv(sub_name, flags);
1448 =for apidoc p||call_pv
1450 Performs a callback to the specified Perl sub. See L<perlcall>.
1456 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1457 /* name of the subroutine */
1458 /* See G_* flags in cop.h */
1460 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1464 =for apidoc p||call_method
1466 Performs a callback to the specified Perl method. The blessed object must
1467 be on the stack. See L<perlcall>.
1473 Perl_call_method(pTHX_ const char *methname, I32 flags)
1474 /* name of the subroutine */
1475 /* See G_* flags in cop.h */
1483 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1488 return call_sv(*PL_stack_sp--, flags);
1491 /* May be called with any of a CV, a GV, or an SV containing the name. */
1493 =for apidoc p||call_sv
1495 Performs a callback to the Perl sub whose name is in the SV. See
1502 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1504 /* See G_* flags in cop.h */
1507 LOGOP myop; /* fake syntax tree node */
1511 bool oldcatch = CATCH_GET;
1516 if (flags & G_DISCARD) {
1521 Zero(&myop, 1, LOGOP);
1522 myop.op_next = Nullop;
1523 if (!(flags & G_NOARGS))
1524 myop.op_flags |= OPf_STACKED;
1525 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1526 (flags & G_ARRAY) ? OPf_WANT_LIST :
1531 EXTEND(PL_stack_sp, 1);
1532 *++PL_stack_sp = sv;
1534 oldscope = PL_scopestack_ix;
1536 if (PERLDB_SUB && PL_curstash != PL_debstash
1537 /* Handle first BEGIN of -d. */
1538 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1539 /* Try harder, since this may have been a sighandler, thus
1540 * curstash may be meaningless. */
1541 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1542 && !(flags & G_NODEBUG))
1543 PL_op->op_private |= OPpENTERSUB_DB;
1545 if (!(flags & G_EVAL)) {
1547 call_xbody((OP*)&myop, FALSE);
1548 retval = PL_stack_sp - (PL_stack_base + oldmark);
1549 CATCH_SET(oldcatch);
1552 cLOGOP->op_other = PL_op;
1554 /* we're trying to emulate pp_entertry() here */
1556 register PERL_CONTEXT *cx;
1557 I32 gimme = GIMME_V;
1562 push_return(PL_op->op_next);
1563 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1565 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1567 PL_in_eval = EVAL_INEVAL;
1568 if (flags & G_KEEPERR)
1569 PL_in_eval |= EVAL_KEEPERR;
1576 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1580 retval = PL_stack_sp - (PL_stack_base + oldmark);
1581 if (!(flags & G_KEEPERR))
1588 /* my_exit() was called */
1589 PL_curstash = PL_defstash;
1591 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1592 Perl_croak(aTHX_ "Callback called exit");
1597 PL_op = PL_restartop;
1601 PL_stack_sp = PL_stack_base + oldmark;
1602 if (flags & G_ARRAY)
1606 *++PL_stack_sp = &PL_sv_undef;
1611 if (PL_scopestack_ix > oldscope) {
1615 register PERL_CONTEXT *cx;
1626 if (flags & G_DISCARD) {
1627 PL_stack_sp = PL_stack_base + oldmark;
1637 S_call_body(pTHX_ va_list args)
1639 OP *myop = va_arg(args, OP*);
1640 int is_eval = va_arg(args, int);
1642 call_xbody(myop, is_eval);
1647 S_call_xbody(pTHX_ OP *myop, int is_eval)
1651 if (PL_op == myop) {
1653 PL_op = Perl_pp_entereval(aTHX);
1655 PL_op = Perl_pp_entersub(aTHX);
1661 /* Eval a string. The G_EVAL flag is always assumed. */
1664 =for apidoc p||eval_sv
1666 Tells Perl to C<eval> the string in the SV.
1672 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1674 /* See G_* flags in cop.h */
1677 UNOP myop; /* fake syntax tree node */
1678 I32 oldmark = SP - PL_stack_base;
1685 if (flags & G_DISCARD) {
1692 Zero(PL_op, 1, UNOP);
1693 EXTEND(PL_stack_sp, 1);
1694 *++PL_stack_sp = sv;
1695 oldscope = PL_scopestack_ix;
1697 if (!(flags & G_NOARGS))
1698 myop.op_flags = OPf_STACKED;
1699 myop.op_next = Nullop;
1700 myop.op_type = OP_ENTEREVAL;
1701 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1702 (flags & G_ARRAY) ? OPf_WANT_LIST :
1704 if (flags & G_KEEPERR)
1705 myop.op_flags |= OPf_SPECIAL;
1708 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1712 retval = PL_stack_sp - (PL_stack_base + oldmark);
1713 if (!(flags & G_KEEPERR))
1720 /* my_exit() was called */
1721 PL_curstash = PL_defstash;
1723 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1724 Perl_croak(aTHX_ "Callback called exit");
1729 PL_op = PL_restartop;
1733 PL_stack_sp = PL_stack_base + oldmark;
1734 if (flags & G_ARRAY)
1738 *++PL_stack_sp = &PL_sv_undef;
1743 if (flags & G_DISCARD) {
1744 PL_stack_sp = PL_stack_base + oldmark;
1754 =for apidoc p||eval_pv
1756 Tells Perl to C<eval> the given string and return an SV* result.
1762 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1765 SV* sv = newSVpv(p, 0);
1768 eval_sv(sv, G_SCALAR);
1775 if (croak_on_error && SvTRUE(ERRSV)) {
1777 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1783 /* Require a module. */
1786 =for apidoc p||require_pv
1788 Tells Perl to C<require> a module.
1794 Perl_require_pv(pTHX_ const char *pv)
1798 PUSHSTACKi(PERLSI_REQUIRE);
1800 sv = sv_newmortal();
1801 sv_setpv(sv, "require '");
1804 eval_sv(sv, G_DISCARD);
1810 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1814 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1815 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1819 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
1821 /* This message really ought to be max 23 lines.
1822 * Removed -h because the user already knows that opton. Others? */
1824 static char *usage_msg[] = {
1825 "-0[octal] specify record separator (\\0, if no argument)",
1826 "-a autosplit mode with -n or -p (splits $_ into @F)",
1827 "-C enable native wide character system interfaces",
1828 "-c check syntax only (runs BEGIN and END blocks)",
1829 "-d[:debugger] run program under debugger",
1830 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1831 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1832 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1833 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1834 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1835 "-l[octal] enable line ending processing, specifies line terminator",
1836 "-[mM][-]module execute `use/no module...' before executing program",
1837 "-n assume 'while (<>) { ... }' loop around program",
1838 "-p assume loop like -n but print line also, like sed",
1839 "-P run program through C preprocessor before compilation",
1840 "-s enable rudimentary parsing for switches after programfile",
1841 "-S look for programfile using PATH environment variable",
1842 "-T enable tainting checks",
1843 "-u dump core after parsing program",
1844 "-U allow unsafe operations",
1845 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1846 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1847 "-w enable many useful warnings (RECOMMENDED)",
1848 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1852 char **p = usage_msg;
1854 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1856 printf("\n %s", *p++);
1859 /* This routine handles any switches that can be given during run */
1862 Perl_moreswitches(pTHX_ char *s)
1871 rschar = (U32)scan_oct(s, 4, &numlen);
1872 SvREFCNT_dec(PL_nrs);
1873 if (rschar & ~((U8)~0))
1874 PL_nrs = &PL_sv_undef;
1875 else if (!rschar && numlen >= 2)
1876 PL_nrs = newSVpvn("", 0);
1879 PL_nrs = newSVpvn(&ch, 1);
1884 PL_widesyscalls = TRUE;
1889 PL_splitstr = savepv(s + 1);
1903 if (*s == ':' || *s == '=') {
1904 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1908 PL_perldb = PERLDB_ALL;
1916 if (isALPHA(s[1])) {
1917 static char debopts[] = "psltocPmfrxuLHXDS";
1920 for (s++; *s && (d = strchr(debopts,*s)); s++)
1921 PL_debug |= 1 << (d - debopts);
1924 PL_debug = atoi(s+1);
1925 for (s++; isDIGIT(*s); s++) ;
1927 PL_debug |= 0x80000000;
1930 if (ckWARN_d(WARN_DEBUGGING))
1931 Perl_warner(aTHX_ WARN_DEBUGGING,
1932 "Recompile perl with -DDEBUGGING to use -D switch\n");
1933 for (s++; isALNUM(*s); s++) ;
1939 usage(PL_origargv[0]);
1943 Safefree(PL_inplace);
1944 PL_inplace = savepv(s+1);
1946 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1949 if (*s == '-') /* Additional switches on #! line. */
1953 case 'I': /* -I handled both here and in parse_perl() */
1956 while (*s && isSPACE(*s))
1961 /* ignore trailing spaces (possibly followed by other switches) */
1963 for (e = p; *e && !isSPACE(*e); e++) ;
1967 } while (*p && *p != '-');
1968 e = savepvn(s, e-s);
1976 Perl_croak(aTHX_ "No directory specified for -I");
1984 PL_ors = savepv("\n");
1986 *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
1991 if (RsPARA(PL_nrs)) {
1996 PL_ors = SvPV(PL_nrs, PL_orslen);
1997 PL_ors = savepvn(PL_ors, PL_orslen);
2001 forbid_setid("-M"); /* XXX ? */
2004 forbid_setid("-m"); /* XXX ? */
2009 /* -M-foo == 'no foo' */
2010 if (*s == '-') { use = "no "; ++s; }
2011 sv = newSVpv(use,0);
2013 /* We allow -M'Module qw(Foo Bar)' */
2014 while(isALNUM(*s) || *s==':') ++s;
2016 sv_catpv(sv, start);
2017 if (*(start-1) == 'm') {
2019 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
2020 sv_catpv( sv, " ()");
2023 sv_catpvn(sv, start, s-start);
2024 sv_catpv(sv, " split(/,/,q{");
2030 PL_preambleav = newAV();
2031 av_push(PL_preambleav, sv);
2034 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
2046 PL_doswitches = TRUE;
2051 Perl_croak(aTHX_ "Too late for \"-T\" option");
2055 PL_do_undump = TRUE;
2063 printf(Perl_form(aTHX_ "\nThis is perl, v%v built for %s",
2064 PL_patchlevel, ARCHNAME));
2065 #if defined(LOCAL_PATCH_COUNT)
2066 if (LOCAL_PATCH_COUNT > 0)
2067 printf("\n(with %d registered patch%s, see perl -V for more detail)",
2068 (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
2071 printf("\n\nCopyright 1987-2000, Larry Wall\n");
2073 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
2076 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
2077 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
2080 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
2081 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
2084 printf("atariST series port, ++jrb bammi@cadence.com\n");
2087 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
2090 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
2093 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
2096 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
2099 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
2102 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
2105 printf("MiNT port by Guido Flohr, 1997-1999\n");
2107 #ifdef BINARY_BUILD_NOTICE
2108 BINARY_BUILD_NOTICE;
2111 Perl may be copied only under the terms of either the Artistic License or the\n\
2112 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
2113 Complete documentation for Perl, including FAQ lists, should be found on\n\
2114 this system using `man perl' or `perldoc perl'. If you have access to the\n\
2115 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
2118 if (! (PL_dowarn & G_WARN_ALL_MASK))
2119 PL_dowarn |= G_WARN_ON;
2123 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
2124 PL_compiling.cop_warnings = WARN_ALL ;
2128 PL_dowarn = G_WARN_ALL_OFF;
2129 PL_compiling.cop_warnings = WARN_NONE ;
2134 if (s[1] == '-') /* Additional switches on #! line. */
2139 #if defined(WIN32) || !defined(PERL_STRICT_CR)
2145 #ifdef ALTERNATE_SHEBANG
2146 case 'S': /* OS/2 needs -S on "extproc" line. */
2154 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
2159 /* compliments of Tom Christiansen */
2161 /* unexec() can be found in the Gnu emacs distribution */
2162 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
2165 Perl_my_unexec(pTHX)
2173 prog = newSVpv(BIN_EXP, 0);
2174 sv_catpv(prog, "/perl");
2175 file = newSVpv(PL_origfilename, 0);
2176 sv_catpv(file, ".perldump");
2178 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2179 /* unexec prints msg to stderr in case of failure */
2180 PerlProc_exit(status);
2183 # include <lib$routines.h>
2184 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
2186 ABORT(); /* for use with undump */
2191 /* initialize curinterp */
2196 #ifdef PERL_OBJECT /* XXX kludge */
2199 PL_chopset = " \n-"; \
2200 PL_copline = NOLINE; \
2201 PL_curcop = &PL_compiling;\
2202 PL_curcopdb = NULL; \
2204 PL_dumpindent = 4; \
2205 PL_laststatval = -1; \
2206 PL_laststype = OP_STAT; \
2207 PL_maxscream = -1; \
2208 PL_maxsysfd = MAXSYSFD; \
2209 PL_statname = Nullsv; \
2210 PL_tmps_floor = -1; \
2212 PL_op_mask = NULL; \
2213 PL_laststatval = -1; \
2214 PL_laststype = OP_STAT; \
2215 PL_mess_sv = Nullsv; \
2216 PL_splitstr = " "; \
2217 PL_generation = 100; \
2218 PL_exitlist = NULL; \
2219 PL_exitlistlen = 0; \
2221 PL_in_clean_objs = FALSE; \
2222 PL_in_clean_all = FALSE; \
2223 PL_profiledata = NULL; \
2225 PL_rsfp_filters = Nullav; \
2230 # ifdef MULTIPLICITY
2231 # define PERLVAR(var,type)
2232 # define PERLVARA(var,n,type)
2233 # if defined(PERL_IMPLICIT_CONTEXT)
2234 # if defined(USE_THREADS)
2235 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2236 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2237 # else /* !USE_THREADS */
2238 # define PERLVARI(var,type,init) aTHX->var = init;
2239 # define PERLVARIC(var,type,init) aTHX->var = init;
2240 # endif /* USE_THREADS */
2242 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2243 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2245 # include "intrpvar.h"
2246 # ifndef USE_THREADS
2247 # include "thrdvar.h"
2254 # define PERLVAR(var,type)
2255 # define PERLVARA(var,n,type)
2256 # define PERLVARI(var,type,init) PL_##var = init;
2257 # define PERLVARIC(var,type,init) PL_##var = init;
2258 # include "intrpvar.h"
2259 # ifndef USE_THREADS
2260 # include "thrdvar.h"
2272 S_init_main_stash(pTHX)
2277 /* Note that strtab is a rather special HV. Assumptions are made
2278 about not iterating on it, and not adding tie magic to it.
2279 It is properly deallocated in perl_destruct() */
2280 PL_strtab = newHV();
2282 MUTEX_INIT(&PL_strtab_mutex);
2284 HvSHAREKEYS_off(PL_strtab); /* mandatory */
2285 hv_ksplit(PL_strtab, 512);
2287 PL_curstash = PL_defstash = newHV();
2288 PL_curstname = newSVpvn("main",4);
2289 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2290 SvREFCNT_dec(GvHV(gv));
2291 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2293 HvNAME(PL_defstash) = savepv("main");
2294 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2295 GvMULTI_on(PL_incgv);
2296 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2297 GvMULTI_on(PL_hintgv);
2298 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2299 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2300 GvMULTI_on(PL_errgv);
2301 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2302 GvMULTI_on(PL_replgv);
2303 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
2304 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2305 sv_setpvn(ERRSV, "", 0);
2306 PL_curstash = PL_defstash;
2307 CopSTASH_set(&PL_compiling, PL_defstash);
2308 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2309 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2310 /* We must init $/ before switches are processed. */
2311 sv_setpvn(get_sv("/", TRUE), "\n", 1);
2315 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2323 PL_origfilename = savepv("-e");
2326 /* if find_script() returns, it returns a malloc()-ed value */
2327 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2329 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2330 char *s = scriptname + 8;
2331 *fdscript = atoi(s);
2335 scriptname = savepv(s + 1);
2336 Safefree(PL_origfilename);
2337 PL_origfilename = scriptname;
2342 CopFILE_set(PL_curcop, PL_origfilename);
2343 if (strEQ(PL_origfilename,"-"))
2345 if (*fdscript >= 0) {
2346 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2347 #if defined(HAS_FCNTL) && defined(F_SETFD)
2349 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2352 else if (PL_preprocess) {
2353 char *cpp_cfg = CPPSTDIN;
2354 SV *cpp = newSVpvn("",0);
2355 SV *cmd = NEWSV(0,0);
2357 if (strEQ(cpp_cfg, "cppstdin"))
2358 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2359 sv_catpv(cpp, cpp_cfg);
2361 sv_catpvn(sv, "-I", 2);
2362 sv_catpv(sv,PRIVLIB_EXP);
2365 Perl_sv_setpvf(aTHX_ cmd, "\
2366 sed %s -e \"/^[^#]/b\" \
2367 -e \"/^#[ ]*include[ ]/b\" \
2368 -e \"/^#[ ]*define[ ]/b\" \
2369 -e \"/^#[ ]*if[ ]/b\" \
2370 -e \"/^#[ ]*ifdef[ ]/b\" \
2371 -e \"/^#[ ]*ifndef[ ]/b\" \
2372 -e \"/^#[ ]*else/b\" \
2373 -e \"/^#[ ]*elif[ ]/b\" \
2374 -e \"/^#[ ]*undef[ ]/b\" \
2375 -e \"/^#[ ]*endif/b\" \
2377 %s | %"SVf" -C %"SVf" %s",
2378 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2381 Perl_sv_setpvf(aTHX_ cmd, "\
2382 %s %s -e '/^[^#]/b' \
2383 -e '/^#[ ]*include[ ]/b' \
2384 -e '/^#[ ]*define[ ]/b' \
2385 -e '/^#[ ]*if[ ]/b' \
2386 -e '/^#[ ]*ifdef[ ]/b' \
2387 -e '/^#[ ]*ifndef[ ]/b' \
2388 -e '/^#[ ]*else/b' \
2389 -e '/^#[ ]*elif[ ]/b' \
2390 -e '/^#[ ]*undef[ ]/b' \
2391 -e '/^#[ ]*endif/b' \
2393 %s | %"SVf" %"SVf" %s",
2395 Perl_sv_setpvf(aTHX_ cmd, "\
2396 %s %s -e '/^[^#]/b' \
2397 -e '/^#[ ]*include[ ]/b' \
2398 -e '/^#[ ]*define[ ]/b' \
2399 -e '/^#[ ]*if[ ]/b' \
2400 -e '/^#[ ]*ifdef[ ]/b' \
2401 -e '/^#[ ]*ifndef[ ]/b' \
2402 -e '/^#[ ]*else/b' \
2403 -e '/^#[ ]*elif[ ]/b' \
2404 -e '/^#[ ]*undef[ ]/b' \
2405 -e '/^#[ ]*endif/b' \
2407 %s | %"SVf" -C %"SVf" %s",
2414 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2416 scriptname, cpp, sv, CPPMINUS);
2417 PL_doextract = FALSE;
2418 #ifdef IAMSUID /* actually, this is caught earlier */
2419 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2421 (void)seteuid(PL_uid); /* musn't stay setuid root */
2424 (void)setreuid((Uid_t)-1, PL_uid);
2426 #ifdef HAS_SETRESUID
2427 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2429 PerlProc_setuid(PL_uid);
2433 if (PerlProc_geteuid() != PL_uid)
2434 Perl_croak(aTHX_ "Can't do seteuid!\n");
2436 #endif /* IAMSUID */
2437 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2441 else if (!*scriptname) {
2442 forbid_setid("program input from stdin");
2443 PL_rsfp = PerlIO_stdin();
2446 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2447 #if defined(HAS_FCNTL) && defined(F_SETFD)
2449 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2454 #ifndef IAMSUID /* in case script is not readable before setuid */
2456 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2457 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2460 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
2461 (int)PERL_REVISION, (int)PERL_VERSION,
2462 (int)PERL_SUBVERSION), PL_origargv);
2463 Perl_croak(aTHX_ "Can't do setuid\n");
2467 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2468 CopFILE(PL_curcop), Strerror(errno));
2473 * I_SYSSTATVFS HAS_FSTATVFS
2475 * I_STATFS HAS_FSTATFS
2476 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2477 * here so that metaconfig picks them up. */
2481 S_fd_on_nosuid_fs(pTHX_ int fd)
2483 int check_okay = 0; /* able to do all the required sys/libcalls */
2484 int on_nosuid = 0; /* the fd is on a nosuid fs */
2486 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2487 * fstatvfs() is UNIX98.
2488 * fstatfs() is 4.3 BSD.
2489 * ustat()+getmnt() is pre-4.3 BSD.
2490 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2491 * an irrelevant filesystem while trying to reach the right one.
2494 # ifdef HAS_FSTATVFS
2495 struct statvfs stfs;
2496 check_okay = fstatvfs(fd, &stfs) == 0;
2497 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2499 # ifdef PERL_MOUNT_NOSUID
2500 # if defined(HAS_FSTATFS) && \
2501 defined(HAS_STRUCT_STATFS) && \
2502 defined(HAS_STRUCT_STATFS_F_FLAGS)
2504 check_okay = fstatfs(fd, &stfs) == 0;
2505 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2507 # if defined(HAS_FSTAT) && \
2508 defined(HAS_USTAT) && \
2509 defined(HAS_GETMNT) && \
2510 defined(HAS_STRUCT_FS_DATA) && \
2513 if (fstat(fd, &fdst) == 0) {
2515 if (ustat(fdst.st_dev, &us) == 0) {
2517 /* NOSTAT_ONE here because we're not examining fields which
2518 * vary between that case and STAT_ONE. */
2519 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2520 size_t cmplen = sizeof(us.f_fname);
2521 if (sizeof(fsd.fd_req.path) < cmplen)
2522 cmplen = sizeof(fsd.fd_req.path);
2523 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2524 fdst.st_dev == fsd.fd_req.dev) {
2526 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2532 # endif /* fstat+ustat+getmnt */
2533 # endif /* fstatfs */
2535 # if defined(HAS_GETMNTENT) && \
2536 defined(HAS_HASMNTOPT) && \
2537 defined(MNTOPT_NOSUID)
2538 FILE *mtab = fopen("/etc/mtab", "r");
2539 struct mntent *entry;
2540 struct stat stb, fsb;
2542 if (mtab && (fstat(fd, &stb) == 0)) {
2543 while (entry = getmntent(mtab)) {
2544 if (stat(entry->mnt_dir, &fsb) == 0
2545 && fsb.st_dev == stb.st_dev)
2547 /* found the filesystem */
2549 if (hasmntopt(entry, MNTOPT_NOSUID))
2552 } /* A single fs may well fail its stat(). */
2557 # endif /* getmntent+hasmntopt */
2558 # endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */
2559 # endif /* statvfs */
2562 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
2565 #endif /* IAMSUID */
2568 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2572 /* do we need to emulate setuid on scripts? */
2574 /* This code is for those BSD systems that have setuid #! scripts disabled
2575 * in the kernel because of a security problem. Merely defining DOSUID
2576 * in perl will not fix that problem, but if you have disabled setuid
2577 * scripts in the kernel, this will attempt to emulate setuid and setgid
2578 * on scripts that have those now-otherwise-useless bits set. The setuid
2579 * root version must be called suidperl or sperlN.NNN. If regular perl
2580 * discovers that it has opened a setuid script, it calls suidperl with
2581 * the same argv that it had. If suidperl finds that the script it has
2582 * just opened is NOT setuid root, it sets the effective uid back to the
2583 * uid. We don't just make perl setuid root because that loses the
2584 * effective uid we had before invoking perl, if it was different from the
2587 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2588 * be defined in suidperl only. suidperl must be setuid root. The
2589 * Configure script will set this up for you if you want it.
2596 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2597 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2598 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2603 #ifndef HAS_SETREUID
2604 /* On this access check to make sure the directories are readable,
2605 * there is actually a small window that the user could use to make
2606 * filename point to an accessible directory. So there is a faint
2607 * chance that someone could execute a setuid script down in a
2608 * non-accessible directory. I don't know what to do about that.
2609 * But I don't think it's too important. The manual lies when
2610 * it says access() is useful in setuid programs.
2612 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
2613 Perl_croak(aTHX_ "Permission denied");
2615 /* If we can swap euid and uid, then we can determine access rights
2616 * with a simple stat of the file, and then compare device and
2617 * inode to make sure we did stat() on the same file we opened.
2618 * Then we just have to make sure he or she can execute it.
2621 struct stat tmpstatbuf;
2625 setreuid(PL_euid,PL_uid) < 0
2628 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2631 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2632 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2633 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
2634 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2635 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2636 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2637 Perl_croak(aTHX_ "Permission denied");
2639 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2640 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2641 (void)PerlIO_close(PL_rsfp);
2642 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2643 PerlIO_printf(PL_rsfp,
2644 "User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2645 (Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n",
2646 PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2647 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2649 PL_statbuf.st_uid, PL_statbuf.st_gid);
2650 (void)PerlProc_pclose(PL_rsfp);
2652 Perl_croak(aTHX_ "Permission denied\n");
2656 setreuid(PL_uid,PL_euid) < 0
2658 # if defined(HAS_SETRESUID)
2659 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2662 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2663 Perl_croak(aTHX_ "Can't reswap uid and euid");
2664 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2665 Perl_croak(aTHX_ "Permission denied\n");
2667 #endif /* HAS_SETREUID */
2668 #endif /* IAMSUID */
2670 if (!S_ISREG(PL_statbuf.st_mode))
2671 Perl_croak(aTHX_ "Permission denied");
2672 if (PL_statbuf.st_mode & S_IWOTH)
2673 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2674 PL_doswitches = FALSE; /* -s is insecure in suid */
2675 CopLINE_inc(PL_curcop);
2676 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2677 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2678 Perl_croak(aTHX_ "No #! line");
2679 s = SvPV(PL_linestr,n_a)+2;
2681 while (!isSPACE(*s)) s++;
2682 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2683 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2684 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2685 Perl_croak(aTHX_ "Not a perl script");
2686 while (*s == ' ' || *s == '\t') s++;
2688 * #! arg must be what we saw above. They can invoke it by
2689 * mentioning suidperl explicitly, but they may not add any strange
2690 * arguments beyond what #! says if they do invoke suidperl that way.
2692 len = strlen(validarg);
2693 if (strEQ(validarg," PHOOEY ") ||
2694 strnNE(s,validarg,len) || !isSPACE(s[len]))
2695 Perl_croak(aTHX_ "Args must match #! line");
2698 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2699 PL_euid == PL_statbuf.st_uid)
2701 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2702 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2703 #endif /* IAMSUID */
2705 if (PL_euid) { /* oops, we're not the setuid root perl */
2706 (void)PerlIO_close(PL_rsfp);
2709 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
2710 (int)PERL_REVISION, (int)PERL_VERSION,
2711 (int)PERL_SUBVERSION), PL_origargv);
2713 Perl_croak(aTHX_ "Can't do setuid\n");
2716 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2718 (void)setegid(PL_statbuf.st_gid);
2721 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2723 #ifdef HAS_SETRESGID
2724 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2726 PerlProc_setgid(PL_statbuf.st_gid);
2730 if (PerlProc_getegid() != PL_statbuf.st_gid)
2731 Perl_croak(aTHX_ "Can't do setegid!\n");
2733 if (PL_statbuf.st_mode & S_ISUID) {
2734 if (PL_statbuf.st_uid != PL_euid)
2736 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2739 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2741 #ifdef HAS_SETRESUID
2742 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2744 PerlProc_setuid(PL_statbuf.st_uid);
2748 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2749 Perl_croak(aTHX_ "Can't do seteuid!\n");
2751 else if (PL_uid) { /* oops, mustn't run as root */
2753 (void)seteuid((Uid_t)PL_uid);
2756 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2758 #ifdef HAS_SETRESUID
2759 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2761 PerlProc_setuid((Uid_t)PL_uid);
2765 if (PerlProc_geteuid() != PL_uid)
2766 Perl_croak(aTHX_ "Can't do seteuid!\n");
2769 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2770 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
2773 else if (PL_preprocess)
2774 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2775 else if (fdscript >= 0)
2776 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2778 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2780 /* We absolutely must clear out any saved ids here, so we */
2781 /* exec the real perl, substituting fd script for scriptname. */
2782 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2783 PerlIO_rewind(PL_rsfp);
2784 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2785 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2786 if (!PL_origargv[which])
2787 Perl_croak(aTHX_ "Permission denied");
2788 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2789 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2790 #if defined(HAS_FCNTL) && defined(F_SETFD)
2791 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2793 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
2794 (int)PERL_REVISION, (int)PERL_VERSION,
2795 (int)PERL_SUBVERSION), PL_origargv);/* try again */
2796 Perl_croak(aTHX_ "Can't do setuid\n");
2797 #endif /* IAMSUID */
2799 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2800 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2802 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2803 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2805 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2808 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2809 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2810 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2811 /* not set-id, must be wrapped */
2817 S_find_beginning(pTHX)
2819 register char *s, *s2;
2821 /* skip forward in input to the real script? */
2824 while (PL_doextract) {
2825 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2826 Perl_croak(aTHX_ "No Perl script found in input\n");
2827 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2828 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2829 PL_doextract = FALSE;
2830 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2832 while (*s == ' ' || *s == '\t') s++;
2834 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2835 if (strnEQ(s2-4,"perl",4))
2837 while (s = moreswitches(s)) ;
2847 PL_uid = PerlProc_getuid();
2848 PL_euid = PerlProc_geteuid();
2849 PL_gid = PerlProc_getgid();
2850 PL_egid = PerlProc_getegid();
2852 PL_uid |= PL_gid << 16;
2853 PL_euid |= PL_egid << 16;
2855 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2859 S_forbid_setid(pTHX_ char *s)
2861 if (PL_euid != PL_uid)
2862 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2863 if (PL_egid != PL_gid)
2864 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2868 Perl_init_debugger(pTHX)
2871 HV *ostash = PL_curstash;
2873 PL_curstash = PL_debstash;
2874 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2875 AvREAL_off(PL_dbargs);
2876 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2877 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2878 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2879 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
2880 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2881 sv_setiv(PL_DBsingle, 0);
2882 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2883 sv_setiv(PL_DBtrace, 0);
2884 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2885 sv_setiv(PL_DBsignal, 0);
2886 PL_curstash = ostash;
2889 #ifndef STRESS_REALLOC
2890 #define REASONABLE(size) (size)
2892 #define REASONABLE(size) (1) /* unreasonable */
2896 Perl_init_stacks(pTHX)
2898 /* start with 128-item stack and 8K cxstack */
2899 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2900 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2901 PL_curstackinfo->si_type = PERLSI_MAIN;
2902 PL_curstack = PL_curstackinfo->si_stack;
2903 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2905 PL_stack_base = AvARRAY(PL_curstack);
2906 PL_stack_sp = PL_stack_base;
2907 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2909 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2912 PL_tmps_max = REASONABLE(128);
2914 New(54,PL_markstack,REASONABLE(32),I32);
2915 PL_markstack_ptr = PL_markstack;
2916 PL_markstack_max = PL_markstack + REASONABLE(32);
2920 New(54,PL_scopestack,REASONABLE(32),I32);
2921 PL_scopestack_ix = 0;
2922 PL_scopestack_max = REASONABLE(32);
2924 New(54,PL_savestack,REASONABLE(128),ANY);
2925 PL_savestack_ix = 0;
2926 PL_savestack_max = REASONABLE(128);
2928 New(54,PL_retstack,REASONABLE(16),OP*);
2930 PL_retstack_max = REASONABLE(16);
2939 while (PL_curstackinfo->si_next)
2940 PL_curstackinfo = PL_curstackinfo->si_next;
2941 while (PL_curstackinfo) {
2942 PERL_SI *p = PL_curstackinfo->si_prev;
2943 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2944 Safefree(PL_curstackinfo->si_cxstack);
2945 Safefree(PL_curstackinfo);
2946 PL_curstackinfo = p;
2948 Safefree(PL_tmps_stack);
2949 Safefree(PL_markstack);
2950 Safefree(PL_scopestack);
2951 Safefree(PL_savestack);
2952 Safefree(PL_retstack);
2956 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2967 lex_start(PL_linestr);
2969 PL_subname = newSVpvn("main",4);
2973 S_init_predump_symbols(pTHX)
2980 sv_setpvn(get_sv("\"", TRUE), " ", 1);
2981 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2982 GvMULTI_on(PL_stdingv);
2983 io = GvIOp(PL_stdingv);
2984 IoIFP(io) = PerlIO_stdin();
2985 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2987 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2989 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2992 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
2994 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2996 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2998 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2999 GvMULTI_on(PL_stderrgv);
3000 io = GvIOp(PL_stderrgv);
3001 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
3002 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
3004 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3006 PL_statname = NEWSV(66,0); /* last filename we did stat on */
3009 PL_osname = savepv(OSNAME);
3013 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3020 argc--,argv++; /* skip name of script */
3021 if (PL_doswitches) {
3022 for (; argc > 0 && **argv == '-'; argc--,argv++) {
3025 if (argv[0][1] == '-' && !argv[0][2]) {
3029 if (s = strchr(argv[0], '=')) {
3031 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
3034 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
3037 PL_toptarget = NEWSV(0,0);
3038 sv_upgrade(PL_toptarget, SVt_PVFM);
3039 sv_setpvn(PL_toptarget, "", 0);
3040 PL_bodytarget = NEWSV(0,0);
3041 sv_upgrade(PL_bodytarget, SVt_PVFM);
3042 sv_setpvn(PL_bodytarget, "", 0);
3043 PL_formtarget = PL_bodytarget;
3046 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
3047 sv_setpv(GvSV(tmpgv),PL_origfilename);
3048 magicname("0", "0", 1);
3050 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
3052 sv_setpv(GvSV(tmpgv), os2_execname());
3054 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
3056 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
3057 GvMULTI_on(PL_argvgv);
3058 (void)gv_AVadd(PL_argvgv);
3059 av_clear(GvAVn(PL_argvgv));
3060 for (; argc > 0; argc--,argv++) {
3061 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
3064 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
3066 GvMULTI_on(PL_envgv);
3067 hv = GvHVn(PL_envgv);
3068 hv_magic(hv, PL_envgv, 'E');
3069 #if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
3070 /* Note that if the supplied env parameter is actually a copy
3071 of the global environ then it may now point to free'd memory
3072 if the environment has been modified since. To avoid this
3073 problem we treat env==NULL as meaning 'use the default'
3078 environ[0] = Nullch;
3079 for (; *env; env++) {
3080 if (!(s = strchr(*env,'=')))
3086 sv = newSVpv(s--,0);
3087 (void)hv_store(hv, *env, s - *env, sv, 0);
3089 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
3090 /* Sins of the RTL. See note in my_setenv(). */
3091 (void)PerlEnv_putenv(savepv(*env));
3095 #ifdef DYNAMIC_ENV_FETCH
3096 HvNAME(hv) = savepv(ENV_HV_NAME);
3100 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
3101 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3105 S_init_perllib(pTHX)
3110 s = PerlEnv_getenv("PERL5LIB");
3114 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
3116 /* Treat PERL5?LIB as a possible search list logical name -- the
3117 * "natural" VMS idiom for a Unix path string. We allow each
3118 * element to be a set of |-separated directories for compatibility.
3122 if (my_trnlnm("PERL5LIB",buf,0))
3123 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
3125 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
3129 /* Use the ~-expanded versions of APPLLIB (undocumented),
3130 ARCHLIB PRIVLIB SITEARCH and SITELIB
3133 incpush(APPLLIB_EXP, TRUE);
3137 incpush(ARCHLIB_EXP, FALSE);
3140 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
3143 incpush(PRIVLIB_EXP, TRUE);
3145 incpush(PRIVLIB_EXP, FALSE);
3149 incpush(SITELIB_EXP, TRUE); /* XXX Win32 needs inc_version_list support */
3153 char *path = SITELIB_EXP;
3158 if (strrchr(buf,'/')) /* XXX Hack, Configure var needed */
3159 *strrchr(buf,'/') = '\0';
3165 #if defined(PERL_VENDORLIB_EXP)
3167 incpush(PERL_VENDORLIB_EXP, TRUE);
3169 incpush(PERL_VENDORLIB_EXP, FALSE);
3173 incpush(".", FALSE);
3177 # define PERLLIB_SEP ';'
3180 # define PERLLIB_SEP '|'
3182 # define PERLLIB_SEP ':'
3185 #ifndef PERLLIB_MANGLE
3186 # define PERLLIB_MANGLE(s,n) (s)
3190 S_incpush(pTHX_ char *p, int addsubdirs)
3192 SV *subdir = Nullsv;
3198 subdir = sv_newmortal();
3201 /* Break at all separators */
3203 SV *libdir = NEWSV(55,0);
3206 /* skip any consecutive separators */
3207 while ( *p == PERLLIB_SEP ) {
3208 /* Uncomment the next line for PATH semantics */
3209 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3213 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3214 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3219 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3220 p = Nullch; /* break out */
3224 * BEFORE pushing libdir onto @INC we may first push version- and
3225 * archname-specific sub-directories.
3228 #ifdef PERL_INC_VERSION_LIST
3229 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3230 const char *incverlist[] = { PERL_INC_VERSION_LIST };
3231 const char **incver;
3233 struct stat tmpstatbuf;
3238 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3240 while (unix[len-1] == '/') len--; /* Cosmetic */
3241 sv_usepvn(libdir,unix,len);
3244 PerlIO_printf(Perl_error_log,
3245 "Failed to unixify @INC element \"%s\"\n",
3248 /* .../version/archname if -d .../version/archname */
3249 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT"/%s", libdir,
3250 (int)PERL_REVISION, (int)PERL_VERSION,
3251 (int)PERL_SUBVERSION, ARCHNAME);
3252 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3253 S_ISDIR(tmpstatbuf.st_mode))
3254 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3256 /* .../version if -d .../version */
3257 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT, libdir,
3258 (int)PERL_REVISION, (int)PERL_VERSION,
3259 (int)PERL_SUBVERSION);
3260 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3261 S_ISDIR(tmpstatbuf.st_mode))
3262 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3264 /* .../archname if -d .../archname */
3265 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, ARCHNAME);
3266 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3267 S_ISDIR(tmpstatbuf.st_mode))
3268 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3270 #ifdef PERL_INC_VERSION_LIST
3271 for (incver = incverlist; *incver; incver++) {
3272 /* .../xxx if -d .../xxx */
3273 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, *incver);
3274 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3275 S_ISDIR(tmpstatbuf.st_mode))
3276 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3281 /* finally push this lib directory on the end of @INC */
3282 av_push(GvAVn(PL_incgv), libdir);
3287 STATIC struct perl_thread *
3288 S_init_main_thread(pTHX)
3290 #if !defined(PERL_IMPLICIT_CONTEXT)
3291 struct perl_thread *thr;
3295 Newz(53, thr, 1, struct perl_thread);
3296 PL_curcop = &PL_compiling;
3297 thr->interp = PERL_GET_INTERP;
3298 thr->cvcache = newHV();
3299 thr->threadsv = newAV();
3300 /* thr->threadsvp is set when find_threadsv is called */
3301 thr->specific = newAV();
3302 thr->flags = THRf_R_JOINABLE;
3303 MUTEX_INIT(&thr->mutex);
3304 /* Handcraft thrsv similarly to mess_sv */
3305 New(53, PL_thrsv, 1, SV);
3306 Newz(53, xpv, 1, XPV);
3307 SvFLAGS(PL_thrsv) = SVt_PV;
3308 SvANY(PL_thrsv) = (void*)xpv;
3309 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3310 SvPVX(PL_thrsv) = (char*)thr;
3311 SvCUR_set(PL_thrsv, sizeof(thr));
3312 SvLEN_set(PL_thrsv, sizeof(thr));
3313 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3314 thr->oursv = PL_thrsv;
3315 PL_chopset = " \n-";
3318 MUTEX_LOCK(&PL_threads_mutex);
3323 MUTEX_UNLOCK(&PL_threads_mutex);
3325 #ifdef HAVE_THREAD_INTERN
3326 Perl_init_thread_intern(thr);
3329 #ifdef SET_THREAD_SELF
3330 SET_THREAD_SELF(thr);
3332 thr->self = pthread_self();
3333 #endif /* SET_THREAD_SELF */
3337 * These must come after the SET_THR because sv_setpvn does
3338 * SvTAINT and the taint fields require dTHR.
3340 PL_toptarget = NEWSV(0,0);
3341 sv_upgrade(PL_toptarget, SVt_PVFM);
3342 sv_setpvn(PL_toptarget, "", 0);
3343 PL_bodytarget = NEWSV(0,0);
3344 sv_upgrade(PL_bodytarget, SVt_PVFM);
3345 sv_setpvn(PL_bodytarget, "", 0);
3346 PL_formtarget = PL_bodytarget;
3347 thr->errsv = newSVpvn("", 0);
3348 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
3351 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3352 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3353 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3354 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3355 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3357 PL_reginterp_cnt = 0;
3361 #endif /* USE_THREADS */
3364 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3368 line_t oldline = CopLINE(PL_curcop);
3374 while (AvFILL(paramList) >= 0) {
3375 cv = (CV*)av_shift(paramList);
3377 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
3381 (void)SvPV(atsv, len);
3384 PL_curcop = &PL_compiling;
3385 CopLINE_set(PL_curcop, oldline);
3386 if (paramList == PL_beginav)
3387 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3389 Perl_sv_catpvf(aTHX_ atsv,
3390 "%s failed--call queue aborted",
3391 paramList == PL_checkav ? "CHECK"
3392 : paramList == PL_initav ? "INIT"
3394 while (PL_scopestack_ix > oldscope)
3396 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
3403 /* my_exit() was called */
3404 while (PL_scopestack_ix > oldscope)
3407 PL_curstash = PL_defstash;
3408 PL_curcop = &PL_compiling;
3409 CopLINE_set(PL_curcop, oldline);
3410 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3411 if (paramList == PL_beginav)
3412 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3414 Perl_croak(aTHX_ "%s failed--call queue aborted",
3415 paramList == PL_checkav ? "CHECK"
3416 : paramList == PL_initav ? "INIT"
3423 PL_curcop = &PL_compiling;
3424 CopLINE_set(PL_curcop, oldline);
3427 PerlIO_printf(Perl_error_log, "panic: restartop\n");
3435 S_call_list_body(pTHX_ va_list args)
3438 CV *cv = va_arg(args, CV*);
3440 PUSHMARK(PL_stack_sp);
3441 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3446 Perl_my_exit(pTHX_ U32 status)
3450 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3451 thr, (unsigned long) status));
3460 STATUS_NATIVE_SET(status);
3467 Perl_my_failure_exit(pTHX)
3470 if (vaxc$errno & 1) {
3471 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3472 STATUS_NATIVE_SET(44);
3475 if (!vaxc$errno && errno) /* unlikely */
3476 STATUS_NATIVE_SET(44);
3478 STATUS_NATIVE_SET(vaxc$errno);
3483 STATUS_POSIX_SET(errno);
3485 exitstatus = STATUS_POSIX >> 8;
3486 if (exitstatus & 255)
3487 STATUS_POSIX_SET(exitstatus);
3489 STATUS_POSIX_SET(255);
3496 S_my_exit_jump(pTHX)
3499 register PERL_CONTEXT *cx;
3504 SvREFCNT_dec(PL_e_script);
3505 PL_e_script = Nullsv;
3508 POPSTACK_TO(PL_mainstack);
3509 if (cxstack_ix >= 0) {
3512 POPBLOCK(cx,PL_curpm);
3524 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3527 p = SvPVX(PL_e_script);
3528 nl = strchr(p, '\n');
3529 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3531 filter_del(read_e_script);
3534 sv_catpvn(buf_sv, p, nl-p);
3535 sv_chop(PL_e_script, nl);