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 if (!specialWARN(PL_compiling.cop_warnings))
516 SvREFCNT_dec(PL_compiling.cop_warnings);
517 PL_compiling.cop_warnings = Nullsv;
519 /* Prepare to destruct main symbol table. */
524 SvREFCNT_dec(PL_curstname);
525 PL_curstname = Nullsv;
527 /* clear queued errors */
528 SvREFCNT_dec(PL_errors);
532 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
533 if (PL_scopestack_ix != 0)
534 Perl_warner(aTHX_ WARN_INTERNAL,
535 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
536 (long)PL_scopestack_ix);
537 if (PL_savestack_ix != 0)
538 Perl_warner(aTHX_ WARN_INTERNAL,
539 "Unbalanced saves: %ld more saves than restores\n",
540 (long)PL_savestack_ix);
541 if (PL_tmps_floor != -1)
542 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
543 (long)PL_tmps_floor + 1);
544 if (cxstack_ix != -1)
545 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
546 (long)cxstack_ix + 1);
549 /* Now absolutely destruct everything, somehow or other, loops or no. */
551 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
552 while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
553 last_sv_count = PL_sv_count;
556 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
557 SvFLAGS(PL_strtab) |= SVt_PVHV;
559 /* Destruct the global string table. */
561 /* Yell and reset the HeVAL() slots that are still holding refcounts,
562 * so that sv_free() won't fail on them.
570 max = HvMAX(PL_strtab);
571 array = HvARRAY(PL_strtab);
574 if (hent && ckWARN_d(WARN_INTERNAL)) {
575 Perl_warner(aTHX_ WARN_INTERNAL,
576 "Unbalanced string table refcount: (%d) for \"%s\"",
577 HeVAL(hent) - Nullsv, HeKEY(hent));
578 HeVAL(hent) = Nullsv;
588 SvREFCNT_dec(PL_strtab);
590 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
591 Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
595 /* No SVs have survived, need to clean out */
596 Safefree(PL_origfilename);
597 Safefree(PL_archpat_auto);
598 Safefree(PL_reg_start_tmp);
600 Safefree(PL_reg_curpm);
601 Safefree(PL_reg_poscache);
602 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
603 Safefree(PL_op_mask);
605 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
607 DEBUG_P(debprofdump());
609 MUTEX_DESTROY(&PL_strtab_mutex);
610 MUTEX_DESTROY(&PL_sv_mutex);
611 MUTEX_DESTROY(&PL_eval_mutex);
612 MUTEX_DESTROY(&PL_cred_mutex);
613 COND_DESTROY(&PL_eval_cond);
614 #ifdef EMULATE_ATOMIC_REFCOUNTS
615 MUTEX_DESTROY(&PL_svref_mutex);
616 #endif /* EMULATE_ATOMIC_REFCOUNTS */
618 /* As the penultimate thing, free the non-arena SV for thrsv */
619 Safefree(SvPVX(PL_thrsv));
620 Safefree(SvANY(PL_thrsv));
623 #endif /* USE_THREADS */
625 /* As the absolutely last thing, free the non-arena SV for mess() */
628 /* it could have accumulated taint magic */
629 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
632 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
633 moremagic = mg->mg_moremagic;
634 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
635 Safefree(mg->mg_ptr);
639 /* we know that type >= SVt_PV */
640 SvOOK_off(PL_mess_sv);
641 Safefree(SvPVX(PL_mess_sv));
642 Safefree(SvANY(PL_mess_sv));
643 Safefree(PL_mess_sv);
651 #if defined(PERL_OBJECT)
659 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
661 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
662 PL_exitlist[PL_exitlistlen].fn = fn;
663 PL_exitlist[PL_exitlistlen].ptr = ptr;
668 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
678 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
681 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
682 setuid perl scripts securely.\n");
686 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
687 _dyld_lookup_and_bind
688 ("__environ", (unsigned long *) &environ_pointer, NULL);
693 #ifndef VMS /* VMS doesn't have environ array */
694 PL_origenviron = environ;
699 /* Come here if running an undumped a.out. */
701 PL_origfilename = savepv(argv[0]);
702 PL_do_undump = FALSE;
703 cxstack_ix = -1; /* start label stack again */
705 init_postdump_symbols(argc,argv,env);
710 PL_curpad = AvARRAY(PL_comppad);
711 op_free(PL_main_root);
712 PL_main_root = Nullop;
714 PL_main_start = Nullop;
715 SvREFCNT_dec(PL_main_cv);
719 oldscope = PL_scopestack_ix;
720 PL_dowarn = G_WARN_OFF;
722 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_parse_body),
727 call_list(oldscope, PL_stopav);
733 /* my_exit() was called */
734 while (PL_scopestack_ix > oldscope)
737 PL_curstash = PL_defstash;
739 call_list(oldscope, PL_stopav);
740 return STATUS_NATIVE_EXPORT;
742 PerlIO_printf(Perl_error_log, "panic: top_env\n");
749 S_parse_body(pTHX_ va_list args)
752 int argc = PL_origargc;
753 char **argv = PL_origargv;
754 char **env = va_arg(args, char**);
755 char *scriptname = NULL;
757 VOL bool dosearch = FALSE;
762 char *cddir = Nullch;
764 XSINIT_t xsinit = va_arg(args, XSINIT_t);
766 sv_setpvn(PL_linestr,"",0);
767 sv = newSVpvn("",0); /* first used for -I flags */
771 for (argc--,argv++; argc > 0; argc--,argv++) {
772 if (argv[0][0] != '-' || !argv[0][1])
776 validarg = " PHOOEY ";
783 #ifndef PERL_STRICT_CR
807 if (s = moreswitches(s))
817 if (PL_euid != PL_uid || PL_egid != PL_gid)
818 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
820 PL_e_script = newSVpvn("",0);
821 filter_add(read_e_script, NULL);
824 sv_catpv(PL_e_script, s);
826 sv_catpv(PL_e_script, argv[1]);
830 Perl_croak(aTHX_ "No code specified for -e");
831 sv_catpv(PL_e_script, "\n");
834 case 'I': /* -I handled both here and in moreswitches() */
836 if (!*++s && (s=argv[1]) != Nullch) {
839 while (s && isSPACE(*s))
843 for (e = s; *e && !isSPACE(*e); e++) ;
850 } /* XXX else croak? */
854 PL_preprocess = TRUE;
864 PL_preambleav = newAV();
865 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
867 PL_Sv = newSVpv("print myconfig();",0);
869 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
871 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
873 sv_catpv(PL_Sv,"\" Compile-time options:");
875 sv_catpv(PL_Sv," DEBUGGING");
878 sv_catpv(PL_Sv," MULTIPLICITY");
881 sv_catpv(PL_Sv," USE_THREADS");
884 sv_catpv(PL_Sv," PERL_OBJECT");
886 # ifdef PERL_IMPLICIT_CONTEXT
887 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
889 # ifdef PERL_IMPLICIT_SYS
890 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
892 sv_catpv(PL_Sv,"\\n\",");
894 #if defined(LOCAL_PATCH_COUNT)
895 if (LOCAL_PATCH_COUNT > 0) {
897 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
898 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
899 if (PL_localpatches[i])
900 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
904 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
907 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
909 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
914 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
915 print \" \\%ENV:\\n @env\\n\" if @env; \
916 print \" \\@INC:\\n @INC\\n\";");
919 PL_Sv = newSVpv("config_vars(qw(",0);
920 sv_catpv(PL_Sv, ++s);
921 sv_catpv(PL_Sv, "))");
924 av_push(PL_preambleav, PL_Sv);
925 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
936 if (!*++s || isSPACE(*s)) {
940 /* catch use of gnu style long options */
941 if (strEQ(s, "version")) {
945 if (strEQ(s, "help")) {
952 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
958 #ifndef SECURE_INTERNAL_GETENV
961 (s = PerlEnv_getenv("PERL5OPT"))) {
964 if (*s == '-' && *(s+1) == 'T')
977 if (!strchr("DIMUdmw", *s))
978 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
985 scriptname = argv[0];
988 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
990 else if (scriptname == Nullch) {
992 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1000 open_script(scriptname,dosearch,sv,&fdscript);
1002 validate_suid(validarg, scriptname,fdscript);
1004 #if defined(SIGCHLD) || defined(SIGCLD)
1007 # define SIGCHLD SIGCLD
1009 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1010 if (sigstate == SIG_IGN) {
1011 if (ckWARN(WARN_SIGNAL))
1012 Perl_warner(aTHX_ WARN_SIGNAL,
1013 "Can't ignore signal CHLD, forcing to default");
1014 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1021 if (cddir && PerlDir_chdir(cddir) < 0)
1022 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1026 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1027 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1028 CvUNIQUE_on(PL_compcv);
1030 PL_comppad = newAV();
1031 av_push(PL_comppad, Nullsv);
1032 PL_curpad = AvARRAY(PL_comppad);
1033 PL_comppad_name = newAV();
1034 PL_comppad_name_fill = 0;
1035 PL_min_intro_pending = 0;
1038 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
1039 PL_curpad[0] = (SV*)newAV();
1040 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
1041 CvOWNER(PL_compcv) = 0;
1042 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1043 MUTEX_INIT(CvMUTEXP(PL_compcv));
1044 #endif /* USE_THREADS */
1046 comppadlist = newAV();
1047 AvREAL_off(comppadlist);
1048 av_store(comppadlist, 0, (SV*)PL_comppad_name);
1049 av_store(comppadlist, 1, (SV*)PL_comppad);
1050 CvPADLIST(PL_compcv) = comppadlist;
1052 boot_core_UNIVERSAL();
1053 boot_core_xsutils();
1056 (*xsinit)(aTHXo); /* in case linked C routines want magical variables */
1057 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
1065 init_predump_symbols();
1066 /* init_postdump_symbols not currently designed to be called */
1067 /* more than once (ENV isn't cleared first, for example) */
1068 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
1070 init_postdump_symbols(argc,argv,env);
1074 /* now parse the script */
1076 SETERRNO(0,SS$_NORMAL);
1078 if (yyparse() || PL_error_count) {
1080 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1082 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1086 CopLINE_set(PL_curcop, 0);
1087 PL_curstash = PL_defstash;
1088 PL_preprocess = FALSE;
1090 SvREFCNT_dec(PL_e_script);
1091 PL_e_script = Nullsv;
1094 /* now that script is parsed, we can modify record separator */
1095 SvREFCNT_dec(PL_rs);
1096 PL_rs = SvREFCNT_inc(PL_nrs);
1097 sv_setsv(get_sv("/", TRUE), PL_rs);
1102 SAVECOPFILE(PL_curcop);
1103 SAVECOPLINE(PL_curcop);
1104 gv_check(PL_defstash);
1111 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1112 dump_mstats("after compilation:");
1131 oldscope = PL_scopestack_ix;
1134 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
1137 cxstack_ix = -1; /* start context stack again */
1139 case 0: /* normal completion */
1140 case 2: /* my_exit() */
1141 while (PL_scopestack_ix > oldscope)
1144 PL_curstash = PL_defstash;
1145 if (PL_endav && !PL_minus_c)
1146 call_list(oldscope, PL_endav);
1148 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1149 dump_mstats("after execution: ");
1151 return STATUS_NATIVE_EXPORT;
1154 POPSTACK_TO(PL_mainstack);
1157 PerlIO_printf(Perl_error_log, "panic: restartop\n");
1167 S_run_body(pTHX_ va_list args)
1170 I32 oldscope = va_arg(args, I32);
1172 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1173 PL_sawampersand ? "Enabling" : "Omitting"));
1175 if (!PL_restartop) {
1176 DEBUG_x(dump_all());
1177 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1178 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1182 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1185 if (PERLDB_SINGLE && PL_DBsingle)
1186 sv_setiv(PL_DBsingle, 1);
1188 call_list(oldscope, PL_initav);
1194 PL_op = PL_restartop;
1198 else if (PL_main_start) {
1199 CvDEPTH(PL_main_cv) = 1;
1200 PL_op = PL_main_start;
1210 Perl_get_sv(pTHX_ const char *name, I32 create)
1214 if (name[1] == '\0' && !isALPHA(name[0])) {
1215 PADOFFSET tmp = find_threadsv(name);
1216 if (tmp != NOT_IN_PAD) {
1218 return THREADSV(tmp);
1221 #endif /* USE_THREADS */
1222 gv = gv_fetchpv(name, create, SVt_PV);
1229 Perl_get_av(pTHX_ const char *name, I32 create)
1231 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1240 Perl_get_hv(pTHX_ const char *name, I32 create)
1242 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1251 Perl_get_cv(pTHX_ const char *name, I32 create)
1253 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1254 /* XXX unsafe for threads if eval_owner isn't held */
1255 /* XXX this is probably not what they think they're getting.
1256 * It has the same effect as "sub name;", i.e. just a forward
1258 if (create && !GvCVu(gv))
1259 return newSUB(start_subparse(FALSE, 0),
1260 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1268 /* Be sure to refetch the stack pointer after calling these routines. */
1271 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1273 /* See G_* flags in cop.h */
1274 /* null terminated arg list */
1281 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1286 return call_pv(sub_name, flags);
1290 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1291 /* name of the subroutine */
1292 /* See G_* flags in cop.h */
1294 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1298 Perl_call_method(pTHX_ const char *methname, I32 flags)
1299 /* name of the subroutine */
1300 /* See G_* flags in cop.h */
1306 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1311 return call_sv(*PL_stack_sp--, flags);
1314 /* May be called with any of a CV, a GV, or an SV containing the name. */
1316 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1318 /* See G_* flags in cop.h */
1321 LOGOP myop; /* fake syntax tree node */
1325 bool oldcatch = CATCH_GET;
1330 if (flags & G_DISCARD) {
1335 Zero(&myop, 1, LOGOP);
1336 myop.op_next = Nullop;
1337 if (!(flags & G_NOARGS))
1338 myop.op_flags |= OPf_STACKED;
1339 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1340 (flags & G_ARRAY) ? OPf_WANT_LIST :
1345 EXTEND(PL_stack_sp, 1);
1346 *++PL_stack_sp = sv;
1348 oldscope = PL_scopestack_ix;
1350 if (PERLDB_SUB && PL_curstash != PL_debstash
1351 /* Handle first BEGIN of -d. */
1352 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1353 /* Try harder, since this may have been a sighandler, thus
1354 * curstash may be meaningless. */
1355 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1356 && !(flags & G_NODEBUG))
1357 PL_op->op_private |= OPpENTERSUB_DB;
1359 if (!(flags & G_EVAL)) {
1361 call_xbody((OP*)&myop, FALSE);
1362 retval = PL_stack_sp - (PL_stack_base + oldmark);
1363 CATCH_SET(oldcatch);
1366 cLOGOP->op_other = PL_op;
1368 /* we're trying to emulate pp_entertry() here */
1370 register PERL_CONTEXT *cx;
1371 I32 gimme = GIMME_V;
1376 push_return(PL_op->op_next);
1377 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1379 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1381 PL_in_eval = EVAL_INEVAL;
1382 if (flags & G_KEEPERR)
1383 PL_in_eval |= EVAL_KEEPERR;
1390 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1394 retval = PL_stack_sp - (PL_stack_base + oldmark);
1395 if (!(flags & G_KEEPERR))
1402 /* my_exit() was called */
1403 PL_curstash = PL_defstash;
1406 Perl_croak(aTHX_ "Callback called exit");
1411 PL_op = PL_restartop;
1415 PL_stack_sp = PL_stack_base + oldmark;
1416 if (flags & G_ARRAY)
1420 *++PL_stack_sp = &PL_sv_undef;
1425 if (PL_scopestack_ix > oldscope) {
1429 register PERL_CONTEXT *cx;
1440 if (flags & G_DISCARD) {
1441 PL_stack_sp = PL_stack_base + oldmark;
1451 S_call_body(pTHX_ va_list args)
1453 OP *myop = va_arg(args, OP*);
1454 int is_eval = va_arg(args, int);
1456 call_xbody(myop, is_eval);
1461 S_call_xbody(pTHX_ OP *myop, int is_eval)
1465 if (PL_op == myop) {
1467 PL_op = Perl_pp_entereval(aTHX);
1469 PL_op = Perl_pp_entersub(aTHX);
1475 /* Eval a string. The G_EVAL flag is always assumed. */
1478 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1480 /* See G_* flags in cop.h */
1483 UNOP myop; /* fake syntax tree node */
1484 I32 oldmark = SP - PL_stack_base;
1491 if (flags & G_DISCARD) {
1498 Zero(PL_op, 1, UNOP);
1499 EXTEND(PL_stack_sp, 1);
1500 *++PL_stack_sp = sv;
1501 oldscope = PL_scopestack_ix;
1503 if (!(flags & G_NOARGS))
1504 myop.op_flags = OPf_STACKED;
1505 myop.op_next = Nullop;
1506 myop.op_type = OP_ENTEREVAL;
1507 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1508 (flags & G_ARRAY) ? OPf_WANT_LIST :
1510 if (flags & G_KEEPERR)
1511 myop.op_flags |= OPf_SPECIAL;
1514 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1518 retval = PL_stack_sp - (PL_stack_base + oldmark);
1519 if (!(flags & G_KEEPERR))
1526 /* my_exit() was called */
1527 PL_curstash = PL_defstash;
1530 Perl_croak(aTHX_ "Callback called exit");
1535 PL_op = PL_restartop;
1539 PL_stack_sp = PL_stack_base + oldmark;
1540 if (flags & G_ARRAY)
1544 *++PL_stack_sp = &PL_sv_undef;
1549 if (flags & G_DISCARD) {
1550 PL_stack_sp = PL_stack_base + oldmark;
1560 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1563 SV* sv = newSVpv(p, 0);
1566 eval_sv(sv, G_SCALAR);
1573 if (croak_on_error && SvTRUE(ERRSV)) {
1575 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1581 /* Require a module. */
1584 Perl_require_pv(pTHX_ const char *pv)
1588 PUSHSTACKi(PERLSI_REQUIRE);
1590 sv = sv_newmortal();
1591 sv_setpv(sv, "require '");
1594 eval_sv(sv, G_DISCARD);
1600 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1604 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1605 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1609 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
1611 /* This message really ought to be max 23 lines.
1612 * Removed -h because the user already knows that opton. Others? */
1614 static char *usage_msg[] = {
1615 "-0[octal] specify record separator (\\0, if no argument)",
1616 "-a autosplit mode with -n or -p (splits $_ into @F)",
1617 "-c check syntax only (runs BEGIN and END blocks)",
1618 "-d[:debugger] run program under debugger",
1619 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1620 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1621 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1622 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1623 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1624 "-l[octal] enable line ending processing, specifies line terminator",
1625 "-[mM][-]module execute `use/no module...' before executing program",
1626 "-n assume 'while (<>) { ... }' loop around program",
1627 "-p assume loop like -n but print line also, like sed",
1628 "-P run program through C preprocessor before compilation",
1629 "-s enable rudimentary parsing for switches after programfile",
1630 "-S look for programfile using PATH environment variable",
1631 "-T enable tainting checks",
1632 "-u dump core after parsing program",
1633 "-U allow unsafe operations",
1634 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1635 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1636 "-w enable many useful warnings (RECOMMENDED)",
1637 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1641 char **p = usage_msg;
1643 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1645 printf("\n %s", *p++);
1648 /* This routine handles any switches that can be given during run */
1651 Perl_moreswitches(pTHX_ char *s)
1660 rschar = (U32)scan_oct(s, 4, &numlen);
1661 SvREFCNT_dec(PL_nrs);
1662 if (rschar & ~((U8)~0))
1663 PL_nrs = &PL_sv_undef;
1664 else if (!rschar && numlen >= 2)
1665 PL_nrs = newSVpvn("", 0);
1668 PL_nrs = newSVpvn(&ch, 1);
1674 PL_splitstr = savepv(s + 1);
1688 if (*s == ':' || *s == '=') {
1689 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1693 PL_perldb = PERLDB_ALL;
1701 if (isALPHA(s[1])) {
1702 static char debopts[] = "psltocPmfrxuLHXDS";
1705 for (s++; *s && (d = strchr(debopts,*s)); s++)
1706 PL_debug |= 1 << (d - debopts);
1709 PL_debug = atoi(s+1);
1710 for (s++; isDIGIT(*s); s++) ;
1712 PL_debug |= 0x80000000;
1715 if (ckWARN_d(WARN_DEBUGGING))
1716 Perl_warner(aTHX_ WARN_DEBUGGING,
1717 "Recompile perl with -DDEBUGGING to use -D switch\n");
1718 for (s++; isALNUM(*s); s++) ;
1724 usage(PL_origargv[0]);
1728 Safefree(PL_inplace);
1729 PL_inplace = savepv(s+1);
1731 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1734 if (*s == '-') /* Additional switches on #! line. */
1738 case 'I': /* -I handled both here and in parse_perl() */
1741 while (*s && isSPACE(*s))
1745 for (e = s; *e && !isSPACE(*e); e++) ;
1746 p = savepvn(s, e-s);
1752 Perl_croak(aTHX_ "No space allowed after -I");
1760 PL_ors = savepv("\n");
1762 *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
1767 if (RsPARA(PL_nrs)) {
1772 PL_ors = SvPV(PL_nrs, PL_orslen);
1773 PL_ors = savepvn(PL_ors, PL_orslen);
1777 forbid_setid("-M"); /* XXX ? */
1780 forbid_setid("-m"); /* XXX ? */
1785 /* -M-foo == 'no foo' */
1786 if (*s == '-') { use = "no "; ++s; }
1787 sv = newSVpv(use,0);
1789 /* We allow -M'Module qw(Foo Bar)' */
1790 while(isALNUM(*s) || *s==':') ++s;
1792 sv_catpv(sv, start);
1793 if (*(start-1) == 'm') {
1795 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
1796 sv_catpv( sv, " ()");
1799 sv_catpvn(sv, start, s-start);
1800 sv_catpv(sv, " split(/,/,q{");
1806 PL_preambleav = newAV();
1807 av_push(PL_preambleav, sv);
1810 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1822 PL_doswitches = TRUE;
1827 Perl_croak(aTHX_ "Too late for \"-T\" option");
1831 PL_do_undump = TRUE;
1839 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
1840 printf("\nThis is perl, version %d.%03d_%02d built for %s",
1841 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME);
1843 printf("\nThis is perl, version %s built for %s",
1844 PL_patchlevel, ARCHNAME);
1846 #if defined(LOCAL_PATCH_COUNT)
1847 if (LOCAL_PATCH_COUNT > 0)
1848 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1849 (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1852 printf("\n\nCopyright 1987-1999, Larry Wall\n");
1854 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1857 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1858 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
1861 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1862 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
1865 printf("atariST series port, ++jrb bammi@cadence.com\n");
1868 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
1871 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1874 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
1877 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
1880 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
1883 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
1886 printf("MiNT port by Guido Flohr, 1997-1999\n");
1888 #ifdef BINARY_BUILD_NOTICE
1889 BINARY_BUILD_NOTICE;
1892 Perl may be copied only under the terms of either the Artistic License or the\n\
1893 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1894 Complete documentation for Perl, including FAQ lists, should be found on\n\
1895 this system using `man perl' or `perldoc perl'. If you have access to the\n\
1896 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1899 if (! (PL_dowarn & G_WARN_ALL_MASK))
1900 PL_dowarn |= G_WARN_ON;
1904 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1905 PL_compiling.cop_warnings = WARN_ALL ;
1909 PL_dowarn = G_WARN_ALL_OFF;
1910 PL_compiling.cop_warnings = WARN_NONE ;
1915 if (s[1] == '-') /* Additional switches on #! line. */
1920 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1926 #ifdef ALTERNATE_SHEBANG
1927 case 'S': /* OS/2 needs -S on "extproc" line. */
1935 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
1940 /* compliments of Tom Christiansen */
1942 /* unexec() can be found in the Gnu emacs distribution */
1943 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1946 Perl_my_unexec(pTHX)
1954 prog = newSVpv(BIN_EXP, 0);
1955 sv_catpv(prog, "/perl");
1956 file = newSVpv(PL_origfilename, 0);
1957 sv_catpv(file, ".perldump");
1959 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1960 /* unexec prints msg to stderr in case of failure */
1961 PerlProc_exit(status);
1964 # include <lib$routines.h>
1965 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1967 ABORT(); /* for use with undump */
1972 /* initialize curinterp */
1977 #ifdef PERL_OBJECT /* XXX kludge */
1980 PL_chopset = " \n-"; \
1981 PL_copline = NOLINE; \
1982 PL_curcop = &PL_compiling;\
1983 PL_curcopdb = NULL; \
1985 PL_dumpindent = 4; \
1986 PL_laststatval = -1; \
1987 PL_laststype = OP_STAT; \
1988 PL_maxscream = -1; \
1989 PL_maxsysfd = MAXSYSFD; \
1990 PL_statname = Nullsv; \
1991 PL_tmps_floor = -1; \
1993 PL_op_mask = NULL; \
1994 PL_laststatval = -1; \
1995 PL_laststype = OP_STAT; \
1996 PL_mess_sv = Nullsv; \
1997 PL_splitstr = " "; \
1998 PL_generation = 100; \
1999 PL_exitlist = NULL; \
2000 PL_exitlistlen = 0; \
2002 PL_in_clean_objs = FALSE; \
2003 PL_in_clean_all = FALSE; \
2004 PL_profiledata = NULL; \
2006 PL_rsfp_filters = Nullav; \
2011 # ifdef MULTIPLICITY
2012 # define PERLVAR(var,type)
2013 # define PERLVARA(var,n,type)
2014 # if defined(PERL_IMPLICIT_CONTEXT)
2015 # if defined(USE_THREADS)
2016 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2017 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2018 # else /* !USE_THREADS */
2019 # define PERLVARI(var,type,init) aTHX->var = init;
2020 # define PERLVARIC(var,type,init) aTHX->var = init;
2021 # endif /* USE_THREADS */
2023 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2024 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2026 # include "intrpvar.h"
2027 # ifndef USE_THREADS
2028 # include "thrdvar.h"
2035 # define PERLVAR(var,type)
2036 # define PERLVARA(var,n,type)
2037 # define PERLVARI(var,type,init) PL_##var = init;
2038 # define PERLVARIC(var,type,init) PL_##var = init;
2039 # include "intrpvar.h"
2040 # ifndef USE_THREADS
2041 # include "thrdvar.h"
2053 S_init_main_stash(pTHX)
2058 /* Note that strtab is a rather special HV. Assumptions are made
2059 about not iterating on it, and not adding tie magic to it.
2060 It is properly deallocated in perl_destruct() */
2061 PL_strtab = newHV();
2063 MUTEX_INIT(&PL_strtab_mutex);
2065 HvSHAREKEYS_off(PL_strtab); /* mandatory */
2066 hv_ksplit(PL_strtab, 512);
2068 PL_curstash = PL_defstash = newHV();
2069 PL_curstname = newSVpvn("main",4);
2070 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2071 SvREFCNT_dec(GvHV(gv));
2072 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2074 HvNAME(PL_defstash) = savepv("main");
2075 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2076 GvMULTI_on(PL_incgv);
2077 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2078 GvMULTI_on(PL_hintgv);
2079 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2080 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2081 GvMULTI_on(PL_errgv);
2082 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2083 GvMULTI_on(PL_replgv);
2084 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
2085 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2086 sv_setpvn(ERRSV, "", 0);
2087 PL_curstash = PL_defstash;
2088 CopSTASH_set(&PL_compiling, PL_defstash);
2089 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2090 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2091 /* We must init $/ before switches are processed. */
2092 sv_setpvn(get_sv("/", TRUE), "\n", 1);
2096 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2104 PL_origfilename = savepv("-e");
2107 /* if find_script() returns, it returns a malloc()-ed value */
2108 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2110 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2111 char *s = scriptname + 8;
2112 *fdscript = atoi(s);
2116 scriptname = savepv(s + 1);
2117 Safefree(PL_origfilename);
2118 PL_origfilename = scriptname;
2123 CopFILE_set(PL_curcop, PL_origfilename);
2124 if (strEQ(PL_origfilename,"-"))
2126 if (*fdscript >= 0) {
2127 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2128 #if defined(HAS_FCNTL) && defined(F_SETFD)
2130 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2133 else if (PL_preprocess) {
2134 char *cpp_cfg = CPPSTDIN;
2135 SV *cpp = newSVpvn("",0);
2136 SV *cmd = NEWSV(0,0);
2138 if (strEQ(cpp_cfg, "cppstdin"))
2139 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2140 sv_catpv(cpp, cpp_cfg);
2143 sv_catpv(sv,PRIVLIB_EXP);
2146 Perl_sv_setpvf(aTHX_ cmd, "\
2147 sed %s -e \"/^[^#]/b\" \
2148 -e \"/^#[ ]*include[ ]/b\" \
2149 -e \"/^#[ ]*define[ ]/b\" \
2150 -e \"/^#[ ]*if[ ]/b\" \
2151 -e \"/^#[ ]*ifdef[ ]/b\" \
2152 -e \"/^#[ ]*ifndef[ ]/b\" \
2153 -e \"/^#[ ]*else/b\" \
2154 -e \"/^#[ ]*elif[ ]/b\" \
2155 -e \"/^#[ ]*undef[ ]/b\" \
2156 -e \"/^#[ ]*endif/b\" \
2159 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2162 Perl_sv_setpvf(aTHX_ cmd, "\
2163 %s %s -e '/^[^#]/b' \
2164 -e '/^#[ ]*include[ ]/b' \
2165 -e '/^#[ ]*define[ ]/b' \
2166 -e '/^#[ ]*if[ ]/b' \
2167 -e '/^#[ ]*ifdef[ ]/b' \
2168 -e '/^#[ ]*ifndef[ ]/b' \
2169 -e '/^#[ ]*else/b' \
2170 -e '/^#[ ]*elif[ ]/b' \
2171 -e '/^#[ ]*undef[ ]/b' \
2172 -e '/^#[ ]*endif/b' \
2176 Perl_sv_setpvf(aTHX_ cmd, "\
2177 %s %s -e '/^[^#]/b' \
2178 -e '/^#[ ]*include[ ]/b' \
2179 -e '/^#[ ]*define[ ]/b' \
2180 -e '/^#[ ]*if[ ]/b' \
2181 -e '/^#[ ]*ifdef[ ]/b' \
2182 -e '/^#[ ]*ifndef[ ]/b' \
2183 -e '/^#[ ]*else/b' \
2184 -e '/^#[ ]*elif[ ]/b' \
2185 -e '/^#[ ]*undef[ ]/b' \
2186 -e '/^#[ ]*endif/b' \
2195 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2197 scriptname, cpp, sv, CPPMINUS);
2198 PL_doextract = FALSE;
2199 #ifdef IAMSUID /* actually, this is caught earlier */
2200 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2202 (void)seteuid(PL_uid); /* musn't stay setuid root */
2205 (void)setreuid((Uid_t)-1, PL_uid);
2207 #ifdef HAS_SETRESUID
2208 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2210 PerlProc_setuid(PL_uid);
2214 if (PerlProc_geteuid() != PL_uid)
2215 Perl_croak(aTHX_ "Can't do seteuid!\n");
2217 #endif /* IAMSUID */
2218 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2222 else if (!*scriptname) {
2223 forbid_setid("program input from stdin");
2224 PL_rsfp = PerlIO_stdin();
2227 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2228 #if defined(HAS_FCNTL) && defined(F_SETFD)
2230 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2235 #ifndef IAMSUID /* in case script is not readable before setuid */
2237 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2238 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2241 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2242 Perl_croak(aTHX_ "Can't do setuid\n");
2246 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2247 CopFILE(PL_curcop), Strerror(errno));
2252 * I_SYSSTATVFS HAS_FSTATVFS
2254 * I_STATFS HAS_FSTATFS
2255 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2256 * here so that metaconfig picks them up. */
2260 S_fd_on_nosuid_fs(pTHX_ int fd)
2262 int check_okay = 0; /* able to do all the required sys/libcalls */
2263 int on_nosuid = 0; /* the fd is on a nosuid fs */
2265 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2266 * fstatvfs() is UNIX98.
2267 * fstatfs() is 4.3 BSD.
2268 * ustat()+getmnt() is pre-4.3 BSD.
2269 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2270 * an irrelevant filesystem while trying to reach the right one.
2273 # ifdef HAS_FSTATVFS
2274 struct statvfs stfs;
2275 check_okay = fstatvfs(fd, &stfs) == 0;
2276 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2278 # ifdef PERL_MOUNT_NOSUID
2279 # if defined(HAS_FSTATFS) && \
2280 defined(HAS_STRUCT_STATFS) && \
2281 defined(HAS_STRUCT_STATFS_F_FLAGS)
2283 check_okay = fstatfs(fd, &stfs) == 0;
2284 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2286 # if defined(HAS_FSTAT) && \
2287 defined(HAS_USTAT) && \
2288 defined(HAS_GETMNT) && \
2289 defined(HAS_STRUCT_FS_DATA) &&
2292 if (fstat(fd, &fdst) == 0) {
2294 if (ustat(fdst.st_dev, &us) == 0) {
2296 /* NOSTAT_ONE here because we're not examining fields which
2297 * vary between that case and STAT_ONE. */
2298 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2299 size_t cmplen = sizeof(us.f_fname);
2300 if (sizeof(fsd.fd_req.path) < cmplen)
2301 cmplen = sizeof(fsd.fd_req.path);
2302 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2303 fdst.st_dev == fsd.fd_req.dev) {
2305 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2311 # endif /* fstat+ustat+getmnt */
2312 # endif /* fstatfs */
2314 # if defined(HAS_GETMNTENT) && \
2315 defined(HAS_HASMNTOPT) && \
2316 defined(MNTOPT_NOSUID)
2317 FILE *mtab = fopen("/etc/mtab", "r");
2318 struct mntent *entry;
2319 struct stat stb, fsb;
2321 if (mtab && (fstat(fd, &stb) == 0)) {
2322 while (entry = getmntent(mtab)) {
2323 if (stat(entry->mnt_dir, &fsb) == 0
2324 && fsb.st_dev == stb.st_dev)
2326 /* found the filesystem */
2328 if (hasmntopt(entry, MNTOPT_NOSUID))
2331 } /* A single fs may well fail its stat(). */
2336 # endif /* getmntent+hasmntopt */
2337 # endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */
2338 # endif /* statvfs */
2341 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
2344 #endif /* IAMSUID */
2347 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2351 /* do we need to emulate setuid on scripts? */
2353 /* This code is for those BSD systems that have setuid #! scripts disabled
2354 * in the kernel because of a security problem. Merely defining DOSUID
2355 * in perl will not fix that problem, but if you have disabled setuid
2356 * scripts in the kernel, this will attempt to emulate setuid and setgid
2357 * on scripts that have those now-otherwise-useless bits set. The setuid
2358 * root version must be called suidperl or sperlN.NNN. If regular perl
2359 * discovers that it has opened a setuid script, it calls suidperl with
2360 * the same argv that it had. If suidperl finds that the script it has
2361 * just opened is NOT setuid root, it sets the effective uid back to the
2362 * uid. We don't just make perl setuid root because that loses the
2363 * effective uid we had before invoking perl, if it was different from the
2366 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2367 * be defined in suidperl only. suidperl must be setuid root. The
2368 * Configure script will set this up for you if you want it.
2375 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2376 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2377 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2382 #ifndef HAS_SETREUID
2383 /* On this access check to make sure the directories are readable,
2384 * there is actually a small window that the user could use to make
2385 * filename point to an accessible directory. So there is a faint
2386 * chance that someone could execute a setuid script down in a
2387 * non-accessible directory. I don't know what to do about that.
2388 * But I don't think it's too important. The manual lies when
2389 * it says access() is useful in setuid programs.
2391 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
2392 Perl_croak(aTHX_ "Permission denied");
2394 /* If we can swap euid and uid, then we can determine access rights
2395 * with a simple stat of the file, and then compare device and
2396 * inode to make sure we did stat() on the same file we opened.
2397 * Then we just have to make sure he or she can execute it.
2400 struct stat tmpstatbuf;
2404 setreuid(PL_euid,PL_uid) < 0
2407 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2410 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2411 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2412 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
2413 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2414 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2415 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2416 Perl_croak(aTHX_ "Permission denied");
2418 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2419 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2420 (void)PerlIO_close(PL_rsfp);
2421 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2422 PerlIO_printf(PL_rsfp,
2423 "User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2424 (Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n",
2425 PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2426 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2428 PL_statbuf.st_uid, PL_statbuf.st_gid);
2429 (void)PerlProc_pclose(PL_rsfp);
2431 Perl_croak(aTHX_ "Permission denied\n");
2435 setreuid(PL_uid,PL_euid) < 0
2437 # if defined(HAS_SETRESUID)
2438 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2441 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2442 Perl_croak(aTHX_ "Can't reswap uid and euid");
2443 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2444 Perl_croak(aTHX_ "Permission denied\n");
2446 #endif /* HAS_SETREUID */
2447 #endif /* IAMSUID */
2449 if (!S_ISREG(PL_statbuf.st_mode))
2450 Perl_croak(aTHX_ "Permission denied");
2451 if (PL_statbuf.st_mode & S_IWOTH)
2452 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2453 PL_doswitches = FALSE; /* -s is insecure in suid */
2454 CopLINE_inc(PL_curcop);
2455 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2456 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2457 Perl_croak(aTHX_ "No #! line");
2458 s = SvPV(PL_linestr,n_a)+2;
2460 while (!isSPACE(*s)) s++;
2461 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2462 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2463 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2464 Perl_croak(aTHX_ "Not a perl script");
2465 while (*s == ' ' || *s == '\t') s++;
2467 * #! arg must be what we saw above. They can invoke it by
2468 * mentioning suidperl explicitly, but they may not add any strange
2469 * arguments beyond what #! says if they do invoke suidperl that way.
2471 len = strlen(validarg);
2472 if (strEQ(validarg," PHOOEY ") ||
2473 strnNE(s,validarg,len) || !isSPACE(s[len]))
2474 Perl_croak(aTHX_ "Args must match #! line");
2477 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2478 PL_euid == PL_statbuf.st_uid)
2480 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2481 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2482 #endif /* IAMSUID */
2484 if (PL_euid) { /* oops, we're not the setuid root perl */
2485 (void)PerlIO_close(PL_rsfp);
2488 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2490 Perl_croak(aTHX_ "Can't do setuid\n");
2493 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2495 (void)setegid(PL_statbuf.st_gid);
2498 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2500 #ifdef HAS_SETRESGID
2501 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2503 PerlProc_setgid(PL_statbuf.st_gid);
2507 if (PerlProc_getegid() != PL_statbuf.st_gid)
2508 Perl_croak(aTHX_ "Can't do setegid!\n");
2510 if (PL_statbuf.st_mode & S_ISUID) {
2511 if (PL_statbuf.st_uid != PL_euid)
2513 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2516 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2518 #ifdef HAS_SETRESUID
2519 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2521 PerlProc_setuid(PL_statbuf.st_uid);
2525 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2526 Perl_croak(aTHX_ "Can't do seteuid!\n");
2528 else if (PL_uid) { /* oops, mustn't run as root */
2530 (void)seteuid((Uid_t)PL_uid);
2533 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2535 #ifdef HAS_SETRESUID
2536 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2538 PerlProc_setuid((Uid_t)PL_uid);
2542 if (PerlProc_geteuid() != PL_uid)
2543 Perl_croak(aTHX_ "Can't do seteuid!\n");
2546 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2547 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
2550 else if (PL_preprocess)
2551 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2552 else if (fdscript >= 0)
2553 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2555 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2557 /* We absolutely must clear out any saved ids here, so we */
2558 /* exec the real perl, substituting fd script for scriptname. */
2559 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2560 PerlIO_rewind(PL_rsfp);
2561 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2562 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2563 if (!PL_origargv[which])
2564 Perl_croak(aTHX_ "Permission denied");
2565 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2566 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2567 #if defined(HAS_FCNTL) && defined(F_SETFD)
2568 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2570 PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
2571 Perl_croak(aTHX_ "Can't do setuid\n");
2572 #endif /* IAMSUID */
2574 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2575 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2577 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2578 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2580 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2583 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2584 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2585 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2586 /* not set-id, must be wrapped */
2592 S_find_beginning(pTHX)
2594 register char *s, *s2;
2596 /* skip forward in input to the real script? */
2599 while (PL_doextract) {
2600 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2601 Perl_croak(aTHX_ "No Perl script found in input\n");
2602 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2603 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2604 PL_doextract = FALSE;
2605 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2607 while (*s == ' ' || *s == '\t') s++;
2609 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2610 if (strnEQ(s2-4,"perl",4))
2612 while (s = moreswitches(s)) ;
2622 PL_uid = PerlProc_getuid();
2623 PL_euid = PerlProc_geteuid();
2624 PL_gid = PerlProc_getgid();
2625 PL_egid = PerlProc_getegid();
2627 PL_uid |= PL_gid << 16;
2628 PL_euid |= PL_egid << 16;
2630 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2634 S_forbid_setid(pTHX_ char *s)
2636 if (PL_euid != PL_uid)
2637 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2638 if (PL_egid != PL_gid)
2639 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2643 Perl_init_debugger(pTHX)
2646 HV *ostash = PL_curstash;
2648 PL_curstash = PL_debstash;
2649 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2650 AvREAL_off(PL_dbargs);
2651 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2652 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2653 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2654 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
2655 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2656 sv_setiv(PL_DBsingle, 0);
2657 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2658 sv_setiv(PL_DBtrace, 0);
2659 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2660 sv_setiv(PL_DBsignal, 0);
2661 PL_curstash = ostash;
2664 #ifndef STRESS_REALLOC
2665 #define REASONABLE(size) (size)
2667 #define REASONABLE(size) (1) /* unreasonable */
2671 Perl_init_stacks(pTHX)
2673 /* start with 128-item stack and 8K cxstack */
2674 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2675 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2676 PL_curstackinfo->si_type = PERLSI_MAIN;
2677 PL_curstack = PL_curstackinfo->si_stack;
2678 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2680 PL_stack_base = AvARRAY(PL_curstack);
2681 PL_stack_sp = PL_stack_base;
2682 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2684 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2687 PL_tmps_max = REASONABLE(128);
2689 New(54,PL_markstack,REASONABLE(32),I32);
2690 PL_markstack_ptr = PL_markstack;
2691 PL_markstack_max = PL_markstack + REASONABLE(32);
2695 New(54,PL_scopestack,REASONABLE(32),I32);
2696 PL_scopestack_ix = 0;
2697 PL_scopestack_max = REASONABLE(32);
2699 New(54,PL_savestack,REASONABLE(128),ANY);
2700 PL_savestack_ix = 0;
2701 PL_savestack_max = REASONABLE(128);
2703 New(54,PL_retstack,REASONABLE(16),OP*);
2705 PL_retstack_max = REASONABLE(16);
2714 while (PL_curstackinfo->si_next)
2715 PL_curstackinfo = PL_curstackinfo->si_next;
2716 while (PL_curstackinfo) {
2717 PERL_SI *p = PL_curstackinfo->si_prev;
2718 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2719 Safefree(PL_curstackinfo->si_cxstack);
2720 Safefree(PL_curstackinfo);
2721 PL_curstackinfo = p;
2723 Safefree(PL_tmps_stack);
2724 Safefree(PL_markstack);
2725 Safefree(PL_scopestack);
2726 Safefree(PL_savestack);
2727 Safefree(PL_retstack);
2731 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2742 lex_start(PL_linestr);
2744 PL_subname = newSVpvn("main",4);
2748 S_init_predump_symbols(pTHX)
2755 sv_setpvn(get_sv("\"", TRUE), " ", 1);
2756 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2757 GvMULTI_on(PL_stdingv);
2758 io = GvIOp(PL_stdingv);
2759 IoIFP(io) = PerlIO_stdin();
2760 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2762 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2764 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2767 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
2769 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2771 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2773 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2774 GvMULTI_on(PL_stderrgv);
2775 io = GvIOp(PL_stderrgv);
2776 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
2777 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2779 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2781 PL_statname = NEWSV(66,0); /* last filename we did stat on */
2784 PL_osname = savepv(OSNAME);
2788 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
2795 argc--,argv++; /* skip name of script */
2796 if (PL_doswitches) {
2797 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2800 if (argv[0][1] == '-') {
2804 if (s = strchr(argv[0], '=')) {
2806 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2809 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2812 PL_toptarget = NEWSV(0,0);
2813 sv_upgrade(PL_toptarget, SVt_PVFM);
2814 sv_setpvn(PL_toptarget, "", 0);
2815 PL_bodytarget = NEWSV(0,0);
2816 sv_upgrade(PL_bodytarget, SVt_PVFM);
2817 sv_setpvn(PL_bodytarget, "", 0);
2818 PL_formtarget = PL_bodytarget;
2821 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2822 sv_setpv(GvSV(tmpgv),PL_origfilename);
2823 magicname("0", "0", 1);
2825 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2827 sv_setpv(GvSV(tmpgv), os2_execname());
2829 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2831 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2832 GvMULTI_on(PL_argvgv);
2833 (void)gv_AVadd(PL_argvgv);
2834 av_clear(GvAVn(PL_argvgv));
2835 for (; argc > 0; argc--,argv++) {
2836 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2839 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2841 GvMULTI_on(PL_envgv);
2842 hv = GvHVn(PL_envgv);
2843 hv_magic(hv, PL_envgv, 'E');
2844 #if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
2845 /* Note that if the supplied env parameter is actually a copy
2846 of the global environ then it may now point to free'd memory
2847 if the environment has been modified since. To avoid this
2848 problem we treat env==NULL as meaning 'use the default'
2853 environ[0] = Nullch;
2854 for (; *env; env++) {
2855 if (!(s = strchr(*env,'=')))
2861 sv = newSVpv(s--,0);
2862 (void)hv_store(hv, *env, s - *env, sv, 0);
2864 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2865 /* Sins of the RTL. See note in my_setenv(). */
2866 (void)PerlEnv_putenv(savepv(*env));
2870 #ifdef DYNAMIC_ENV_FETCH
2871 HvNAME(hv) = savepv(ENV_HV_NAME);
2875 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2876 sv_setiv(GvSV(tmpgv), (IV)getpid());
2880 S_init_perllib(pTHX)
2885 s = PerlEnv_getenv("PERL5LIB");
2889 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2891 /* Treat PERL5?LIB as a possible search list logical name -- the
2892 * "natural" VMS idiom for a Unix path string. We allow each
2893 * element to be a set of |-separated directories for compatibility.
2897 if (my_trnlnm("PERL5LIB",buf,0))
2898 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2900 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2904 /* Use the ~-expanded versions of APPLLIB (undocumented),
2905 ARCHLIB PRIVLIB SITEARCH and SITELIB
2908 incpush(APPLLIB_EXP, TRUE);
2912 incpush(ARCHLIB_EXP, FALSE);
2915 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2918 incpush(PRIVLIB_EXP, TRUE);
2920 incpush(PRIVLIB_EXP, FALSE);
2924 incpush(SITEARCH_EXP, FALSE);
2928 incpush(SITELIB_EXP, TRUE);
2930 incpush(SITELIB_EXP, FALSE);
2933 #if defined(PERL_VENDORLIB_EXP)
2935 incpush(PERL_VENDORLIB_EXP, TRUE);
2937 incpush(PERL_VENDORLIB_EXP, FALSE);
2941 incpush(".", FALSE);
2945 # define PERLLIB_SEP ';'
2948 # define PERLLIB_SEP '|'
2950 # define PERLLIB_SEP ':'
2953 #ifndef PERLLIB_MANGLE
2954 # define PERLLIB_MANGLE(s,n) (s)
2958 S_incpush(pTHX_ char *p, int addsubdirs)
2960 SV *subdir = Nullsv;
2966 subdir = sv_newmortal();
2967 if (!PL_archpat_auto) {
2968 STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
2969 + sizeof("//auto"));
2970 New(55, PL_archpat_auto, len, char);
2971 sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
2973 for (len = sizeof(ARCHNAME) + 2;
2974 PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2975 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
2980 /* Break at all separators */
2982 SV *libdir = NEWSV(55,0);
2985 /* skip any consecutive separators */
2986 while ( *p == PERLLIB_SEP ) {
2987 /* Uncomment the next line for PATH semantics */
2988 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
2992 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2993 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2998 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2999 p = Nullch; /* break out */
3003 * BEFORE pushing libdir onto @INC we may first push version- and
3004 * archname-specific sub-directories.
3007 struct stat tmpstatbuf;
3012 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3014 while (unix[len-1] == '/') len--; /* Cosmetic */
3015 sv_usepvn(libdir,unix,len);
3018 PerlIO_printf(Perl_error_log,
3019 "Failed to unixify @INC element \"%s\"\n",
3022 /* .../archname/version if -d .../archname/version/auto */
3023 sv_setsv(subdir, libdir);
3024 sv_catpv(subdir, PL_archpat_auto);
3025 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3026 S_ISDIR(tmpstatbuf.st_mode))
3027 av_push(GvAVn(PL_incgv),
3028 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
3030 /* .../archname if -d .../archname/auto */
3031 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
3032 strlen(PL_patchlevel) + 1, "", 0);
3033 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3034 S_ISDIR(tmpstatbuf.st_mode))
3035 av_push(GvAVn(PL_incgv),
3036 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
3039 /* finally push this lib directory on the end of @INC */
3040 av_push(GvAVn(PL_incgv), libdir);
3045 STATIC struct perl_thread *
3046 S_init_main_thread(pTHX)
3048 #if !defined(PERL_IMPLICIT_CONTEXT)
3049 struct perl_thread *thr;
3053 Newz(53, thr, 1, struct perl_thread);
3054 PL_curcop = &PL_compiling;
3055 thr->interp = PERL_GET_INTERP;
3056 thr->cvcache = newHV();
3057 thr->threadsv = newAV();
3058 /* thr->threadsvp is set when find_threadsv is called */
3059 thr->specific = newAV();
3060 thr->flags = THRf_R_JOINABLE;
3061 MUTEX_INIT(&thr->mutex);
3062 /* Handcraft thrsv similarly to mess_sv */
3063 New(53, PL_thrsv, 1, SV);
3064 Newz(53, xpv, 1, XPV);
3065 SvFLAGS(PL_thrsv) = SVt_PV;
3066 SvANY(PL_thrsv) = (void*)xpv;
3067 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3068 SvPVX(PL_thrsv) = (char*)thr;
3069 SvCUR_set(PL_thrsv, sizeof(thr));
3070 SvLEN_set(PL_thrsv, sizeof(thr));
3071 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3072 thr->oursv = PL_thrsv;
3073 PL_chopset = " \n-";
3076 MUTEX_LOCK(&PL_threads_mutex);
3081 MUTEX_UNLOCK(&PL_threads_mutex);
3083 #ifdef HAVE_THREAD_INTERN
3084 Perl_init_thread_intern(thr);
3087 #ifdef SET_THREAD_SELF
3088 SET_THREAD_SELF(thr);
3090 thr->self = pthread_self();
3091 #endif /* SET_THREAD_SELF */
3095 * These must come after the SET_THR because sv_setpvn does
3096 * SvTAINT and the taint fields require dTHR.
3098 PL_toptarget = NEWSV(0,0);
3099 sv_upgrade(PL_toptarget, SVt_PVFM);
3100 sv_setpvn(PL_toptarget, "", 0);
3101 PL_bodytarget = NEWSV(0,0);
3102 sv_upgrade(PL_bodytarget, SVt_PVFM);
3103 sv_setpvn(PL_bodytarget, "", 0);
3104 PL_formtarget = PL_bodytarget;
3105 thr->errsv = newSVpvn("", 0);
3106 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
3109 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3110 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3111 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3112 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3113 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3115 PL_reginterp_cnt = 0;
3119 #endif /* USE_THREADS */
3122 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3126 line_t oldline = CopLINE(PL_curcop);
3132 while (AvFILL(paramList) >= 0) {
3133 cv = (CV*)av_shift(paramList);
3135 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
3139 (void)SvPV(atsv, len);
3142 PL_curcop = &PL_compiling;
3143 CopLINE_set(PL_curcop, oldline);
3144 if (paramList == PL_beginav)
3145 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3147 Perl_sv_catpvf(aTHX_ atsv,
3148 "%s failed--call queue aborted",
3149 paramList == PL_stopav ? "STOP"
3150 : paramList == PL_initav ? "INIT"
3152 while (PL_scopestack_ix > oldscope)
3154 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
3161 /* my_exit() was called */
3162 while (PL_scopestack_ix > oldscope)
3165 PL_curstash = PL_defstash;
3166 PL_curcop = &PL_compiling;
3167 CopLINE_set(PL_curcop, oldline);
3168 if (PL_statusvalue) {
3169 if (paramList == PL_beginav)
3170 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3172 Perl_croak(aTHX_ "%s failed--call queue aborted",
3173 paramList == PL_stopav ? "STOP"
3174 : paramList == PL_initav ? "INIT"
3181 PL_curcop = &PL_compiling;
3182 CopLINE_set(PL_curcop, oldline);
3185 PerlIO_printf(Perl_error_log, "panic: restartop\n");
3193 S_call_list_body(pTHX_ va_list args)
3196 CV *cv = va_arg(args, CV*);
3198 PUSHMARK(PL_stack_sp);
3199 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3204 Perl_my_exit(pTHX_ U32 status)
3208 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3209 thr, (unsigned long) status));
3218 STATUS_NATIVE_SET(status);
3225 Perl_my_failure_exit(pTHX)
3228 if (vaxc$errno & 1) {
3229 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3230 STATUS_NATIVE_SET(44);
3233 if (!vaxc$errno && errno) /* unlikely */
3234 STATUS_NATIVE_SET(44);
3236 STATUS_NATIVE_SET(vaxc$errno);
3241 STATUS_POSIX_SET(errno);
3243 exitstatus = STATUS_POSIX >> 8;
3244 if (exitstatus & 255)
3245 STATUS_POSIX_SET(exitstatus);
3247 STATUS_POSIX_SET(255);
3254 S_my_exit_jump(pTHX)
3257 register PERL_CONTEXT *cx;
3262 SvREFCNT_dec(PL_e_script);
3263 PL_e_script = Nullsv;
3266 POPSTACK_TO(PL_mainstack);
3267 if (cxstack_ix >= 0) {
3270 POPBLOCK(cx,PL_curpm);
3282 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3285 p = SvPVX(PL_e_script);
3286 nl = strchr(p, '\n');
3287 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3289 filter_del(read_e_script);
3292 sv_catpvn(buf_sv, p, nl-p);
3293 sv_chop(PL_e_script, nl);