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 PL_curcop->cop_line = 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 gv_check(PL_defstash);
1107 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1108 dump_mstats("after compilation:");
1127 oldscope = PL_scopestack_ix;
1130 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
1133 cxstack_ix = -1; /* start context stack again */
1135 case 0: /* normal completion */
1136 case 2: /* my_exit() */
1137 while (PL_scopestack_ix > oldscope)
1140 PL_curstash = PL_defstash;
1141 if (PL_endav && !PL_minus_c)
1142 call_list(oldscope, PL_endav);
1144 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1145 dump_mstats("after execution: ");
1147 return STATUS_NATIVE_EXPORT;
1150 POPSTACK_TO(PL_mainstack);
1153 PerlIO_printf(Perl_error_log, "panic: restartop\n");
1163 S_run_body(pTHX_ va_list args)
1166 I32 oldscope = va_arg(args, I32);
1168 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1169 PL_sawampersand ? "Enabling" : "Omitting"));
1171 if (!PL_restartop) {
1172 DEBUG_x(dump_all());
1173 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1174 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1178 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1181 if (PERLDB_SINGLE && PL_DBsingle)
1182 sv_setiv(PL_DBsingle, 1);
1184 call_list(oldscope, PL_initav);
1190 PL_op = PL_restartop;
1194 else if (PL_main_start) {
1195 CvDEPTH(PL_main_cv) = 1;
1196 PL_op = PL_main_start;
1206 Perl_get_sv(pTHX_ const char *name, I32 create)
1210 if (name[1] == '\0' && !isALPHA(name[0])) {
1211 PADOFFSET tmp = find_threadsv(name);
1212 if (tmp != NOT_IN_PAD) {
1214 return THREADSV(tmp);
1217 #endif /* USE_THREADS */
1218 gv = gv_fetchpv(name, create, SVt_PV);
1225 Perl_get_av(pTHX_ const char *name, I32 create)
1227 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1236 Perl_get_hv(pTHX_ const char *name, I32 create)
1238 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1247 Perl_get_cv(pTHX_ const char *name, I32 create)
1249 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1250 /* XXX unsafe for threads if eval_owner isn't held */
1251 /* XXX this is probably not what they think they're getting.
1252 * It has the same effect as "sub name;", i.e. just a forward
1254 if (create && !GvCVu(gv))
1255 return newSUB(start_subparse(FALSE, 0),
1256 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1264 /* Be sure to refetch the stack pointer after calling these routines. */
1267 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1269 /* See G_* flags in cop.h */
1270 /* null terminated arg list */
1277 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1282 return call_pv(sub_name, flags);
1286 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1287 /* name of the subroutine */
1288 /* See G_* flags in cop.h */
1290 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1294 Perl_call_method(pTHX_ const char *methname, I32 flags)
1295 /* name of the subroutine */
1296 /* See G_* flags in cop.h */
1302 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1307 return call_sv(*PL_stack_sp--, flags);
1310 /* May be called with any of a CV, a GV, or an SV containing the name. */
1312 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1314 /* See G_* flags in cop.h */
1317 LOGOP myop; /* fake syntax tree node */
1321 bool oldcatch = CATCH_GET;
1326 if (flags & G_DISCARD) {
1331 Zero(&myop, 1, LOGOP);
1332 myop.op_next = Nullop;
1333 if (!(flags & G_NOARGS))
1334 myop.op_flags |= OPf_STACKED;
1335 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1336 (flags & G_ARRAY) ? OPf_WANT_LIST :
1341 EXTEND(PL_stack_sp, 1);
1342 *++PL_stack_sp = sv;
1344 oldscope = PL_scopestack_ix;
1346 if (PERLDB_SUB && PL_curstash != PL_debstash
1347 /* Handle first BEGIN of -d. */
1348 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1349 /* Try harder, since this may have been a sighandler, thus
1350 * curstash may be meaningless. */
1351 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1352 && !(flags & G_NODEBUG))
1353 PL_op->op_private |= OPpENTERSUB_DB;
1355 if (!(flags & G_EVAL)) {
1357 call_xbody((OP*)&myop, FALSE);
1358 retval = PL_stack_sp - (PL_stack_base + oldmark);
1359 CATCH_SET(oldcatch);
1362 cLOGOP->op_other = PL_op;
1364 /* we're trying to emulate pp_entertry() here */
1366 register PERL_CONTEXT *cx;
1367 I32 gimme = GIMME_V;
1372 push_return(PL_op->op_next);
1373 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1375 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1377 PL_in_eval = EVAL_INEVAL;
1378 if (flags & G_KEEPERR)
1379 PL_in_eval |= EVAL_KEEPERR;
1386 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1390 retval = PL_stack_sp - (PL_stack_base + oldmark);
1391 if (!(flags & G_KEEPERR))
1398 /* my_exit() was called */
1399 PL_curstash = PL_defstash;
1402 Perl_croak(aTHX_ "Callback called exit");
1407 PL_op = PL_restartop;
1411 PL_stack_sp = PL_stack_base + oldmark;
1412 if (flags & G_ARRAY)
1416 *++PL_stack_sp = &PL_sv_undef;
1421 if (PL_scopestack_ix > oldscope) {
1425 register PERL_CONTEXT *cx;
1436 if (flags & G_DISCARD) {
1437 PL_stack_sp = PL_stack_base + oldmark;
1447 S_call_body(pTHX_ va_list args)
1449 OP *myop = va_arg(args, OP*);
1450 int is_eval = va_arg(args, int);
1452 call_xbody(myop, is_eval);
1457 S_call_xbody(pTHX_ OP *myop, int is_eval)
1461 if (PL_op == myop) {
1463 PL_op = Perl_pp_entereval(aTHX);
1465 PL_op = Perl_pp_entersub(aTHX);
1471 /* Eval a string. The G_EVAL flag is always assumed. */
1474 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1476 /* See G_* flags in cop.h */
1479 UNOP myop; /* fake syntax tree node */
1480 I32 oldmark = SP - PL_stack_base;
1487 if (flags & G_DISCARD) {
1494 Zero(PL_op, 1, UNOP);
1495 EXTEND(PL_stack_sp, 1);
1496 *++PL_stack_sp = sv;
1497 oldscope = PL_scopestack_ix;
1499 if (!(flags & G_NOARGS))
1500 myop.op_flags = OPf_STACKED;
1501 myop.op_next = Nullop;
1502 myop.op_type = OP_ENTEREVAL;
1503 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1504 (flags & G_ARRAY) ? OPf_WANT_LIST :
1506 if (flags & G_KEEPERR)
1507 myop.op_flags |= OPf_SPECIAL;
1510 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1514 retval = PL_stack_sp - (PL_stack_base + oldmark);
1515 if (!(flags & G_KEEPERR))
1522 /* my_exit() was called */
1523 PL_curstash = PL_defstash;
1526 Perl_croak(aTHX_ "Callback called exit");
1531 PL_op = PL_restartop;
1535 PL_stack_sp = PL_stack_base + oldmark;
1536 if (flags & G_ARRAY)
1540 *++PL_stack_sp = &PL_sv_undef;
1545 if (flags & G_DISCARD) {
1546 PL_stack_sp = PL_stack_base + oldmark;
1556 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1559 SV* sv = newSVpv(p, 0);
1562 eval_sv(sv, G_SCALAR);
1569 if (croak_on_error && SvTRUE(ERRSV)) {
1571 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1577 /* Require a module. */
1580 Perl_require_pv(pTHX_ const char *pv)
1584 PUSHSTACKi(PERLSI_REQUIRE);
1586 sv = sv_newmortal();
1587 sv_setpv(sv, "require '");
1590 eval_sv(sv, G_DISCARD);
1596 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1600 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1601 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1605 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
1607 /* This message really ought to be max 23 lines.
1608 * Removed -h because the user already knows that opton. Others? */
1610 static char *usage_msg[] = {
1611 "-0[octal] specify record separator (\\0, if no argument)",
1612 "-a autosplit mode with -n or -p (splits $_ into @F)",
1613 "-c check syntax only (runs BEGIN and END blocks)",
1614 "-d[:debugger] run program under debugger",
1615 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1616 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1617 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1618 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1619 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1620 "-l[octal] enable line ending processing, specifies line terminator",
1621 "-[mM][-]module execute `use/no module...' before executing program",
1622 "-n assume 'while (<>) { ... }' loop around program",
1623 "-p assume loop like -n but print line also, like sed",
1624 "-P run program through C preprocessor before compilation",
1625 "-s enable rudimentary parsing for switches after programfile",
1626 "-S look for programfile using PATH environment variable",
1627 "-T enable tainting checks",
1628 "-u dump core after parsing program",
1629 "-U allow unsafe operations",
1630 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1631 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1632 "-w enable many useful warnings (RECOMMENDED)",
1633 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1637 char **p = usage_msg;
1639 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1641 printf("\n %s", *p++);
1644 /* This routine handles any switches that can be given during run */
1647 Perl_moreswitches(pTHX_ char *s)
1656 rschar = (U32)scan_oct(s, 4, &numlen);
1657 SvREFCNT_dec(PL_nrs);
1658 if (rschar & ~((U8)~0))
1659 PL_nrs = &PL_sv_undef;
1660 else if (!rschar && numlen >= 2)
1661 PL_nrs = newSVpvn("", 0);
1664 PL_nrs = newSVpvn(&ch, 1);
1670 PL_splitstr = savepv(s + 1);
1684 if (*s == ':' || *s == '=') {
1685 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1689 PL_perldb = PERLDB_ALL;
1697 if (isALPHA(s[1])) {
1698 static char debopts[] = "psltocPmfrxuLHXDS";
1701 for (s++; *s && (d = strchr(debopts,*s)); s++)
1702 PL_debug |= 1 << (d - debopts);
1705 PL_debug = atoi(s+1);
1706 for (s++; isDIGIT(*s); s++) ;
1708 PL_debug |= 0x80000000;
1711 if (ckWARN_d(WARN_DEBUGGING))
1712 Perl_warner(aTHX_ WARN_DEBUGGING,
1713 "Recompile perl with -DDEBUGGING to use -D switch\n");
1714 for (s++; isALNUM(*s); s++) ;
1720 usage(PL_origargv[0]);
1724 Safefree(PL_inplace);
1725 PL_inplace = savepv(s+1);
1727 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1730 if (*s == '-') /* Additional switches on #! line. */
1734 case 'I': /* -I handled both here and in parse_perl() */
1737 while (*s && isSPACE(*s))
1741 for (e = s; *e && !isSPACE(*e); e++) ;
1742 p = savepvn(s, e-s);
1748 Perl_croak(aTHX_ "No space allowed after -I");
1756 PL_ors = savepv("\n");
1758 *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
1763 if (RsPARA(PL_nrs)) {
1768 PL_ors = SvPV(PL_nrs, PL_orslen);
1769 PL_ors = savepvn(PL_ors, PL_orslen);
1773 forbid_setid("-M"); /* XXX ? */
1776 forbid_setid("-m"); /* XXX ? */
1781 /* -M-foo == 'no foo' */
1782 if (*s == '-') { use = "no "; ++s; }
1783 sv = newSVpv(use,0);
1785 /* We allow -M'Module qw(Foo Bar)' */
1786 while(isALNUM(*s) || *s==':') ++s;
1788 sv_catpv(sv, start);
1789 if (*(start-1) == 'm') {
1791 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
1792 sv_catpv( sv, " ()");
1795 sv_catpvn(sv, start, s-start);
1796 sv_catpv(sv, " split(/,/,q{");
1802 PL_preambleav = newAV();
1803 av_push(PL_preambleav, sv);
1806 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1818 PL_doswitches = TRUE;
1823 Perl_croak(aTHX_ "Too late for \"-T\" option");
1827 PL_do_undump = TRUE;
1835 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
1836 printf("\nThis is perl, version %d.%03d_%02d built for %s",
1837 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME);
1839 printf("\nThis is perl, version %s built for %s",
1840 PL_patchlevel, ARCHNAME);
1842 #if defined(LOCAL_PATCH_COUNT)
1843 if (LOCAL_PATCH_COUNT > 0)
1844 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1845 (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1848 printf("\n\nCopyright 1987-1999, Larry Wall\n");
1850 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1853 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1854 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
1857 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1858 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
1861 printf("atariST series port, ++jrb bammi@cadence.com\n");
1864 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
1867 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1870 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
1873 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
1876 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
1879 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
1882 printf("MiNT port by Guido Flohr, 1997-1999\n");
1884 #ifdef BINARY_BUILD_NOTICE
1885 BINARY_BUILD_NOTICE;
1888 Perl may be copied only under the terms of either the Artistic License or the\n\
1889 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1890 Complete documentation for Perl, including FAQ lists, should be found on\n\
1891 this system using `man perl' or `perldoc perl'. If you have access to the\n\
1892 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1895 if (! (PL_dowarn & G_WARN_ALL_MASK))
1896 PL_dowarn |= G_WARN_ON;
1900 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1901 PL_compiling.cop_warnings = WARN_ALL ;
1905 PL_dowarn = G_WARN_ALL_OFF;
1906 PL_compiling.cop_warnings = WARN_NONE ;
1911 if (s[1] == '-') /* Additional switches on #! line. */
1916 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1922 #ifdef ALTERNATE_SHEBANG
1923 case 'S': /* OS/2 needs -S on "extproc" line. */
1931 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
1936 /* compliments of Tom Christiansen */
1938 /* unexec() can be found in the Gnu emacs distribution */
1939 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1942 Perl_my_unexec(pTHX)
1950 prog = newSVpv(BIN_EXP, 0);
1951 sv_catpv(prog, "/perl");
1952 file = newSVpv(PL_origfilename, 0);
1953 sv_catpv(file, ".perldump");
1955 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1956 /* unexec prints msg to stderr in case of failure */
1957 PerlProc_exit(status);
1960 # include <lib$routines.h>
1961 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1963 ABORT(); /* for use with undump */
1968 /* initialize curinterp */
1973 #ifdef PERL_OBJECT /* XXX kludge */
1976 PL_chopset = " \n-"; \
1977 PL_copline = NOLINE; \
1978 PL_curcop = &PL_compiling;\
1979 PL_curcopdb = NULL; \
1981 PL_dumpindent = 4; \
1982 PL_laststatval = -1; \
1983 PL_laststype = OP_STAT; \
1984 PL_maxscream = -1; \
1985 PL_maxsysfd = MAXSYSFD; \
1986 PL_statname = Nullsv; \
1987 PL_tmps_floor = -1; \
1989 PL_op_mask = NULL; \
1990 PL_laststatval = -1; \
1991 PL_laststype = OP_STAT; \
1992 PL_mess_sv = Nullsv; \
1993 PL_splitstr = " "; \
1994 PL_generation = 100; \
1995 PL_exitlist = NULL; \
1996 PL_exitlistlen = 0; \
1998 PL_in_clean_objs = FALSE; \
1999 PL_in_clean_all = FALSE; \
2000 PL_profiledata = NULL; \
2002 PL_rsfp_filters = Nullav; \
2007 # ifdef MULTIPLICITY
2008 # define PERLVAR(var,type)
2009 # define PERLVARA(var,n,type)
2010 # if defined(PERL_IMPLICIT_CONTEXT)
2011 # if defined(USE_THREADS)
2012 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2013 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2014 # else /* !USE_THREADS */
2015 # define PERLVARI(var,type,init) aTHX->var = init;
2016 # define PERLVARIC(var,type,init) aTHX->var = init;
2017 # endif /* USE_THREADS */
2019 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2020 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2022 # include "intrpvar.h"
2023 # ifndef USE_THREADS
2024 # include "thrdvar.h"
2031 # define PERLVAR(var,type)
2032 # define PERLVARA(var,n,type)
2033 # define PERLVARI(var,type,init) PL_##var = init;
2034 # define PERLVARIC(var,type,init) PL_##var = init;
2035 # include "intrpvar.h"
2036 # ifndef USE_THREADS
2037 # include "thrdvar.h"
2049 S_init_main_stash(pTHX)
2054 /* Note that strtab is a rather special HV. Assumptions are made
2055 about not iterating on it, and not adding tie magic to it.
2056 It is properly deallocated in perl_destruct() */
2057 PL_strtab = newHV();
2059 MUTEX_INIT(&PL_strtab_mutex);
2061 HvSHAREKEYS_off(PL_strtab); /* mandatory */
2062 hv_ksplit(PL_strtab, 512);
2064 PL_curstash = PL_defstash = newHV();
2065 PL_curstname = newSVpvn("main",4);
2066 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2067 SvREFCNT_dec(GvHV(gv));
2068 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2070 HvNAME(PL_defstash) = savepv("main");
2071 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2072 GvMULTI_on(PL_incgv);
2073 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2074 GvMULTI_on(PL_hintgv);
2075 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2076 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2077 GvMULTI_on(PL_errgv);
2078 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2079 GvMULTI_on(PL_replgv);
2080 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
2081 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2082 sv_setpvn(ERRSV, "", 0);
2083 PL_curstash = PL_defstash;
2084 PL_compiling.cop_stash = PL_defstash;
2085 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2086 /* We must init $/ before switches are processed. */
2087 sv_setpvn(get_sv("/", TRUE), "\n", 1);
2091 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2099 PL_origfilename = savepv("-e");
2102 /* if find_script() returns, it returns a malloc()-ed value */
2103 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2105 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2106 char *s = scriptname + 8;
2107 *fdscript = atoi(s);
2111 scriptname = savepv(s + 1);
2112 Safefree(PL_origfilename);
2113 PL_origfilename = scriptname;
2118 CopFILEGV_set(PL_curcop, gv_fetchfile(PL_origfilename));
2119 if (strEQ(PL_origfilename,"-"))
2121 if (*fdscript >= 0) {
2122 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2123 #if defined(HAS_FCNTL) && defined(F_SETFD)
2125 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2128 else if (PL_preprocess) {
2129 char *cpp_cfg = CPPSTDIN;
2130 SV *cpp = newSVpvn("",0);
2131 SV *cmd = NEWSV(0,0);
2133 if (strEQ(cpp_cfg, "cppstdin"))
2134 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2135 sv_catpv(cpp, cpp_cfg);
2138 sv_catpv(sv,PRIVLIB_EXP);
2141 Perl_sv_setpvf(aTHX_ cmd, "\
2142 sed %s -e \"/^[^#]/b\" \
2143 -e \"/^#[ ]*include[ ]/b\" \
2144 -e \"/^#[ ]*define[ ]/b\" \
2145 -e \"/^#[ ]*if[ ]/b\" \
2146 -e \"/^#[ ]*ifdef[ ]/b\" \
2147 -e \"/^#[ ]*ifndef[ ]/b\" \
2148 -e \"/^#[ ]*else/b\" \
2149 -e \"/^#[ ]*elif[ ]/b\" \
2150 -e \"/^#[ ]*undef[ ]/b\" \
2151 -e \"/^#[ ]*endif/b\" \
2154 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2157 Perl_sv_setpvf(aTHX_ cmd, "\
2158 %s %s -e '/^[^#]/b' \
2159 -e '/^#[ ]*include[ ]/b' \
2160 -e '/^#[ ]*define[ ]/b' \
2161 -e '/^#[ ]*if[ ]/b' \
2162 -e '/^#[ ]*ifdef[ ]/b' \
2163 -e '/^#[ ]*ifndef[ ]/b' \
2164 -e '/^#[ ]*else/b' \
2165 -e '/^#[ ]*elif[ ]/b' \
2166 -e '/^#[ ]*undef[ ]/b' \
2167 -e '/^#[ ]*endif/b' \
2171 Perl_sv_setpvf(aTHX_ cmd, "\
2172 %s %s -e '/^[^#]/b' \
2173 -e '/^#[ ]*include[ ]/b' \
2174 -e '/^#[ ]*define[ ]/b' \
2175 -e '/^#[ ]*if[ ]/b' \
2176 -e '/^#[ ]*ifdef[ ]/b' \
2177 -e '/^#[ ]*ifndef[ ]/b' \
2178 -e '/^#[ ]*else/b' \
2179 -e '/^#[ ]*elif[ ]/b' \
2180 -e '/^#[ ]*undef[ ]/b' \
2181 -e '/^#[ ]*endif/b' \
2190 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2192 scriptname, cpp, sv, CPPMINUS);
2193 PL_doextract = FALSE;
2194 #ifdef IAMSUID /* actually, this is caught earlier */
2195 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2197 (void)seteuid(PL_uid); /* musn't stay setuid root */
2200 (void)setreuid((Uid_t)-1, PL_uid);
2202 #ifdef HAS_SETRESUID
2203 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2205 PerlProc_setuid(PL_uid);
2209 if (PerlProc_geteuid() != PL_uid)
2210 Perl_croak(aTHX_ "Can't do seteuid!\n");
2212 #endif /* IAMSUID */
2213 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2217 else if (!*scriptname) {
2218 forbid_setid("program input from stdin");
2219 PL_rsfp = PerlIO_stdin();
2222 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2223 #if defined(HAS_FCNTL) && defined(F_SETFD)
2225 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2230 #ifndef IAMSUID /* in case script is not readable before setuid */
2232 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2233 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2236 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2237 Perl_croak(aTHX_ "Can't do setuid\n");
2241 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2242 CopFILE(PL_curcop), Strerror(errno));
2247 * I_SYSSTATVFS HAS_FSTATVFS
2249 * I_STATFS HAS_FSTATFS
2250 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2251 * here so that metaconfig picks them up. */
2255 S_fd_on_nosuid_fs(pTHX_ int fd)
2257 int check_okay = 0; /* able to do all the required sys/libcalls */
2258 int on_nosuid = 0; /* the fd is on a nosuid fs */
2260 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2261 * fstatvfs() is UNIX98.
2262 * fstatfs() is 4.3 BSD.
2263 * ustat()+getmnt() is pre-4.3 BSD.
2264 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2265 * an irrelevant filesystem while trying to reach the right one.
2268 # ifdef HAS_FSTATVFS
2269 struct statvfs stfs;
2270 check_okay = fstatvfs(fd, &stfs) == 0;
2271 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2273 # ifdef PERL_MOUNT_NOSUID
2274 # if defined(HAS_FSTATFS) && \
2275 defined(HAS_STRUCT_STATFS) && \
2276 defined(HAS_STRUCT_STATFS_F_FLAGS)
2278 check_okay = fstatfs(fd, &stfs) == 0;
2279 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2281 # if defined(HAS_FSTAT) && \
2282 defined(HAS_USTAT) && \
2283 defined(HAS_GETMNT) && \
2284 defined(HAS_STRUCT_FS_DATA) &&
2287 if (fstat(fd, &fdst) == 0) {
2289 if (ustat(fdst.st_dev, &us) == 0) {
2291 /* NOSTAT_ONE here because we're not examining fields which
2292 * vary between that case and STAT_ONE. */
2293 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2294 size_t cmplen = sizeof(us.f_fname);
2295 if (sizeof(fsd.fd_req.path) < cmplen)
2296 cmplen = sizeof(fsd.fd_req.path);
2297 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2298 fdst.st_dev == fsd.fd_req.dev) {
2300 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2306 # endif /* fstat+ustat+getmnt */
2307 # endif /* fstatfs */
2309 # if defined(HAS_GETMNTENT) && \
2310 defined(HAS_HASMNTOPT) && \
2311 defined(MNTOPT_NOSUID)
2312 FILE *mtab = fopen("/etc/mtab", "r");
2313 struct mntent *entry;
2314 struct stat stb, fsb;
2316 if (mtab && (fstat(fd, &stb) == 0)) {
2317 while (entry = getmntent(mtab)) {
2318 if (stat(entry->mnt_dir, &fsb) == 0
2319 && fsb.st_dev == stb.st_dev)
2321 /* found the filesystem */
2323 if (hasmntopt(entry, MNTOPT_NOSUID))
2326 } /* A single fs may well fail its stat(). */
2331 # endif /* getmntent+hasmntopt */
2332 # endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */
2333 # endif /* statvfs */
2336 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
2339 #endif /* IAMSUID */
2342 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2346 /* do we need to emulate setuid on scripts? */
2348 /* This code is for those BSD systems that have setuid #! scripts disabled
2349 * in the kernel because of a security problem. Merely defining DOSUID
2350 * in perl will not fix that problem, but if you have disabled setuid
2351 * scripts in the kernel, this will attempt to emulate setuid and setgid
2352 * on scripts that have those now-otherwise-useless bits set. The setuid
2353 * root version must be called suidperl or sperlN.NNN. If regular perl
2354 * discovers that it has opened a setuid script, it calls suidperl with
2355 * the same argv that it had. If suidperl finds that the script it has
2356 * just opened is NOT setuid root, it sets the effective uid back to the
2357 * uid. We don't just make perl setuid root because that loses the
2358 * effective uid we had before invoking perl, if it was different from the
2361 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2362 * be defined in suidperl only. suidperl must be setuid root. The
2363 * Configure script will set this up for you if you want it.
2370 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2371 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2372 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2377 #ifndef HAS_SETREUID
2378 /* On this access check to make sure the directories are readable,
2379 * there is actually a small window that the user could use to make
2380 * filename point to an accessible directory. So there is a faint
2381 * chance that someone could execute a setuid script down in a
2382 * non-accessible directory. I don't know what to do about that.
2383 * But I don't think it's too important. The manual lies when
2384 * it says access() is useful in setuid programs.
2386 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
2387 Perl_croak(aTHX_ "Permission denied");
2389 /* If we can swap euid and uid, then we can determine access rights
2390 * with a simple stat of the file, and then compare device and
2391 * inode to make sure we did stat() on the same file we opened.
2392 * Then we just have to make sure he or she can execute it.
2395 struct stat tmpstatbuf;
2399 setreuid(PL_euid,PL_uid) < 0
2402 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2405 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2406 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2407 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
2408 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2409 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2410 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2411 Perl_croak(aTHX_ "Permission denied");
2413 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2414 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2415 (void)PerlIO_close(PL_rsfp);
2416 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2417 PerlIO_printf(PL_rsfp,
2418 "User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2419 (Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n",
2420 PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2421 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2423 PL_statbuf.st_uid, PL_statbuf.st_gid);
2424 (void)PerlProc_pclose(PL_rsfp);
2426 Perl_croak(aTHX_ "Permission denied\n");
2430 setreuid(PL_uid,PL_euid) < 0
2432 # if defined(HAS_SETRESUID)
2433 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2436 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2437 Perl_croak(aTHX_ "Can't reswap uid and euid");
2438 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2439 Perl_croak(aTHX_ "Permission denied\n");
2441 #endif /* HAS_SETREUID */
2442 #endif /* IAMSUID */
2444 if (!S_ISREG(PL_statbuf.st_mode))
2445 Perl_croak(aTHX_ "Permission denied");
2446 if (PL_statbuf.st_mode & S_IWOTH)
2447 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2448 PL_doswitches = FALSE; /* -s is insecure in suid */
2449 PL_curcop->cop_line++;
2450 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2451 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2452 Perl_croak(aTHX_ "No #! line");
2453 s = SvPV(PL_linestr,n_a)+2;
2455 while (!isSPACE(*s)) s++;
2456 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2457 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2458 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2459 Perl_croak(aTHX_ "Not a perl script");
2460 while (*s == ' ' || *s == '\t') s++;
2462 * #! arg must be what we saw above. They can invoke it by
2463 * mentioning suidperl explicitly, but they may not add any strange
2464 * arguments beyond what #! says if they do invoke suidperl that way.
2466 len = strlen(validarg);
2467 if (strEQ(validarg," PHOOEY ") ||
2468 strnNE(s,validarg,len) || !isSPACE(s[len]))
2469 Perl_croak(aTHX_ "Args must match #! line");
2472 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2473 PL_euid == PL_statbuf.st_uid)
2475 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2476 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2477 #endif /* IAMSUID */
2479 if (PL_euid) { /* oops, we're not the setuid root perl */
2480 (void)PerlIO_close(PL_rsfp);
2483 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2485 Perl_croak(aTHX_ "Can't do setuid\n");
2488 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2490 (void)setegid(PL_statbuf.st_gid);
2493 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2495 #ifdef HAS_SETRESGID
2496 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2498 PerlProc_setgid(PL_statbuf.st_gid);
2502 if (PerlProc_getegid() != PL_statbuf.st_gid)
2503 Perl_croak(aTHX_ "Can't do setegid!\n");
2505 if (PL_statbuf.st_mode & S_ISUID) {
2506 if (PL_statbuf.st_uid != PL_euid)
2508 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2511 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2513 #ifdef HAS_SETRESUID
2514 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2516 PerlProc_setuid(PL_statbuf.st_uid);
2520 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2521 Perl_croak(aTHX_ "Can't do seteuid!\n");
2523 else if (PL_uid) { /* oops, mustn't run as root */
2525 (void)seteuid((Uid_t)PL_uid);
2528 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2530 #ifdef HAS_SETRESUID
2531 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2533 PerlProc_setuid((Uid_t)PL_uid);
2537 if (PerlProc_geteuid() != PL_uid)
2538 Perl_croak(aTHX_ "Can't do seteuid!\n");
2541 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2542 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
2545 else if (PL_preprocess)
2546 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2547 else if (fdscript >= 0)
2548 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2550 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2552 /* We absolutely must clear out any saved ids here, so we */
2553 /* exec the real perl, substituting fd script for scriptname. */
2554 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2555 PerlIO_rewind(PL_rsfp);
2556 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2557 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2558 if (!PL_origargv[which])
2559 Perl_croak(aTHX_ "Permission denied");
2560 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2561 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2562 #if defined(HAS_FCNTL) && defined(F_SETFD)
2563 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2565 PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
2566 Perl_croak(aTHX_ "Can't do setuid\n");
2567 #endif /* IAMSUID */
2569 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2570 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2572 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2573 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2575 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2578 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2579 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2580 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2581 /* not set-id, must be wrapped */
2587 S_find_beginning(pTHX)
2589 register char *s, *s2;
2591 /* skip forward in input to the real script? */
2594 while (PL_doextract) {
2595 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2596 Perl_croak(aTHX_ "No Perl script found in input\n");
2597 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2598 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2599 PL_doextract = FALSE;
2600 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2602 while (*s == ' ' || *s == '\t') s++;
2604 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2605 if (strnEQ(s2-4,"perl",4))
2607 while (s = moreswitches(s)) ;
2617 PL_uid = PerlProc_getuid();
2618 PL_euid = PerlProc_geteuid();
2619 PL_gid = PerlProc_getgid();
2620 PL_egid = PerlProc_getegid();
2622 PL_uid |= PL_gid << 16;
2623 PL_euid |= PL_egid << 16;
2625 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2629 S_forbid_setid(pTHX_ char *s)
2631 if (PL_euid != PL_uid)
2632 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2633 if (PL_egid != PL_gid)
2634 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2638 Perl_init_debugger(pTHX)
2641 HV *ostash = PL_curstash;
2643 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2644 PL_curstash = PL_debstash;
2645 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2646 AvREAL_off(PL_dbargs);
2647 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2648 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2649 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2650 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
2651 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2652 sv_setiv(PL_DBsingle, 0);
2653 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2654 sv_setiv(PL_DBtrace, 0);
2655 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2656 sv_setiv(PL_DBsignal, 0);
2657 PL_curstash = ostash;
2660 #ifndef STRESS_REALLOC
2661 #define REASONABLE(size) (size)
2663 #define REASONABLE(size) (1) /* unreasonable */
2667 Perl_init_stacks(pTHX)
2669 /* start with 128-item stack and 8K cxstack */
2670 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2671 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2672 PL_curstackinfo->si_type = PERLSI_MAIN;
2673 PL_curstack = PL_curstackinfo->si_stack;
2674 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2676 PL_stack_base = AvARRAY(PL_curstack);
2677 PL_stack_sp = PL_stack_base;
2678 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2680 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2683 PL_tmps_max = REASONABLE(128);
2685 New(54,PL_markstack,REASONABLE(32),I32);
2686 PL_markstack_ptr = PL_markstack;
2687 PL_markstack_max = PL_markstack + REASONABLE(32);
2691 New(54,PL_scopestack,REASONABLE(32),I32);
2692 PL_scopestack_ix = 0;
2693 PL_scopestack_max = REASONABLE(32);
2695 New(54,PL_savestack,REASONABLE(128),ANY);
2696 PL_savestack_ix = 0;
2697 PL_savestack_max = REASONABLE(128);
2699 New(54,PL_retstack,REASONABLE(16),OP*);
2701 PL_retstack_max = REASONABLE(16);
2710 while (PL_curstackinfo->si_next)
2711 PL_curstackinfo = PL_curstackinfo->si_next;
2712 while (PL_curstackinfo) {
2713 PERL_SI *p = PL_curstackinfo->si_prev;
2714 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2715 Safefree(PL_curstackinfo->si_cxstack);
2716 Safefree(PL_curstackinfo);
2717 PL_curstackinfo = p;
2719 Safefree(PL_tmps_stack);
2720 Safefree(PL_markstack);
2721 Safefree(PL_scopestack);
2722 Safefree(PL_savestack);
2723 Safefree(PL_retstack);
2727 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2738 lex_start(PL_linestr);
2740 PL_subname = newSVpvn("main",4);
2744 S_init_predump_symbols(pTHX)
2751 sv_setpvn(get_sv("\"", TRUE), " ", 1);
2752 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2753 GvMULTI_on(PL_stdingv);
2754 io = GvIOp(PL_stdingv);
2755 IoIFP(io) = PerlIO_stdin();
2756 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2758 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2760 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2763 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
2765 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2767 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2769 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2770 GvMULTI_on(PL_stderrgv);
2771 io = GvIOp(PL_stderrgv);
2772 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
2773 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2775 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2777 PL_statname = NEWSV(66,0); /* last filename we did stat on */
2780 PL_osname = savepv(OSNAME);
2784 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
2791 argc--,argv++; /* skip name of script */
2792 if (PL_doswitches) {
2793 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2796 if (argv[0][1] == '-') {
2800 if (s = strchr(argv[0], '=')) {
2802 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2805 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2808 PL_toptarget = NEWSV(0,0);
2809 sv_upgrade(PL_toptarget, SVt_PVFM);
2810 sv_setpvn(PL_toptarget, "", 0);
2811 PL_bodytarget = NEWSV(0,0);
2812 sv_upgrade(PL_bodytarget, SVt_PVFM);
2813 sv_setpvn(PL_bodytarget, "", 0);
2814 PL_formtarget = PL_bodytarget;
2817 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2818 sv_setpv(GvSV(tmpgv),PL_origfilename);
2819 magicname("0", "0", 1);
2821 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2823 sv_setpv(GvSV(tmpgv), os2_execname());
2825 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2827 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2828 GvMULTI_on(PL_argvgv);
2829 (void)gv_AVadd(PL_argvgv);
2830 av_clear(GvAVn(PL_argvgv));
2831 for (; argc > 0; argc--,argv++) {
2832 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2835 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2837 GvMULTI_on(PL_envgv);
2838 hv = GvHVn(PL_envgv);
2839 hv_magic(hv, PL_envgv, 'E');
2840 #if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
2841 /* Note that if the supplied env parameter is actually a copy
2842 of the global environ then it may now point to free'd memory
2843 if the environment has been modified since. To avoid this
2844 problem we treat env==NULL as meaning 'use the default'
2849 environ[0] = Nullch;
2850 for (; *env; env++) {
2851 if (!(s = strchr(*env,'=')))
2857 sv = newSVpv(s--,0);
2858 (void)hv_store(hv, *env, s - *env, sv, 0);
2860 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2861 /* Sins of the RTL. See note in my_setenv(). */
2862 (void)PerlEnv_putenv(savepv(*env));
2866 #ifdef DYNAMIC_ENV_FETCH
2867 HvNAME(hv) = savepv(ENV_HV_NAME);
2871 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2872 sv_setiv(GvSV(tmpgv), (IV)getpid());
2876 S_init_perllib(pTHX)
2881 s = PerlEnv_getenv("PERL5LIB");
2885 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2887 /* Treat PERL5?LIB as a possible search list logical name -- the
2888 * "natural" VMS idiom for a Unix path string. We allow each
2889 * element to be a set of |-separated directories for compatibility.
2893 if (my_trnlnm("PERL5LIB",buf,0))
2894 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2896 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2900 /* Use the ~-expanded versions of APPLLIB (undocumented),
2901 ARCHLIB PRIVLIB SITEARCH and SITELIB
2904 incpush(APPLLIB_EXP, TRUE);
2908 incpush(ARCHLIB_EXP, FALSE);
2911 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2914 incpush(PRIVLIB_EXP, TRUE);
2916 incpush(PRIVLIB_EXP, FALSE);
2920 incpush(SITEARCH_EXP, FALSE);
2924 incpush(SITELIB_EXP, TRUE);
2926 incpush(SITELIB_EXP, FALSE);
2929 #if defined(PERL_VENDORLIB_EXP)
2931 incpush(PERL_VENDORLIB_EXP, TRUE);
2933 incpush(PERL_VENDORLIB_EXP, FALSE);
2937 incpush(".", FALSE);
2941 # define PERLLIB_SEP ';'
2944 # define PERLLIB_SEP '|'
2946 # define PERLLIB_SEP ':'
2949 #ifndef PERLLIB_MANGLE
2950 # define PERLLIB_MANGLE(s,n) (s)
2954 S_incpush(pTHX_ char *p, int addsubdirs)
2956 SV *subdir = Nullsv;
2962 subdir = sv_newmortal();
2963 if (!PL_archpat_auto) {
2964 STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
2965 + sizeof("//auto"));
2966 New(55, PL_archpat_auto, len, char);
2967 sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
2969 for (len = sizeof(ARCHNAME) + 2;
2970 PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2971 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
2976 /* Break at all separators */
2978 SV *libdir = NEWSV(55,0);
2981 /* skip any consecutive separators */
2982 while ( *p == PERLLIB_SEP ) {
2983 /* Uncomment the next line for PATH semantics */
2984 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
2988 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2989 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2994 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2995 p = Nullch; /* break out */
2999 * BEFORE pushing libdir onto @INC we may first push version- and
3000 * archname-specific sub-directories.
3003 struct stat tmpstatbuf;
3008 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3010 while (unix[len-1] == '/') len--; /* Cosmetic */
3011 sv_usepvn(libdir,unix,len);
3014 PerlIO_printf(Perl_error_log,
3015 "Failed to unixify @INC element \"%s\"\n",
3018 /* .../archname/version if -d .../archname/version/auto */
3019 sv_setsv(subdir, libdir);
3020 sv_catpv(subdir, PL_archpat_auto);
3021 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3022 S_ISDIR(tmpstatbuf.st_mode))
3023 av_push(GvAVn(PL_incgv),
3024 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
3026 /* .../archname if -d .../archname/auto */
3027 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
3028 strlen(PL_patchlevel) + 1, "", 0);
3029 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3030 S_ISDIR(tmpstatbuf.st_mode))
3031 av_push(GvAVn(PL_incgv),
3032 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
3035 /* finally push this lib directory on the end of @INC */
3036 av_push(GvAVn(PL_incgv), libdir);
3041 STATIC struct perl_thread *
3042 S_init_main_thread(pTHX)
3044 #if !defined(PERL_IMPLICIT_CONTEXT)
3045 struct perl_thread *thr;
3049 Newz(53, thr, 1, struct perl_thread);
3050 PL_curcop = &PL_compiling;
3051 thr->interp = PERL_GET_INTERP;
3052 thr->cvcache = newHV();
3053 thr->threadsv = newAV();
3054 /* thr->threadsvp is set when find_threadsv is called */
3055 thr->specific = newAV();
3056 thr->flags = THRf_R_JOINABLE;
3057 MUTEX_INIT(&thr->mutex);
3058 /* Handcraft thrsv similarly to mess_sv */
3059 New(53, PL_thrsv, 1, SV);
3060 Newz(53, xpv, 1, XPV);
3061 SvFLAGS(PL_thrsv) = SVt_PV;
3062 SvANY(PL_thrsv) = (void*)xpv;
3063 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3064 SvPVX(PL_thrsv) = (char*)thr;
3065 SvCUR_set(PL_thrsv, sizeof(thr));
3066 SvLEN_set(PL_thrsv, sizeof(thr));
3067 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3068 thr->oursv = PL_thrsv;
3069 PL_chopset = " \n-";
3072 MUTEX_LOCK(&PL_threads_mutex);
3077 MUTEX_UNLOCK(&PL_threads_mutex);
3079 #ifdef HAVE_THREAD_INTERN
3080 Perl_init_thread_intern(thr);
3083 #ifdef SET_THREAD_SELF
3084 SET_THREAD_SELF(thr);
3086 thr->self = pthread_self();
3087 #endif /* SET_THREAD_SELF */
3091 * These must come after the SET_THR because sv_setpvn does
3092 * SvTAINT and the taint fields require dTHR.
3094 PL_toptarget = NEWSV(0,0);
3095 sv_upgrade(PL_toptarget, SVt_PVFM);
3096 sv_setpvn(PL_toptarget, "", 0);
3097 PL_bodytarget = NEWSV(0,0);
3098 sv_upgrade(PL_bodytarget, SVt_PVFM);
3099 sv_setpvn(PL_bodytarget, "", 0);
3100 PL_formtarget = PL_bodytarget;
3101 thr->errsv = newSVpvn("", 0);
3102 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
3105 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3106 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3107 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3108 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3109 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3111 PL_reginterp_cnt = 0;
3115 #endif /* USE_THREADS */
3118 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3122 line_t oldline = PL_curcop->cop_line;
3128 while (AvFILL(paramList) >= 0) {
3129 cv = (CV*)av_shift(paramList);
3131 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
3134 (void)SvPV(atsv, len);
3136 PL_curcop = &PL_compiling;
3137 PL_curcop->cop_line = oldline;
3138 if (paramList == PL_beginav)
3139 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3141 Perl_sv_catpvf(aTHX_ atsv,
3142 "%s failed--call queue aborted",
3143 paramList == PL_stopav ? "STOP"
3144 : paramList == PL_initav ? "INIT"
3146 while (PL_scopestack_ix > oldscope)
3148 Perl_croak(aTHX_ "%s", SvPVX(atsv));
3155 /* my_exit() was called */
3156 while (PL_scopestack_ix > oldscope)
3159 PL_curstash = PL_defstash;
3160 PL_curcop = &PL_compiling;
3161 PL_curcop->cop_line = oldline;
3162 if (PL_statusvalue) {
3163 if (paramList == PL_beginav)
3164 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3166 Perl_croak(aTHX_ "%s failed--call queue aborted",
3167 paramList == PL_stopav ? "STOP"
3168 : paramList == PL_initav ? "INIT"
3175 PL_curcop = &PL_compiling;
3176 PL_curcop->cop_line = oldline;
3179 PerlIO_printf(Perl_error_log, "panic: restartop\n");
3187 S_call_list_body(pTHX_ va_list args)
3190 CV *cv = va_arg(args, CV*);
3192 PUSHMARK(PL_stack_sp);
3193 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3198 Perl_my_exit(pTHX_ U32 status)
3202 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3203 thr, (unsigned long) status));
3212 STATUS_NATIVE_SET(status);
3219 Perl_my_failure_exit(pTHX)
3222 if (vaxc$errno & 1) {
3223 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3224 STATUS_NATIVE_SET(44);
3227 if (!vaxc$errno && errno) /* unlikely */
3228 STATUS_NATIVE_SET(44);
3230 STATUS_NATIVE_SET(vaxc$errno);
3235 STATUS_POSIX_SET(errno);
3237 exitstatus = STATUS_POSIX >> 8;
3238 if (exitstatus & 255)
3239 STATUS_POSIX_SET(exitstatus);
3241 STATUS_POSIX_SET(255);
3248 S_my_exit_jump(pTHX)
3251 register PERL_CONTEXT *cx;
3256 SvREFCNT_dec(PL_e_script);
3257 PL_e_script = Nullsv;
3260 POPSTACK_TO(PL_mainstack);
3261 if (cxstack_ix >= 0) {
3264 POPBLOCK(cx,PL_curpm);
3276 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3279 p = SvPVX(PL_e_script);
3280 nl = strchr(p, '\n');
3281 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3283 filter_del(read_e_script);
3286 sv_catpvn(buf_sv, p, nl-p);
3287 sv_chop(PL_e_script, nl);