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; /* $* */
459 SvREFCNT_dec(PL_statname);
460 PL_statname = Nullsv;
463 /* defgv, aka *_ should be taken care of elsewhere */
465 /* clean up after study() */
466 SvREFCNT_dec(PL_lastscream);
467 PL_lastscream = Nullsv;
468 Safefree(PL_screamfirst);
470 Safefree(PL_screamnext);
474 Safefree(PL_efloatbuf);
475 PL_efloatbuf = Nullch;
478 /* startup and shutdown function lists */
479 SvREFCNT_dec(PL_beginav);
480 SvREFCNT_dec(PL_endav);
481 SvREFCNT_dec(PL_checkav);
482 SvREFCNT_dec(PL_initav);
488 /* shortcuts just get cleared */
494 PL_argvoutgv = Nullgv;
496 PL_stderrgv = Nullgv;
497 PL_last_in_gv = Nullgv;
499 PL_debstash = Nullhv;
501 /* reset so print() ends up where we expect */
504 SvREFCNT_dec(PL_argvout_stack);
505 PL_argvout_stack = Nullav;
507 SvREFCNT_dec(PL_fdpid);
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 /* clear utf8 character classes */
526 SvREFCNT_dec(PL_utf8_alnum);
527 SvREFCNT_dec(PL_utf8_alnumc);
528 SvREFCNT_dec(PL_utf8_ascii);
529 SvREFCNT_dec(PL_utf8_alpha);
530 SvREFCNT_dec(PL_utf8_space);
531 SvREFCNT_dec(PL_utf8_cntrl);
532 SvREFCNT_dec(PL_utf8_graph);
533 SvREFCNT_dec(PL_utf8_digit);
534 SvREFCNT_dec(PL_utf8_upper);
535 SvREFCNT_dec(PL_utf8_lower);
536 SvREFCNT_dec(PL_utf8_print);
537 SvREFCNT_dec(PL_utf8_punct);
538 SvREFCNT_dec(PL_utf8_xdigit);
539 SvREFCNT_dec(PL_utf8_mark);
540 SvREFCNT_dec(PL_utf8_toupper);
541 SvREFCNT_dec(PL_utf8_tolower);
542 PL_utf8_alnum = Nullsv;
543 PL_utf8_alnumc = Nullsv;
544 PL_utf8_ascii = Nullsv;
545 PL_utf8_alpha = Nullsv;
546 PL_utf8_space = Nullsv;
547 PL_utf8_cntrl = Nullsv;
548 PL_utf8_graph = Nullsv;
549 PL_utf8_digit = Nullsv;
550 PL_utf8_upper = Nullsv;
551 PL_utf8_lower = Nullsv;
552 PL_utf8_print = Nullsv;
553 PL_utf8_punct = Nullsv;
554 PL_utf8_xdigit = Nullsv;
555 PL_utf8_mark = Nullsv;
556 PL_utf8_toupper = Nullsv;
557 PL_utf8_totitle = Nullsv;
558 PL_utf8_tolower = Nullsv;
560 if (!specialWARN(PL_compiling.cop_warnings))
561 SvREFCNT_dec(PL_compiling.cop_warnings);
562 PL_compiling.cop_warnings = Nullsv;
564 /* Prepare to destruct main symbol table. */
569 SvREFCNT_dec(PL_curstname);
570 PL_curstname = Nullsv;
572 /* clear queued errors */
573 SvREFCNT_dec(PL_errors);
577 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
578 if (PL_scopestack_ix != 0)
579 Perl_warner(aTHX_ WARN_INTERNAL,
580 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
581 (long)PL_scopestack_ix);
582 if (PL_savestack_ix != 0)
583 Perl_warner(aTHX_ WARN_INTERNAL,
584 "Unbalanced saves: %ld more saves than restores\n",
585 (long)PL_savestack_ix);
586 if (PL_tmps_floor != -1)
587 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
588 (long)PL_tmps_floor + 1);
589 if (cxstack_ix != -1)
590 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
591 (long)cxstack_ix + 1);
594 /* Now absolutely destruct everything, somehow or other, loops or no. */
596 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
597 while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
598 last_sv_count = PL_sv_count;
601 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
602 SvFLAGS(PL_strtab) |= SVt_PVHV;
604 /* Destruct the global string table. */
606 /* Yell and reset the HeVAL() slots that are still holding refcounts,
607 * so that sv_free() won't fail on them.
615 max = HvMAX(PL_strtab);
616 array = HvARRAY(PL_strtab);
619 if (hent && ckWARN_d(WARN_INTERNAL)) {
620 Perl_warner(aTHX_ WARN_INTERNAL,
621 "Unbalanced string table refcount: (%d) for \"%s\"",
622 HeVAL(hent) - Nullsv, HeKEY(hent));
623 HeVAL(hent) = Nullsv;
633 SvREFCNT_dec(PL_strtab);
635 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
636 Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
640 /* No SVs have survived, need to clean out */
641 Safefree(PL_origfilename);
642 Safefree(PL_reg_start_tmp);
644 Safefree(PL_reg_curpm);
645 Safefree(PL_reg_poscache);
646 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
647 Safefree(PL_op_mask);
649 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
651 DEBUG_P(debprofdump());
653 MUTEX_DESTROY(&PL_strtab_mutex);
654 MUTEX_DESTROY(&PL_sv_mutex);
655 MUTEX_DESTROY(&PL_eval_mutex);
656 MUTEX_DESTROY(&PL_cred_mutex);
657 COND_DESTROY(&PL_eval_cond);
658 #ifdef EMULATE_ATOMIC_REFCOUNTS
659 MUTEX_DESTROY(&PL_svref_mutex);
660 #endif /* EMULATE_ATOMIC_REFCOUNTS */
662 /* As the penultimate thing, free the non-arena SV for thrsv */
663 Safefree(SvPVX(PL_thrsv));
664 Safefree(SvANY(PL_thrsv));
667 #endif /* USE_THREADS */
669 /* As the absolutely last thing, free the non-arena SV for mess() */
672 /* it could have accumulated taint magic */
673 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
676 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
677 moremagic = mg->mg_moremagic;
678 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
679 Safefree(mg->mg_ptr);
683 /* we know that type >= SVt_PV */
684 SvOOK_off(PL_mess_sv);
685 Safefree(SvPVX(PL_mess_sv));
686 Safefree(SvANY(PL_mess_sv));
687 Safefree(PL_mess_sv);
693 =for apidoc perl_free
695 Releases a Perl interpreter. See L<perlembed>.
703 #if defined(PERL_OBJECT)
711 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
713 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
714 PL_exitlist[PL_exitlistlen].fn = fn;
715 PL_exitlist[PL_exitlistlen].ptr = ptr;
720 =for apidoc perl_parse
722 Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
728 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
738 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
741 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
742 setuid perl scripts securely.\n");
746 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
747 _dyld_lookup_and_bind
748 ("__environ", (unsigned long *) &environ_pointer, NULL);
753 #ifndef VMS /* VMS doesn't have environ array */
754 PL_origenviron = environ;
759 /* Come here if running an undumped a.out. */
761 PL_origfilename = savepv(argv[0]);
762 PL_do_undump = FALSE;
763 cxstack_ix = -1; /* start label stack again */
765 init_postdump_symbols(argc,argv,env);
770 PL_curpad = AvARRAY(PL_comppad);
771 op_free(PL_main_root);
772 PL_main_root = Nullop;
774 PL_main_start = Nullop;
775 SvREFCNT_dec(PL_main_cv);
779 oldscope = PL_scopestack_ix;
780 PL_dowarn = G_WARN_OFF;
782 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_parse_body),
787 call_list(oldscope, PL_checkav);
793 /* my_exit() was called */
794 while (PL_scopestack_ix > oldscope)
797 PL_curstash = PL_defstash;
799 call_list(oldscope, PL_checkav);
800 return STATUS_NATIVE_EXPORT;
802 PerlIO_printf(Perl_error_log, "panic: top_env\n");
809 S_parse_body(pTHX_ va_list args)
812 int argc = PL_origargc;
813 char **argv = PL_origargv;
814 char **env = va_arg(args, char**);
815 char *scriptname = NULL;
817 VOL bool dosearch = FALSE;
822 char *cddir = Nullch;
824 XSINIT_t xsinit = va_arg(args, XSINIT_t);
826 sv_setpvn(PL_linestr,"",0);
827 sv = newSVpvn("",0); /* first used for -I flags */
831 for (argc--,argv++; argc > 0; argc--,argv++) {
832 if (argv[0][0] != '-' || !argv[0][1])
836 validarg = " PHOOEY ";
843 #ifndef PERL_STRICT_CR
868 if (s = moreswitches(s))
878 if (PL_euid != PL_uid || PL_egid != PL_gid)
879 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
881 PL_e_script = newSVpvn("",0);
882 filter_add(read_e_script, NULL);
885 sv_catpv(PL_e_script, s);
887 sv_catpv(PL_e_script, argv[1]);
891 Perl_croak(aTHX_ "No code specified for -e");
892 sv_catpv(PL_e_script, "\n");
895 case 'I': /* -I handled both here and in moreswitches() */
897 if (!*++s && (s=argv[1]) != Nullch) {
902 STRLEN len = strlen(s);
905 sv_catpvn(sv, "-I", 2);
906 sv_catpvn(sv, p, len);
907 sv_catpvn(sv, " ", 1);
911 Perl_croak(aTHX_ "No directory specified for -I");
915 PL_preprocess = TRUE;
925 PL_preambleav = newAV();
926 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
928 PL_Sv = newSVpv("print myconfig();",0);
930 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
932 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
934 sv_catpv(PL_Sv,"\" Compile-time options:");
936 sv_catpv(PL_Sv," DEBUGGING");
939 sv_catpv(PL_Sv," MULTIPLICITY");
942 sv_catpv(PL_Sv," USE_THREADS");
945 sv_catpv(PL_Sv," USE_ITHREADS");
948 sv_catpv(PL_Sv," USE_64_BITS");
950 # ifdef USE_LONG_DOUBLE
951 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
953 # ifdef USE_LARGE_FILES
954 sv_catpv(PL_Sv," USE_LARGE_FILES");
957 sv_catpv(PL_Sv," USE_SOCKS");
960 sv_catpv(PL_Sv," PERL_OBJECT");
962 # ifdef PERL_IMPLICIT_CONTEXT
963 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
965 # ifdef PERL_IMPLICIT_SYS
966 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
968 sv_catpv(PL_Sv,"\\n\",");
970 #if defined(LOCAL_PATCH_COUNT)
971 if (LOCAL_PATCH_COUNT > 0) {
973 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
974 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
975 if (PL_localpatches[i])
976 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
980 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
983 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
985 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
990 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
991 print \" \\%ENV:\\n @env\\n\" if @env; \
992 print \" \\@INC:\\n @INC\\n\";");
995 PL_Sv = newSVpv("config_vars(qw(",0);
996 sv_catpv(PL_Sv, ++s);
997 sv_catpv(PL_Sv, "))");
1000 av_push(PL_preambleav, PL_Sv);
1001 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1004 PL_doextract = TRUE;
1012 if (!*++s || isSPACE(*s)) {
1016 /* catch use of gnu style long options */
1017 if (strEQ(s, "version")) {
1021 if (strEQ(s, "help")) {
1028 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
1034 #ifndef SECURE_INTERNAL_GETENV
1037 (s = PerlEnv_getenv("PERL5OPT")))
1041 if (*s == '-' && *(s+1) == 'T')
1054 if (!strchr("DIMUdmw", *s))
1055 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
1056 s = moreswitches(s);
1062 scriptname = argv[0];
1065 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1067 else if (scriptname == Nullch) {
1069 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1077 open_script(scriptname,dosearch,sv,&fdscript);
1079 validate_suid(validarg, scriptname,fdscript);
1081 #if defined(SIGCHLD) || defined(SIGCLD)
1084 # define SIGCHLD SIGCLD
1086 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1087 if (sigstate == SIG_IGN) {
1088 if (ckWARN(WARN_SIGNAL))
1089 Perl_warner(aTHX_ WARN_SIGNAL,
1090 "Can't ignore signal CHLD, forcing to default");
1091 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1098 if (cddir && PerlDir_chdir(cddir) < 0)
1099 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1103 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1104 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1105 CvUNIQUE_on(PL_compcv);
1107 PL_comppad = newAV();
1108 av_push(PL_comppad, Nullsv);
1109 PL_curpad = AvARRAY(PL_comppad);
1110 PL_comppad_name = newAV();
1111 PL_comppad_name_fill = 0;
1112 PL_min_intro_pending = 0;
1115 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
1116 PL_curpad[0] = (SV*)newAV();
1117 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
1118 CvOWNER(PL_compcv) = 0;
1119 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1120 MUTEX_INIT(CvMUTEXP(PL_compcv));
1121 #endif /* USE_THREADS */
1123 comppadlist = newAV();
1124 AvREAL_off(comppadlist);
1125 av_store(comppadlist, 0, (SV*)PL_comppad_name);
1126 av_store(comppadlist, 1, (SV*)PL_comppad);
1127 CvPADLIST(PL_compcv) = comppadlist;
1129 boot_core_UNIVERSAL();
1130 boot_core_xsutils();
1133 (*xsinit)(aTHXo); /* in case linked C routines want magical variables */
1134 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
1142 init_predump_symbols();
1143 /* init_postdump_symbols not currently designed to be called */
1144 /* more than once (ENV isn't cleared first, for example) */
1145 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
1147 init_postdump_symbols(argc,argv,env);
1151 /* now parse the script */
1153 SETERRNO(0,SS$_NORMAL);
1155 if (yyparse() || PL_error_count) {
1157 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1159 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1163 CopLINE_set(PL_curcop, 0);
1164 PL_curstash = PL_defstash;
1165 PL_preprocess = FALSE;
1167 SvREFCNT_dec(PL_e_script);
1168 PL_e_script = Nullsv;
1171 /* now that script is parsed, we can modify record separator */
1172 SvREFCNT_dec(PL_rs);
1173 PL_rs = SvREFCNT_inc(PL_nrs);
1174 sv_setsv(get_sv("/", TRUE), PL_rs);
1179 SAVECOPFILE(PL_curcop);
1180 SAVECOPLINE(PL_curcop);
1181 gv_check(PL_defstash);
1188 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1189 dump_mstats("after compilation:");
1198 =for apidoc perl_run
1200 Tells a Perl interpreter to run. See L<perlembed>.
1216 oldscope = PL_scopestack_ix;
1219 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
1222 cxstack_ix = -1; /* start context stack again */
1224 case 0: /* normal completion */
1225 case 2: /* my_exit() */
1226 while (PL_scopestack_ix > oldscope)
1229 PL_curstash = PL_defstash;
1230 if (PL_endav && !PL_minus_c)
1231 call_list(oldscope, PL_endav);
1233 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1234 dump_mstats("after execution: ");
1236 return STATUS_NATIVE_EXPORT;
1239 POPSTACK_TO(PL_mainstack);
1242 PerlIO_printf(Perl_error_log, "panic: restartop\n");
1252 S_run_body(pTHX_ va_list args)
1255 I32 oldscope = va_arg(args, I32);
1257 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1258 PL_sawampersand ? "Enabling" : "Omitting"));
1260 if (!PL_restartop) {
1261 DEBUG_x(dump_all());
1262 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1263 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1267 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1270 if (PERLDB_SINGLE && PL_DBsingle)
1271 sv_setiv(PL_DBsingle, 1);
1273 call_list(oldscope, PL_initav);
1279 PL_op = PL_restartop;
1283 else if (PL_main_start) {
1284 CvDEPTH(PL_main_cv) = 1;
1285 PL_op = PL_main_start;
1295 =for apidoc p||get_sv
1297 Returns the SV of the specified Perl scalar. If C<create> is set and the
1298 Perl variable does not exist then it will be created. If C<create> is not
1299 set and the variable does not exist then NULL is returned.
1305 Perl_get_sv(pTHX_ const char *name, I32 create)
1309 if (name[1] == '\0' && !isALPHA(name[0])) {
1310 PADOFFSET tmp = find_threadsv(name);
1311 if (tmp != NOT_IN_PAD) {
1313 return THREADSV(tmp);
1316 #endif /* USE_THREADS */
1317 gv = gv_fetchpv(name, create, SVt_PV);
1324 =for apidoc p||get_av
1326 Returns the AV of the specified Perl array. If C<create> is set and the
1327 Perl variable does not exist then it will be created. If C<create> is not
1328 set and the variable does not exist then NULL is returned.
1334 Perl_get_av(pTHX_ const char *name, I32 create)
1336 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1345 =for apidoc p||get_hv
1347 Returns the HV of the specified Perl hash. If C<create> is set and the
1348 Perl variable does not exist then it will be created. If C<create> is not
1349 set and the variable does not exist then NULL is returned.
1355 Perl_get_hv(pTHX_ const char *name, I32 create)
1357 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1366 =for apidoc p||get_cv
1368 Returns the CV of the specified Perl subroutine. If C<create> is set and
1369 the Perl subroutine does not exist then it will be declared (which has the
1370 same effect as saying C<sub name;>). If C<create> is not set and the
1371 subroutine does not exist then NULL is returned.
1377 Perl_get_cv(pTHX_ const char *name, I32 create)
1379 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1380 /* XXX unsafe for threads if eval_owner isn't held */
1381 /* XXX this is probably not what they think they're getting.
1382 * It has the same effect as "sub name;", i.e. just a forward
1384 if (create && !GvCVu(gv))
1385 return newSUB(start_subparse(FALSE, 0),
1386 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1394 /* Be sure to refetch the stack pointer after calling these routines. */
1397 =for apidoc p||call_argv
1399 Performs a callback to the specified Perl sub. See L<perlcall>.
1405 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1407 /* See G_* flags in cop.h */
1408 /* null terminated arg list */
1415 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1420 return call_pv(sub_name, flags);
1424 =for apidoc p||call_pv
1426 Performs a callback to the specified Perl sub. See L<perlcall>.
1432 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1433 /* name of the subroutine */
1434 /* See G_* flags in cop.h */
1436 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1440 =for apidoc p||call_method
1442 Performs a callback to the specified Perl method. The blessed object must
1443 be on the stack. See L<perlcall>.
1449 Perl_call_method(pTHX_ const char *methname, I32 flags)
1450 /* name of the subroutine */
1451 /* See G_* flags in cop.h */
1459 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1462 return call_sv(*PL_stack_sp--, flags);
1465 /* May be called with any of a CV, a GV, or an SV containing the name. */
1467 =for apidoc p||call_sv
1469 Performs a callback to the Perl sub whose name is in the SV. See
1476 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1478 /* See G_* flags in cop.h */
1481 LOGOP myop; /* fake syntax tree node */
1485 bool oldcatch = CATCH_GET;
1490 if (flags & G_DISCARD) {
1495 Zero(&myop, 1, LOGOP);
1496 myop.op_next = Nullop;
1497 if (!(flags & G_NOARGS))
1498 myop.op_flags |= OPf_STACKED;
1499 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1500 (flags & G_ARRAY) ? OPf_WANT_LIST :
1505 EXTEND(PL_stack_sp, 1);
1506 *++PL_stack_sp = sv;
1508 oldscope = PL_scopestack_ix;
1510 if (PERLDB_SUB && PL_curstash != PL_debstash
1511 /* Handle first BEGIN of -d. */
1512 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1513 /* Try harder, since this may have been a sighandler, thus
1514 * curstash may be meaningless. */
1515 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1516 && !(flags & G_NODEBUG))
1517 PL_op->op_private |= OPpENTERSUB_DB;
1519 if (!(flags & G_EVAL)) {
1521 call_xbody((OP*)&myop, FALSE);
1522 retval = PL_stack_sp - (PL_stack_base + oldmark);
1523 CATCH_SET(oldcatch);
1526 cLOGOP->op_other = PL_op;
1528 /* we're trying to emulate pp_entertry() here */
1530 register PERL_CONTEXT *cx;
1531 I32 gimme = GIMME_V;
1536 push_return(PL_op->op_next);
1537 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1539 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1541 PL_in_eval = EVAL_INEVAL;
1542 if (flags & G_KEEPERR)
1543 PL_in_eval |= EVAL_KEEPERR;
1550 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1554 retval = PL_stack_sp - (PL_stack_base + oldmark);
1555 if (!(flags & G_KEEPERR))
1562 /* my_exit() was called */
1563 PL_curstash = PL_defstash;
1565 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1566 Perl_croak(aTHX_ "Callback called exit");
1571 PL_op = PL_restartop;
1575 PL_stack_sp = PL_stack_base + oldmark;
1576 if (flags & G_ARRAY)
1580 *++PL_stack_sp = &PL_sv_undef;
1585 if (PL_scopestack_ix > oldscope) {
1589 register PERL_CONTEXT *cx;
1600 if (flags & G_DISCARD) {
1601 PL_stack_sp = PL_stack_base + oldmark;
1611 S_call_body(pTHX_ va_list args)
1613 OP *myop = va_arg(args, OP*);
1614 int is_eval = va_arg(args, int);
1616 call_xbody(myop, is_eval);
1621 S_call_xbody(pTHX_ OP *myop, int is_eval)
1625 if (PL_op == myop) {
1627 PL_op = Perl_pp_entereval(aTHX);
1629 PL_op = Perl_pp_entersub(aTHX);
1635 /* Eval a string. The G_EVAL flag is always assumed. */
1638 =for apidoc p||eval_sv
1640 Tells Perl to C<eval> the string in the SV.
1646 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1648 /* See G_* flags in cop.h */
1651 UNOP myop; /* fake syntax tree node */
1652 I32 oldmark = SP - PL_stack_base;
1659 if (flags & G_DISCARD) {
1666 Zero(PL_op, 1, UNOP);
1667 EXTEND(PL_stack_sp, 1);
1668 *++PL_stack_sp = sv;
1669 oldscope = PL_scopestack_ix;
1671 if (!(flags & G_NOARGS))
1672 myop.op_flags = OPf_STACKED;
1673 myop.op_next = Nullop;
1674 myop.op_type = OP_ENTEREVAL;
1675 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1676 (flags & G_ARRAY) ? OPf_WANT_LIST :
1678 if (flags & G_KEEPERR)
1679 myop.op_flags |= OPf_SPECIAL;
1682 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1686 retval = PL_stack_sp - (PL_stack_base + oldmark);
1687 if (!(flags & G_KEEPERR))
1694 /* my_exit() was called */
1695 PL_curstash = PL_defstash;
1697 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1698 Perl_croak(aTHX_ "Callback called exit");
1703 PL_op = PL_restartop;
1707 PL_stack_sp = PL_stack_base + oldmark;
1708 if (flags & G_ARRAY)
1712 *++PL_stack_sp = &PL_sv_undef;
1717 if (flags & G_DISCARD) {
1718 PL_stack_sp = PL_stack_base + oldmark;
1728 =for apidoc p||eval_pv
1730 Tells Perl to C<eval> the given string and return an SV* result.
1736 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1739 SV* sv = newSVpv(p, 0);
1742 eval_sv(sv, G_SCALAR);
1749 if (croak_on_error && SvTRUE(ERRSV)) {
1751 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1757 /* Require a module. */
1760 =for apidoc p||require_pv
1762 Tells Perl to C<require> a module.
1768 Perl_require_pv(pTHX_ const char *pv)
1772 PUSHSTACKi(PERLSI_REQUIRE);
1774 sv = sv_newmortal();
1775 sv_setpv(sv, "require '");
1778 eval_sv(sv, G_DISCARD);
1784 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1788 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1789 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1793 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
1795 /* This message really ought to be max 23 lines.
1796 * Removed -h because the user already knows that opton. Others? */
1798 static char *usage_msg[] = {
1799 "-0[octal] specify record separator (\\0, if no argument)",
1800 "-a autosplit mode with -n or -p (splits $_ into @F)",
1801 "-C enable native wide character system interfaces",
1802 "-c check syntax only (runs BEGIN and END blocks)",
1803 "-d[:debugger] run program under debugger",
1804 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1805 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1806 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1807 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1808 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1809 "-l[octal] enable line ending processing, specifies line terminator",
1810 "-[mM][-]module execute `use/no module...' before executing program",
1811 "-n assume 'while (<>) { ... }' loop around program",
1812 "-p assume loop like -n but print line also, like sed",
1813 "-P run program through C preprocessor before compilation",
1814 "-s enable rudimentary parsing for switches after programfile",
1815 "-S look for programfile using PATH environment variable",
1816 "-T enable tainting checks",
1817 "-u dump core after parsing program",
1818 "-U allow unsafe operations",
1819 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1820 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1821 "-w enable many useful warnings (RECOMMENDED)",
1822 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1826 char **p = usage_msg;
1828 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1830 printf("\n %s", *p++);
1833 /* This routine handles any switches that can be given during run */
1836 Perl_moreswitches(pTHX_ char *s)
1845 rschar = (U32)scan_oct(s, 4, &numlen);
1846 SvREFCNT_dec(PL_nrs);
1847 if (rschar & ~((U8)~0))
1848 PL_nrs = &PL_sv_undef;
1849 else if (!rschar && numlen >= 2)
1850 PL_nrs = newSVpvn("", 0);
1853 PL_nrs = newSVpvn(&ch, 1);
1858 PL_widesyscalls = TRUE;
1863 PL_splitstr = savepv(s + 1);
1877 if (*s == ':' || *s == '=') {
1878 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1882 PL_perldb = PERLDB_ALL;
1890 if (isALPHA(s[1])) {
1891 static char debopts[] = "psltocPmfrxuLHXDS";
1894 for (s++; *s && (d = strchr(debopts,*s)); s++)
1895 PL_debug |= 1 << (d - debopts);
1898 PL_debug = atoi(s+1);
1899 for (s++; isDIGIT(*s); s++) ;
1901 PL_debug |= 0x80000000;
1904 if (ckWARN_d(WARN_DEBUGGING))
1905 Perl_warner(aTHX_ WARN_DEBUGGING,
1906 "Recompile perl with -DDEBUGGING to use -D switch\n");
1907 for (s++; isALNUM(*s); s++) ;
1913 usage(PL_origargv[0]);
1917 Safefree(PL_inplace);
1918 PL_inplace = savepv(s+1);
1920 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1923 if (*s == '-') /* Additional switches on #! line. */
1927 case 'I': /* -I handled both here and in parse_perl() */
1930 while (*s && isSPACE(*s))
1935 /* ignore trailing spaces (possibly followed by other switches) */
1937 for (e = p; *e && !isSPACE(*e); e++) ;
1941 } while (*p && *p != '-');
1942 e = savepvn(s, e-s);
1950 Perl_croak(aTHX_ "No directory specified for -I");
1958 PL_ors = savepv("\n");
1960 *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
1965 if (RsPARA(PL_nrs)) {
1970 PL_ors = SvPV(PL_nrs, PL_orslen);
1971 PL_ors = savepvn(PL_ors, PL_orslen);
1975 forbid_setid("-M"); /* XXX ? */
1978 forbid_setid("-m"); /* XXX ? */
1983 /* -M-foo == 'no foo' */
1984 if (*s == '-') { use = "no "; ++s; }
1985 sv = newSVpv(use,0);
1987 /* We allow -M'Module qw(Foo Bar)' */
1988 while(isALNUM(*s) || *s==':') ++s;
1990 sv_catpv(sv, start);
1991 if (*(start-1) == 'm') {
1993 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
1994 sv_catpv( sv, " ()");
1997 sv_catpvn(sv, start, s-start);
1998 sv_catpv(sv, " split(/,/,q{");
2004 PL_preambleav = newAV();
2005 av_push(PL_preambleav, sv);
2008 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
2020 PL_doswitches = TRUE;
2025 Perl_croak(aTHX_ "Too late for \"-T\" option");
2029 PL_do_undump = TRUE;
2037 printf(Perl_form(aTHX_ "\nThis is perl, v%v built for %s",
2038 PL_patchlevel, ARCHNAME));
2039 #if defined(LOCAL_PATCH_COUNT)
2040 if (LOCAL_PATCH_COUNT > 0)
2041 printf("\n(with %d registered patch%s, see perl -V for more detail)",
2042 (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
2045 printf("\n\nCopyright 1987-2000, Larry Wall\n");
2047 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
2050 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
2051 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
2054 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
2055 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
2058 printf("atariST series port, ++jrb bammi@cadence.com\n");
2061 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
2064 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
2067 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
2070 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
2073 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
2076 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
2079 printf("MiNT port by Guido Flohr, 1997-1999\n");
2081 #ifdef BINARY_BUILD_NOTICE
2082 BINARY_BUILD_NOTICE;
2085 Perl may be copied only under the terms of either the Artistic License or the\n\
2086 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
2087 Complete documentation for Perl, including FAQ lists, should be found on\n\
2088 this system using `man perl' or `perldoc perl'. If you have access to the\n\
2089 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
2092 if (! (PL_dowarn & G_WARN_ALL_MASK))
2093 PL_dowarn |= G_WARN_ON;
2097 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
2098 PL_compiling.cop_warnings = WARN_ALL ;
2102 PL_dowarn = G_WARN_ALL_OFF;
2103 PL_compiling.cop_warnings = WARN_NONE ;
2108 if (s[1] == '-') /* Additional switches on #! line. */
2113 #if defined(WIN32) || !defined(PERL_STRICT_CR)
2119 #ifdef ALTERNATE_SHEBANG
2120 case 'S': /* OS/2 needs -S on "extproc" line. */
2128 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
2133 /* compliments of Tom Christiansen */
2135 /* unexec() can be found in the Gnu emacs distribution */
2136 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
2139 Perl_my_unexec(pTHX)
2147 prog = newSVpv(BIN_EXP, 0);
2148 sv_catpv(prog, "/perl");
2149 file = newSVpv(PL_origfilename, 0);
2150 sv_catpv(file, ".perldump");
2152 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2153 /* unexec prints msg to stderr in case of failure */
2154 PerlProc_exit(status);
2157 # include <lib$routines.h>
2158 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
2160 ABORT(); /* for use with undump */
2165 /* initialize curinterp */
2170 #ifdef PERL_OBJECT /* XXX kludge */
2173 PL_chopset = " \n-"; \
2174 PL_copline = NOLINE; \
2175 PL_curcop = &PL_compiling;\
2176 PL_curcopdb = NULL; \
2178 PL_dumpindent = 4; \
2179 PL_laststatval = -1; \
2180 PL_laststype = OP_STAT; \
2181 PL_maxscream = -1; \
2182 PL_maxsysfd = MAXSYSFD; \
2183 PL_statname = Nullsv; \
2184 PL_tmps_floor = -1; \
2186 PL_op_mask = NULL; \
2187 PL_laststatval = -1; \
2188 PL_laststype = OP_STAT; \
2189 PL_mess_sv = Nullsv; \
2190 PL_splitstr = " "; \
2191 PL_generation = 100; \
2192 PL_exitlist = NULL; \
2193 PL_exitlistlen = 0; \
2195 PL_in_clean_objs = FALSE; \
2196 PL_in_clean_all = FALSE; \
2197 PL_profiledata = NULL; \
2199 PL_rsfp_filters = Nullav; \
2204 # ifdef MULTIPLICITY
2205 # define PERLVAR(var,type)
2206 # define PERLVARA(var,n,type)
2207 # if defined(PERL_IMPLICIT_CONTEXT)
2208 # if defined(USE_THREADS)
2209 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2210 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2211 # else /* !USE_THREADS */
2212 # define PERLVARI(var,type,init) aTHX->var = init;
2213 # define PERLVARIC(var,type,init) aTHX->var = init;
2214 # endif /* USE_THREADS */
2216 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2217 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2219 # include "intrpvar.h"
2220 # ifndef USE_THREADS
2221 # include "thrdvar.h"
2228 # define PERLVAR(var,type)
2229 # define PERLVARA(var,n,type)
2230 # define PERLVARI(var,type,init) PL_##var = init;
2231 # define PERLVARIC(var,type,init) PL_##var = init;
2232 # include "intrpvar.h"
2233 # ifndef USE_THREADS
2234 # include "thrdvar.h"
2246 S_init_main_stash(pTHX)
2251 /* Note that strtab is a rather special HV. Assumptions are made
2252 about not iterating on it, and not adding tie magic to it.
2253 It is properly deallocated in perl_destruct() */
2254 PL_strtab = newHV();
2256 MUTEX_INIT(&PL_strtab_mutex);
2258 HvSHAREKEYS_off(PL_strtab); /* mandatory */
2259 hv_ksplit(PL_strtab, 512);
2261 PL_curstash = PL_defstash = newHV();
2262 PL_curstname = newSVpvn("main",4);
2263 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2264 SvREFCNT_dec(GvHV(gv));
2265 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2267 HvNAME(PL_defstash) = savepv("main");
2268 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2269 GvMULTI_on(PL_incgv);
2270 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2271 GvMULTI_on(PL_hintgv);
2272 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2273 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2274 GvMULTI_on(PL_errgv);
2275 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2276 GvMULTI_on(PL_replgv);
2277 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
2278 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2279 sv_setpvn(ERRSV, "", 0);
2280 PL_curstash = PL_defstash;
2281 CopSTASH_set(&PL_compiling, PL_defstash);
2282 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2283 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2284 /* We must init $/ before switches are processed. */
2285 sv_setpvn(get_sv("/", TRUE), "\n", 1);
2289 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2297 PL_origfilename = savepv("-e");
2300 /* if find_script() returns, it returns a malloc()-ed value */
2301 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2303 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2304 char *s = scriptname + 8;
2305 *fdscript = atoi(s);
2309 scriptname = savepv(s + 1);
2310 Safefree(PL_origfilename);
2311 PL_origfilename = scriptname;
2316 CopFILE_set(PL_curcop, PL_origfilename);
2317 if (strEQ(PL_origfilename,"-"))
2319 if (*fdscript >= 0) {
2320 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2321 #if defined(HAS_FCNTL) && defined(F_SETFD)
2323 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2326 else if (PL_preprocess) {
2327 char *cpp_cfg = CPPSTDIN;
2328 SV *cpp = newSVpvn("",0);
2329 SV *cmd = NEWSV(0,0);
2331 if (strEQ(cpp_cfg, "cppstdin"))
2332 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2333 sv_catpv(cpp, cpp_cfg);
2335 sv_catpvn(sv, "-I", 2);
2336 sv_catpv(sv,PRIVLIB_EXP);
2339 Perl_sv_setpvf(aTHX_ cmd, "\
2340 sed %s -e \"/^[^#]/b\" \
2341 -e \"/^#[ ]*include[ ]/b\" \
2342 -e \"/^#[ ]*define[ ]/b\" \
2343 -e \"/^#[ ]*if[ ]/b\" \
2344 -e \"/^#[ ]*ifdef[ ]/b\" \
2345 -e \"/^#[ ]*ifndef[ ]/b\" \
2346 -e \"/^#[ ]*else/b\" \
2347 -e \"/^#[ ]*elif[ ]/b\" \
2348 -e \"/^#[ ]*undef[ ]/b\" \
2349 -e \"/^#[ ]*endif/b\" \
2351 %s | %"SVf" -C %"SVf" %s",
2352 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2355 Perl_sv_setpvf(aTHX_ cmd, "\
2356 %s %s -e '/^[^#]/b' \
2357 -e '/^#[ ]*include[ ]/b' \
2358 -e '/^#[ ]*define[ ]/b' \
2359 -e '/^#[ ]*if[ ]/b' \
2360 -e '/^#[ ]*ifdef[ ]/b' \
2361 -e '/^#[ ]*ifndef[ ]/b' \
2362 -e '/^#[ ]*else/b' \
2363 -e '/^#[ ]*elif[ ]/b' \
2364 -e '/^#[ ]*undef[ ]/b' \
2365 -e '/^#[ ]*endif/b' \
2367 %s | %"SVf" %"SVf" %s",
2369 Perl_sv_setpvf(aTHX_ cmd, "\
2370 %s %s -e '/^[^#]/b' \
2371 -e '/^#[ ]*include[ ]/b' \
2372 -e '/^#[ ]*define[ ]/b' \
2373 -e '/^#[ ]*if[ ]/b' \
2374 -e '/^#[ ]*ifdef[ ]/b' \
2375 -e '/^#[ ]*ifndef[ ]/b' \
2376 -e '/^#[ ]*else/b' \
2377 -e '/^#[ ]*elif[ ]/b' \
2378 -e '/^#[ ]*undef[ ]/b' \
2379 -e '/^#[ ]*endif/b' \
2381 %s | %"SVf" -C %"SVf" %s",
2388 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2390 scriptname, cpp, sv, CPPMINUS);
2391 PL_doextract = FALSE;
2392 #ifdef IAMSUID /* actually, this is caught earlier */
2393 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2395 (void)seteuid(PL_uid); /* musn't stay setuid root */
2398 (void)setreuid((Uid_t)-1, PL_uid);
2400 #ifdef HAS_SETRESUID
2401 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2403 PerlProc_setuid(PL_uid);
2407 if (PerlProc_geteuid() != PL_uid)
2408 Perl_croak(aTHX_ "Can't do seteuid!\n");
2410 #endif /* IAMSUID */
2411 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2415 else if (!*scriptname) {
2416 forbid_setid("program input from stdin");
2417 PL_rsfp = PerlIO_stdin();
2420 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2421 #if defined(HAS_FCNTL) && defined(F_SETFD)
2423 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2428 #ifndef IAMSUID /* in case script is not readable before setuid */
2430 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2431 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2434 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
2435 (int)PERL_REVISION, (int)PERL_VERSION,
2436 (int)PERL_SUBVERSION), PL_origargv);
2437 Perl_croak(aTHX_ "Can't do setuid\n");
2441 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2442 CopFILE(PL_curcop), Strerror(errno));
2447 * I_SYSSTATVFS HAS_FSTATVFS
2449 * I_STATFS HAS_FSTATFS
2450 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2451 * here so that metaconfig picks them up. */
2455 S_fd_on_nosuid_fs(pTHX_ int fd)
2457 int check_okay = 0; /* able to do all the required sys/libcalls */
2458 int on_nosuid = 0; /* the fd is on a nosuid fs */
2460 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2461 * fstatvfs() is UNIX98.
2462 * fstatfs() is 4.3 BSD.
2463 * ustat()+getmnt() is pre-4.3 BSD.
2464 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2465 * an irrelevant filesystem while trying to reach the right one.
2468 # ifdef HAS_FSTATVFS
2469 struct statvfs stfs;
2470 check_okay = fstatvfs(fd, &stfs) == 0;
2471 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2473 # ifdef PERL_MOUNT_NOSUID
2474 # if defined(HAS_FSTATFS) && \
2475 defined(HAS_STRUCT_STATFS) && \
2476 defined(HAS_STRUCT_STATFS_F_FLAGS)
2478 check_okay = fstatfs(fd, &stfs) == 0;
2479 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2481 # if defined(HAS_FSTAT) && \
2482 defined(HAS_USTAT) && \
2483 defined(HAS_GETMNT) && \
2484 defined(HAS_STRUCT_FS_DATA) && \
2487 if (fstat(fd, &fdst) == 0) {
2489 if (ustat(fdst.st_dev, &us) == 0) {
2491 /* NOSTAT_ONE here because we're not examining fields which
2492 * vary between that case and STAT_ONE. */
2493 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2494 size_t cmplen = sizeof(us.f_fname);
2495 if (sizeof(fsd.fd_req.path) < cmplen)
2496 cmplen = sizeof(fsd.fd_req.path);
2497 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2498 fdst.st_dev == fsd.fd_req.dev) {
2500 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2506 # endif /* fstat+ustat+getmnt */
2507 # endif /* fstatfs */
2509 # if defined(HAS_GETMNTENT) && \
2510 defined(HAS_HASMNTOPT) && \
2511 defined(MNTOPT_NOSUID)
2512 FILE *mtab = fopen("/etc/mtab", "r");
2513 struct mntent *entry;
2514 struct stat stb, fsb;
2516 if (mtab && (fstat(fd, &stb) == 0)) {
2517 while (entry = getmntent(mtab)) {
2518 if (stat(entry->mnt_dir, &fsb) == 0
2519 && fsb.st_dev == stb.st_dev)
2521 /* found the filesystem */
2523 if (hasmntopt(entry, MNTOPT_NOSUID))
2526 } /* A single fs may well fail its stat(). */
2531 # endif /* getmntent+hasmntopt */
2532 # endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */
2533 # endif /* statvfs */
2536 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
2539 #endif /* IAMSUID */
2542 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2546 /* do we need to emulate setuid on scripts? */
2548 /* This code is for those BSD systems that have setuid #! scripts disabled
2549 * in the kernel because of a security problem. Merely defining DOSUID
2550 * in perl will not fix that problem, but if you have disabled setuid
2551 * scripts in the kernel, this will attempt to emulate setuid and setgid
2552 * on scripts that have those now-otherwise-useless bits set. The setuid
2553 * root version must be called suidperl or sperlN.NNN. If regular perl
2554 * discovers that it has opened a setuid script, it calls suidperl with
2555 * the same argv that it had. If suidperl finds that the script it has
2556 * just opened is NOT setuid root, it sets the effective uid back to the
2557 * uid. We don't just make perl setuid root because that loses the
2558 * effective uid we had before invoking perl, if it was different from the
2561 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2562 * be defined in suidperl only. suidperl must be setuid root. The
2563 * Configure script will set this up for you if you want it.
2570 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2571 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2572 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2577 #ifndef HAS_SETREUID
2578 /* On this access check to make sure the directories are readable,
2579 * there is actually a small window that the user could use to make
2580 * filename point to an accessible directory. So there is a faint
2581 * chance that someone could execute a setuid script down in a
2582 * non-accessible directory. I don't know what to do about that.
2583 * But I don't think it's too important. The manual lies when
2584 * it says access() is useful in setuid programs.
2586 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
2587 Perl_croak(aTHX_ "Permission denied");
2589 /* If we can swap euid and uid, then we can determine access rights
2590 * with a simple stat of the file, and then compare device and
2591 * inode to make sure we did stat() on the same file we opened.
2592 * Then we just have to make sure he or she can execute it.
2595 struct stat tmpstatbuf;
2599 setreuid(PL_euid,PL_uid) < 0
2602 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2605 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2606 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2607 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
2608 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2609 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2610 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2611 Perl_croak(aTHX_ "Permission denied");
2613 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2614 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2615 (void)PerlIO_close(PL_rsfp);
2616 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2617 PerlIO_printf(PL_rsfp,
2618 "User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2619 (Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n",
2620 PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2621 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2623 PL_statbuf.st_uid, PL_statbuf.st_gid);
2624 (void)PerlProc_pclose(PL_rsfp);
2626 Perl_croak(aTHX_ "Permission denied\n");
2630 setreuid(PL_uid,PL_euid) < 0
2632 # if defined(HAS_SETRESUID)
2633 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2636 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2637 Perl_croak(aTHX_ "Can't reswap uid and euid");
2638 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2639 Perl_croak(aTHX_ "Permission denied\n");
2641 #endif /* HAS_SETREUID */
2642 #endif /* IAMSUID */
2644 if (!S_ISREG(PL_statbuf.st_mode))
2645 Perl_croak(aTHX_ "Permission denied");
2646 if (PL_statbuf.st_mode & S_IWOTH)
2647 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2648 PL_doswitches = FALSE; /* -s is insecure in suid */
2649 CopLINE_inc(PL_curcop);
2650 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2651 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2652 Perl_croak(aTHX_ "No #! line");
2653 s = SvPV(PL_linestr,n_a)+2;
2655 while (!isSPACE(*s)) s++;
2656 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2657 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2658 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2659 Perl_croak(aTHX_ "Not a perl script");
2660 while (*s == ' ' || *s == '\t') s++;
2662 * #! arg must be what we saw above. They can invoke it by
2663 * mentioning suidperl explicitly, but they may not add any strange
2664 * arguments beyond what #! says if they do invoke suidperl that way.
2666 len = strlen(validarg);
2667 if (strEQ(validarg," PHOOEY ") ||
2668 strnNE(s,validarg,len) || !isSPACE(s[len]))
2669 Perl_croak(aTHX_ "Args must match #! line");
2672 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2673 PL_euid == PL_statbuf.st_uid)
2675 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2676 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2677 #endif /* IAMSUID */
2679 if (PL_euid) { /* oops, we're not the setuid root perl */
2680 (void)PerlIO_close(PL_rsfp);
2683 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
2684 (int)PERL_REVISION, (int)PERL_VERSION,
2685 (int)PERL_SUBVERSION), PL_origargv);
2687 Perl_croak(aTHX_ "Can't do setuid\n");
2690 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2692 (void)setegid(PL_statbuf.st_gid);
2695 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2697 #ifdef HAS_SETRESGID
2698 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2700 PerlProc_setgid(PL_statbuf.st_gid);
2704 if (PerlProc_getegid() != PL_statbuf.st_gid)
2705 Perl_croak(aTHX_ "Can't do setegid!\n");
2707 if (PL_statbuf.st_mode & S_ISUID) {
2708 if (PL_statbuf.st_uid != PL_euid)
2710 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2713 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2715 #ifdef HAS_SETRESUID
2716 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2718 PerlProc_setuid(PL_statbuf.st_uid);
2722 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2723 Perl_croak(aTHX_ "Can't do seteuid!\n");
2725 else if (PL_uid) { /* oops, mustn't run as root */
2727 (void)seteuid((Uid_t)PL_uid);
2730 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2732 #ifdef HAS_SETRESUID
2733 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2735 PerlProc_setuid((Uid_t)PL_uid);
2739 if (PerlProc_geteuid() != PL_uid)
2740 Perl_croak(aTHX_ "Can't do seteuid!\n");
2743 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2744 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
2747 else if (PL_preprocess)
2748 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2749 else if (fdscript >= 0)
2750 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2752 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2754 /* We absolutely must clear out any saved ids here, so we */
2755 /* exec the real perl, substituting fd script for scriptname. */
2756 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2757 PerlIO_rewind(PL_rsfp);
2758 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2759 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2760 if (!PL_origargv[which])
2761 Perl_croak(aTHX_ "Permission denied");
2762 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2763 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2764 #if defined(HAS_FCNTL) && defined(F_SETFD)
2765 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2767 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
2768 (int)PERL_REVISION, (int)PERL_VERSION,
2769 (int)PERL_SUBVERSION), PL_origargv);/* try again */
2770 Perl_croak(aTHX_ "Can't do setuid\n");
2771 #endif /* IAMSUID */
2773 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2774 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2776 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2777 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2779 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2782 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2783 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2784 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2785 /* not set-id, must be wrapped */
2791 S_find_beginning(pTHX)
2793 register char *s, *s2;
2795 /* skip forward in input to the real script? */
2798 while (PL_doextract) {
2799 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2800 Perl_croak(aTHX_ "No Perl script found in input\n");
2801 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2802 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2803 PL_doextract = FALSE;
2804 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2806 while (*s == ' ' || *s == '\t') s++;
2808 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2809 if (strnEQ(s2-4,"perl",4))
2811 while (s = moreswitches(s)) ;
2821 PL_uid = PerlProc_getuid();
2822 PL_euid = PerlProc_geteuid();
2823 PL_gid = PerlProc_getgid();
2824 PL_egid = PerlProc_getegid();
2826 PL_uid |= PL_gid << 16;
2827 PL_euid |= PL_egid << 16;
2829 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2833 S_forbid_setid(pTHX_ char *s)
2835 if (PL_euid != PL_uid)
2836 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2837 if (PL_egid != PL_gid)
2838 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2842 Perl_init_debugger(pTHX)
2845 HV *ostash = PL_curstash;
2847 PL_curstash = PL_debstash;
2848 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2849 AvREAL_off(PL_dbargs);
2850 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2851 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2852 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2853 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
2854 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2855 sv_setiv(PL_DBsingle, 0);
2856 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2857 sv_setiv(PL_DBtrace, 0);
2858 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2859 sv_setiv(PL_DBsignal, 0);
2860 PL_curstash = ostash;
2863 #ifndef STRESS_REALLOC
2864 #define REASONABLE(size) (size)
2866 #define REASONABLE(size) (1) /* unreasonable */
2870 Perl_init_stacks(pTHX)
2872 /* start with 128-item stack and 8K cxstack */
2873 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2874 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2875 PL_curstackinfo->si_type = PERLSI_MAIN;
2876 PL_curstack = PL_curstackinfo->si_stack;
2877 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2879 PL_stack_base = AvARRAY(PL_curstack);
2880 PL_stack_sp = PL_stack_base;
2881 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2883 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2886 PL_tmps_max = REASONABLE(128);
2888 New(54,PL_markstack,REASONABLE(32),I32);
2889 PL_markstack_ptr = PL_markstack;
2890 PL_markstack_max = PL_markstack + REASONABLE(32);
2894 New(54,PL_scopestack,REASONABLE(32),I32);
2895 PL_scopestack_ix = 0;
2896 PL_scopestack_max = REASONABLE(32);
2898 New(54,PL_savestack,REASONABLE(128),ANY);
2899 PL_savestack_ix = 0;
2900 PL_savestack_max = REASONABLE(128);
2902 New(54,PL_retstack,REASONABLE(16),OP*);
2904 PL_retstack_max = REASONABLE(16);
2913 while (PL_curstackinfo->si_next)
2914 PL_curstackinfo = PL_curstackinfo->si_next;
2915 while (PL_curstackinfo) {
2916 PERL_SI *p = PL_curstackinfo->si_prev;
2917 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2918 Safefree(PL_curstackinfo->si_cxstack);
2919 Safefree(PL_curstackinfo);
2920 PL_curstackinfo = p;
2922 Safefree(PL_tmps_stack);
2923 Safefree(PL_markstack);
2924 Safefree(PL_scopestack);
2925 Safefree(PL_savestack);
2926 Safefree(PL_retstack);
2930 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2941 lex_start(PL_linestr);
2943 PL_subname = newSVpvn("main",4);
2947 S_init_predump_symbols(pTHX)
2954 sv_setpvn(get_sv("\"", TRUE), " ", 1);
2955 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2956 GvMULTI_on(PL_stdingv);
2957 io = GvIOp(PL_stdingv);
2958 IoIFP(io) = PerlIO_stdin();
2959 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2961 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2963 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2966 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
2968 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2970 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2972 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2973 GvMULTI_on(PL_stderrgv);
2974 io = GvIOp(PL_stderrgv);
2975 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
2976 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2978 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2980 PL_statname = NEWSV(66,0); /* last filename we did stat on */
2983 PL_osname = savepv(OSNAME);
2987 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
2994 argc--,argv++; /* skip name of script */
2995 if (PL_doswitches) {
2996 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2999 if (argv[0][1] == '-' && !argv[0][2]) {
3003 if (s = strchr(argv[0], '=')) {
3005 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
3008 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
3011 PL_toptarget = NEWSV(0,0);
3012 sv_upgrade(PL_toptarget, SVt_PVFM);
3013 sv_setpvn(PL_toptarget, "", 0);
3014 PL_bodytarget = NEWSV(0,0);
3015 sv_upgrade(PL_bodytarget, SVt_PVFM);
3016 sv_setpvn(PL_bodytarget, "", 0);
3017 PL_formtarget = PL_bodytarget;
3020 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
3021 sv_setpv(GvSV(tmpgv),PL_origfilename);
3022 magicname("0", "0", 1);
3024 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
3026 sv_setpv(GvSV(tmpgv), os2_execname());
3028 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
3030 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
3031 GvMULTI_on(PL_argvgv);
3032 (void)gv_AVadd(PL_argvgv);
3033 av_clear(GvAVn(PL_argvgv));
3034 for (; argc > 0; argc--,argv++) {
3035 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
3038 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
3040 GvMULTI_on(PL_envgv);
3041 hv = GvHVn(PL_envgv);
3042 hv_magic(hv, PL_envgv, 'E');
3043 #if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
3044 /* Note that if the supplied env parameter is actually a copy
3045 of the global environ then it may now point to free'd memory
3046 if the environment has been modified since. To avoid this
3047 problem we treat env==NULL as meaning 'use the default'
3052 environ[0] = Nullch;
3053 for (; *env; env++) {
3054 if (!(s = strchr(*env,'=')))
3060 sv = newSVpv(s--,0);
3061 (void)hv_store(hv, *env, s - *env, sv, 0);
3063 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
3064 /* Sins of the RTL. See note in my_setenv(). */
3065 (void)PerlEnv_putenv(savepv(*env));
3069 #ifdef DYNAMIC_ENV_FETCH
3070 HvNAME(hv) = savepv(ENV_HV_NAME);
3074 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
3075 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3079 S_init_perllib(pTHX)
3084 s = PerlEnv_getenv("PERL5LIB");
3088 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
3090 /* Treat PERL5?LIB as a possible search list logical name -- the
3091 * "natural" VMS idiom for a Unix path string. We allow each
3092 * element to be a set of |-separated directories for compatibility.
3096 if (my_trnlnm("PERL5LIB",buf,0))
3097 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
3099 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
3103 /* Use the ~-expanded versions of APPLLIB (undocumented),
3104 ARCHLIB PRIVLIB SITEARCH and SITELIB
3107 incpush(APPLLIB_EXP, TRUE);
3111 incpush(ARCHLIB_EXP, FALSE);
3114 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
3117 incpush(PRIVLIB_EXP, TRUE);
3119 incpush(PRIVLIB_EXP, FALSE);
3123 incpush(SITELIB_EXP, TRUE); /* XXX Win32 needs inc_version_list support */
3127 char *path = SITELIB_EXP;
3132 if (strrchr(buf,'/')) /* XXX Hack, Configure var needed */
3133 *strrchr(buf,'/') = '\0';
3139 #if defined(PERL_VENDORLIB_EXP)
3141 incpush(PERL_VENDORLIB_EXP, TRUE);
3143 incpush(PERL_VENDORLIB_EXP, FALSE);
3147 incpush(".", FALSE);
3151 # define PERLLIB_SEP ';'
3154 # define PERLLIB_SEP '|'
3156 # define PERLLIB_SEP ':'
3159 #ifndef PERLLIB_MANGLE
3160 # define PERLLIB_MANGLE(s,n) (s)
3164 S_incpush(pTHX_ char *p, int addsubdirs)
3166 SV *subdir = Nullsv;
3172 subdir = sv_newmortal();
3175 /* Break at all separators */
3177 SV *libdir = NEWSV(55,0);
3180 /* skip any consecutive separators */
3181 while ( *p == PERLLIB_SEP ) {
3182 /* Uncomment the next line for PATH semantics */
3183 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3187 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3188 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3193 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3194 p = Nullch; /* break out */
3198 * BEFORE pushing libdir onto @INC we may first push version- and
3199 * archname-specific sub-directories.
3202 #ifdef PERL_INC_VERSION_LIST
3203 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3204 const char *incverlist[] = { PERL_INC_VERSION_LIST };
3205 const char **incver;
3207 struct stat tmpstatbuf;
3212 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3214 while (unix[len-1] == '/') len--; /* Cosmetic */
3215 sv_usepvn(libdir,unix,len);
3218 PerlIO_printf(Perl_error_log,
3219 "Failed to unixify @INC element \"%s\"\n",
3222 /* .../version/archname if -d .../version/archname */
3223 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT"/%s", libdir,
3224 (int)PERL_REVISION, (int)PERL_VERSION,
3225 (int)PERL_SUBVERSION, ARCHNAME);
3226 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3227 S_ISDIR(tmpstatbuf.st_mode))
3228 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3230 /* .../version if -d .../version */
3231 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT, libdir,
3232 (int)PERL_REVISION, (int)PERL_VERSION,
3233 (int)PERL_SUBVERSION);
3234 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3235 S_ISDIR(tmpstatbuf.st_mode))
3236 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3238 /* .../archname if -d .../archname */
3239 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, ARCHNAME);
3240 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3241 S_ISDIR(tmpstatbuf.st_mode))
3242 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3244 #ifdef PERL_INC_VERSION_LIST
3245 for (incver = incverlist; *incver; incver++) {
3246 /* .../xxx if -d .../xxx */
3247 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, *incver);
3248 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3249 S_ISDIR(tmpstatbuf.st_mode))
3250 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3255 /* finally push this lib directory on the end of @INC */
3256 av_push(GvAVn(PL_incgv), libdir);
3261 STATIC struct perl_thread *
3262 S_init_main_thread(pTHX)
3264 #if !defined(PERL_IMPLICIT_CONTEXT)
3265 struct perl_thread *thr;
3269 Newz(53, thr, 1, struct perl_thread);
3270 PL_curcop = &PL_compiling;
3271 thr->interp = PERL_GET_INTERP;
3272 thr->cvcache = newHV();
3273 thr->threadsv = newAV();
3274 /* thr->threadsvp is set when find_threadsv is called */
3275 thr->specific = newAV();
3276 thr->flags = THRf_R_JOINABLE;
3277 MUTEX_INIT(&thr->mutex);
3278 /* Handcraft thrsv similarly to mess_sv */
3279 New(53, PL_thrsv, 1, SV);
3280 Newz(53, xpv, 1, XPV);
3281 SvFLAGS(PL_thrsv) = SVt_PV;
3282 SvANY(PL_thrsv) = (void*)xpv;
3283 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3284 SvPVX(PL_thrsv) = (char*)thr;
3285 SvCUR_set(PL_thrsv, sizeof(thr));
3286 SvLEN_set(PL_thrsv, sizeof(thr));
3287 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3288 thr->oursv = PL_thrsv;
3289 PL_chopset = " \n-";
3292 MUTEX_LOCK(&PL_threads_mutex);
3297 MUTEX_UNLOCK(&PL_threads_mutex);
3299 #ifdef HAVE_THREAD_INTERN
3300 Perl_init_thread_intern(thr);
3303 #ifdef SET_THREAD_SELF
3304 SET_THREAD_SELF(thr);
3306 thr->self = pthread_self();
3307 #endif /* SET_THREAD_SELF */
3311 * These must come after the SET_THR because sv_setpvn does
3312 * SvTAINT and the taint fields require dTHR.
3314 PL_toptarget = NEWSV(0,0);
3315 sv_upgrade(PL_toptarget, SVt_PVFM);
3316 sv_setpvn(PL_toptarget, "", 0);
3317 PL_bodytarget = NEWSV(0,0);
3318 sv_upgrade(PL_bodytarget, SVt_PVFM);
3319 sv_setpvn(PL_bodytarget, "", 0);
3320 PL_formtarget = PL_bodytarget;
3321 thr->errsv = newSVpvn("", 0);
3322 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
3325 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3326 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3327 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3328 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3329 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3331 PL_reginterp_cnt = 0;
3335 #endif /* USE_THREADS */
3338 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3342 line_t oldline = CopLINE(PL_curcop);
3348 while (AvFILL(paramList) >= 0) {
3349 cv = (CV*)av_shift(paramList);
3351 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
3355 (void)SvPV(atsv, len);
3358 PL_curcop = &PL_compiling;
3359 CopLINE_set(PL_curcop, oldline);
3360 if (paramList == PL_beginav)
3361 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3363 Perl_sv_catpvf(aTHX_ atsv,
3364 "%s failed--call queue aborted",
3365 paramList == PL_checkav ? "CHECK"
3366 : paramList == PL_initav ? "INIT"
3368 while (PL_scopestack_ix > oldscope)
3370 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
3377 /* my_exit() was called */
3378 while (PL_scopestack_ix > oldscope)
3381 PL_curstash = PL_defstash;
3382 PL_curcop = &PL_compiling;
3383 CopLINE_set(PL_curcop, oldline);
3384 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3385 if (paramList == PL_beginav)
3386 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3388 Perl_croak(aTHX_ "%s failed--call queue aborted",
3389 paramList == PL_checkav ? "CHECK"
3390 : paramList == PL_initav ? "INIT"
3397 PL_curcop = &PL_compiling;
3398 CopLINE_set(PL_curcop, oldline);
3401 PerlIO_printf(Perl_error_log, "panic: restartop\n");
3409 S_call_list_body(pTHX_ va_list args)
3412 CV *cv = va_arg(args, CV*);
3414 PUSHMARK(PL_stack_sp);
3415 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3420 Perl_my_exit(pTHX_ U32 status)
3424 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3425 thr, (unsigned long) status));
3434 STATUS_NATIVE_SET(status);
3441 Perl_my_failure_exit(pTHX)
3444 if (vaxc$errno & 1) {
3445 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3446 STATUS_NATIVE_SET(44);
3449 if (!vaxc$errno && errno) /* unlikely */
3450 STATUS_NATIVE_SET(44);
3452 STATUS_NATIVE_SET(vaxc$errno);
3457 STATUS_POSIX_SET(errno);
3459 exitstatus = STATUS_POSIX >> 8;
3460 if (exitstatus & 255)
3461 STATUS_POSIX_SET(exitstatus);
3463 STATUS_POSIX_SET(255);
3470 S_my_exit_jump(pTHX)
3473 register PERL_CONTEXT *cx;
3478 SvREFCNT_dec(PL_e_script);
3479 PL_e_script = Nullsv;
3482 POPSTACK_TO(PL_mainstack);
3483 if (cxstack_ix >= 0) {
3486 POPBLOCK(cx,PL_curpm);
3498 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3501 p = SvPVX(PL_e_script);
3502 nl = strchr(p, '\n');
3503 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3505 filter_del(read_e_script);
3508 sv_catpvn(buf_sv, p, nl-p);
3509 sv_chop(PL_e_script, nl);