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 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
617 /* Destruct the global string table. */
619 /* Yell and reset the HeVAL() slots that are still holding refcounts,
620 * so that sv_free() won't fail on them.
628 max = HvMAX(PL_strtab);
629 array = HvARRAY(PL_strtab);
632 if (hent && ckWARN_d(WARN_INTERNAL)) {
633 Perl_warner(aTHX_ WARN_INTERNAL,
634 "Unbalanced string table refcount: (%d) for \"%s\"",
635 HeVAL(hent) - Nullsv, HeKEY(hent));
636 HeVAL(hent) = Nullsv;
646 SvREFCNT_dec(PL_strtab);
648 /* free special SVs */
650 SvREFCNT(&PL_sv_yes) = 0;
651 sv_clear(&PL_sv_yes);
652 SvANY(&PL_sv_yes) = NULL;
654 SvREFCNT(&PL_sv_no) = 0;
656 SvANY(&PL_sv_no) = NULL;
658 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
659 Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
663 /* No SVs have survived, need to clean out */
664 Safefree(PL_origfilename);
665 Safefree(PL_reg_start_tmp);
667 Safefree(PL_reg_curpm);
668 Safefree(PL_reg_poscache);
669 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
670 Safefree(PL_op_mask);
672 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
674 DEBUG_P(debprofdump());
676 MUTEX_DESTROY(&PL_strtab_mutex);
677 MUTEX_DESTROY(&PL_sv_mutex);
678 MUTEX_DESTROY(&PL_eval_mutex);
679 MUTEX_DESTROY(&PL_cred_mutex);
680 COND_DESTROY(&PL_eval_cond);
681 #ifdef EMULATE_ATOMIC_REFCOUNTS
682 MUTEX_DESTROY(&PL_svref_mutex);
683 #endif /* EMULATE_ATOMIC_REFCOUNTS */
685 /* As the penultimate thing, free the non-arena SV for thrsv */
686 Safefree(SvPVX(PL_thrsv));
687 Safefree(SvANY(PL_thrsv));
690 #endif /* USE_THREADS */
692 /* As the absolutely last thing, free the non-arena SV for mess() */
695 /* it could have accumulated taint magic */
696 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
699 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
700 moremagic = mg->mg_moremagic;
701 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
702 Safefree(mg->mg_ptr);
706 /* we know that type >= SVt_PV */
707 SvOOK_off(PL_mess_sv);
708 Safefree(SvPVX(PL_mess_sv));
709 Safefree(SvANY(PL_mess_sv));
710 Safefree(PL_mess_sv);
716 =for apidoc perl_free
718 Releases a Perl interpreter. See L<perlembed>.
726 #if defined(PERL_OBJECT)
734 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
736 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
737 PL_exitlist[PL_exitlistlen].fn = fn;
738 PL_exitlist[PL_exitlistlen].ptr = ptr;
743 =for apidoc perl_parse
745 Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
751 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
761 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
764 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
765 setuid perl scripts securely.\n");
769 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
770 _dyld_lookup_and_bind
771 ("__environ", (unsigned long *) &environ_pointer, NULL);
776 #ifndef VMS /* VMS doesn't have environ array */
777 PL_origenviron = environ;
782 /* Come here if running an undumped a.out. */
784 PL_origfilename = savepv(argv[0]);
785 PL_do_undump = FALSE;
786 cxstack_ix = -1; /* start label stack again */
788 init_postdump_symbols(argc,argv,env);
793 PL_curpad = AvARRAY(PL_comppad);
794 op_free(PL_main_root);
795 PL_main_root = Nullop;
797 PL_main_start = Nullop;
798 SvREFCNT_dec(PL_main_cv);
802 oldscope = PL_scopestack_ix;
803 PL_dowarn = G_WARN_OFF;
805 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_parse_body),
810 call_list(oldscope, PL_checkav);
816 /* my_exit() was called */
817 while (PL_scopestack_ix > oldscope)
820 PL_curstash = PL_defstash;
822 call_list(oldscope, PL_checkav);
823 return STATUS_NATIVE_EXPORT;
825 PerlIO_printf(Perl_error_log, "panic: top_env\n");
832 S_parse_body(pTHX_ va_list args)
835 int argc = PL_origargc;
836 char **argv = PL_origargv;
837 char **env = va_arg(args, char**);
838 char *scriptname = NULL;
840 VOL bool dosearch = FALSE;
845 char *cddir = Nullch;
847 XSINIT_t xsinit = va_arg(args, XSINIT_t);
849 sv_setpvn(PL_linestr,"",0);
850 sv = newSVpvn("",0); /* first used for -I flags */
854 for (argc--,argv++; argc > 0; argc--,argv++) {
855 if (argv[0][0] != '-' || !argv[0][1])
859 validarg = " PHOOEY ";
866 #ifndef PERL_STRICT_CR
891 if (s = moreswitches(s))
901 if (PL_euid != PL_uid || PL_egid != PL_gid)
902 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
904 PL_e_script = newSVpvn("",0);
905 filter_add(read_e_script, NULL);
908 sv_catpv(PL_e_script, s);
910 sv_catpv(PL_e_script, argv[1]);
914 Perl_croak(aTHX_ "No code specified for -e");
915 sv_catpv(PL_e_script, "\n");
918 case 'I': /* -I handled both here and in moreswitches() */
920 if (!*++s && (s=argv[1]) != Nullch) {
925 STRLEN len = strlen(s);
928 sv_catpvn(sv, "-I", 2);
929 sv_catpvn(sv, p, len);
930 sv_catpvn(sv, " ", 1);
934 Perl_croak(aTHX_ "No directory specified for -I");
938 PL_preprocess = TRUE;
948 PL_preambleav = newAV();
949 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
951 PL_Sv = newSVpv("print myconfig();",0);
953 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
955 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
957 sv_catpv(PL_Sv,"\" Compile-time options:");
959 sv_catpv(PL_Sv," DEBUGGING");
962 sv_catpv(PL_Sv," MULTIPLICITY");
965 sv_catpv(PL_Sv," USE_THREADS");
968 sv_catpv(PL_Sv," USE_ITHREADS");
971 sv_catpv(PL_Sv," USE_64_BITS");
973 # ifdef USE_LONG_DOUBLE
974 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
976 # ifdef USE_LARGE_FILES
977 sv_catpv(PL_Sv," USE_LARGE_FILES");
980 sv_catpv(PL_Sv," USE_SOCKS");
983 sv_catpv(PL_Sv," PERL_OBJECT");
985 # ifdef PERL_IMPLICIT_CONTEXT
986 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
988 # ifdef PERL_IMPLICIT_SYS
989 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
991 sv_catpv(PL_Sv,"\\n\",");
993 #if defined(LOCAL_PATCH_COUNT)
994 if (LOCAL_PATCH_COUNT > 0) {
996 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
997 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
998 if (PL_localpatches[i])
999 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
1003 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
1006 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
1008 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
1011 sv_catpv(PL_Sv, "; \
1013 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
1014 print \" \\%ENV:\\n @env\\n\" if @env; \
1015 print \" \\@INC:\\n @INC\\n\";");
1018 PL_Sv = newSVpv("config_vars(qw(",0);
1019 sv_catpv(PL_Sv, ++s);
1020 sv_catpv(PL_Sv, "))");
1023 av_push(PL_preambleav, PL_Sv);
1024 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1027 PL_doextract = TRUE;
1035 if (!*++s || isSPACE(*s)) {
1039 /* catch use of gnu style long options */
1040 if (strEQ(s, "version")) {
1044 if (strEQ(s, "help")) {
1051 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
1057 #ifndef SECURE_INTERNAL_GETENV
1060 (s = PerlEnv_getenv("PERL5OPT")))
1064 if (*s == '-' && *(s+1) == 'T')
1077 if (!strchr("DIMUdmw", *s))
1078 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
1079 s = moreswitches(s);
1085 scriptname = argv[0];
1088 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1090 else if (scriptname == Nullch) {
1092 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1100 open_script(scriptname,dosearch,sv,&fdscript);
1102 validate_suid(validarg, scriptname,fdscript);
1104 #if defined(SIGCHLD) || defined(SIGCLD)
1107 # define SIGCHLD SIGCLD
1109 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1110 if (sigstate == SIG_IGN) {
1111 if (ckWARN(WARN_SIGNAL))
1112 Perl_warner(aTHX_ WARN_SIGNAL,
1113 "Can't ignore signal CHLD, forcing to default");
1114 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1121 if (cddir && PerlDir_chdir(cddir) < 0)
1122 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1126 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1127 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1128 CvUNIQUE_on(PL_compcv);
1130 PL_comppad = newAV();
1131 av_push(PL_comppad, Nullsv);
1132 PL_curpad = AvARRAY(PL_comppad);
1133 PL_comppad_name = newAV();
1134 PL_comppad_name_fill = 0;
1135 PL_min_intro_pending = 0;
1138 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
1139 PL_curpad[0] = (SV*)newAV();
1140 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
1141 CvOWNER(PL_compcv) = 0;
1142 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1143 MUTEX_INIT(CvMUTEXP(PL_compcv));
1144 #endif /* USE_THREADS */
1146 comppadlist = newAV();
1147 AvREAL_off(comppadlist);
1148 av_store(comppadlist, 0, (SV*)PL_comppad_name);
1149 av_store(comppadlist, 1, (SV*)PL_comppad);
1150 CvPADLIST(PL_compcv) = comppadlist;
1152 boot_core_UNIVERSAL();
1153 boot_core_xsutils();
1156 (*xsinit)(aTHXo); /* in case linked C routines want magical variables */
1157 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
1165 init_predump_symbols();
1166 /* init_postdump_symbols not currently designed to be called */
1167 /* more than once (ENV isn't cleared first, for example) */
1168 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
1170 init_postdump_symbols(argc,argv,env);
1174 /* now parse the script */
1176 SETERRNO(0,SS$_NORMAL);
1178 if (yyparse() || PL_error_count) {
1180 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1182 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1186 CopLINE_set(PL_curcop, 0);
1187 PL_curstash = PL_defstash;
1188 PL_preprocess = FALSE;
1190 SvREFCNT_dec(PL_e_script);
1191 PL_e_script = Nullsv;
1194 /* now that script is parsed, we can modify record separator */
1195 SvREFCNT_dec(PL_rs);
1196 PL_rs = SvREFCNT_inc(PL_nrs);
1197 sv_setsv(get_sv("/", TRUE), PL_rs);
1202 SAVECOPFILE(PL_curcop);
1203 SAVECOPLINE(PL_curcop);
1204 gv_check(PL_defstash);
1211 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1212 dump_mstats("after compilation:");
1221 =for apidoc perl_run
1223 Tells a Perl interpreter to run. See L<perlembed>.
1239 oldscope = PL_scopestack_ix;
1242 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
1245 cxstack_ix = -1; /* start context stack again */
1247 case 0: /* normal completion */
1248 case 2: /* my_exit() */
1249 while (PL_scopestack_ix > oldscope)
1252 PL_curstash = PL_defstash;
1253 if (PL_endav && !PL_minus_c)
1254 call_list(oldscope, PL_endav);
1256 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1257 dump_mstats("after execution: ");
1259 return STATUS_NATIVE_EXPORT;
1262 POPSTACK_TO(PL_mainstack);
1265 PerlIO_printf(Perl_error_log, "panic: restartop\n");
1275 S_run_body(pTHX_ va_list args)
1278 I32 oldscope = va_arg(args, I32);
1280 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1281 PL_sawampersand ? "Enabling" : "Omitting"));
1283 if (!PL_restartop) {
1284 DEBUG_x(dump_all());
1285 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1286 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1290 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1293 if (PERLDB_SINGLE && PL_DBsingle)
1294 sv_setiv(PL_DBsingle, 1);
1296 call_list(oldscope, PL_initav);
1302 PL_op = PL_restartop;
1306 else if (PL_main_start) {
1307 CvDEPTH(PL_main_cv) = 1;
1308 PL_op = PL_main_start;
1318 =for apidoc p||get_sv
1320 Returns the SV of the specified Perl scalar. If C<create> is set and the
1321 Perl variable does not exist then it will be created. If C<create> is not
1322 set and the variable does not exist then NULL is returned.
1328 Perl_get_sv(pTHX_ const char *name, I32 create)
1332 if (name[1] == '\0' && !isALPHA(name[0])) {
1333 PADOFFSET tmp = find_threadsv(name);
1334 if (tmp != NOT_IN_PAD) {
1336 return THREADSV(tmp);
1339 #endif /* USE_THREADS */
1340 gv = gv_fetchpv(name, create, SVt_PV);
1347 =for apidoc p||get_av
1349 Returns the AV of the specified Perl array. If C<create> is set and the
1350 Perl variable does not exist then it will be created. If C<create> is not
1351 set and the variable does not exist then NULL is returned.
1357 Perl_get_av(pTHX_ const char *name, I32 create)
1359 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1368 =for apidoc p||get_hv
1370 Returns the HV of the specified Perl hash. If C<create> is set and the
1371 Perl variable does not exist then it will be created. If C<create> is not
1372 set and the variable does not exist then NULL is returned.
1378 Perl_get_hv(pTHX_ const char *name, I32 create)
1380 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1389 =for apidoc p||get_cv
1391 Returns the CV of the specified Perl subroutine. If C<create> is set and
1392 the Perl subroutine does not exist then it will be declared (which has the
1393 same effect as saying C<sub name;>). If C<create> is not set and the
1394 subroutine does not exist then NULL is returned.
1400 Perl_get_cv(pTHX_ const char *name, I32 create)
1402 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1403 /* XXX unsafe for threads if eval_owner isn't held */
1404 /* XXX this is probably not what they think they're getting.
1405 * It has the same effect as "sub name;", i.e. just a forward
1407 if (create && !GvCVu(gv))
1408 return newSUB(start_subparse(FALSE, 0),
1409 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1417 /* Be sure to refetch the stack pointer after calling these routines. */
1420 =for apidoc p||call_argv
1422 Performs a callback to the specified Perl sub. See L<perlcall>.
1428 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1430 /* See G_* flags in cop.h */
1431 /* null terminated arg list */
1438 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1443 return call_pv(sub_name, flags);
1447 =for apidoc p||call_pv
1449 Performs a callback to the specified Perl sub. See L<perlcall>.
1455 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1456 /* name of the subroutine */
1457 /* See G_* flags in cop.h */
1459 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1463 =for apidoc p||call_method
1465 Performs a callback to the specified Perl method. The blessed object must
1466 be on the stack. See L<perlcall>.
1472 Perl_call_method(pTHX_ const char *methname, I32 flags)
1473 /* name of the subroutine */
1474 /* See G_* flags in cop.h */
1482 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1487 return call_sv(*PL_stack_sp--, flags);
1490 /* May be called with any of a CV, a GV, or an SV containing the name. */
1492 =for apidoc p||call_sv
1494 Performs a callback to the Perl sub whose name is in the SV. See
1501 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1503 /* See G_* flags in cop.h */
1506 LOGOP myop; /* fake syntax tree node */
1510 bool oldcatch = CATCH_GET;
1515 if (flags & G_DISCARD) {
1520 Zero(&myop, 1, LOGOP);
1521 myop.op_next = Nullop;
1522 if (!(flags & G_NOARGS))
1523 myop.op_flags |= OPf_STACKED;
1524 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1525 (flags & G_ARRAY) ? OPf_WANT_LIST :
1530 EXTEND(PL_stack_sp, 1);
1531 *++PL_stack_sp = sv;
1533 oldscope = PL_scopestack_ix;
1535 if (PERLDB_SUB && PL_curstash != PL_debstash
1536 /* Handle first BEGIN of -d. */
1537 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1538 /* Try harder, since this may have been a sighandler, thus
1539 * curstash may be meaningless. */
1540 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1541 && !(flags & G_NODEBUG))
1542 PL_op->op_private |= OPpENTERSUB_DB;
1544 if (!(flags & G_EVAL)) {
1546 call_xbody((OP*)&myop, FALSE);
1547 retval = PL_stack_sp - (PL_stack_base + oldmark);
1548 CATCH_SET(oldcatch);
1551 cLOGOP->op_other = PL_op;
1553 /* we're trying to emulate pp_entertry() here */
1555 register PERL_CONTEXT *cx;
1556 I32 gimme = GIMME_V;
1561 push_return(PL_op->op_next);
1562 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1564 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1566 PL_in_eval = EVAL_INEVAL;
1567 if (flags & G_KEEPERR)
1568 PL_in_eval |= EVAL_KEEPERR;
1575 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1579 retval = PL_stack_sp - (PL_stack_base + oldmark);
1580 if (!(flags & G_KEEPERR))
1587 /* my_exit() was called */
1588 PL_curstash = PL_defstash;
1590 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1591 Perl_croak(aTHX_ "Callback called exit");
1596 PL_op = PL_restartop;
1600 PL_stack_sp = PL_stack_base + oldmark;
1601 if (flags & G_ARRAY)
1605 *++PL_stack_sp = &PL_sv_undef;
1610 if (PL_scopestack_ix > oldscope) {
1614 register PERL_CONTEXT *cx;
1625 if (flags & G_DISCARD) {
1626 PL_stack_sp = PL_stack_base + oldmark;
1636 S_call_body(pTHX_ va_list args)
1638 OP *myop = va_arg(args, OP*);
1639 int is_eval = va_arg(args, int);
1641 call_xbody(myop, is_eval);
1646 S_call_xbody(pTHX_ OP *myop, int is_eval)
1650 if (PL_op == myop) {
1652 PL_op = Perl_pp_entereval(aTHX);
1654 PL_op = Perl_pp_entersub(aTHX);
1660 /* Eval a string. The G_EVAL flag is always assumed. */
1663 =for apidoc p||eval_sv
1665 Tells Perl to C<eval> the string in the SV.
1671 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1673 /* See G_* flags in cop.h */
1676 UNOP myop; /* fake syntax tree node */
1677 I32 oldmark = SP - PL_stack_base;
1684 if (flags & G_DISCARD) {
1691 Zero(PL_op, 1, UNOP);
1692 EXTEND(PL_stack_sp, 1);
1693 *++PL_stack_sp = sv;
1694 oldscope = PL_scopestack_ix;
1696 if (!(flags & G_NOARGS))
1697 myop.op_flags = OPf_STACKED;
1698 myop.op_next = Nullop;
1699 myop.op_type = OP_ENTEREVAL;
1700 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1701 (flags & G_ARRAY) ? OPf_WANT_LIST :
1703 if (flags & G_KEEPERR)
1704 myop.op_flags |= OPf_SPECIAL;
1707 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1711 retval = PL_stack_sp - (PL_stack_base + oldmark);
1712 if (!(flags & G_KEEPERR))
1719 /* my_exit() was called */
1720 PL_curstash = PL_defstash;
1722 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1723 Perl_croak(aTHX_ "Callback called exit");
1728 PL_op = PL_restartop;
1732 PL_stack_sp = PL_stack_base + oldmark;
1733 if (flags & G_ARRAY)
1737 *++PL_stack_sp = &PL_sv_undef;
1742 if (flags & G_DISCARD) {
1743 PL_stack_sp = PL_stack_base + oldmark;
1753 =for apidoc p||eval_pv
1755 Tells Perl to C<eval> the given string and return an SV* result.
1761 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1764 SV* sv = newSVpv(p, 0);
1767 eval_sv(sv, G_SCALAR);
1774 if (croak_on_error && SvTRUE(ERRSV)) {
1776 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1782 /* Require a module. */
1785 =for apidoc p||require_pv
1787 Tells Perl to C<require> a module.
1793 Perl_require_pv(pTHX_ const char *pv)
1797 PUSHSTACKi(PERLSI_REQUIRE);
1799 sv = sv_newmortal();
1800 sv_setpv(sv, "require '");
1803 eval_sv(sv, G_DISCARD);
1809 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1813 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1814 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1818 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
1820 /* This message really ought to be max 23 lines.
1821 * Removed -h because the user already knows that opton. Others? */
1823 static char *usage_msg[] = {
1824 "-0[octal] specify record separator (\\0, if no argument)",
1825 "-a autosplit mode with -n or -p (splits $_ into @F)",
1826 "-C enable native wide character system interfaces",
1827 "-c check syntax only (runs BEGIN and END blocks)",
1828 "-d[:debugger] run program under debugger",
1829 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1830 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1831 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1832 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1833 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1834 "-l[octal] enable line ending processing, specifies line terminator",
1835 "-[mM][-]module execute `use/no module...' before executing program",
1836 "-n assume 'while (<>) { ... }' loop around program",
1837 "-p assume loop like -n but print line also, like sed",
1838 "-P run program through C preprocessor before compilation",
1839 "-s enable rudimentary parsing for switches after programfile",
1840 "-S look for programfile using PATH environment variable",
1841 "-T enable tainting checks",
1842 "-u dump core after parsing program",
1843 "-U allow unsafe operations",
1844 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1845 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1846 "-w enable many useful warnings (RECOMMENDED)",
1847 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1851 char **p = usage_msg;
1853 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1855 printf("\n %s", *p++);
1858 /* This routine handles any switches that can be given during run */
1861 Perl_moreswitches(pTHX_ char *s)
1870 rschar = (U32)scan_oct(s, 4, &numlen);
1871 SvREFCNT_dec(PL_nrs);
1872 if (rschar & ~((U8)~0))
1873 PL_nrs = &PL_sv_undef;
1874 else if (!rschar && numlen >= 2)
1875 PL_nrs = newSVpvn("", 0);
1878 PL_nrs = newSVpvn(&ch, 1);
1883 PL_widesyscalls = TRUE;
1888 PL_splitstr = savepv(s + 1);
1902 if (*s == ':' || *s == '=') {
1903 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1907 PL_perldb = PERLDB_ALL;
1915 if (isALPHA(s[1])) {
1916 static char debopts[] = "psltocPmfrxuLHXDS";
1919 for (s++; *s && (d = strchr(debopts,*s)); s++)
1920 PL_debug |= 1 << (d - debopts);
1923 PL_debug = atoi(s+1);
1924 for (s++; isDIGIT(*s); s++) ;
1926 PL_debug |= 0x80000000;
1929 if (ckWARN_d(WARN_DEBUGGING))
1930 Perl_warner(aTHX_ WARN_DEBUGGING,
1931 "Recompile perl with -DDEBUGGING to use -D switch\n");
1932 for (s++; isALNUM(*s); s++) ;
1938 usage(PL_origargv[0]);
1942 Safefree(PL_inplace);
1943 PL_inplace = savepv(s+1);
1945 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1948 if (*s == '-') /* Additional switches on #! line. */
1952 case 'I': /* -I handled both here and in parse_perl() */
1955 while (*s && isSPACE(*s))
1960 /* ignore trailing spaces (possibly followed by other switches) */
1962 for (e = p; *e && !isSPACE(*e); e++) ;
1966 } while (*p && *p != '-');
1967 e = savepvn(s, e-s);
1975 Perl_croak(aTHX_ "No directory specified for -I");
1983 PL_ors = savepv("\n");
1985 *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
1990 if (RsPARA(PL_nrs)) {
1995 PL_ors = SvPV(PL_nrs, PL_orslen);
1996 PL_ors = savepvn(PL_ors, PL_orslen);
2000 forbid_setid("-M"); /* XXX ? */
2003 forbid_setid("-m"); /* XXX ? */
2008 /* -M-foo == 'no foo' */
2009 if (*s == '-') { use = "no "; ++s; }
2010 sv = newSVpv(use,0);
2012 /* We allow -M'Module qw(Foo Bar)' */
2013 while(isALNUM(*s) || *s==':') ++s;
2015 sv_catpv(sv, start);
2016 if (*(start-1) == 'm') {
2018 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
2019 sv_catpv( sv, " ()");
2022 sv_catpvn(sv, start, s-start);
2023 sv_catpv(sv, " split(/,/,q{");
2029 PL_preambleav = newAV();
2030 av_push(PL_preambleav, sv);
2033 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
2045 PL_doswitches = TRUE;
2050 Perl_croak(aTHX_ "Too late for \"-T\" option");
2054 PL_do_undump = TRUE;
2062 printf(Perl_form(aTHX_ "\nThis is perl, v%v built for %s",
2063 PL_patchlevel, ARCHNAME));
2064 #if defined(LOCAL_PATCH_COUNT)
2065 if (LOCAL_PATCH_COUNT > 0)
2066 printf("\n(with %d registered patch%s, see perl -V for more detail)",
2067 (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
2070 printf("\n\nCopyright 1987-2000, Larry Wall\n");
2072 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
2075 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
2076 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
2079 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
2080 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
2083 printf("atariST series port, ++jrb bammi@cadence.com\n");
2086 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
2089 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
2092 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
2095 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
2098 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
2101 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
2104 printf("MiNT port by Guido Flohr, 1997-1999\n");
2106 #ifdef BINARY_BUILD_NOTICE
2107 BINARY_BUILD_NOTICE;
2110 Perl may be copied only under the terms of either the Artistic License or the\n\
2111 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
2112 Complete documentation for Perl, including FAQ lists, should be found on\n\
2113 this system using `man perl' or `perldoc perl'. If you have access to the\n\
2114 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
2117 if (! (PL_dowarn & G_WARN_ALL_MASK))
2118 PL_dowarn |= G_WARN_ON;
2122 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
2123 PL_compiling.cop_warnings = WARN_ALL ;
2127 PL_dowarn = G_WARN_ALL_OFF;
2128 PL_compiling.cop_warnings = WARN_NONE ;
2133 if (s[1] == '-') /* Additional switches on #! line. */
2138 #if defined(WIN32) || !defined(PERL_STRICT_CR)
2144 #ifdef ALTERNATE_SHEBANG
2145 case 'S': /* OS/2 needs -S on "extproc" line. */
2153 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
2158 /* compliments of Tom Christiansen */
2160 /* unexec() can be found in the Gnu emacs distribution */
2161 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
2164 Perl_my_unexec(pTHX)
2172 prog = newSVpv(BIN_EXP, 0);
2173 sv_catpv(prog, "/perl");
2174 file = newSVpv(PL_origfilename, 0);
2175 sv_catpv(file, ".perldump");
2177 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2178 /* unexec prints msg to stderr in case of failure */
2179 PerlProc_exit(status);
2182 # include <lib$routines.h>
2183 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
2185 ABORT(); /* for use with undump */
2190 /* initialize curinterp */
2195 #ifdef PERL_OBJECT /* XXX kludge */
2198 PL_chopset = " \n-"; \
2199 PL_copline = NOLINE; \
2200 PL_curcop = &PL_compiling;\
2201 PL_curcopdb = NULL; \
2203 PL_dumpindent = 4; \
2204 PL_laststatval = -1; \
2205 PL_laststype = OP_STAT; \
2206 PL_maxscream = -1; \
2207 PL_maxsysfd = MAXSYSFD; \
2208 PL_statname = Nullsv; \
2209 PL_tmps_floor = -1; \
2211 PL_op_mask = NULL; \
2212 PL_laststatval = -1; \
2213 PL_laststype = OP_STAT; \
2214 PL_mess_sv = Nullsv; \
2215 PL_splitstr = " "; \
2216 PL_generation = 100; \
2217 PL_exitlist = NULL; \
2218 PL_exitlistlen = 0; \
2220 PL_in_clean_objs = FALSE; \
2221 PL_in_clean_all = FALSE; \
2222 PL_profiledata = NULL; \
2224 PL_rsfp_filters = Nullav; \
2229 # ifdef MULTIPLICITY
2230 # define PERLVAR(var,type)
2231 # define PERLVARA(var,n,type)
2232 # if defined(PERL_IMPLICIT_CONTEXT)
2233 # if defined(USE_THREADS)
2234 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2235 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2236 # else /* !USE_THREADS */
2237 # define PERLVARI(var,type,init) aTHX->var = init;
2238 # define PERLVARIC(var,type,init) aTHX->var = init;
2239 # endif /* USE_THREADS */
2241 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2242 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2244 # include "intrpvar.h"
2245 # ifndef USE_THREADS
2246 # include "thrdvar.h"
2253 # define PERLVAR(var,type)
2254 # define PERLVARA(var,n,type)
2255 # define PERLVARI(var,type,init) PL_##var = init;
2256 # define PERLVARIC(var,type,init) PL_##var = init;
2257 # include "intrpvar.h"
2258 # ifndef USE_THREADS
2259 # include "thrdvar.h"
2271 S_init_main_stash(pTHX)
2276 /* Note that strtab is a rather special HV. Assumptions are made
2277 about not iterating on it, and not adding tie magic to it.
2278 It is properly deallocated in perl_destruct() */
2279 PL_strtab = newHV();
2281 MUTEX_INIT(&PL_strtab_mutex);
2283 HvSHAREKEYS_off(PL_strtab); /* mandatory */
2284 hv_ksplit(PL_strtab, 512);
2286 PL_curstash = PL_defstash = newHV();
2287 PL_curstname = newSVpvn("main",4);
2288 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2289 SvREFCNT_dec(GvHV(gv));
2290 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2292 HvNAME(PL_defstash) = savepv("main");
2293 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2294 GvMULTI_on(PL_incgv);
2295 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2296 GvMULTI_on(PL_hintgv);
2297 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2298 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2299 GvMULTI_on(PL_errgv);
2300 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2301 GvMULTI_on(PL_replgv);
2302 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
2303 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2304 sv_setpvn(ERRSV, "", 0);
2305 PL_curstash = PL_defstash;
2306 CopSTASH_set(&PL_compiling, PL_defstash);
2307 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2308 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2309 /* We must init $/ before switches are processed. */
2310 sv_setpvn(get_sv("/", TRUE), "\n", 1);
2314 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2322 PL_origfilename = savepv("-e");
2325 /* if find_script() returns, it returns a malloc()-ed value */
2326 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2328 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2329 char *s = scriptname + 8;
2330 *fdscript = atoi(s);
2334 scriptname = savepv(s + 1);
2335 Safefree(PL_origfilename);
2336 PL_origfilename = scriptname;
2341 CopFILE_set(PL_curcop, PL_origfilename);
2342 if (strEQ(PL_origfilename,"-"))
2344 if (*fdscript >= 0) {
2345 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2346 #if defined(HAS_FCNTL) && defined(F_SETFD)
2348 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2351 else if (PL_preprocess) {
2352 char *cpp_cfg = CPPSTDIN;
2353 SV *cpp = newSVpvn("",0);
2354 SV *cmd = NEWSV(0,0);
2356 if (strEQ(cpp_cfg, "cppstdin"))
2357 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2358 sv_catpv(cpp, cpp_cfg);
2360 sv_catpvn(sv, "-I", 2);
2361 sv_catpv(sv,PRIVLIB_EXP);
2364 Perl_sv_setpvf(aTHX_ cmd, "\
2365 sed %s -e \"/^[^#]/b\" \
2366 -e \"/^#[ ]*include[ ]/b\" \
2367 -e \"/^#[ ]*define[ ]/b\" \
2368 -e \"/^#[ ]*if[ ]/b\" \
2369 -e \"/^#[ ]*ifdef[ ]/b\" \
2370 -e \"/^#[ ]*ifndef[ ]/b\" \
2371 -e \"/^#[ ]*else/b\" \
2372 -e \"/^#[ ]*elif[ ]/b\" \
2373 -e \"/^#[ ]*undef[ ]/b\" \
2374 -e \"/^#[ ]*endif/b\" \
2376 %s | %"SVf" -C %"SVf" %s",
2377 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2380 Perl_sv_setpvf(aTHX_ cmd, "\
2381 %s %s -e '/^[^#]/b' \
2382 -e '/^#[ ]*include[ ]/b' \
2383 -e '/^#[ ]*define[ ]/b' \
2384 -e '/^#[ ]*if[ ]/b' \
2385 -e '/^#[ ]*ifdef[ ]/b' \
2386 -e '/^#[ ]*ifndef[ ]/b' \
2387 -e '/^#[ ]*else/b' \
2388 -e '/^#[ ]*elif[ ]/b' \
2389 -e '/^#[ ]*undef[ ]/b' \
2390 -e '/^#[ ]*endif/b' \
2392 %s | %"SVf" %"SVf" %s",
2394 Perl_sv_setpvf(aTHX_ cmd, "\
2395 %s %s -e '/^[^#]/b' \
2396 -e '/^#[ ]*include[ ]/b' \
2397 -e '/^#[ ]*define[ ]/b' \
2398 -e '/^#[ ]*if[ ]/b' \
2399 -e '/^#[ ]*ifdef[ ]/b' \
2400 -e '/^#[ ]*ifndef[ ]/b' \
2401 -e '/^#[ ]*else/b' \
2402 -e '/^#[ ]*elif[ ]/b' \
2403 -e '/^#[ ]*undef[ ]/b' \
2404 -e '/^#[ ]*endif/b' \
2406 %s | %"SVf" -C %"SVf" %s",
2413 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2415 scriptname, cpp, sv, CPPMINUS);
2416 PL_doextract = FALSE;
2417 #ifdef IAMSUID /* actually, this is caught earlier */
2418 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2420 (void)seteuid(PL_uid); /* musn't stay setuid root */
2423 (void)setreuid((Uid_t)-1, PL_uid);
2425 #ifdef HAS_SETRESUID
2426 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2428 PerlProc_setuid(PL_uid);
2432 if (PerlProc_geteuid() != PL_uid)
2433 Perl_croak(aTHX_ "Can't do seteuid!\n");
2435 #endif /* IAMSUID */
2436 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2440 else if (!*scriptname) {
2441 forbid_setid("program input from stdin");
2442 PL_rsfp = PerlIO_stdin();
2445 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2446 #if defined(HAS_FCNTL) && defined(F_SETFD)
2448 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2453 #ifndef IAMSUID /* in case script is not readable before setuid */
2455 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2456 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2459 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
2460 (int)PERL_REVISION, (int)PERL_VERSION,
2461 (int)PERL_SUBVERSION), PL_origargv);
2462 Perl_croak(aTHX_ "Can't do setuid\n");
2466 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2467 CopFILE(PL_curcop), Strerror(errno));
2472 * I_SYSSTATVFS HAS_FSTATVFS
2474 * I_STATFS HAS_FSTATFS
2475 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2476 * here so that metaconfig picks them up. */
2480 S_fd_on_nosuid_fs(pTHX_ int fd)
2482 int check_okay = 0; /* able to do all the required sys/libcalls */
2483 int on_nosuid = 0; /* the fd is on a nosuid fs */
2485 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2486 * fstatvfs() is UNIX98.
2487 * fstatfs() is 4.3 BSD.
2488 * ustat()+getmnt() is pre-4.3 BSD.
2489 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2490 * an irrelevant filesystem while trying to reach the right one.
2493 # ifdef HAS_FSTATVFS
2494 struct statvfs stfs;
2495 check_okay = fstatvfs(fd, &stfs) == 0;
2496 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2498 # ifdef PERL_MOUNT_NOSUID
2499 # if defined(HAS_FSTATFS) && \
2500 defined(HAS_STRUCT_STATFS) && \
2501 defined(HAS_STRUCT_STATFS_F_FLAGS)
2503 check_okay = fstatfs(fd, &stfs) == 0;
2504 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2506 # if defined(HAS_FSTAT) && \
2507 defined(HAS_USTAT) && \
2508 defined(HAS_GETMNT) && \
2509 defined(HAS_STRUCT_FS_DATA) && \
2512 if (fstat(fd, &fdst) == 0) {
2514 if (ustat(fdst.st_dev, &us) == 0) {
2516 /* NOSTAT_ONE here because we're not examining fields which
2517 * vary between that case and STAT_ONE. */
2518 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2519 size_t cmplen = sizeof(us.f_fname);
2520 if (sizeof(fsd.fd_req.path) < cmplen)
2521 cmplen = sizeof(fsd.fd_req.path);
2522 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2523 fdst.st_dev == fsd.fd_req.dev) {
2525 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2531 # endif /* fstat+ustat+getmnt */
2532 # endif /* fstatfs */
2534 # if defined(HAS_GETMNTENT) && \
2535 defined(HAS_HASMNTOPT) && \
2536 defined(MNTOPT_NOSUID)
2537 FILE *mtab = fopen("/etc/mtab", "r");
2538 struct mntent *entry;
2539 struct stat stb, fsb;
2541 if (mtab && (fstat(fd, &stb) == 0)) {
2542 while (entry = getmntent(mtab)) {
2543 if (stat(entry->mnt_dir, &fsb) == 0
2544 && fsb.st_dev == stb.st_dev)
2546 /* found the filesystem */
2548 if (hasmntopt(entry, MNTOPT_NOSUID))
2551 } /* A single fs may well fail its stat(). */
2556 # endif /* getmntent+hasmntopt */
2557 # endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */
2558 # endif /* statvfs */
2561 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
2564 #endif /* IAMSUID */
2567 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2571 /* do we need to emulate setuid on scripts? */
2573 /* This code is for those BSD systems that have setuid #! scripts disabled
2574 * in the kernel because of a security problem. Merely defining DOSUID
2575 * in perl will not fix that problem, but if you have disabled setuid
2576 * scripts in the kernel, this will attempt to emulate setuid and setgid
2577 * on scripts that have those now-otherwise-useless bits set. The setuid
2578 * root version must be called suidperl or sperlN.NNN. If regular perl
2579 * discovers that it has opened a setuid script, it calls suidperl with
2580 * the same argv that it had. If suidperl finds that the script it has
2581 * just opened is NOT setuid root, it sets the effective uid back to the
2582 * uid. We don't just make perl setuid root because that loses the
2583 * effective uid we had before invoking perl, if it was different from the
2586 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2587 * be defined in suidperl only. suidperl must be setuid root. The
2588 * Configure script will set this up for you if you want it.
2595 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2596 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2597 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2602 #ifndef HAS_SETREUID
2603 /* On this access check to make sure the directories are readable,
2604 * there is actually a small window that the user could use to make
2605 * filename point to an accessible directory. So there is a faint
2606 * chance that someone could execute a setuid script down in a
2607 * non-accessible directory. I don't know what to do about that.
2608 * But I don't think it's too important. The manual lies when
2609 * it says access() is useful in setuid programs.
2611 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
2612 Perl_croak(aTHX_ "Permission denied");
2614 /* If we can swap euid and uid, then we can determine access rights
2615 * with a simple stat of the file, and then compare device and
2616 * inode to make sure we did stat() on the same file we opened.
2617 * Then we just have to make sure he or she can execute it.
2620 struct stat tmpstatbuf;
2624 setreuid(PL_euid,PL_uid) < 0
2627 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2630 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2631 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2632 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
2633 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2634 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2635 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2636 Perl_croak(aTHX_ "Permission denied");
2638 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2639 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2640 (void)PerlIO_close(PL_rsfp);
2641 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2642 PerlIO_printf(PL_rsfp,
2643 "User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2644 (Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n",
2645 PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2646 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2648 PL_statbuf.st_uid, PL_statbuf.st_gid);
2649 (void)PerlProc_pclose(PL_rsfp);
2651 Perl_croak(aTHX_ "Permission denied\n");
2655 setreuid(PL_uid,PL_euid) < 0
2657 # if defined(HAS_SETRESUID)
2658 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2661 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2662 Perl_croak(aTHX_ "Can't reswap uid and euid");
2663 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2664 Perl_croak(aTHX_ "Permission denied\n");
2666 #endif /* HAS_SETREUID */
2667 #endif /* IAMSUID */
2669 if (!S_ISREG(PL_statbuf.st_mode))
2670 Perl_croak(aTHX_ "Permission denied");
2671 if (PL_statbuf.st_mode & S_IWOTH)
2672 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2673 PL_doswitches = FALSE; /* -s is insecure in suid */
2674 CopLINE_inc(PL_curcop);
2675 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2676 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2677 Perl_croak(aTHX_ "No #! line");
2678 s = SvPV(PL_linestr,n_a)+2;
2680 while (!isSPACE(*s)) s++;
2681 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2682 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2683 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2684 Perl_croak(aTHX_ "Not a perl script");
2685 while (*s == ' ' || *s == '\t') s++;
2687 * #! arg must be what we saw above. They can invoke it by
2688 * mentioning suidperl explicitly, but they may not add any strange
2689 * arguments beyond what #! says if they do invoke suidperl that way.
2691 len = strlen(validarg);
2692 if (strEQ(validarg," PHOOEY ") ||
2693 strnNE(s,validarg,len) || !isSPACE(s[len]))
2694 Perl_croak(aTHX_ "Args must match #! line");
2697 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2698 PL_euid == PL_statbuf.st_uid)
2700 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2701 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2702 #endif /* IAMSUID */
2704 if (PL_euid) { /* oops, we're not the setuid root perl */
2705 (void)PerlIO_close(PL_rsfp);
2708 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
2709 (int)PERL_REVISION, (int)PERL_VERSION,
2710 (int)PERL_SUBVERSION), PL_origargv);
2712 Perl_croak(aTHX_ "Can't do setuid\n");
2715 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2717 (void)setegid(PL_statbuf.st_gid);
2720 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2722 #ifdef HAS_SETRESGID
2723 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2725 PerlProc_setgid(PL_statbuf.st_gid);
2729 if (PerlProc_getegid() != PL_statbuf.st_gid)
2730 Perl_croak(aTHX_ "Can't do setegid!\n");
2732 if (PL_statbuf.st_mode & S_ISUID) {
2733 if (PL_statbuf.st_uid != PL_euid)
2735 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2738 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2740 #ifdef HAS_SETRESUID
2741 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2743 PerlProc_setuid(PL_statbuf.st_uid);
2747 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2748 Perl_croak(aTHX_ "Can't do seteuid!\n");
2750 else if (PL_uid) { /* oops, mustn't run as root */
2752 (void)seteuid((Uid_t)PL_uid);
2755 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2757 #ifdef HAS_SETRESUID
2758 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2760 PerlProc_setuid((Uid_t)PL_uid);
2764 if (PerlProc_geteuid() != PL_uid)
2765 Perl_croak(aTHX_ "Can't do seteuid!\n");
2768 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2769 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
2772 else if (PL_preprocess)
2773 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2774 else if (fdscript >= 0)
2775 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2777 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2779 /* We absolutely must clear out any saved ids here, so we */
2780 /* exec the real perl, substituting fd script for scriptname. */
2781 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2782 PerlIO_rewind(PL_rsfp);
2783 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2784 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2785 if (!PL_origargv[which])
2786 Perl_croak(aTHX_ "Permission denied");
2787 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2788 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2789 #if defined(HAS_FCNTL) && defined(F_SETFD)
2790 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2792 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
2793 (int)PERL_REVISION, (int)PERL_VERSION,
2794 (int)PERL_SUBVERSION), PL_origargv);/* try again */
2795 Perl_croak(aTHX_ "Can't do setuid\n");
2796 #endif /* IAMSUID */
2798 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2799 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2801 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2802 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2804 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2807 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2808 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2809 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2810 /* not set-id, must be wrapped */
2816 S_find_beginning(pTHX)
2818 register char *s, *s2;
2820 /* skip forward in input to the real script? */
2823 while (PL_doextract) {
2824 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2825 Perl_croak(aTHX_ "No Perl script found in input\n");
2826 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2827 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2828 PL_doextract = FALSE;
2829 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2831 while (*s == ' ' || *s == '\t') s++;
2833 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2834 if (strnEQ(s2-4,"perl",4))
2836 while (s = moreswitches(s)) ;
2846 PL_uid = PerlProc_getuid();
2847 PL_euid = PerlProc_geteuid();
2848 PL_gid = PerlProc_getgid();
2849 PL_egid = PerlProc_getegid();
2851 PL_uid |= PL_gid << 16;
2852 PL_euid |= PL_egid << 16;
2854 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2858 S_forbid_setid(pTHX_ char *s)
2860 if (PL_euid != PL_uid)
2861 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2862 if (PL_egid != PL_gid)
2863 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2867 Perl_init_debugger(pTHX)
2870 HV *ostash = PL_curstash;
2872 PL_curstash = PL_debstash;
2873 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2874 AvREAL_off(PL_dbargs);
2875 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2876 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2877 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2878 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
2879 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2880 sv_setiv(PL_DBsingle, 0);
2881 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2882 sv_setiv(PL_DBtrace, 0);
2883 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2884 sv_setiv(PL_DBsignal, 0);
2885 PL_curstash = ostash;
2888 #ifndef STRESS_REALLOC
2889 #define REASONABLE(size) (size)
2891 #define REASONABLE(size) (1) /* unreasonable */
2895 Perl_init_stacks(pTHX)
2897 /* start with 128-item stack and 8K cxstack */
2898 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2899 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2900 PL_curstackinfo->si_type = PERLSI_MAIN;
2901 PL_curstack = PL_curstackinfo->si_stack;
2902 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2904 PL_stack_base = AvARRAY(PL_curstack);
2905 PL_stack_sp = PL_stack_base;
2906 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2908 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2911 PL_tmps_max = REASONABLE(128);
2913 New(54,PL_markstack,REASONABLE(32),I32);
2914 PL_markstack_ptr = PL_markstack;
2915 PL_markstack_max = PL_markstack + REASONABLE(32);
2919 New(54,PL_scopestack,REASONABLE(32),I32);
2920 PL_scopestack_ix = 0;
2921 PL_scopestack_max = REASONABLE(32);
2923 New(54,PL_savestack,REASONABLE(128),ANY);
2924 PL_savestack_ix = 0;
2925 PL_savestack_max = REASONABLE(128);
2927 New(54,PL_retstack,REASONABLE(16),OP*);
2929 PL_retstack_max = REASONABLE(16);
2938 while (PL_curstackinfo->si_next)
2939 PL_curstackinfo = PL_curstackinfo->si_next;
2940 while (PL_curstackinfo) {
2941 PERL_SI *p = PL_curstackinfo->si_prev;
2942 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2943 Safefree(PL_curstackinfo->si_cxstack);
2944 Safefree(PL_curstackinfo);
2945 PL_curstackinfo = p;
2947 Safefree(PL_tmps_stack);
2948 Safefree(PL_markstack);
2949 Safefree(PL_scopestack);
2950 Safefree(PL_savestack);
2951 Safefree(PL_retstack);
2955 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2966 lex_start(PL_linestr);
2968 PL_subname = newSVpvn("main",4);
2972 S_init_predump_symbols(pTHX)
2979 sv_setpvn(get_sv("\"", TRUE), " ", 1);
2980 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2981 GvMULTI_on(PL_stdingv);
2982 io = GvIOp(PL_stdingv);
2983 IoIFP(io) = PerlIO_stdin();
2984 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2986 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2988 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2991 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
2993 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2995 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2997 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2998 GvMULTI_on(PL_stderrgv);
2999 io = GvIOp(PL_stderrgv);
3000 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
3001 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
3003 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3005 PL_statname = NEWSV(66,0); /* last filename we did stat on */
3008 PL_osname = savepv(OSNAME);
3012 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3019 argc--,argv++; /* skip name of script */
3020 if (PL_doswitches) {
3021 for (; argc > 0 && **argv == '-'; argc--,argv++) {
3024 if (argv[0][1] == '-' && !argv[0][2]) {
3028 if (s = strchr(argv[0], '=')) {
3030 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
3033 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
3036 PL_toptarget = NEWSV(0,0);
3037 sv_upgrade(PL_toptarget, SVt_PVFM);
3038 sv_setpvn(PL_toptarget, "", 0);
3039 PL_bodytarget = NEWSV(0,0);
3040 sv_upgrade(PL_bodytarget, SVt_PVFM);
3041 sv_setpvn(PL_bodytarget, "", 0);
3042 PL_formtarget = PL_bodytarget;
3045 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
3046 sv_setpv(GvSV(tmpgv),PL_origfilename);
3047 magicname("0", "0", 1);
3049 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
3051 sv_setpv(GvSV(tmpgv), os2_execname());
3053 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
3055 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
3056 GvMULTI_on(PL_argvgv);
3057 (void)gv_AVadd(PL_argvgv);
3058 av_clear(GvAVn(PL_argvgv));
3059 for (; argc > 0; argc--,argv++) {
3060 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
3063 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
3065 GvMULTI_on(PL_envgv);
3066 hv = GvHVn(PL_envgv);
3067 hv_magic(hv, PL_envgv, 'E');
3068 #if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
3069 /* Note that if the supplied env parameter is actually a copy
3070 of the global environ then it may now point to free'd memory
3071 if the environment has been modified since. To avoid this
3072 problem we treat env==NULL as meaning 'use the default'
3077 environ[0] = Nullch;
3078 for (; *env; env++) {
3079 if (!(s = strchr(*env,'=')))
3085 sv = newSVpv(s--,0);
3086 (void)hv_store(hv, *env, s - *env, sv, 0);
3088 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
3089 /* Sins of the RTL. See note in my_setenv(). */
3090 (void)PerlEnv_putenv(savepv(*env));
3094 #ifdef DYNAMIC_ENV_FETCH
3095 HvNAME(hv) = savepv(ENV_HV_NAME);
3099 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
3100 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3104 S_init_perllib(pTHX)
3109 s = PerlEnv_getenv("PERL5LIB");
3113 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
3115 /* Treat PERL5?LIB as a possible search list logical name -- the
3116 * "natural" VMS idiom for a Unix path string. We allow each
3117 * element to be a set of |-separated directories for compatibility.
3121 if (my_trnlnm("PERL5LIB",buf,0))
3122 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
3124 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
3128 /* Use the ~-expanded versions of APPLLIB (undocumented),
3129 ARCHLIB PRIVLIB SITEARCH and SITELIB
3132 incpush(APPLLIB_EXP, TRUE);
3136 incpush(ARCHLIB_EXP, FALSE);
3139 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
3142 incpush(PRIVLIB_EXP, TRUE);
3144 incpush(PRIVLIB_EXP, FALSE);
3148 incpush(SITELIB_EXP, TRUE); /* XXX Win32 needs inc_version_list support */
3152 char *path = SITELIB_EXP;
3157 if (strrchr(buf,'/')) /* XXX Hack, Configure var needed */
3158 *strrchr(buf,'/') = '\0';
3164 #if defined(PERL_VENDORLIB_EXP)
3166 incpush(PERL_VENDORLIB_EXP, TRUE);
3168 incpush(PERL_VENDORLIB_EXP, FALSE);
3172 incpush(".", FALSE);
3176 # define PERLLIB_SEP ';'
3179 # define PERLLIB_SEP '|'
3181 # define PERLLIB_SEP ':'
3184 #ifndef PERLLIB_MANGLE
3185 # define PERLLIB_MANGLE(s,n) (s)
3189 S_incpush(pTHX_ char *p, int addsubdirs)
3191 SV *subdir = Nullsv;
3197 subdir = sv_newmortal();
3200 /* Break at all separators */
3202 SV *libdir = NEWSV(55,0);
3205 /* skip any consecutive separators */
3206 while ( *p == PERLLIB_SEP ) {
3207 /* Uncomment the next line for PATH semantics */
3208 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3212 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3213 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3218 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3219 p = Nullch; /* break out */
3223 * BEFORE pushing libdir onto @INC we may first push version- and
3224 * archname-specific sub-directories.
3227 #ifdef PERL_INC_VERSION_LIST
3228 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3229 const char *incverlist[] = { PERL_INC_VERSION_LIST };
3230 const char **incver;
3232 struct stat tmpstatbuf;
3237 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3239 while (unix[len-1] == '/') len--; /* Cosmetic */
3240 sv_usepvn(libdir,unix,len);
3243 PerlIO_printf(Perl_error_log,
3244 "Failed to unixify @INC element \"%s\"\n",
3247 /* .../version/archname if -d .../version/archname */
3248 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT"/%s", libdir,
3249 (int)PERL_REVISION, (int)PERL_VERSION,
3250 (int)PERL_SUBVERSION, ARCHNAME);
3251 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3252 S_ISDIR(tmpstatbuf.st_mode))
3253 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3255 /* .../version if -d .../version */
3256 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT, libdir,
3257 (int)PERL_REVISION, (int)PERL_VERSION,
3258 (int)PERL_SUBVERSION);
3259 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3260 S_ISDIR(tmpstatbuf.st_mode))
3261 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3263 /* .../archname if -d .../archname */
3264 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, ARCHNAME);
3265 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3266 S_ISDIR(tmpstatbuf.st_mode))
3267 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3269 #ifdef PERL_INC_VERSION_LIST
3270 for (incver = incverlist; *incver; incver++) {
3271 /* .../xxx if -d .../xxx */
3272 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, *incver);
3273 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3274 S_ISDIR(tmpstatbuf.st_mode))
3275 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3280 /* finally push this lib directory on the end of @INC */
3281 av_push(GvAVn(PL_incgv), libdir);
3286 STATIC struct perl_thread *
3287 S_init_main_thread(pTHX)
3289 #if !defined(PERL_IMPLICIT_CONTEXT)
3290 struct perl_thread *thr;
3294 Newz(53, thr, 1, struct perl_thread);
3295 PL_curcop = &PL_compiling;
3296 thr->interp = PERL_GET_INTERP;
3297 thr->cvcache = newHV();
3298 thr->threadsv = newAV();
3299 /* thr->threadsvp is set when find_threadsv is called */
3300 thr->specific = newAV();
3301 thr->flags = THRf_R_JOINABLE;
3302 MUTEX_INIT(&thr->mutex);
3303 /* Handcraft thrsv similarly to mess_sv */
3304 New(53, PL_thrsv, 1, SV);
3305 Newz(53, xpv, 1, XPV);
3306 SvFLAGS(PL_thrsv) = SVt_PV;
3307 SvANY(PL_thrsv) = (void*)xpv;
3308 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3309 SvPVX(PL_thrsv) = (char*)thr;
3310 SvCUR_set(PL_thrsv, sizeof(thr));
3311 SvLEN_set(PL_thrsv, sizeof(thr));
3312 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3313 thr->oursv = PL_thrsv;
3314 PL_chopset = " \n-";
3317 MUTEX_LOCK(&PL_threads_mutex);
3322 MUTEX_UNLOCK(&PL_threads_mutex);
3324 #ifdef HAVE_THREAD_INTERN
3325 Perl_init_thread_intern(thr);
3328 #ifdef SET_THREAD_SELF
3329 SET_THREAD_SELF(thr);
3331 thr->self = pthread_self();
3332 #endif /* SET_THREAD_SELF */
3336 * These must come after the SET_THR because sv_setpvn does
3337 * SvTAINT and the taint fields require dTHR.
3339 PL_toptarget = NEWSV(0,0);
3340 sv_upgrade(PL_toptarget, SVt_PVFM);
3341 sv_setpvn(PL_toptarget, "", 0);
3342 PL_bodytarget = NEWSV(0,0);
3343 sv_upgrade(PL_bodytarget, SVt_PVFM);
3344 sv_setpvn(PL_bodytarget, "", 0);
3345 PL_formtarget = PL_bodytarget;
3346 thr->errsv = newSVpvn("", 0);
3347 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
3350 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3351 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3352 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3353 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3354 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3356 PL_reginterp_cnt = 0;
3360 #endif /* USE_THREADS */
3363 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3367 line_t oldline = CopLINE(PL_curcop);
3373 while (AvFILL(paramList) >= 0) {
3374 cv = (CV*)av_shift(paramList);
3376 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
3380 (void)SvPV(atsv, len);
3383 PL_curcop = &PL_compiling;
3384 CopLINE_set(PL_curcop, oldline);
3385 if (paramList == PL_beginav)
3386 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3388 Perl_sv_catpvf(aTHX_ atsv,
3389 "%s failed--call queue aborted",
3390 paramList == PL_checkav ? "CHECK"
3391 : paramList == PL_initav ? "INIT"
3393 while (PL_scopestack_ix > oldscope)
3395 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
3402 /* my_exit() was called */
3403 while (PL_scopestack_ix > oldscope)
3406 PL_curstash = PL_defstash;
3407 PL_curcop = &PL_compiling;
3408 CopLINE_set(PL_curcop, oldline);
3409 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3410 if (paramList == PL_beginav)
3411 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3413 Perl_croak(aTHX_ "%s failed--call queue aborted",
3414 paramList == PL_checkav ? "CHECK"
3415 : paramList == PL_initav ? "INIT"
3422 PL_curcop = &PL_compiling;
3423 CopLINE_set(PL_curcop, oldline);
3426 PerlIO_printf(Perl_error_log, "panic: restartop\n");
3434 S_call_list_body(pTHX_ va_list args)
3437 CV *cv = va_arg(args, CV*);
3439 PUSHMARK(PL_stack_sp);
3440 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3445 Perl_my_exit(pTHX_ U32 status)
3449 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3450 thr, (unsigned long) status));
3459 STATUS_NATIVE_SET(status);
3466 Perl_my_failure_exit(pTHX)
3469 if (vaxc$errno & 1) {
3470 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3471 STATUS_NATIVE_SET(44);
3474 if (!vaxc$errno && errno) /* unlikely */
3475 STATUS_NATIVE_SET(44);
3477 STATUS_NATIVE_SET(vaxc$errno);
3482 STATUS_POSIX_SET(errno);
3484 exitstatus = STATUS_POSIX >> 8;
3485 if (exitstatus & 255)
3486 STATUS_POSIX_SET(exitstatus);
3488 STATUS_POSIX_SET(255);
3495 S_my_exit_jump(pTHX)
3498 register PERL_CONTEXT *cx;
3503 SvREFCNT_dec(PL_e_script);
3504 PL_e_script = Nullsv;
3507 POPSTACK_TO(PL_mainstack);
3508 if (cxstack_ix >= 0) {
3511 POPBLOCK(cx,PL_curpm);
3523 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3526 p = SvPVX(PL_e_script);
3527 nl = strchr(p, '\n');
3528 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3530 filter_del(read_e_script);
3533 sv_catpvn(buf_sv, p, nl-p);
3534 sv_chop(PL_e_script, nl);