3 * Copyright (c) 1987-1999 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
51 perl_alloc(struct IPerlMem* ipM, struct IPerlEnv* ipE,
52 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
53 struct IPerlDir* ipD, struct IPerlSock* ipS,
54 struct IPerlProc* ipP)
56 CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP);
64 #ifdef PERL_IMPLICIT_SYS
66 perl_alloc_using(struct IPerlMem* ipM, struct IPerlEnv* ipE,
67 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
68 struct IPerlDir* ipD, struct IPerlSock* ipS,
69 struct IPerlProc* ipP)
71 PerlInterpreter *my_perl;
73 /* New() needs interpreter, so call malloc() instead */
74 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
75 PERL_SET_INTERP(my_perl);
76 Zero(my_perl, 1, PerlInterpreter);
90 PerlInterpreter *my_perl;
92 /* New() needs interpreter, so call malloc() instead */
93 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
94 PERL_SET_INTERP(my_perl);
97 #endif /* PERL_IMPLICIT_SYS */
98 #endif /* PERL_OBJECT */
101 perl_construct(pTHXx)
106 struct perl_thread *thr = NULL;
107 #endif /* FAKE_THREADS */
108 #endif /* USE_THREADS */
112 PL_perl_destruct_level = 1;
114 if (PL_perl_destruct_level > 0)
118 /* Init the real globals (and main thread)? */
123 #ifdef ALLOC_THREAD_KEY
126 if (pthread_key_create(&PL_thr_key, 0))
127 Perl_croak(aTHX_ "panic: pthread_key_create");
129 MUTEX_INIT(&PL_sv_mutex);
131 * Safe to use basic SV functions from now on (though
132 * not things like mortals or tainting yet).
134 MUTEX_INIT(&PL_eval_mutex);
135 COND_INIT(&PL_eval_cond);
136 MUTEX_INIT(&PL_threads_mutex);
137 COND_INIT(&PL_nthreads_cond);
138 #ifdef EMULATE_ATOMIC_REFCOUNTS
139 MUTEX_INIT(&PL_svref_mutex);
140 #endif /* EMULATE_ATOMIC_REFCOUNTS */
142 MUTEX_INIT(&PL_cred_mutex);
144 thr = init_main_thread();
145 #endif /* USE_THREADS */
147 PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
149 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
151 PL_linestr = NEWSV(65,79);
152 sv_upgrade(PL_linestr,SVt_PVIV);
154 if (!SvREADONLY(&PL_sv_undef)) {
155 /* set read-only and try to insure than we wont see REFCNT==0
158 SvREADONLY_on(&PL_sv_undef);
159 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
161 sv_setpv(&PL_sv_no,PL_No);
163 SvREADONLY_on(&PL_sv_no);
164 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
166 sv_setpv(&PL_sv_yes,PL_Yes);
168 SvREADONLY_on(&PL_sv_yes);
169 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
174 /* PL_sighandlerp = sighandler; */
176 PL_sighandlerp = Perl_sighandler;
178 PL_pidstatus = newHV();
182 * There is no way we can refer to them from Perl so close them to save
183 * space. The other alternative would be to provide STDAUX and STDPRN
186 (void)fclose(stdaux);
187 (void)fclose(stdprn);
191 PL_nrs = newSVpvn("\n", 1);
192 PL_rs = SvREFCNT_inc(PL_nrs);
197 PL_lex_state = LEX_NOTPARSING;
203 SET_NUMERIC_STANDARD();
205 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
206 sprintf(PL_patchlevel, "%7.5f", (double) PERL_REVISION
207 + ((double) PERL_VERSION / (double) 1000)
208 + ((double) PERL_SUBVERSION / (double) 100000));
210 sprintf(PL_patchlevel, "%5.3f", (double) PERL_REVISION +
211 ((double) PERL_VERSION / (double) 1000));
214 #if defined(LOCAL_PATCH_COUNT)
215 PL_localpatches = local_patches; /* For possible -v */
218 PerlIO_init(); /* Hook to IO system */
220 PL_fdpid = newAV(); /* for remembering popen pids by fd */
221 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
230 int destruct_level; /* 0=none, 1=full, 2=full with checks */
236 #endif /* USE_THREADS */
240 /* Pass 1 on any remaining threads: detach joinables, join zombies */
242 MUTEX_LOCK(&PL_threads_mutex);
243 DEBUG_S(PerlIO_printf(Perl_debug_log,
244 "perl_destruct: waiting for %d threads...\n",
246 for (t = thr->next; t != thr; t = t->next) {
247 MUTEX_LOCK(&t->mutex);
248 switch (ThrSTATE(t)) {
251 DEBUG_S(PerlIO_printf(Perl_debug_log,
252 "perl_destruct: joining zombie %p\n", t));
253 ThrSETSTATE(t, THRf_DEAD);
254 MUTEX_UNLOCK(&t->mutex);
257 * The SvREFCNT_dec below may take a long time (e.g. av
258 * may contain an object scalar whose destructor gets
259 * called) so we have to unlock threads_mutex and start
262 MUTEX_UNLOCK(&PL_threads_mutex);
264 SvREFCNT_dec((SV*)av);
265 DEBUG_S(PerlIO_printf(Perl_debug_log,
266 "perl_destruct: joined zombie %p OK\n", t));
268 case THRf_R_JOINABLE:
269 DEBUG_S(PerlIO_printf(Perl_debug_log,
270 "perl_destruct: detaching thread %p\n", t));
271 ThrSETSTATE(t, THRf_R_DETACHED);
273 * We unlock threads_mutex and t->mutex in the opposite order
274 * from which we locked them just so that DETACH won't
275 * deadlock if it panics. It's only a breach of good style
276 * not a bug since they are unlocks not locks.
278 MUTEX_UNLOCK(&PL_threads_mutex);
280 MUTEX_UNLOCK(&t->mutex);
283 DEBUG_S(PerlIO_printf(Perl_debug_log,
284 "perl_destruct: ignoring %p (state %u)\n",
286 MUTEX_UNLOCK(&t->mutex);
287 /* fall through and out */
290 /* We leave the above "Pass 1" loop with threads_mutex still locked */
292 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
293 while (PL_nthreads > 1)
295 DEBUG_S(PerlIO_printf(Perl_debug_log,
296 "perl_destruct: final wait for %d threads\n",
298 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
300 /* At this point, we're the last thread */
301 MUTEX_UNLOCK(&PL_threads_mutex);
302 DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
303 MUTEX_DESTROY(&PL_threads_mutex);
304 COND_DESTROY(&PL_nthreads_cond);
305 #endif /* !defined(FAKE_THREADS) */
306 #endif /* USE_THREADS */
308 destruct_level = PL_perl_destruct_level;
312 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
314 if (destruct_level < i)
323 /* We must account for everything. */
325 /* Destroy the main CV and syntax tree */
327 PL_curpad = AvARRAY(PL_comppad);
328 op_free(PL_main_root);
329 PL_main_root = Nullop;
331 PL_curcop = &PL_compiling;
332 PL_main_start = Nullop;
333 SvREFCNT_dec(PL_main_cv);
337 if (PL_sv_objcount) {
339 * Try to destruct global references. We do this first so that the
340 * destructors and destructees still exist. Some sv's might remain.
341 * Non-referenced objects are on their own.
346 /* unhook hooks which will soon be, or use, destroyed data */
347 SvREFCNT_dec(PL_warnhook);
348 PL_warnhook = Nullsv;
349 SvREFCNT_dec(PL_diehook);
352 /* call exit list functions */
353 while (PL_exitlistlen-- > 0)
354 PL_exitlist[PL_exitlistlen].fn(aTHXo_ PL_exitlist[PL_exitlistlen].ptr);
356 Safefree(PL_exitlist);
358 if (destruct_level == 0){
360 DEBUG_P(debprofdump());
362 /* The exit() function will do everything that needs doing. */
366 /* loosen bonds of global variables */
369 (void)PerlIO_close(PL_rsfp);
373 /* Filters for program text */
374 SvREFCNT_dec(PL_rsfp_filters);
375 PL_rsfp_filters = Nullav;
378 PL_preprocess = FALSE;
384 PL_doswitches = FALSE;
385 PL_dowarn = G_WARN_OFF;
386 PL_doextract = FALSE;
387 PL_sawampersand = FALSE; /* must save all match strings */
390 Safefree(PL_inplace);
394 SvREFCNT_dec(PL_e_script);
395 PL_e_script = Nullsv;
398 /* magical thingies */
400 Safefree(PL_ofs); /* $, */
403 Safefree(PL_ors); /* $\ */
406 SvREFCNT_dec(PL_rs); /* $/ */
409 SvREFCNT_dec(PL_nrs); /* $/ helper */
412 PL_multiline = 0; /* $* */
414 SvREFCNT_dec(PL_statname);
415 PL_statname = Nullsv;
418 /* defgv, aka *_ should be taken care of elsewhere */
420 /* clean up after study() */
421 SvREFCNT_dec(PL_lastscream);
422 PL_lastscream = Nullsv;
423 Safefree(PL_screamfirst);
425 Safefree(PL_screamnext);
429 Safefree(PL_efloatbuf);
430 PL_efloatbuf = Nullch;
433 /* startup and shutdown function lists */
434 SvREFCNT_dec(PL_beginav);
435 SvREFCNT_dec(PL_endav);
436 SvREFCNT_dec(PL_stopav);
437 SvREFCNT_dec(PL_initav);
443 /* shortcuts just get cleared */
449 PL_argvoutgv = Nullgv;
451 PL_stderrgv = Nullgv;
452 PL_last_in_gv = Nullgv;
454 PL_debstash = Nullhv;
456 /* reset so print() ends up where we expect */
459 SvREFCNT_dec(PL_argvout_stack);
460 PL_argvout_stack = Nullav;
462 SvREFCNT_dec(PL_fdpid);
464 SvREFCNT_dec(PL_modglobal);
465 PL_modglobal = Nullhv;
466 SvREFCNT_dec(PL_preambleav);
467 PL_preambleav = Nullav;
468 SvREFCNT_dec(PL_subname);
470 SvREFCNT_dec(PL_linestr);
472 SvREFCNT_dec(PL_pidstatus);
473 PL_pidstatus = Nullhv;
474 SvREFCNT_dec(PL_toptarget);
475 PL_toptarget = Nullsv;
476 SvREFCNT_dec(PL_bodytarget);
477 PL_bodytarget = Nullsv;
478 PL_formtarget = Nullsv;
480 /* clear utf8 character classes */
481 SvREFCNT_dec(PL_utf8_alnum);
482 SvREFCNT_dec(PL_utf8_alnumc);
483 SvREFCNT_dec(PL_utf8_ascii);
484 SvREFCNT_dec(PL_utf8_alpha);
485 SvREFCNT_dec(PL_utf8_space);
486 SvREFCNT_dec(PL_utf8_cntrl);
487 SvREFCNT_dec(PL_utf8_graph);
488 SvREFCNT_dec(PL_utf8_digit);
489 SvREFCNT_dec(PL_utf8_upper);
490 SvREFCNT_dec(PL_utf8_lower);
491 SvREFCNT_dec(PL_utf8_print);
492 SvREFCNT_dec(PL_utf8_punct);
493 SvREFCNT_dec(PL_utf8_xdigit);
494 SvREFCNT_dec(PL_utf8_mark);
495 SvREFCNT_dec(PL_utf8_toupper);
496 SvREFCNT_dec(PL_utf8_tolower);
497 PL_utf8_alnum = Nullsv;
498 PL_utf8_alnumc = Nullsv;
499 PL_utf8_ascii = Nullsv;
500 PL_utf8_alpha = Nullsv;
501 PL_utf8_space = Nullsv;
502 PL_utf8_cntrl = Nullsv;
503 PL_utf8_graph = Nullsv;
504 PL_utf8_digit = Nullsv;
505 PL_utf8_upper = Nullsv;
506 PL_utf8_lower = Nullsv;
507 PL_utf8_print = Nullsv;
508 PL_utf8_punct = Nullsv;
509 PL_utf8_xdigit = Nullsv;
510 PL_utf8_mark = Nullsv;
511 PL_utf8_toupper = Nullsv;
512 PL_utf8_totitle = Nullsv;
513 PL_utf8_tolower = Nullsv;
515 SvREFCNT_dec(PL_compiling.cop_warnings);
516 PL_compiling.cop_warnings = Nullsv;
518 /* Prepare to destruct main symbol table. */
523 SvREFCNT_dec(PL_curstname);
524 PL_curstname = Nullsv;
526 /* clear queued errors */
527 SvREFCNT_dec(PL_errors);
531 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
532 if (PL_scopestack_ix != 0)
533 Perl_warner(aTHX_ WARN_INTERNAL,
534 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
535 (long)PL_scopestack_ix);
536 if (PL_savestack_ix != 0)
537 Perl_warner(aTHX_ WARN_INTERNAL,
538 "Unbalanced saves: %ld more saves than restores\n",
539 (long)PL_savestack_ix);
540 if (PL_tmps_floor != -1)
541 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
542 (long)PL_tmps_floor + 1);
543 if (cxstack_ix != -1)
544 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
545 (long)cxstack_ix + 1);
548 /* Now absolutely destruct everything, somehow or other, loops or no. */
550 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
551 while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
552 last_sv_count = PL_sv_count;
555 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
556 SvFLAGS(PL_strtab) |= SVt_PVHV;
558 /* Destruct the global string table. */
560 /* Yell and reset the HeVAL() slots that are still holding refcounts,
561 * so that sv_free() won't fail on them.
569 max = HvMAX(PL_strtab);
570 array = HvARRAY(PL_strtab);
573 if (hent && ckWARN_d(WARN_INTERNAL)) {
574 Perl_warner(aTHX_ WARN_INTERNAL,
575 "Unbalanced string table refcount: (%d) for \"%s\"",
576 HeVAL(hent) - Nullsv, HeKEY(hent));
577 HeVAL(hent) = Nullsv;
587 SvREFCNT_dec(PL_strtab);
589 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
590 Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
594 /* No SVs have survived, need to clean out */
595 Safefree(PL_origfilename);
596 Safefree(PL_archpat_auto);
597 Safefree(PL_reg_start_tmp);
599 Safefree(PL_reg_curpm);
600 Safefree(PL_reg_poscache);
601 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
602 Safefree(PL_op_mask);
604 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
606 DEBUG_P(debprofdump());
608 MUTEX_DESTROY(&PL_strtab_mutex);
609 MUTEX_DESTROY(&PL_sv_mutex);
610 MUTEX_DESTROY(&PL_eval_mutex);
611 MUTEX_DESTROY(&PL_cred_mutex);
612 COND_DESTROY(&PL_eval_cond);
613 #ifdef EMULATE_ATOMIC_REFCOUNTS
614 MUTEX_DESTROY(&PL_svref_mutex);
615 #endif /* EMULATE_ATOMIC_REFCOUNTS */
617 /* As the penultimate thing, free the non-arena SV for thrsv */
618 Safefree(SvPVX(PL_thrsv));
619 Safefree(SvANY(PL_thrsv));
622 #endif /* USE_THREADS */
624 /* As the absolutely last thing, free the non-arena SV for mess() */
627 /* it could have accumulated taint magic */
628 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
631 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
632 moremagic = mg->mg_moremagic;
633 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
634 Safefree(mg->mg_ptr);
638 /* we know that type >= SVt_PV */
639 SvOOK_off(PL_mess_sv);
640 Safefree(SvPVX(PL_mess_sv));
641 Safefree(SvANY(PL_mess_sv));
642 Safefree(PL_mess_sv);
650 #if defined(PERL_OBJECT)
658 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
660 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
661 PL_exitlist[PL_exitlistlen].fn = fn;
662 PL_exitlist[PL_exitlistlen].ptr = ptr;
667 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
677 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
680 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
681 setuid perl scripts securely.\n");
685 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
686 _dyld_lookup_and_bind
687 ("__environ", (unsigned long *) &environ_pointer, NULL);
692 #ifndef VMS /* VMS doesn't have environ array */
693 PL_origenviron = environ;
698 /* Come here if running an undumped a.out. */
700 PL_origfilename = savepv(argv[0]);
701 PL_do_undump = FALSE;
702 cxstack_ix = -1; /* start label stack again */
704 init_postdump_symbols(argc,argv,env);
709 PL_curpad = AvARRAY(PL_comppad);
710 op_free(PL_main_root);
711 PL_main_root = Nullop;
713 PL_main_start = Nullop;
714 SvREFCNT_dec(PL_main_cv);
718 oldscope = PL_scopestack_ix;
719 PL_dowarn = G_WARN_OFF;
721 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_parse_body),
726 call_list(oldscope, PL_stopav);
732 /* my_exit() was called */
733 while (PL_scopestack_ix > oldscope)
736 PL_curstash = PL_defstash;
738 call_list(oldscope, PL_stopav);
739 return STATUS_NATIVE_EXPORT;
741 PerlIO_printf(Perl_error_log, "panic: top_env\n");
748 S_parse_body(pTHX_ va_list args)
751 int argc = PL_origargc;
752 char **argv = PL_origargv;
753 char **env = va_arg(args, char**);
754 char *scriptname = NULL;
756 VOL bool dosearch = FALSE;
761 char *cddir = Nullch;
763 XSINIT_t xsinit = va_arg(args, XSINIT_t);
765 sv_setpvn(PL_linestr,"",0);
766 sv = newSVpvn("",0); /* first used for -I flags */
770 for (argc--,argv++; argc > 0; argc--,argv++) {
771 if (argv[0][0] != '-' || !argv[0][1])
775 validarg = " PHOOEY ";
782 #ifndef PERL_STRICT_CR
806 if (s = moreswitches(s))
816 if (PL_euid != PL_uid || PL_egid != PL_gid)
817 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
819 PL_e_script = newSVpvn("",0);
820 filter_add(read_e_script, NULL);
823 sv_catpv(PL_e_script, s);
825 sv_catpv(PL_e_script, argv[1]);
829 Perl_croak(aTHX_ "No code specified for -e");
830 sv_catpv(PL_e_script, "\n");
833 case 'I': /* -I handled both here and in moreswitches() */
835 if (!*++s && (s=argv[1]) != Nullch) {
838 while (s && isSPACE(*s))
842 for (e = s; *e && !isSPACE(*e); e++) ;
849 } /* XXX else croak? */
853 PL_preprocess = TRUE;
863 PL_preambleav = newAV();
864 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
866 PL_Sv = newSVpv("print myconfig();",0);
868 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
870 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
872 sv_catpv(PL_Sv,"\" Compile-time options:");
874 sv_catpv(PL_Sv," DEBUGGING");
877 sv_catpv(PL_Sv," MULTIPLICITY");
880 sv_catpv(PL_Sv," USE_THREADS");
883 sv_catpv(PL_Sv," PERL_OBJECT");
885 # ifdef PERL_IMPLICIT_CONTEXT
886 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
888 # ifdef PERL_IMPLICIT_SYS
889 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
891 sv_catpv(PL_Sv,"\\n\",");
893 #if defined(LOCAL_PATCH_COUNT)
894 if (LOCAL_PATCH_COUNT > 0) {
896 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
897 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
898 if (PL_localpatches[i])
899 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
903 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
906 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
908 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
913 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
914 print \" \\%ENV:\\n @env\\n\" if @env; \
915 print \" \\@INC:\\n @INC\\n\";");
918 PL_Sv = newSVpv("config_vars(qw(",0);
919 sv_catpv(PL_Sv, ++s);
920 sv_catpv(PL_Sv, "))");
923 av_push(PL_preambleav, PL_Sv);
924 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
935 if (!*++s || isSPACE(*s)) {
939 /* catch use of gnu style long options */
940 if (strEQ(s, "version")) {
944 if (strEQ(s, "help")) {
951 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
957 #ifndef SECURE_INTERNAL_GETENV
960 (s = PerlEnv_getenv("PERL5OPT"))) {
963 if (*s == '-' && *(s+1) == 'T')
976 if (!strchr("DIMUdmw", *s))
977 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
984 scriptname = argv[0];
987 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
989 else if (scriptname == Nullch) {
991 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
999 open_script(scriptname,dosearch,sv,&fdscript);
1001 validate_suid(validarg, scriptname,fdscript);
1003 #if defined(SIGCHLD) || defined(SIGCLD)
1006 # define SIGCHLD SIGCLD
1008 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1009 if (sigstate == SIG_IGN) {
1010 if (ckWARN(WARN_SIGNAL))
1011 Perl_warner(aTHX_ WARN_SIGNAL,
1012 "Can't ignore signal CHLD, forcing to default");
1013 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1020 if (cddir && PerlDir_chdir(cddir) < 0)
1021 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1025 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1026 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1027 CvUNIQUE_on(PL_compcv);
1029 PL_comppad = newAV();
1030 av_push(PL_comppad, Nullsv);
1031 PL_curpad = AvARRAY(PL_comppad);
1032 PL_comppad_name = newAV();
1033 PL_comppad_name_fill = 0;
1034 PL_min_intro_pending = 0;
1037 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
1038 PL_curpad[0] = (SV*)newAV();
1039 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
1040 CvOWNER(PL_compcv) = 0;
1041 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1042 MUTEX_INIT(CvMUTEXP(PL_compcv));
1043 #endif /* USE_THREADS */
1045 comppadlist = newAV();
1046 AvREAL_off(comppadlist);
1047 av_store(comppadlist, 0, (SV*)PL_comppad_name);
1048 av_store(comppadlist, 1, (SV*)PL_comppad);
1049 CvPADLIST(PL_compcv) = comppadlist;
1051 boot_core_UNIVERSAL();
1052 boot_core_xsutils();
1055 (*xsinit)(aTHXo); /* in case linked C routines want magical variables */
1056 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
1064 init_predump_symbols();
1065 /* init_postdump_symbols not currently designed to be called */
1066 /* more than once (ENV isn't cleared first, for example) */
1067 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
1069 init_postdump_symbols(argc,argv,env);
1073 /* now parse the script */
1075 SETERRNO(0,SS$_NORMAL);
1077 if (yyparse() || PL_error_count) {
1079 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1081 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1085 CopLINE_set(PL_curcop, 0);
1086 PL_curstash = PL_defstash;
1087 PL_preprocess = FALSE;
1089 SvREFCNT_dec(PL_e_script);
1090 PL_e_script = Nullsv;
1093 /* now that script is parsed, we can modify record separator */
1094 SvREFCNT_dec(PL_rs);
1095 PL_rs = SvREFCNT_inc(PL_nrs);
1096 sv_setsv(get_sv("/", TRUE), PL_rs);
1101 SAVECOPFILE(PL_curcop);
1102 SAVECOPLINE(PL_curcop);
1103 gv_check(PL_defstash);
1110 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1111 dump_mstats("after compilation:");
1130 oldscope = PL_scopestack_ix;
1133 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
1136 cxstack_ix = -1; /* start context stack again */
1138 case 0: /* normal completion */
1139 case 2: /* my_exit() */
1140 while (PL_scopestack_ix > oldscope)
1143 PL_curstash = PL_defstash;
1144 if (PL_endav && !PL_minus_c)
1145 call_list(oldscope, PL_endav);
1147 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1148 dump_mstats("after execution: ");
1150 return STATUS_NATIVE_EXPORT;
1153 POPSTACK_TO(PL_mainstack);
1156 PerlIO_printf(Perl_error_log, "panic: restartop\n");
1166 S_run_body(pTHX_ va_list args)
1169 I32 oldscope = va_arg(args, I32);
1171 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1172 PL_sawampersand ? "Enabling" : "Omitting"));
1174 if (!PL_restartop) {
1175 DEBUG_x(dump_all());
1176 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1177 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1181 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1184 if (PERLDB_SINGLE && PL_DBsingle)
1185 sv_setiv(PL_DBsingle, 1);
1187 call_list(oldscope, PL_initav);
1193 PL_op = PL_restartop;
1197 else if (PL_main_start) {
1198 CvDEPTH(PL_main_cv) = 1;
1199 PL_op = PL_main_start;
1209 Perl_get_sv(pTHX_ const char *name, I32 create)
1213 if (name[1] == '\0' && !isALPHA(name[0])) {
1214 PADOFFSET tmp = find_threadsv(name);
1215 if (tmp != NOT_IN_PAD) {
1217 return THREADSV(tmp);
1220 #endif /* USE_THREADS */
1221 gv = gv_fetchpv(name, create, SVt_PV);
1228 Perl_get_av(pTHX_ const char *name, I32 create)
1230 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1239 Perl_get_hv(pTHX_ const char *name, I32 create)
1241 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1250 Perl_get_cv(pTHX_ const char *name, I32 create)
1252 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1253 /* XXX unsafe for threads if eval_owner isn't held */
1254 /* XXX this is probably not what they think they're getting.
1255 * It has the same effect as "sub name;", i.e. just a forward
1257 if (create && !GvCVu(gv))
1258 return newSUB(start_subparse(FALSE, 0),
1259 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1267 /* Be sure to refetch the stack pointer after calling these routines. */
1270 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1272 /* See G_* flags in cop.h */
1273 /* null terminated arg list */
1280 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1285 return call_pv(sub_name, flags);
1289 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1290 /* name of the subroutine */
1291 /* See G_* flags in cop.h */
1293 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1297 Perl_call_method(pTHX_ const char *methname, I32 flags)
1298 /* name of the subroutine */
1299 /* See G_* flags in cop.h */
1305 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1310 return call_sv(*PL_stack_sp--, flags);
1313 /* May be called with any of a CV, a GV, or an SV containing the name. */
1315 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1317 /* See G_* flags in cop.h */
1320 LOGOP myop; /* fake syntax tree node */
1324 bool oldcatch = CATCH_GET;
1329 if (flags & G_DISCARD) {
1334 Zero(&myop, 1, LOGOP);
1335 myop.op_next = Nullop;
1336 if (!(flags & G_NOARGS))
1337 myop.op_flags |= OPf_STACKED;
1338 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1339 (flags & G_ARRAY) ? OPf_WANT_LIST :
1344 EXTEND(PL_stack_sp, 1);
1345 *++PL_stack_sp = sv;
1347 oldscope = PL_scopestack_ix;
1349 if (PERLDB_SUB && PL_curstash != PL_debstash
1350 /* Handle first BEGIN of -d. */
1351 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1352 /* Try harder, since this may have been a sighandler, thus
1353 * curstash may be meaningless. */
1354 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1355 && !(flags & G_NODEBUG))
1356 PL_op->op_private |= OPpENTERSUB_DB;
1358 if (!(flags & G_EVAL)) {
1360 call_xbody((OP*)&myop, FALSE);
1361 retval = PL_stack_sp - (PL_stack_base + oldmark);
1362 CATCH_SET(oldcatch);
1365 cLOGOP->op_other = PL_op;
1367 /* we're trying to emulate pp_entertry() here */
1369 register PERL_CONTEXT *cx;
1370 I32 gimme = GIMME_V;
1375 push_return(PL_op->op_next);
1376 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1378 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1380 PL_in_eval = EVAL_INEVAL;
1381 if (flags & G_KEEPERR)
1382 PL_in_eval |= EVAL_KEEPERR;
1389 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1393 retval = PL_stack_sp - (PL_stack_base + oldmark);
1394 if (!(flags & G_KEEPERR))
1401 /* my_exit() was called */
1402 PL_curstash = PL_defstash;
1405 Perl_croak(aTHX_ "Callback called exit");
1410 PL_op = PL_restartop;
1414 PL_stack_sp = PL_stack_base + oldmark;
1415 if (flags & G_ARRAY)
1419 *++PL_stack_sp = &PL_sv_undef;
1424 if (PL_scopestack_ix > oldscope) {
1428 register PERL_CONTEXT *cx;
1439 if (flags & G_DISCARD) {
1440 PL_stack_sp = PL_stack_base + oldmark;
1450 S_call_body(pTHX_ va_list args)
1452 OP *myop = va_arg(args, OP*);
1453 int is_eval = va_arg(args, int);
1455 call_xbody(myop, is_eval);
1460 S_call_xbody(pTHX_ OP *myop, int is_eval)
1464 if (PL_op == myop) {
1466 PL_op = Perl_pp_entereval(aTHX);
1468 PL_op = Perl_pp_entersub(aTHX);
1474 /* Eval a string. The G_EVAL flag is always assumed. */
1477 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1479 /* See G_* flags in cop.h */
1482 UNOP myop; /* fake syntax tree node */
1483 I32 oldmark = SP - PL_stack_base;
1490 if (flags & G_DISCARD) {
1497 Zero(PL_op, 1, UNOP);
1498 EXTEND(PL_stack_sp, 1);
1499 *++PL_stack_sp = sv;
1500 oldscope = PL_scopestack_ix;
1502 if (!(flags & G_NOARGS))
1503 myop.op_flags = OPf_STACKED;
1504 myop.op_next = Nullop;
1505 myop.op_type = OP_ENTEREVAL;
1506 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1507 (flags & G_ARRAY) ? OPf_WANT_LIST :
1509 if (flags & G_KEEPERR)
1510 myop.op_flags |= OPf_SPECIAL;
1513 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1517 retval = PL_stack_sp - (PL_stack_base + oldmark);
1518 if (!(flags & G_KEEPERR))
1525 /* my_exit() was called */
1526 PL_curstash = PL_defstash;
1529 Perl_croak(aTHX_ "Callback called exit");
1534 PL_op = PL_restartop;
1538 PL_stack_sp = PL_stack_base + oldmark;
1539 if (flags & G_ARRAY)
1543 *++PL_stack_sp = &PL_sv_undef;
1548 if (flags & G_DISCARD) {
1549 PL_stack_sp = PL_stack_base + oldmark;
1559 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1562 SV* sv = newSVpv(p, 0);
1565 eval_sv(sv, G_SCALAR);
1572 if (croak_on_error && SvTRUE(ERRSV)) {
1574 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1580 /* Require a module. */
1583 Perl_require_pv(pTHX_ const char *pv)
1587 PUSHSTACKi(PERLSI_REQUIRE);
1589 sv = sv_newmortal();
1590 sv_setpv(sv, "require '");
1593 eval_sv(sv, G_DISCARD);
1599 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1603 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1604 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1608 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
1610 /* This message really ought to be max 23 lines.
1611 * Removed -h because the user already knows that opton. Others? */
1613 static char *usage_msg[] = {
1614 "-0[octal] specify record separator (\\0, if no argument)",
1615 "-a autosplit mode with -n or -p (splits $_ into @F)",
1616 "-c check syntax only (runs BEGIN and END blocks)",
1617 "-d[:debugger] run program under debugger",
1618 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1619 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1620 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1621 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1622 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1623 "-l[octal] enable line ending processing, specifies line terminator",
1624 "-[mM][-]module execute `use/no module...' before executing program",
1625 "-n assume 'while (<>) { ... }' loop around program",
1626 "-p assume loop like -n but print line also, like sed",
1627 "-P run program through C preprocessor before compilation",
1628 "-s enable rudimentary parsing for switches after programfile",
1629 "-S look for programfile using PATH environment variable",
1630 "-T enable tainting checks",
1631 "-u dump core after parsing program",
1632 "-U allow unsafe operations",
1633 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1634 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1635 "-w enable many useful warnings (RECOMMENDED)",
1636 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1640 char **p = usage_msg;
1642 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1644 printf("\n %s", *p++);
1647 /* This routine handles any switches that can be given during run */
1650 Perl_moreswitches(pTHX_ char *s)
1659 rschar = (U32)scan_oct(s, 4, &numlen);
1660 SvREFCNT_dec(PL_nrs);
1661 if (rschar & ~((U8)~0))
1662 PL_nrs = &PL_sv_undef;
1663 else if (!rschar && numlen >= 2)
1664 PL_nrs = newSVpvn("", 0);
1667 PL_nrs = newSVpvn(&ch, 1);
1673 PL_splitstr = savepv(s + 1);
1687 if (*s == ':' || *s == '=') {
1688 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1692 PL_perldb = PERLDB_ALL;
1700 if (isALPHA(s[1])) {
1701 static char debopts[] = "psltocPmfrxuLHXDS";
1704 for (s++; *s && (d = strchr(debopts,*s)); s++)
1705 PL_debug |= 1 << (d - debopts);
1708 PL_debug = atoi(s+1);
1709 for (s++; isDIGIT(*s); s++) ;
1711 PL_debug |= 0x80000000;
1714 if (ckWARN_d(WARN_DEBUGGING))
1715 Perl_warner(aTHX_ WARN_DEBUGGING,
1716 "Recompile perl with -DDEBUGGING to use -D switch\n");
1717 for (s++; isALNUM(*s); s++) ;
1723 usage(PL_origargv[0]);
1727 Safefree(PL_inplace);
1728 PL_inplace = savepv(s+1);
1730 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1733 if (*s == '-') /* Additional switches on #! line. */
1737 case 'I': /* -I handled both here and in parse_perl() */
1740 while (*s && isSPACE(*s))
1744 for (e = s; *e && !isSPACE(*e); e++) ;
1745 p = savepvn(s, e-s);
1751 Perl_croak(aTHX_ "No space allowed after -I");
1759 PL_ors = savepv("\n");
1761 *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
1766 if (RsPARA(PL_nrs)) {
1771 PL_ors = SvPV(PL_nrs, PL_orslen);
1772 PL_ors = savepvn(PL_ors, PL_orslen);
1776 forbid_setid("-M"); /* XXX ? */
1779 forbid_setid("-m"); /* XXX ? */
1784 /* -M-foo == 'no foo' */
1785 if (*s == '-') { use = "no "; ++s; }
1786 sv = newSVpv(use,0);
1788 /* We allow -M'Module qw(Foo Bar)' */
1789 while(isALNUM(*s) || *s==':') ++s;
1791 sv_catpv(sv, start);
1792 if (*(start-1) == 'm') {
1794 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
1795 sv_catpv( sv, " ()");
1798 sv_catpvn(sv, start, s-start);
1799 sv_catpv(sv, " split(/,/,q{");
1805 PL_preambleav = newAV();
1806 av_push(PL_preambleav, sv);
1809 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1821 PL_doswitches = TRUE;
1826 Perl_croak(aTHX_ "Too late for \"-T\" option");
1830 PL_do_undump = TRUE;
1838 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
1839 printf("\nThis is perl, version %d.%03d_%02d built for %s",
1840 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME);
1842 printf("\nThis is perl, version %s built for %s",
1843 PL_patchlevel, ARCHNAME);
1845 #if defined(LOCAL_PATCH_COUNT)
1846 if (LOCAL_PATCH_COUNT > 0)
1847 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1848 (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1851 printf("\n\nCopyright 1987-1999, Larry Wall\n");
1853 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1856 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1857 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
1860 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1861 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
1864 printf("atariST series port, ++jrb bammi@cadence.com\n");
1867 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
1870 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1873 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
1876 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
1879 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
1882 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
1885 printf("MiNT port by Guido Flohr, 1997-1999\n");
1887 #ifdef BINARY_BUILD_NOTICE
1888 BINARY_BUILD_NOTICE;
1891 Perl may be copied only under the terms of either the Artistic License or the\n\
1892 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1893 Complete documentation for Perl, including FAQ lists, should be found on\n\
1894 this system using `man perl' or `perldoc perl'. If you have access to the\n\
1895 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1898 if (! (PL_dowarn & G_WARN_ALL_MASK))
1899 PL_dowarn |= G_WARN_ON;
1903 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1904 PL_compiling.cop_warnings = WARN_ALL ;
1908 PL_dowarn = G_WARN_ALL_OFF;
1909 PL_compiling.cop_warnings = WARN_NONE ;
1914 if (s[1] == '-') /* Additional switches on #! line. */
1919 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1925 #ifdef ALTERNATE_SHEBANG
1926 case 'S': /* OS/2 needs -S on "extproc" line. */
1934 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
1939 /* compliments of Tom Christiansen */
1941 /* unexec() can be found in the Gnu emacs distribution */
1942 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1945 Perl_my_unexec(pTHX)
1953 prog = newSVpv(BIN_EXP, 0);
1954 sv_catpv(prog, "/perl");
1955 file = newSVpv(PL_origfilename, 0);
1956 sv_catpv(file, ".perldump");
1958 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1959 /* unexec prints msg to stderr in case of failure */
1960 PerlProc_exit(status);
1963 # include <lib$routines.h>
1964 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1966 ABORT(); /* for use with undump */
1971 /* initialize curinterp */
1976 #ifdef PERL_OBJECT /* XXX kludge */
1979 PL_chopset = " \n-"; \
1980 PL_copline = NOLINE; \
1981 PL_curcop = &PL_compiling;\
1982 PL_curcopdb = NULL; \
1984 PL_dumpindent = 4; \
1985 PL_laststatval = -1; \
1986 PL_laststype = OP_STAT; \
1987 PL_maxscream = -1; \
1988 PL_maxsysfd = MAXSYSFD; \
1989 PL_statname = Nullsv; \
1990 PL_tmps_floor = -1; \
1992 PL_op_mask = NULL; \
1993 PL_laststatval = -1; \
1994 PL_laststype = OP_STAT; \
1995 PL_mess_sv = Nullsv; \
1996 PL_splitstr = " "; \
1997 PL_generation = 100; \
1998 PL_exitlist = NULL; \
1999 PL_exitlistlen = 0; \
2001 PL_in_clean_objs = FALSE; \
2002 PL_in_clean_all = FALSE; \
2003 PL_profiledata = NULL; \
2005 PL_rsfp_filters = Nullav; \
2010 # ifdef MULTIPLICITY
2011 # define PERLVAR(var,type)
2012 # define PERLVARA(var,n,type)
2013 # if defined(PERL_IMPLICIT_CONTEXT)
2014 # if defined(USE_THREADS)
2015 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2016 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2017 # else /* !USE_THREADS */
2018 # define PERLVARI(var,type,init) aTHX->var = init;
2019 # define PERLVARIC(var,type,init) aTHX->var = init;
2020 # endif /* USE_THREADS */
2022 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2023 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2025 # include "intrpvar.h"
2026 # ifndef USE_THREADS
2027 # include "thrdvar.h"
2034 # define PERLVAR(var,type)
2035 # define PERLVARA(var,n,type)
2036 # define PERLVARI(var,type,init) PL_##var = init;
2037 # define PERLVARIC(var,type,init) PL_##var = init;
2038 # include "intrpvar.h"
2039 # ifndef USE_THREADS
2040 # include "thrdvar.h"
2052 S_init_main_stash(pTHX)
2057 /* Note that strtab is a rather special HV. Assumptions are made
2058 about not iterating on it, and not adding tie magic to it.
2059 It is properly deallocated in perl_destruct() */
2060 PL_strtab = newHV();
2062 MUTEX_INIT(&PL_strtab_mutex);
2064 HvSHAREKEYS_off(PL_strtab); /* mandatory */
2065 hv_ksplit(PL_strtab, 512);
2067 PL_curstash = PL_defstash = newHV();
2068 PL_curstname = newSVpvn("main",4);
2069 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2070 SvREFCNT_dec(GvHV(gv));
2071 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2073 HvNAME(PL_defstash) = savepv("main");
2074 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2075 GvMULTI_on(PL_incgv);
2076 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2077 GvMULTI_on(PL_hintgv);
2078 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2079 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2080 GvMULTI_on(PL_errgv);
2081 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2082 GvMULTI_on(PL_replgv);
2083 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
2084 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2085 sv_setpvn(ERRSV, "", 0);
2086 PL_curstash = PL_defstash;
2087 PL_compiling.cop_stash = PL_defstash;
2088 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2089 /* We must init $/ before switches are processed. */
2090 sv_setpvn(get_sv("/", TRUE), "\n", 1);
2094 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2102 PL_origfilename = savepv("-e");
2105 /* if find_script() returns, it returns a malloc()-ed value */
2106 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2108 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2109 char *s = scriptname + 8;
2110 *fdscript = atoi(s);
2114 scriptname = savepv(s + 1);
2115 Safefree(PL_origfilename);
2116 PL_origfilename = scriptname;
2121 CopFILE_set(PL_curcop, PL_origfilename);
2122 if (strEQ(PL_origfilename,"-"))
2124 if (*fdscript >= 0) {
2125 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2126 #if defined(HAS_FCNTL) && defined(F_SETFD)
2128 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2131 else if (PL_preprocess) {
2132 char *cpp_cfg = CPPSTDIN;
2133 SV *cpp = newSVpvn("",0);
2134 SV *cmd = NEWSV(0,0);
2136 if (strEQ(cpp_cfg, "cppstdin"))
2137 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2138 sv_catpv(cpp, cpp_cfg);
2141 sv_catpv(sv,PRIVLIB_EXP);
2144 Perl_sv_setpvf(aTHX_ cmd, "\
2145 sed %s -e \"/^[^#]/b\" \
2146 -e \"/^#[ ]*include[ ]/b\" \
2147 -e \"/^#[ ]*define[ ]/b\" \
2148 -e \"/^#[ ]*if[ ]/b\" \
2149 -e \"/^#[ ]*ifdef[ ]/b\" \
2150 -e \"/^#[ ]*ifndef[ ]/b\" \
2151 -e \"/^#[ ]*else/b\" \
2152 -e \"/^#[ ]*elif[ ]/b\" \
2153 -e \"/^#[ ]*undef[ ]/b\" \
2154 -e \"/^#[ ]*endif/b\" \
2157 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2160 Perl_sv_setpvf(aTHX_ cmd, "\
2161 %s %s -e '/^[^#]/b' \
2162 -e '/^#[ ]*include[ ]/b' \
2163 -e '/^#[ ]*define[ ]/b' \
2164 -e '/^#[ ]*if[ ]/b' \
2165 -e '/^#[ ]*ifdef[ ]/b' \
2166 -e '/^#[ ]*ifndef[ ]/b' \
2167 -e '/^#[ ]*else/b' \
2168 -e '/^#[ ]*elif[ ]/b' \
2169 -e '/^#[ ]*undef[ ]/b' \
2170 -e '/^#[ ]*endif/b' \
2174 Perl_sv_setpvf(aTHX_ cmd, "\
2175 %s %s -e '/^[^#]/b' \
2176 -e '/^#[ ]*include[ ]/b' \
2177 -e '/^#[ ]*define[ ]/b' \
2178 -e '/^#[ ]*if[ ]/b' \
2179 -e '/^#[ ]*ifdef[ ]/b' \
2180 -e '/^#[ ]*ifndef[ ]/b' \
2181 -e '/^#[ ]*else/b' \
2182 -e '/^#[ ]*elif[ ]/b' \
2183 -e '/^#[ ]*undef[ ]/b' \
2184 -e '/^#[ ]*endif/b' \
2193 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2195 scriptname, cpp, sv, CPPMINUS);
2196 PL_doextract = FALSE;
2197 #ifdef IAMSUID /* actually, this is caught earlier */
2198 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2200 (void)seteuid(PL_uid); /* musn't stay setuid root */
2203 (void)setreuid((Uid_t)-1, PL_uid);
2205 #ifdef HAS_SETRESUID
2206 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2208 PerlProc_setuid(PL_uid);
2212 if (PerlProc_geteuid() != PL_uid)
2213 Perl_croak(aTHX_ "Can't do seteuid!\n");
2215 #endif /* IAMSUID */
2216 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2220 else if (!*scriptname) {
2221 forbid_setid("program input from stdin");
2222 PL_rsfp = PerlIO_stdin();
2225 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2226 #if defined(HAS_FCNTL) && defined(F_SETFD)
2228 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2233 #ifndef IAMSUID /* in case script is not readable before setuid */
2235 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2236 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2239 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2240 Perl_croak(aTHX_ "Can't do setuid\n");
2244 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2245 CopFILE(PL_curcop), Strerror(errno));
2250 * I_SYSSTATVFS HAS_FSTATVFS
2252 * I_STATFS HAS_FSTATFS
2253 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2254 * here so that metaconfig picks them up. */
2258 S_fd_on_nosuid_fs(pTHX_ int fd)
2260 int check_okay = 0; /* able to do all the required sys/libcalls */
2261 int on_nosuid = 0; /* the fd is on a nosuid fs */
2263 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2264 * fstatvfs() is UNIX98.
2265 * fstatfs() is 4.3 BSD.
2266 * ustat()+getmnt() is pre-4.3 BSD.
2267 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2268 * an irrelevant filesystem while trying to reach the right one.
2271 # ifdef HAS_FSTATVFS
2272 struct statvfs stfs;
2273 check_okay = fstatvfs(fd, &stfs) == 0;
2274 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2276 # ifdef PERL_MOUNT_NOSUID
2277 # if defined(HAS_FSTATFS) && \
2278 defined(HAS_STRUCT_STATFS) && \
2279 defined(HAS_STRUCT_STATFS_F_FLAGS)
2281 check_okay = fstatfs(fd, &stfs) == 0;
2282 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2284 # if defined(HAS_FSTAT) && \
2285 defined(HAS_USTAT) && \
2286 defined(HAS_GETMNT) && \
2287 defined(HAS_STRUCT_FS_DATA) &&
2290 if (fstat(fd, &fdst) == 0) {
2292 if (ustat(fdst.st_dev, &us) == 0) {
2294 /* NOSTAT_ONE here because we're not examining fields which
2295 * vary between that case and STAT_ONE. */
2296 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2297 size_t cmplen = sizeof(us.f_fname);
2298 if (sizeof(fsd.fd_req.path) < cmplen)
2299 cmplen = sizeof(fsd.fd_req.path);
2300 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2301 fdst.st_dev == fsd.fd_req.dev) {
2303 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2309 # endif /* fstat+ustat+getmnt */
2310 # endif /* fstatfs */
2312 # if defined(HAS_GETMNTENT) && \
2313 defined(HAS_HASMNTOPT) && \
2314 defined(MNTOPT_NOSUID)
2315 FILE *mtab = fopen("/etc/mtab", "r");
2316 struct mntent *entry;
2317 struct stat stb, fsb;
2319 if (mtab && (fstat(fd, &stb) == 0)) {
2320 while (entry = getmntent(mtab)) {
2321 if (stat(entry->mnt_dir, &fsb) == 0
2322 && fsb.st_dev == stb.st_dev)
2324 /* found the filesystem */
2326 if (hasmntopt(entry, MNTOPT_NOSUID))
2329 } /* A single fs may well fail its stat(). */
2334 # endif /* getmntent+hasmntopt */
2335 # endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */
2336 # endif /* statvfs */
2339 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
2342 #endif /* IAMSUID */
2345 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2349 /* do we need to emulate setuid on scripts? */
2351 /* This code is for those BSD systems that have setuid #! scripts disabled
2352 * in the kernel because of a security problem. Merely defining DOSUID
2353 * in perl will not fix that problem, but if you have disabled setuid
2354 * scripts in the kernel, this will attempt to emulate setuid and setgid
2355 * on scripts that have those now-otherwise-useless bits set. The setuid
2356 * root version must be called suidperl or sperlN.NNN. If regular perl
2357 * discovers that it has opened a setuid script, it calls suidperl with
2358 * the same argv that it had. If suidperl finds that the script it has
2359 * just opened is NOT setuid root, it sets the effective uid back to the
2360 * uid. We don't just make perl setuid root because that loses the
2361 * effective uid we had before invoking perl, if it was different from the
2364 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2365 * be defined in suidperl only. suidperl must be setuid root. The
2366 * Configure script will set this up for you if you want it.
2373 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2374 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2375 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2380 #ifndef HAS_SETREUID
2381 /* On this access check to make sure the directories are readable,
2382 * there is actually a small window that the user could use to make
2383 * filename point to an accessible directory. So there is a faint
2384 * chance that someone could execute a setuid script down in a
2385 * non-accessible directory. I don't know what to do about that.
2386 * But I don't think it's too important. The manual lies when
2387 * it says access() is useful in setuid programs.
2389 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
2390 Perl_croak(aTHX_ "Permission denied");
2392 /* If we can swap euid and uid, then we can determine access rights
2393 * with a simple stat of the file, and then compare device and
2394 * inode to make sure we did stat() on the same file we opened.
2395 * Then we just have to make sure he or she can execute it.
2398 struct stat tmpstatbuf;
2402 setreuid(PL_euid,PL_uid) < 0
2405 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2408 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2409 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2410 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
2411 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2412 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2413 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2414 Perl_croak(aTHX_ "Permission denied");
2416 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2417 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2418 (void)PerlIO_close(PL_rsfp);
2419 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2420 PerlIO_printf(PL_rsfp,
2421 "User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2422 (Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n",
2423 PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2424 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2426 PL_statbuf.st_uid, PL_statbuf.st_gid);
2427 (void)PerlProc_pclose(PL_rsfp);
2429 Perl_croak(aTHX_ "Permission denied\n");
2433 setreuid(PL_uid,PL_euid) < 0
2435 # if defined(HAS_SETRESUID)
2436 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2439 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2440 Perl_croak(aTHX_ "Can't reswap uid and euid");
2441 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2442 Perl_croak(aTHX_ "Permission denied\n");
2444 #endif /* HAS_SETREUID */
2445 #endif /* IAMSUID */
2447 if (!S_ISREG(PL_statbuf.st_mode))
2448 Perl_croak(aTHX_ "Permission denied");
2449 if (PL_statbuf.st_mode & S_IWOTH)
2450 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2451 PL_doswitches = FALSE; /* -s is insecure in suid */
2452 CopLINE_inc(PL_curcop);
2453 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2454 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2455 Perl_croak(aTHX_ "No #! line");
2456 s = SvPV(PL_linestr,n_a)+2;
2458 while (!isSPACE(*s)) s++;
2459 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2460 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2461 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2462 Perl_croak(aTHX_ "Not a perl script");
2463 while (*s == ' ' || *s == '\t') s++;
2465 * #! arg must be what we saw above. They can invoke it by
2466 * mentioning suidperl explicitly, but they may not add any strange
2467 * arguments beyond what #! says if they do invoke suidperl that way.
2469 len = strlen(validarg);
2470 if (strEQ(validarg," PHOOEY ") ||
2471 strnNE(s,validarg,len) || !isSPACE(s[len]))
2472 Perl_croak(aTHX_ "Args must match #! line");
2475 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2476 PL_euid == PL_statbuf.st_uid)
2478 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2479 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2480 #endif /* IAMSUID */
2482 if (PL_euid) { /* oops, we're not the setuid root perl */
2483 (void)PerlIO_close(PL_rsfp);
2486 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2488 Perl_croak(aTHX_ "Can't do setuid\n");
2491 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2493 (void)setegid(PL_statbuf.st_gid);
2496 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2498 #ifdef HAS_SETRESGID
2499 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2501 PerlProc_setgid(PL_statbuf.st_gid);
2505 if (PerlProc_getegid() != PL_statbuf.st_gid)
2506 Perl_croak(aTHX_ "Can't do setegid!\n");
2508 if (PL_statbuf.st_mode & S_ISUID) {
2509 if (PL_statbuf.st_uid != PL_euid)
2511 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2514 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2516 #ifdef HAS_SETRESUID
2517 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2519 PerlProc_setuid(PL_statbuf.st_uid);
2523 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2524 Perl_croak(aTHX_ "Can't do seteuid!\n");
2526 else if (PL_uid) { /* oops, mustn't run as root */
2528 (void)seteuid((Uid_t)PL_uid);
2531 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2533 #ifdef HAS_SETRESUID
2534 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2536 PerlProc_setuid((Uid_t)PL_uid);
2540 if (PerlProc_geteuid() != PL_uid)
2541 Perl_croak(aTHX_ "Can't do seteuid!\n");
2544 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2545 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
2548 else if (PL_preprocess)
2549 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2550 else if (fdscript >= 0)
2551 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2553 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2555 /* We absolutely must clear out any saved ids here, so we */
2556 /* exec the real perl, substituting fd script for scriptname. */
2557 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2558 PerlIO_rewind(PL_rsfp);
2559 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2560 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2561 if (!PL_origargv[which])
2562 Perl_croak(aTHX_ "Permission denied");
2563 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2564 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2565 #if defined(HAS_FCNTL) && defined(F_SETFD)
2566 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2568 PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
2569 Perl_croak(aTHX_ "Can't do setuid\n");
2570 #endif /* IAMSUID */
2572 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2573 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2575 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2576 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2578 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2581 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2582 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2583 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2584 /* not set-id, must be wrapped */
2590 S_find_beginning(pTHX)
2592 register char *s, *s2;
2594 /* skip forward in input to the real script? */
2597 while (PL_doextract) {
2598 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2599 Perl_croak(aTHX_ "No Perl script found in input\n");
2600 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2601 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2602 PL_doextract = FALSE;
2603 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2605 while (*s == ' ' || *s == '\t') s++;
2607 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2608 if (strnEQ(s2-4,"perl",4))
2610 while (s = moreswitches(s)) ;
2620 PL_uid = PerlProc_getuid();
2621 PL_euid = PerlProc_geteuid();
2622 PL_gid = PerlProc_getgid();
2623 PL_egid = PerlProc_getegid();
2625 PL_uid |= PL_gid << 16;
2626 PL_euid |= PL_egid << 16;
2628 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2632 S_forbid_setid(pTHX_ char *s)
2634 if (PL_euid != PL_uid)
2635 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2636 if (PL_egid != PL_gid)
2637 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2641 Perl_init_debugger(pTHX)
2644 HV *ostash = PL_curstash;
2646 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2647 PL_curstash = PL_debstash;
2648 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2649 AvREAL_off(PL_dbargs);
2650 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2651 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2652 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2653 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
2654 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2655 sv_setiv(PL_DBsingle, 0);
2656 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2657 sv_setiv(PL_DBtrace, 0);
2658 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2659 sv_setiv(PL_DBsignal, 0);
2660 PL_curstash = ostash;
2663 #ifndef STRESS_REALLOC
2664 #define REASONABLE(size) (size)
2666 #define REASONABLE(size) (1) /* unreasonable */
2670 Perl_init_stacks(pTHX)
2672 /* start with 128-item stack and 8K cxstack */
2673 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2674 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2675 PL_curstackinfo->si_type = PERLSI_MAIN;
2676 PL_curstack = PL_curstackinfo->si_stack;
2677 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2679 PL_stack_base = AvARRAY(PL_curstack);
2680 PL_stack_sp = PL_stack_base;
2681 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2683 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2686 PL_tmps_max = REASONABLE(128);
2688 New(54,PL_markstack,REASONABLE(32),I32);
2689 PL_markstack_ptr = PL_markstack;
2690 PL_markstack_max = PL_markstack + REASONABLE(32);
2694 New(54,PL_scopestack,REASONABLE(32),I32);
2695 PL_scopestack_ix = 0;
2696 PL_scopestack_max = REASONABLE(32);
2698 New(54,PL_savestack,REASONABLE(128),ANY);
2699 PL_savestack_ix = 0;
2700 PL_savestack_max = REASONABLE(128);
2702 New(54,PL_retstack,REASONABLE(16),OP*);
2704 PL_retstack_max = REASONABLE(16);
2713 while (PL_curstackinfo->si_next)
2714 PL_curstackinfo = PL_curstackinfo->si_next;
2715 while (PL_curstackinfo) {
2716 PERL_SI *p = PL_curstackinfo->si_prev;
2717 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2718 Safefree(PL_curstackinfo->si_cxstack);
2719 Safefree(PL_curstackinfo);
2720 PL_curstackinfo = p;
2722 Safefree(PL_tmps_stack);
2723 Safefree(PL_markstack);
2724 Safefree(PL_scopestack);
2725 Safefree(PL_savestack);
2726 Safefree(PL_retstack);
2730 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2741 lex_start(PL_linestr);
2743 PL_subname = newSVpvn("main",4);
2747 S_init_predump_symbols(pTHX)
2754 sv_setpvn(get_sv("\"", TRUE), " ", 1);
2755 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2756 GvMULTI_on(PL_stdingv);
2757 io = GvIOp(PL_stdingv);
2758 IoIFP(io) = PerlIO_stdin();
2759 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2761 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2763 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2766 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
2768 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2770 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2772 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2773 GvMULTI_on(PL_stderrgv);
2774 io = GvIOp(PL_stderrgv);
2775 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
2776 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2778 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2780 PL_statname = NEWSV(66,0); /* last filename we did stat on */
2783 PL_osname = savepv(OSNAME);
2787 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
2794 argc--,argv++; /* skip name of script */
2795 if (PL_doswitches) {
2796 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2799 if (argv[0][1] == '-') {
2803 if (s = strchr(argv[0], '=')) {
2805 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2808 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2811 PL_toptarget = NEWSV(0,0);
2812 sv_upgrade(PL_toptarget, SVt_PVFM);
2813 sv_setpvn(PL_toptarget, "", 0);
2814 PL_bodytarget = NEWSV(0,0);
2815 sv_upgrade(PL_bodytarget, SVt_PVFM);
2816 sv_setpvn(PL_bodytarget, "", 0);
2817 PL_formtarget = PL_bodytarget;
2820 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2821 sv_setpv(GvSV(tmpgv),PL_origfilename);
2822 magicname("0", "0", 1);
2824 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2826 sv_setpv(GvSV(tmpgv), os2_execname());
2828 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2830 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2831 GvMULTI_on(PL_argvgv);
2832 (void)gv_AVadd(PL_argvgv);
2833 av_clear(GvAVn(PL_argvgv));
2834 for (; argc > 0; argc--,argv++) {
2835 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2838 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2840 GvMULTI_on(PL_envgv);
2841 hv = GvHVn(PL_envgv);
2842 hv_magic(hv, PL_envgv, 'E');
2843 #if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
2844 /* Note that if the supplied env parameter is actually a copy
2845 of the global environ then it may now point to free'd memory
2846 if the environment has been modified since. To avoid this
2847 problem we treat env==NULL as meaning 'use the default'
2852 environ[0] = Nullch;
2853 for (; *env; env++) {
2854 if (!(s = strchr(*env,'=')))
2860 sv = newSVpv(s--,0);
2861 (void)hv_store(hv, *env, s - *env, sv, 0);
2863 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2864 /* Sins of the RTL. See note in my_setenv(). */
2865 (void)PerlEnv_putenv(savepv(*env));
2869 #ifdef DYNAMIC_ENV_FETCH
2870 HvNAME(hv) = savepv(ENV_HV_NAME);
2874 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2875 sv_setiv(GvSV(tmpgv), (IV)getpid());
2879 S_init_perllib(pTHX)
2884 s = PerlEnv_getenv("PERL5LIB");
2888 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2890 /* Treat PERL5?LIB as a possible search list logical name -- the
2891 * "natural" VMS idiom for a Unix path string. We allow each
2892 * element to be a set of |-separated directories for compatibility.
2896 if (my_trnlnm("PERL5LIB",buf,0))
2897 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2899 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2903 /* Use the ~-expanded versions of APPLLIB (undocumented),
2904 ARCHLIB PRIVLIB SITEARCH and SITELIB
2907 incpush(APPLLIB_EXP, TRUE);
2911 incpush(ARCHLIB_EXP, FALSE);
2914 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2917 incpush(PRIVLIB_EXP, TRUE);
2919 incpush(PRIVLIB_EXP, FALSE);
2923 incpush(SITEARCH_EXP, FALSE);
2927 incpush(SITELIB_EXP, TRUE);
2929 incpush(SITELIB_EXP, FALSE);
2932 #if defined(PERL_VENDORLIB_EXP)
2934 incpush(PERL_VENDORLIB_EXP, TRUE);
2936 incpush(PERL_VENDORLIB_EXP, FALSE);
2940 incpush(".", FALSE);
2944 # define PERLLIB_SEP ';'
2947 # define PERLLIB_SEP '|'
2949 # define PERLLIB_SEP ':'
2952 #ifndef PERLLIB_MANGLE
2953 # define PERLLIB_MANGLE(s,n) (s)
2957 S_incpush(pTHX_ char *p, int addsubdirs)
2959 SV *subdir = Nullsv;
2965 subdir = sv_newmortal();
2966 if (!PL_archpat_auto) {
2967 STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
2968 + sizeof("//auto"));
2969 New(55, PL_archpat_auto, len, char);
2970 sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
2972 for (len = sizeof(ARCHNAME) + 2;
2973 PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2974 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
2979 /* Break at all separators */
2981 SV *libdir = NEWSV(55,0);
2984 /* skip any consecutive separators */
2985 while ( *p == PERLLIB_SEP ) {
2986 /* Uncomment the next line for PATH semantics */
2987 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
2991 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2992 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2997 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2998 p = Nullch; /* break out */
3002 * BEFORE pushing libdir onto @INC we may first push version- and
3003 * archname-specific sub-directories.
3006 struct stat tmpstatbuf;
3011 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3013 while (unix[len-1] == '/') len--; /* Cosmetic */
3014 sv_usepvn(libdir,unix,len);
3017 PerlIO_printf(Perl_error_log,
3018 "Failed to unixify @INC element \"%s\"\n",
3021 /* .../archname/version if -d .../archname/version/auto */
3022 sv_setsv(subdir, libdir);
3023 sv_catpv(subdir, PL_archpat_auto);
3024 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3025 S_ISDIR(tmpstatbuf.st_mode))
3026 av_push(GvAVn(PL_incgv),
3027 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
3029 /* .../archname if -d .../archname/auto */
3030 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
3031 strlen(PL_patchlevel) + 1, "", 0);
3032 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3033 S_ISDIR(tmpstatbuf.st_mode))
3034 av_push(GvAVn(PL_incgv),
3035 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
3038 /* finally push this lib directory on the end of @INC */
3039 av_push(GvAVn(PL_incgv), libdir);
3044 STATIC struct perl_thread *
3045 S_init_main_thread(pTHX)
3047 #if !defined(PERL_IMPLICIT_CONTEXT)
3048 struct perl_thread *thr;
3052 Newz(53, thr, 1, struct perl_thread);
3053 PL_curcop = &PL_compiling;
3054 thr->interp = PERL_GET_INTERP;
3055 thr->cvcache = newHV();
3056 thr->threadsv = newAV();
3057 /* thr->threadsvp is set when find_threadsv is called */
3058 thr->specific = newAV();
3059 thr->flags = THRf_R_JOINABLE;
3060 MUTEX_INIT(&thr->mutex);
3061 /* Handcraft thrsv similarly to mess_sv */
3062 New(53, PL_thrsv, 1, SV);
3063 Newz(53, xpv, 1, XPV);
3064 SvFLAGS(PL_thrsv) = SVt_PV;
3065 SvANY(PL_thrsv) = (void*)xpv;
3066 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3067 SvPVX(PL_thrsv) = (char*)thr;
3068 SvCUR_set(PL_thrsv, sizeof(thr));
3069 SvLEN_set(PL_thrsv, sizeof(thr));
3070 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3071 thr->oursv = PL_thrsv;
3072 PL_chopset = " \n-";
3075 MUTEX_LOCK(&PL_threads_mutex);
3080 MUTEX_UNLOCK(&PL_threads_mutex);
3082 #ifdef HAVE_THREAD_INTERN
3083 Perl_init_thread_intern(thr);
3086 #ifdef SET_THREAD_SELF
3087 SET_THREAD_SELF(thr);
3089 thr->self = pthread_self();
3090 #endif /* SET_THREAD_SELF */
3094 * These must come after the SET_THR because sv_setpvn does
3095 * SvTAINT and the taint fields require dTHR.
3097 PL_toptarget = NEWSV(0,0);
3098 sv_upgrade(PL_toptarget, SVt_PVFM);
3099 sv_setpvn(PL_toptarget, "", 0);
3100 PL_bodytarget = NEWSV(0,0);
3101 sv_upgrade(PL_bodytarget, SVt_PVFM);
3102 sv_setpvn(PL_bodytarget, "", 0);
3103 PL_formtarget = PL_bodytarget;
3104 thr->errsv = newSVpvn("", 0);
3105 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
3108 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3109 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3110 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3111 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3112 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3114 PL_reginterp_cnt = 0;
3118 #endif /* USE_THREADS */
3121 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3125 line_t oldline = CopLINE(PL_curcop);
3131 while (AvFILL(paramList) >= 0) {
3132 cv = (CV*)av_shift(paramList);
3134 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
3137 (void)SvPV(atsv, len);
3139 PL_curcop = &PL_compiling;
3140 CopLINE_set(PL_curcop, oldline);
3141 if (paramList == PL_beginav)
3142 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3144 Perl_sv_catpvf(aTHX_ atsv,
3145 "%s failed--call queue aborted",
3146 paramList == PL_stopav ? "STOP"
3147 : paramList == PL_initav ? "INIT"
3149 while (PL_scopestack_ix > oldscope)
3151 Perl_croak(aTHX_ "%s", SvPVX(atsv));
3158 /* my_exit() was called */
3159 while (PL_scopestack_ix > oldscope)
3162 PL_curstash = PL_defstash;
3163 PL_curcop = &PL_compiling;
3164 CopLINE_set(PL_curcop, oldline);
3165 if (PL_statusvalue) {
3166 if (paramList == PL_beginav)
3167 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3169 Perl_croak(aTHX_ "%s failed--call queue aborted",
3170 paramList == PL_stopav ? "STOP"
3171 : paramList == PL_initav ? "INIT"
3178 PL_curcop = &PL_compiling;
3179 CopLINE_set(PL_curcop, oldline);
3182 PerlIO_printf(Perl_error_log, "panic: restartop\n");
3190 S_call_list_body(pTHX_ va_list args)
3193 CV *cv = va_arg(args, CV*);
3195 PUSHMARK(PL_stack_sp);
3196 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3201 Perl_my_exit(pTHX_ U32 status)
3205 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3206 thr, (unsigned long) status));
3215 STATUS_NATIVE_SET(status);
3222 Perl_my_failure_exit(pTHX)
3225 if (vaxc$errno & 1) {
3226 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3227 STATUS_NATIVE_SET(44);
3230 if (!vaxc$errno && errno) /* unlikely */
3231 STATUS_NATIVE_SET(44);
3233 STATUS_NATIVE_SET(vaxc$errno);
3238 STATUS_POSIX_SET(errno);
3240 exitstatus = STATUS_POSIX >> 8;
3241 if (exitstatus & 255)
3242 STATUS_POSIX_SET(exitstatus);
3244 STATUS_POSIX_SET(255);
3251 S_my_exit_jump(pTHX)
3254 register PERL_CONTEXT *cx;
3259 SvREFCNT_dec(PL_e_script);
3260 PL_e_script = Nullsv;
3263 POPSTACK_TO(PL_mainstack);
3264 if (cxstack_ix >= 0) {
3267 POPBLOCK(cx,PL_curpm);
3279 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3282 p = SvPVX(PL_e_script);
3283 nl = strchr(p, '\n');
3284 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3286 filter_del(read_e_script);
3289 sv_catpvn(buf_sv, p, nl-p);
3290 sv_chop(PL_e_script, nl);