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
50 #define perl_construct Perl_construct
51 #define perl_parse Perl_parse
52 #define perl_run Perl_run
53 #define perl_destruct Perl_destruct
54 #define perl_free Perl_free
57 #ifdef PERL_IMPLICIT_SYS
59 perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
60 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
61 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
62 struct IPerlDir* ipD, struct IPerlSock* ipS,
63 struct IPerlProc* ipP)
65 PerlInterpreter *my_perl;
67 my_perl = (PerlInterpreter*)new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd,
68 ipLIO, ipD, ipS, ipP);
69 PERL_SET_INTERP(my_perl);
71 /* New() needs interpreter, so call malloc() instead */
72 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
73 PERL_SET_INTERP(my_perl);
74 Zero(my_perl, 1, PerlInterpreter);
92 PerlInterpreter *my_perl;
94 /* New() needs interpreter, so call malloc() instead */
95 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
96 PERL_SET_INTERP(my_perl);
97 Zero(my_perl, 1, PerlInterpreter);
100 #endif /* PERL_IMPLICIT_SYS */
103 perl_construct(pTHXx)
108 struct perl_thread *thr = NULL;
109 #endif /* FAKE_THREADS */
110 #endif /* USE_THREADS */
114 PL_perl_destruct_level = 1;
116 if (PL_perl_destruct_level > 0)
120 /* Init the real globals (and main thread)? */
125 #ifdef ALLOC_THREAD_KEY
128 if (pthread_key_create(&PL_thr_key, 0))
129 Perl_croak(aTHX_ "panic: pthread_key_create");
131 MUTEX_INIT(&PL_sv_mutex);
133 * Safe to use basic SV functions from now on (though
134 * not things like mortals or tainting yet).
136 MUTEX_INIT(&PL_eval_mutex);
137 COND_INIT(&PL_eval_cond);
138 MUTEX_INIT(&PL_threads_mutex);
139 COND_INIT(&PL_nthreads_cond);
140 #ifdef EMULATE_ATOMIC_REFCOUNTS
141 MUTEX_INIT(&PL_svref_mutex);
142 #endif /* EMULATE_ATOMIC_REFCOUNTS */
144 MUTEX_INIT(&PL_cred_mutex);
146 thr = init_main_thread();
147 #endif /* USE_THREADS */
149 PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
151 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
153 PL_linestr = NEWSV(65,79);
154 sv_upgrade(PL_linestr,SVt_PVIV);
156 if (!SvREADONLY(&PL_sv_undef)) {
157 /* set read-only and try to insure than we wont see REFCNT==0
160 SvREADONLY_on(&PL_sv_undef);
161 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
163 sv_setpv(&PL_sv_no,PL_No);
165 SvREADONLY_on(&PL_sv_no);
166 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
168 sv_setpv(&PL_sv_yes,PL_Yes);
170 SvREADONLY_on(&PL_sv_yes);
171 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
176 /* PL_sighandlerp = sighandler; */
178 PL_sighandlerp = Perl_sighandler;
180 PL_pidstatus = newHV();
184 * There is no way we can refer to them from Perl so close them to save
185 * space. The other alternative would be to provide STDAUX and STDPRN
188 (void)fclose(stdaux);
189 (void)fclose(stdprn);
193 PL_nrs = newSVpvn("\n", 1);
194 PL_rs = SvREFCNT_inc(PL_nrs);
199 PL_lex_state = LEX_NOTPARSING;
205 SET_NUMERIC_STANDARD();
207 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
208 sprintf(PL_patchlevel, "%7.5f", (double) PERL_REVISION
209 + ((double) PERL_VERSION / (double) 1000)
210 + ((double) PERL_SUBVERSION / (double) 100000));
212 sprintf(PL_patchlevel, "%5.3f", (double) PERL_REVISION +
213 ((double) PERL_VERSION / (double) 1000));
216 #if defined(LOCAL_PATCH_COUNT)
217 PL_localpatches = local_patches; /* For possible -v */
220 PerlIO_init(); /* Hook to IO system */
222 PL_fdpid = newAV(); /* for remembering popen pids by fd */
223 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
232 int destruct_level; /* 0=none, 1=full, 2=full with checks */
238 #endif /* USE_THREADS */
240 /* wait for all pseudo-forked children to finish */
241 PERL_WAIT_FOR_CHILDREN;
245 /* Pass 1 on any remaining threads: detach joinables, join zombies */
247 MUTEX_LOCK(&PL_threads_mutex);
248 DEBUG_S(PerlIO_printf(Perl_debug_log,
249 "perl_destruct: waiting for %d threads...\n",
251 for (t = thr->next; t != thr; t = t->next) {
252 MUTEX_LOCK(&t->mutex);
253 switch (ThrSTATE(t)) {
256 DEBUG_S(PerlIO_printf(Perl_debug_log,
257 "perl_destruct: joining zombie %p\n", t));
258 ThrSETSTATE(t, THRf_DEAD);
259 MUTEX_UNLOCK(&t->mutex);
262 * The SvREFCNT_dec below may take a long time (e.g. av
263 * may contain an object scalar whose destructor gets
264 * called) so we have to unlock threads_mutex and start
267 MUTEX_UNLOCK(&PL_threads_mutex);
269 SvREFCNT_dec((SV*)av);
270 DEBUG_S(PerlIO_printf(Perl_debug_log,
271 "perl_destruct: joined zombie %p OK\n", t));
273 case THRf_R_JOINABLE:
274 DEBUG_S(PerlIO_printf(Perl_debug_log,
275 "perl_destruct: detaching thread %p\n", t));
276 ThrSETSTATE(t, THRf_R_DETACHED);
278 * We unlock threads_mutex and t->mutex in the opposite order
279 * from which we locked them just so that DETACH won't
280 * deadlock if it panics. It's only a breach of good style
281 * not a bug since they are unlocks not locks.
283 MUTEX_UNLOCK(&PL_threads_mutex);
285 MUTEX_UNLOCK(&t->mutex);
288 DEBUG_S(PerlIO_printf(Perl_debug_log,
289 "perl_destruct: ignoring %p (state %u)\n",
291 MUTEX_UNLOCK(&t->mutex);
292 /* fall through and out */
295 /* We leave the above "Pass 1" loop with threads_mutex still locked */
297 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
298 while (PL_nthreads > 1)
300 DEBUG_S(PerlIO_printf(Perl_debug_log,
301 "perl_destruct: final wait for %d threads\n",
303 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
305 /* At this point, we're the last thread */
306 MUTEX_UNLOCK(&PL_threads_mutex);
307 DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
308 MUTEX_DESTROY(&PL_threads_mutex);
309 COND_DESTROY(&PL_nthreads_cond);
310 #endif /* !defined(FAKE_THREADS) */
311 #endif /* USE_THREADS */
313 destruct_level = PL_perl_destruct_level;
317 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
319 if (destruct_level < i)
328 /* We must account for everything. */
330 /* Destroy the main CV and syntax tree */
332 PL_curpad = AvARRAY(PL_comppad);
333 op_free(PL_main_root);
334 PL_main_root = Nullop;
336 PL_curcop = &PL_compiling;
337 PL_main_start = Nullop;
338 SvREFCNT_dec(PL_main_cv);
342 if (PL_sv_objcount) {
344 * Try to destruct global references. We do this first so that the
345 * destructors and destructees still exist. Some sv's might remain.
346 * Non-referenced objects are on their own.
351 /* unhook hooks which will soon be, or use, destroyed data */
352 SvREFCNT_dec(PL_warnhook);
353 PL_warnhook = Nullsv;
354 SvREFCNT_dec(PL_diehook);
357 /* call exit list functions */
358 while (PL_exitlistlen-- > 0)
359 PL_exitlist[PL_exitlistlen].fn(aTHXo_ PL_exitlist[PL_exitlistlen].ptr);
361 Safefree(PL_exitlist);
363 if (destruct_level == 0){
365 DEBUG_P(debprofdump());
367 /* The exit() function will do everything that needs doing. */
371 /* loosen bonds of global variables */
374 (void)PerlIO_close(PL_rsfp);
378 /* Filters for program text */
379 SvREFCNT_dec(PL_rsfp_filters);
380 PL_rsfp_filters = Nullav;
383 PL_preprocess = FALSE;
389 PL_doswitches = FALSE;
390 PL_dowarn = G_WARN_OFF;
391 PL_doextract = FALSE;
392 PL_sawampersand = FALSE; /* must save all match strings */
395 Safefree(PL_inplace);
399 SvREFCNT_dec(PL_e_script);
400 PL_e_script = Nullsv;
403 /* magical thingies */
405 Safefree(PL_ofs); /* $, */
408 Safefree(PL_ors); /* $\ */
411 SvREFCNT_dec(PL_rs); /* $/ */
414 SvREFCNT_dec(PL_nrs); /* $/ helper */
417 PL_multiline = 0; /* $* */
419 SvREFCNT_dec(PL_statname);
420 PL_statname = Nullsv;
423 /* defgv, aka *_ should be taken care of elsewhere */
425 /* clean up after study() */
426 SvREFCNT_dec(PL_lastscream);
427 PL_lastscream = Nullsv;
428 Safefree(PL_screamfirst);
430 Safefree(PL_screamnext);
434 Safefree(PL_efloatbuf);
435 PL_efloatbuf = Nullch;
438 /* startup and shutdown function lists */
439 SvREFCNT_dec(PL_beginav);
440 SvREFCNT_dec(PL_endav);
441 SvREFCNT_dec(PL_stopav);
442 SvREFCNT_dec(PL_initav);
448 /* shortcuts just get cleared */
454 PL_argvoutgv = Nullgv;
456 PL_stderrgv = Nullgv;
457 PL_last_in_gv = Nullgv;
459 PL_debstash = Nullhv;
461 /* reset so print() ends up where we expect */
464 SvREFCNT_dec(PL_argvout_stack);
465 PL_argvout_stack = Nullav;
467 SvREFCNT_dec(PL_fdpid);
469 SvREFCNT_dec(PL_modglobal);
470 PL_modglobal = Nullhv;
471 SvREFCNT_dec(PL_preambleav);
472 PL_preambleav = Nullav;
473 SvREFCNT_dec(PL_subname);
475 SvREFCNT_dec(PL_linestr);
477 SvREFCNT_dec(PL_pidstatus);
478 PL_pidstatus = Nullhv;
479 SvREFCNT_dec(PL_toptarget);
480 PL_toptarget = Nullsv;
481 SvREFCNT_dec(PL_bodytarget);
482 PL_bodytarget = Nullsv;
483 PL_formtarget = Nullsv;
485 /* clear utf8 character classes */
486 SvREFCNT_dec(PL_utf8_alnum);
487 SvREFCNT_dec(PL_utf8_alnumc);
488 SvREFCNT_dec(PL_utf8_ascii);
489 SvREFCNT_dec(PL_utf8_alpha);
490 SvREFCNT_dec(PL_utf8_space);
491 SvREFCNT_dec(PL_utf8_cntrl);
492 SvREFCNT_dec(PL_utf8_graph);
493 SvREFCNT_dec(PL_utf8_digit);
494 SvREFCNT_dec(PL_utf8_upper);
495 SvREFCNT_dec(PL_utf8_lower);
496 SvREFCNT_dec(PL_utf8_print);
497 SvREFCNT_dec(PL_utf8_punct);
498 SvREFCNT_dec(PL_utf8_xdigit);
499 SvREFCNT_dec(PL_utf8_mark);
500 SvREFCNT_dec(PL_utf8_toupper);
501 SvREFCNT_dec(PL_utf8_tolower);
502 PL_utf8_alnum = Nullsv;
503 PL_utf8_alnumc = Nullsv;
504 PL_utf8_ascii = Nullsv;
505 PL_utf8_alpha = Nullsv;
506 PL_utf8_space = Nullsv;
507 PL_utf8_cntrl = Nullsv;
508 PL_utf8_graph = Nullsv;
509 PL_utf8_digit = Nullsv;
510 PL_utf8_upper = Nullsv;
511 PL_utf8_lower = Nullsv;
512 PL_utf8_print = Nullsv;
513 PL_utf8_punct = Nullsv;
514 PL_utf8_xdigit = Nullsv;
515 PL_utf8_mark = Nullsv;
516 PL_utf8_toupper = Nullsv;
517 PL_utf8_totitle = Nullsv;
518 PL_utf8_tolower = Nullsv;
520 if (!specialWARN(PL_compiling.cop_warnings))
521 SvREFCNT_dec(PL_compiling.cop_warnings);
522 PL_compiling.cop_warnings = Nullsv;
524 /* Prepare to destruct main symbol table. */
529 SvREFCNT_dec(PL_curstname);
530 PL_curstname = Nullsv;
532 /* clear queued errors */
533 SvREFCNT_dec(PL_errors);
537 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
538 if (PL_scopestack_ix != 0)
539 Perl_warner(aTHX_ WARN_INTERNAL,
540 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
541 (long)PL_scopestack_ix);
542 if (PL_savestack_ix != 0)
543 Perl_warner(aTHX_ WARN_INTERNAL,
544 "Unbalanced saves: %ld more saves than restores\n",
545 (long)PL_savestack_ix);
546 if (PL_tmps_floor != -1)
547 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
548 (long)PL_tmps_floor + 1);
549 if (cxstack_ix != -1)
550 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
551 (long)cxstack_ix + 1);
554 /* Now absolutely destruct everything, somehow or other, loops or no. */
556 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
557 while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
558 last_sv_count = PL_sv_count;
561 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
562 SvFLAGS(PL_strtab) |= SVt_PVHV;
564 /* Destruct the global string table. */
566 /* Yell and reset the HeVAL() slots that are still holding refcounts,
567 * so that sv_free() won't fail on them.
575 max = HvMAX(PL_strtab);
576 array = HvARRAY(PL_strtab);
579 if (hent && ckWARN_d(WARN_INTERNAL)) {
580 Perl_warner(aTHX_ WARN_INTERNAL,
581 "Unbalanced string table refcount: (%d) for \"%s\"",
582 HeVAL(hent) - Nullsv, HeKEY(hent));
583 HeVAL(hent) = Nullsv;
593 SvREFCNT_dec(PL_strtab);
595 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
596 Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
600 /* No SVs have survived, need to clean out */
601 Safefree(PL_origfilename);
602 Safefree(PL_archpat_auto);
603 Safefree(PL_reg_start_tmp);
605 Safefree(PL_reg_curpm);
606 Safefree(PL_reg_poscache);
607 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
608 Safefree(PL_op_mask);
610 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
612 DEBUG_P(debprofdump());
614 MUTEX_DESTROY(&PL_strtab_mutex);
615 MUTEX_DESTROY(&PL_sv_mutex);
616 MUTEX_DESTROY(&PL_eval_mutex);
617 MUTEX_DESTROY(&PL_cred_mutex);
618 COND_DESTROY(&PL_eval_cond);
619 #ifdef EMULATE_ATOMIC_REFCOUNTS
620 MUTEX_DESTROY(&PL_svref_mutex);
621 #endif /* EMULATE_ATOMIC_REFCOUNTS */
623 /* As the penultimate thing, free the non-arena SV for thrsv */
624 Safefree(SvPVX(PL_thrsv));
625 Safefree(SvANY(PL_thrsv));
628 #endif /* USE_THREADS */
630 /* As the absolutely last thing, free the non-arena SV for mess() */
633 /* it could have accumulated taint magic */
634 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
637 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
638 moremagic = mg->mg_moremagic;
639 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
640 Safefree(mg->mg_ptr);
644 /* we know that type >= SVt_PV */
645 SvOOK_off(PL_mess_sv);
646 Safefree(SvPVX(PL_mess_sv));
647 Safefree(SvANY(PL_mess_sv));
648 Safefree(PL_mess_sv);
656 #if defined(PERL_OBJECT)
664 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
666 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
667 PL_exitlist[PL_exitlistlen].fn = fn;
668 PL_exitlist[PL_exitlistlen].ptr = ptr;
673 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
683 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
686 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
687 setuid perl scripts securely.\n");
691 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
692 _dyld_lookup_and_bind
693 ("__environ", (unsigned long *) &environ_pointer, NULL);
698 #ifndef VMS /* VMS doesn't have environ array */
699 PL_origenviron = environ;
704 /* Come here if running an undumped a.out. */
706 PL_origfilename = savepv(argv[0]);
707 PL_do_undump = FALSE;
708 cxstack_ix = -1; /* start label stack again */
710 init_postdump_symbols(argc,argv,env);
715 PL_curpad = AvARRAY(PL_comppad);
716 op_free(PL_main_root);
717 PL_main_root = Nullop;
719 PL_main_start = Nullop;
720 SvREFCNT_dec(PL_main_cv);
724 oldscope = PL_scopestack_ix;
725 PL_dowarn = G_WARN_OFF;
727 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_parse_body),
732 call_list(oldscope, PL_stopav);
738 /* my_exit() was called */
739 while (PL_scopestack_ix > oldscope)
742 PL_curstash = PL_defstash;
744 call_list(oldscope, PL_stopav);
745 return STATUS_NATIVE_EXPORT;
747 PerlIO_printf(Perl_error_log, "panic: top_env\n");
754 S_parse_body(pTHX_ va_list args)
757 int argc = PL_origargc;
758 char **argv = PL_origargv;
759 char **env = va_arg(args, char**);
760 char *scriptname = NULL;
762 VOL bool dosearch = FALSE;
767 char *cddir = Nullch;
769 XSINIT_t xsinit = va_arg(args, XSINIT_t);
771 sv_setpvn(PL_linestr,"",0);
772 sv = newSVpvn("",0); /* first used for -I flags */
776 for (argc--,argv++; argc > 0; argc--,argv++) {
777 if (argv[0][0] != '-' || !argv[0][1])
781 validarg = " PHOOEY ";
788 #ifndef PERL_STRICT_CR
812 if (s = moreswitches(s))
822 if (PL_euid != PL_uid || PL_egid != PL_gid)
823 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
825 PL_e_script = newSVpvn("",0);
826 filter_add(read_e_script, NULL);
829 sv_catpv(PL_e_script, s);
831 sv_catpv(PL_e_script, argv[1]);
835 Perl_croak(aTHX_ "No code specified for -e");
836 sv_catpv(PL_e_script, "\n");
839 case 'I': /* -I handled both here and in moreswitches() */
841 if (!*++s && (s=argv[1]) != Nullch) {
844 while (s && isSPACE(*s))
848 for (e = s; *e && !isSPACE(*e); e++) ;
855 } /* XXX else croak? */
859 PL_preprocess = TRUE;
869 PL_preambleav = newAV();
870 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
872 PL_Sv = newSVpv("print myconfig();",0);
874 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
876 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
878 sv_catpv(PL_Sv,"\" Compile-time options:");
880 sv_catpv(PL_Sv," DEBUGGING");
883 sv_catpv(PL_Sv," MULTIPLICITY");
886 sv_catpv(PL_Sv," USE_THREADS");
889 sv_catpv(PL_Sv," PERL_OBJECT");
891 # ifdef PERL_IMPLICIT_CONTEXT
892 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
894 # ifdef PERL_IMPLICIT_SYS
895 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
897 sv_catpv(PL_Sv,"\\n\",");
899 #if defined(LOCAL_PATCH_COUNT)
900 if (LOCAL_PATCH_COUNT > 0) {
902 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
903 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
904 if (PL_localpatches[i])
905 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
909 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
912 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
914 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
919 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
920 print \" \\%ENV:\\n @env\\n\" if @env; \
921 print \" \\@INC:\\n @INC\\n\";");
924 PL_Sv = newSVpv("config_vars(qw(",0);
925 sv_catpv(PL_Sv, ++s);
926 sv_catpv(PL_Sv, "))");
929 av_push(PL_preambleav, PL_Sv);
930 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
941 if (!*++s || isSPACE(*s)) {
945 /* catch use of gnu style long options */
946 if (strEQ(s, "version")) {
950 if (strEQ(s, "help")) {
957 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
963 #ifndef SECURE_INTERNAL_GETENV
966 (s = PerlEnv_getenv("PERL5OPT"))) {
969 if (*s == '-' && *(s+1) == 'T')
982 if (!strchr("DIMUdmw", *s))
983 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
990 scriptname = argv[0];
993 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
995 else if (scriptname == Nullch) {
997 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1005 open_script(scriptname,dosearch,sv,&fdscript);
1007 validate_suid(validarg, scriptname,fdscript);
1009 #if defined(SIGCHLD) || defined(SIGCLD)
1012 # define SIGCHLD SIGCLD
1014 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1015 if (sigstate == SIG_IGN) {
1016 if (ckWARN(WARN_SIGNAL))
1017 Perl_warner(aTHX_ WARN_SIGNAL,
1018 "Can't ignore signal CHLD, forcing to default");
1019 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1026 if (cddir && PerlDir_chdir(cddir) < 0)
1027 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1031 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1032 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1033 CvUNIQUE_on(PL_compcv);
1035 PL_comppad = newAV();
1036 av_push(PL_comppad, Nullsv);
1037 PL_curpad = AvARRAY(PL_comppad);
1038 PL_comppad_name = newAV();
1039 PL_comppad_name_fill = 0;
1040 PL_min_intro_pending = 0;
1043 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
1044 PL_curpad[0] = (SV*)newAV();
1045 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
1046 CvOWNER(PL_compcv) = 0;
1047 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1048 MUTEX_INIT(CvMUTEXP(PL_compcv));
1049 #endif /* USE_THREADS */
1051 comppadlist = newAV();
1052 AvREAL_off(comppadlist);
1053 av_store(comppadlist, 0, (SV*)PL_comppad_name);
1054 av_store(comppadlist, 1, (SV*)PL_comppad);
1055 CvPADLIST(PL_compcv) = comppadlist;
1057 boot_core_UNIVERSAL();
1058 boot_core_xsutils();
1061 (*xsinit)(aTHXo); /* in case linked C routines want magical variables */
1062 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
1070 init_predump_symbols();
1071 /* init_postdump_symbols not currently designed to be called */
1072 /* more than once (ENV isn't cleared first, for example) */
1073 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
1075 init_postdump_symbols(argc,argv,env);
1079 /* now parse the script */
1081 SETERRNO(0,SS$_NORMAL);
1083 if (yyparse() || PL_error_count) {
1085 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1087 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1091 CopLINE_set(PL_curcop, 0);
1092 PL_curstash = PL_defstash;
1093 PL_preprocess = FALSE;
1095 SvREFCNT_dec(PL_e_script);
1096 PL_e_script = Nullsv;
1099 /* now that script is parsed, we can modify record separator */
1100 SvREFCNT_dec(PL_rs);
1101 PL_rs = SvREFCNT_inc(PL_nrs);
1102 sv_setsv(get_sv("/", TRUE), PL_rs);
1107 SAVECOPFILE(PL_curcop);
1108 SAVECOPLINE(PL_curcop);
1109 gv_check(PL_defstash);
1116 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1117 dump_mstats("after compilation:");
1136 oldscope = PL_scopestack_ix;
1139 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
1142 cxstack_ix = -1; /* start context stack again */
1144 case 0: /* normal completion */
1145 case 2: /* my_exit() */
1146 while (PL_scopestack_ix > oldscope)
1149 PL_curstash = PL_defstash;
1150 if (PL_endav && !PL_minus_c)
1151 call_list(oldscope, PL_endav);
1153 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1154 dump_mstats("after execution: ");
1156 return STATUS_NATIVE_EXPORT;
1159 POPSTACK_TO(PL_mainstack);
1162 PerlIO_printf(Perl_error_log, "panic: restartop\n");
1172 S_run_body(pTHX_ va_list args)
1175 I32 oldscope = va_arg(args, I32);
1177 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1178 PL_sawampersand ? "Enabling" : "Omitting"));
1180 if (!PL_restartop) {
1181 DEBUG_x(dump_all());
1182 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1183 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1187 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1190 if (PERLDB_SINGLE && PL_DBsingle)
1191 sv_setiv(PL_DBsingle, 1);
1193 call_list(oldscope, PL_initav);
1199 PL_op = PL_restartop;
1203 else if (PL_main_start) {
1204 CvDEPTH(PL_main_cv) = 1;
1205 PL_op = PL_main_start;
1215 Perl_get_sv(pTHX_ const char *name, I32 create)
1219 if (name[1] == '\0' && !isALPHA(name[0])) {
1220 PADOFFSET tmp = find_threadsv(name);
1221 if (tmp != NOT_IN_PAD) {
1223 return THREADSV(tmp);
1226 #endif /* USE_THREADS */
1227 gv = gv_fetchpv(name, create, SVt_PV);
1234 Perl_get_av(pTHX_ const char *name, I32 create)
1236 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1245 Perl_get_hv(pTHX_ const char *name, I32 create)
1247 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1256 Perl_get_cv(pTHX_ const char *name, I32 create)
1258 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1259 /* XXX unsafe for threads if eval_owner isn't held */
1260 /* XXX this is probably not what they think they're getting.
1261 * It has the same effect as "sub name;", i.e. just a forward
1263 if (create && !GvCVu(gv))
1264 return newSUB(start_subparse(FALSE, 0),
1265 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1273 /* Be sure to refetch the stack pointer after calling these routines. */
1276 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1278 /* See G_* flags in cop.h */
1279 /* null terminated arg list */
1286 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1291 return call_pv(sub_name, flags);
1295 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1296 /* name of the subroutine */
1297 /* See G_* flags in cop.h */
1299 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1303 Perl_call_method(pTHX_ const char *methname, I32 flags)
1304 /* name of the subroutine */
1305 /* See G_* flags in cop.h */
1311 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1316 return call_sv(*PL_stack_sp--, flags);
1319 /* May be called with any of a CV, a GV, or an SV containing the name. */
1321 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1323 /* See G_* flags in cop.h */
1326 LOGOP myop; /* fake syntax tree node */
1330 bool oldcatch = CATCH_GET;
1335 if (flags & G_DISCARD) {
1340 Zero(&myop, 1, LOGOP);
1341 myop.op_next = Nullop;
1342 if (!(flags & G_NOARGS))
1343 myop.op_flags |= OPf_STACKED;
1344 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1345 (flags & G_ARRAY) ? OPf_WANT_LIST :
1350 EXTEND(PL_stack_sp, 1);
1351 *++PL_stack_sp = sv;
1353 oldscope = PL_scopestack_ix;
1355 if (PERLDB_SUB && PL_curstash != PL_debstash
1356 /* Handle first BEGIN of -d. */
1357 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1358 /* Try harder, since this may have been a sighandler, thus
1359 * curstash may be meaningless. */
1360 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1361 && !(flags & G_NODEBUG))
1362 PL_op->op_private |= OPpENTERSUB_DB;
1364 if (!(flags & G_EVAL)) {
1366 call_xbody((OP*)&myop, FALSE);
1367 retval = PL_stack_sp - (PL_stack_base + oldmark);
1368 CATCH_SET(oldcatch);
1371 cLOGOP->op_other = PL_op;
1373 /* we're trying to emulate pp_entertry() here */
1375 register PERL_CONTEXT *cx;
1376 I32 gimme = GIMME_V;
1381 push_return(PL_op->op_next);
1382 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1384 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1386 PL_in_eval = EVAL_INEVAL;
1387 if (flags & G_KEEPERR)
1388 PL_in_eval |= EVAL_KEEPERR;
1395 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1399 retval = PL_stack_sp - (PL_stack_base + oldmark);
1400 if (!(flags & G_KEEPERR))
1407 /* my_exit() was called */
1408 PL_curstash = PL_defstash;
1410 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1411 Perl_croak(aTHX_ "Callback called exit");
1416 PL_op = PL_restartop;
1420 PL_stack_sp = PL_stack_base + oldmark;
1421 if (flags & G_ARRAY)
1425 *++PL_stack_sp = &PL_sv_undef;
1430 if (PL_scopestack_ix > oldscope) {
1434 register PERL_CONTEXT *cx;
1445 if (flags & G_DISCARD) {
1446 PL_stack_sp = PL_stack_base + oldmark;
1456 S_call_body(pTHX_ va_list args)
1458 OP *myop = va_arg(args, OP*);
1459 int is_eval = va_arg(args, int);
1461 call_xbody(myop, is_eval);
1466 S_call_xbody(pTHX_ OP *myop, int is_eval)
1470 if (PL_op == myop) {
1472 PL_op = Perl_pp_entereval(aTHX);
1474 PL_op = Perl_pp_entersub(aTHX);
1480 /* Eval a string. The G_EVAL flag is always assumed. */
1483 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1485 /* See G_* flags in cop.h */
1488 UNOP myop; /* fake syntax tree node */
1489 I32 oldmark = SP - PL_stack_base;
1496 if (flags & G_DISCARD) {
1503 Zero(PL_op, 1, UNOP);
1504 EXTEND(PL_stack_sp, 1);
1505 *++PL_stack_sp = sv;
1506 oldscope = PL_scopestack_ix;
1508 if (!(flags & G_NOARGS))
1509 myop.op_flags = OPf_STACKED;
1510 myop.op_next = Nullop;
1511 myop.op_type = OP_ENTEREVAL;
1512 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1513 (flags & G_ARRAY) ? OPf_WANT_LIST :
1515 if (flags & G_KEEPERR)
1516 myop.op_flags |= OPf_SPECIAL;
1519 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1523 retval = PL_stack_sp - (PL_stack_base + oldmark);
1524 if (!(flags & G_KEEPERR))
1531 /* my_exit() was called */
1532 PL_curstash = PL_defstash;
1534 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1535 Perl_croak(aTHX_ "Callback called exit");
1540 PL_op = PL_restartop;
1544 PL_stack_sp = PL_stack_base + oldmark;
1545 if (flags & G_ARRAY)
1549 *++PL_stack_sp = &PL_sv_undef;
1554 if (flags & G_DISCARD) {
1555 PL_stack_sp = PL_stack_base + oldmark;
1565 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1568 SV* sv = newSVpv(p, 0);
1571 eval_sv(sv, G_SCALAR);
1578 if (croak_on_error && SvTRUE(ERRSV)) {
1580 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1586 /* Require a module. */
1589 Perl_require_pv(pTHX_ const char *pv)
1593 PUSHSTACKi(PERLSI_REQUIRE);
1595 sv = sv_newmortal();
1596 sv_setpv(sv, "require '");
1599 eval_sv(sv, G_DISCARD);
1605 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1609 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1610 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1614 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
1616 /* This message really ought to be max 23 lines.
1617 * Removed -h because the user already knows that opton. Others? */
1619 static char *usage_msg[] = {
1620 "-0[octal] specify record separator (\\0, if no argument)",
1621 "-a autosplit mode with -n or -p (splits $_ into @F)",
1622 "-c check syntax only (runs BEGIN and END blocks)",
1623 "-d[:debugger] run program under debugger",
1624 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1625 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1626 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1627 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1628 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1629 "-l[octal] enable line ending processing, specifies line terminator",
1630 "-[mM][-]module execute `use/no module...' before executing program",
1631 "-n assume 'while (<>) { ... }' loop around program",
1632 "-p assume loop like -n but print line also, like sed",
1633 "-P run program through C preprocessor before compilation",
1634 "-s enable rudimentary parsing for switches after programfile",
1635 "-S look for programfile using PATH environment variable",
1636 "-T enable tainting checks",
1637 "-u dump core after parsing program",
1638 "-U allow unsafe operations",
1639 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1640 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1641 "-w enable many useful warnings (RECOMMENDED)",
1642 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1646 char **p = usage_msg;
1648 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1650 printf("\n %s", *p++);
1653 /* This routine handles any switches that can be given during run */
1656 Perl_moreswitches(pTHX_ char *s)
1665 rschar = (U32)scan_oct(s, 4, &numlen);
1666 SvREFCNT_dec(PL_nrs);
1667 if (rschar & ~((U8)~0))
1668 PL_nrs = &PL_sv_undef;
1669 else if (!rschar && numlen >= 2)
1670 PL_nrs = newSVpvn("", 0);
1673 PL_nrs = newSVpvn(&ch, 1);
1679 PL_splitstr = savepv(s + 1);
1693 if (*s == ':' || *s == '=') {
1694 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1698 PL_perldb = PERLDB_ALL;
1706 if (isALPHA(s[1])) {
1707 static char debopts[] = "psltocPmfrxuLHXDS";
1710 for (s++; *s && (d = strchr(debopts,*s)); s++)
1711 PL_debug |= 1 << (d - debopts);
1714 PL_debug = atoi(s+1);
1715 for (s++; isDIGIT(*s); s++) ;
1717 PL_debug |= 0x80000000;
1720 if (ckWARN_d(WARN_DEBUGGING))
1721 Perl_warner(aTHX_ WARN_DEBUGGING,
1722 "Recompile perl with -DDEBUGGING to use -D switch\n");
1723 for (s++; isALNUM(*s); s++) ;
1729 usage(PL_origargv[0]);
1733 Safefree(PL_inplace);
1734 PL_inplace = savepv(s+1);
1736 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1739 if (*s == '-') /* Additional switches on #! line. */
1743 case 'I': /* -I handled both here and in parse_perl() */
1746 while (*s && isSPACE(*s))
1750 for (e = s; *e && !isSPACE(*e); e++) ;
1751 p = savepvn(s, e-s);
1757 Perl_croak(aTHX_ "No space allowed after -I");
1765 PL_ors = savepv("\n");
1767 *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
1772 if (RsPARA(PL_nrs)) {
1777 PL_ors = SvPV(PL_nrs, PL_orslen);
1778 PL_ors = savepvn(PL_ors, PL_orslen);
1782 forbid_setid("-M"); /* XXX ? */
1785 forbid_setid("-m"); /* XXX ? */
1790 /* -M-foo == 'no foo' */
1791 if (*s == '-') { use = "no "; ++s; }
1792 sv = newSVpv(use,0);
1794 /* We allow -M'Module qw(Foo Bar)' */
1795 while(isALNUM(*s) || *s==':') ++s;
1797 sv_catpv(sv, start);
1798 if (*(start-1) == 'm') {
1800 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
1801 sv_catpv( sv, " ()");
1804 sv_catpvn(sv, start, s-start);
1805 sv_catpv(sv, " split(/,/,q{");
1811 PL_preambleav = newAV();
1812 av_push(PL_preambleav, sv);
1815 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1827 PL_doswitches = TRUE;
1832 Perl_croak(aTHX_ "Too late for \"-T\" option");
1836 PL_do_undump = TRUE;
1844 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
1845 printf("\nThis is perl, version %d.%03d_%02d built for %s",
1846 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME);
1848 printf("\nThis is perl, version %s built for %s",
1849 PL_patchlevel, ARCHNAME);
1851 #if defined(LOCAL_PATCH_COUNT)
1852 if (LOCAL_PATCH_COUNT > 0)
1853 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1854 (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1857 printf("\n\nCopyright 1987-1999, Larry Wall\n");
1859 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1862 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1863 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
1866 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1867 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
1870 printf("atariST series port, ++jrb bammi@cadence.com\n");
1873 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
1876 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1879 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
1882 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
1885 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
1888 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
1891 printf("MiNT port by Guido Flohr, 1997-1999\n");
1893 #ifdef BINARY_BUILD_NOTICE
1894 BINARY_BUILD_NOTICE;
1897 Perl may be copied only under the terms of either the Artistic License or the\n\
1898 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1899 Complete documentation for Perl, including FAQ lists, should be found on\n\
1900 this system using `man perl' or `perldoc perl'. If you have access to the\n\
1901 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1904 if (! (PL_dowarn & G_WARN_ALL_MASK))
1905 PL_dowarn |= G_WARN_ON;
1909 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1910 PL_compiling.cop_warnings = WARN_ALL ;
1914 PL_dowarn = G_WARN_ALL_OFF;
1915 PL_compiling.cop_warnings = WARN_NONE ;
1920 if (s[1] == '-') /* Additional switches on #! line. */
1925 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1931 #ifdef ALTERNATE_SHEBANG
1932 case 'S': /* OS/2 needs -S on "extproc" line. */
1940 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
1945 /* compliments of Tom Christiansen */
1947 /* unexec() can be found in the Gnu emacs distribution */
1948 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1951 Perl_my_unexec(pTHX)
1959 prog = newSVpv(BIN_EXP, 0);
1960 sv_catpv(prog, "/perl");
1961 file = newSVpv(PL_origfilename, 0);
1962 sv_catpv(file, ".perldump");
1964 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1965 /* unexec prints msg to stderr in case of failure */
1966 PerlProc_exit(status);
1969 # include <lib$routines.h>
1970 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1972 ABORT(); /* for use with undump */
1977 /* initialize curinterp */
1982 #ifdef PERL_OBJECT /* XXX kludge */
1985 PL_chopset = " \n-"; \
1986 PL_copline = NOLINE; \
1987 PL_curcop = &PL_compiling;\
1988 PL_curcopdb = NULL; \
1990 PL_dumpindent = 4; \
1991 PL_laststatval = -1; \
1992 PL_laststype = OP_STAT; \
1993 PL_maxscream = -1; \
1994 PL_maxsysfd = MAXSYSFD; \
1995 PL_statname = Nullsv; \
1996 PL_tmps_floor = -1; \
1998 PL_op_mask = NULL; \
1999 PL_laststatval = -1; \
2000 PL_laststype = OP_STAT; \
2001 PL_mess_sv = Nullsv; \
2002 PL_splitstr = " "; \
2003 PL_generation = 100; \
2004 PL_exitlist = NULL; \
2005 PL_exitlistlen = 0; \
2007 PL_in_clean_objs = FALSE; \
2008 PL_in_clean_all = FALSE; \
2009 PL_profiledata = NULL; \
2011 PL_rsfp_filters = Nullav; \
2016 # ifdef MULTIPLICITY
2017 # define PERLVAR(var,type)
2018 # define PERLVARA(var,n,type)
2019 # if defined(PERL_IMPLICIT_CONTEXT)
2020 # if defined(USE_THREADS)
2021 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2022 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2023 # else /* !USE_THREADS */
2024 # define PERLVARI(var,type,init) aTHX->var = init;
2025 # define PERLVARIC(var,type,init) aTHX->var = init;
2026 # endif /* USE_THREADS */
2028 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2029 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2031 # include "intrpvar.h"
2032 # ifndef USE_THREADS
2033 # include "thrdvar.h"
2040 # define PERLVAR(var,type)
2041 # define PERLVARA(var,n,type)
2042 # define PERLVARI(var,type,init) PL_##var = init;
2043 # define PERLVARIC(var,type,init) PL_##var = init;
2044 # include "intrpvar.h"
2045 # ifndef USE_THREADS
2046 # include "thrdvar.h"
2058 S_init_main_stash(pTHX)
2063 /* Note that strtab is a rather special HV. Assumptions are made
2064 about not iterating on it, and not adding tie magic to it.
2065 It is properly deallocated in perl_destruct() */
2066 PL_strtab = newHV();
2068 MUTEX_INIT(&PL_strtab_mutex);
2070 HvSHAREKEYS_off(PL_strtab); /* mandatory */
2071 hv_ksplit(PL_strtab, 512);
2073 PL_curstash = PL_defstash = newHV();
2074 PL_curstname = newSVpvn("main",4);
2075 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2076 SvREFCNT_dec(GvHV(gv));
2077 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2079 HvNAME(PL_defstash) = savepv("main");
2080 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2081 GvMULTI_on(PL_incgv);
2082 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2083 GvMULTI_on(PL_hintgv);
2084 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2085 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2086 GvMULTI_on(PL_errgv);
2087 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2088 GvMULTI_on(PL_replgv);
2089 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
2090 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2091 sv_setpvn(ERRSV, "", 0);
2092 PL_curstash = PL_defstash;
2093 CopSTASH_set(&PL_compiling, PL_defstash);
2094 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2095 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2096 /* We must init $/ before switches are processed. */
2097 sv_setpvn(get_sv("/", TRUE), "\n", 1);
2101 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2109 PL_origfilename = savepv("-e");
2112 /* if find_script() returns, it returns a malloc()-ed value */
2113 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2115 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2116 char *s = scriptname + 8;
2117 *fdscript = atoi(s);
2121 scriptname = savepv(s + 1);
2122 Safefree(PL_origfilename);
2123 PL_origfilename = scriptname;
2128 CopFILE_set(PL_curcop, PL_origfilename);
2129 if (strEQ(PL_origfilename,"-"))
2131 if (*fdscript >= 0) {
2132 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2133 #if defined(HAS_FCNTL) && defined(F_SETFD)
2135 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2138 else if (PL_preprocess) {
2139 char *cpp_cfg = CPPSTDIN;
2140 SV *cpp = newSVpvn("",0);
2141 SV *cmd = NEWSV(0,0);
2143 if (strEQ(cpp_cfg, "cppstdin"))
2144 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2145 sv_catpv(cpp, cpp_cfg);
2148 sv_catpv(sv,PRIVLIB_EXP);
2151 Perl_sv_setpvf(aTHX_ cmd, "\
2152 sed %s -e \"/^[^#]/b\" \
2153 -e \"/^#[ ]*include[ ]/b\" \
2154 -e \"/^#[ ]*define[ ]/b\" \
2155 -e \"/^#[ ]*if[ ]/b\" \
2156 -e \"/^#[ ]*ifdef[ ]/b\" \
2157 -e \"/^#[ ]*ifndef[ ]/b\" \
2158 -e \"/^#[ ]*else/b\" \
2159 -e \"/^#[ ]*elif[ ]/b\" \
2160 -e \"/^#[ ]*undef[ ]/b\" \
2161 -e \"/^#[ ]*endif/b\" \
2164 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2167 Perl_sv_setpvf(aTHX_ cmd, "\
2168 %s %s -e '/^[^#]/b' \
2169 -e '/^#[ ]*include[ ]/b' \
2170 -e '/^#[ ]*define[ ]/b' \
2171 -e '/^#[ ]*if[ ]/b' \
2172 -e '/^#[ ]*ifdef[ ]/b' \
2173 -e '/^#[ ]*ifndef[ ]/b' \
2174 -e '/^#[ ]*else/b' \
2175 -e '/^#[ ]*elif[ ]/b' \
2176 -e '/^#[ ]*undef[ ]/b' \
2177 -e '/^#[ ]*endif/b' \
2181 Perl_sv_setpvf(aTHX_ cmd, "\
2182 %s %s -e '/^[^#]/b' \
2183 -e '/^#[ ]*include[ ]/b' \
2184 -e '/^#[ ]*define[ ]/b' \
2185 -e '/^#[ ]*if[ ]/b' \
2186 -e '/^#[ ]*ifdef[ ]/b' \
2187 -e '/^#[ ]*ifndef[ ]/b' \
2188 -e '/^#[ ]*else/b' \
2189 -e '/^#[ ]*elif[ ]/b' \
2190 -e '/^#[ ]*undef[ ]/b' \
2191 -e '/^#[ ]*endif/b' \
2200 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2202 scriptname, cpp, sv, CPPMINUS);
2203 PL_doextract = FALSE;
2204 #ifdef IAMSUID /* actually, this is caught earlier */
2205 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2207 (void)seteuid(PL_uid); /* musn't stay setuid root */
2210 (void)setreuid((Uid_t)-1, PL_uid);
2212 #ifdef HAS_SETRESUID
2213 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2215 PerlProc_setuid(PL_uid);
2219 if (PerlProc_geteuid() != PL_uid)
2220 Perl_croak(aTHX_ "Can't do seteuid!\n");
2222 #endif /* IAMSUID */
2223 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2227 else if (!*scriptname) {
2228 forbid_setid("program input from stdin");
2229 PL_rsfp = PerlIO_stdin();
2232 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2233 #if defined(HAS_FCNTL) && defined(F_SETFD)
2235 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2240 #ifndef IAMSUID /* in case script is not readable before setuid */
2242 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2243 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2246 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2247 Perl_croak(aTHX_ "Can't do setuid\n");
2251 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2252 CopFILE(PL_curcop), Strerror(errno));
2257 * I_SYSSTATVFS HAS_FSTATVFS
2259 * I_STATFS HAS_FSTATFS
2260 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2261 * here so that metaconfig picks them up. */
2265 S_fd_on_nosuid_fs(pTHX_ int fd)
2267 int check_okay = 0; /* able to do all the required sys/libcalls */
2268 int on_nosuid = 0; /* the fd is on a nosuid fs */
2270 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2271 * fstatvfs() is UNIX98.
2272 * fstatfs() is 4.3 BSD.
2273 * ustat()+getmnt() is pre-4.3 BSD.
2274 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2275 * an irrelevant filesystem while trying to reach the right one.
2278 # ifdef HAS_FSTATVFS
2279 struct statvfs stfs;
2280 check_okay = fstatvfs(fd, &stfs) == 0;
2281 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2283 # ifdef PERL_MOUNT_NOSUID
2284 # if defined(HAS_FSTATFS) && \
2285 defined(HAS_STRUCT_STATFS) && \
2286 defined(HAS_STRUCT_STATFS_F_FLAGS)
2288 check_okay = fstatfs(fd, &stfs) == 0;
2289 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2291 # if defined(HAS_FSTAT) && \
2292 defined(HAS_USTAT) && \
2293 defined(HAS_GETMNT) && \
2294 defined(HAS_STRUCT_FS_DATA) &&
2297 if (fstat(fd, &fdst) == 0) {
2299 if (ustat(fdst.st_dev, &us) == 0) {
2301 /* NOSTAT_ONE here because we're not examining fields which
2302 * vary between that case and STAT_ONE. */
2303 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2304 size_t cmplen = sizeof(us.f_fname);
2305 if (sizeof(fsd.fd_req.path) < cmplen)
2306 cmplen = sizeof(fsd.fd_req.path);
2307 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2308 fdst.st_dev == fsd.fd_req.dev) {
2310 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2316 # endif /* fstat+ustat+getmnt */
2317 # endif /* fstatfs */
2319 # if defined(HAS_GETMNTENT) && \
2320 defined(HAS_HASMNTOPT) && \
2321 defined(MNTOPT_NOSUID)
2322 FILE *mtab = fopen("/etc/mtab", "r");
2323 struct mntent *entry;
2324 struct stat stb, fsb;
2326 if (mtab && (fstat(fd, &stb) == 0)) {
2327 while (entry = getmntent(mtab)) {
2328 if (stat(entry->mnt_dir, &fsb) == 0
2329 && fsb.st_dev == stb.st_dev)
2331 /* found the filesystem */
2333 if (hasmntopt(entry, MNTOPT_NOSUID))
2336 } /* A single fs may well fail its stat(). */
2341 # endif /* getmntent+hasmntopt */
2342 # endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */
2343 # endif /* statvfs */
2346 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
2349 #endif /* IAMSUID */
2352 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2356 /* do we need to emulate setuid on scripts? */
2358 /* This code is for those BSD systems that have setuid #! scripts disabled
2359 * in the kernel because of a security problem. Merely defining DOSUID
2360 * in perl will not fix that problem, but if you have disabled setuid
2361 * scripts in the kernel, this will attempt to emulate setuid and setgid
2362 * on scripts that have those now-otherwise-useless bits set. The setuid
2363 * root version must be called suidperl or sperlN.NNN. If regular perl
2364 * discovers that it has opened a setuid script, it calls suidperl with
2365 * the same argv that it had. If suidperl finds that the script it has
2366 * just opened is NOT setuid root, it sets the effective uid back to the
2367 * uid. We don't just make perl setuid root because that loses the
2368 * effective uid we had before invoking perl, if it was different from the
2371 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2372 * be defined in suidperl only. suidperl must be setuid root. The
2373 * Configure script will set this up for you if you want it.
2380 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2381 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2382 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2387 #ifndef HAS_SETREUID
2388 /* On this access check to make sure the directories are readable,
2389 * there is actually a small window that the user could use to make
2390 * filename point to an accessible directory. So there is a faint
2391 * chance that someone could execute a setuid script down in a
2392 * non-accessible directory. I don't know what to do about that.
2393 * But I don't think it's too important. The manual lies when
2394 * it says access() is useful in setuid programs.
2396 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
2397 Perl_croak(aTHX_ "Permission denied");
2399 /* If we can swap euid and uid, then we can determine access rights
2400 * with a simple stat of the file, and then compare device and
2401 * inode to make sure we did stat() on the same file we opened.
2402 * Then we just have to make sure he or she can execute it.
2405 struct stat tmpstatbuf;
2409 setreuid(PL_euid,PL_uid) < 0
2412 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2415 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2416 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2417 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
2418 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2419 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2420 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2421 Perl_croak(aTHX_ "Permission denied");
2423 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2424 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2425 (void)PerlIO_close(PL_rsfp);
2426 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2427 PerlIO_printf(PL_rsfp,
2428 "User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2429 (Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n",
2430 PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2431 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2433 PL_statbuf.st_uid, PL_statbuf.st_gid);
2434 (void)PerlProc_pclose(PL_rsfp);
2436 Perl_croak(aTHX_ "Permission denied\n");
2440 setreuid(PL_uid,PL_euid) < 0
2442 # if defined(HAS_SETRESUID)
2443 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2446 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2447 Perl_croak(aTHX_ "Can't reswap uid and euid");
2448 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2449 Perl_croak(aTHX_ "Permission denied\n");
2451 #endif /* HAS_SETREUID */
2452 #endif /* IAMSUID */
2454 if (!S_ISREG(PL_statbuf.st_mode))
2455 Perl_croak(aTHX_ "Permission denied");
2456 if (PL_statbuf.st_mode & S_IWOTH)
2457 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2458 PL_doswitches = FALSE; /* -s is insecure in suid */
2459 CopLINE_inc(PL_curcop);
2460 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2461 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2462 Perl_croak(aTHX_ "No #! line");
2463 s = SvPV(PL_linestr,n_a)+2;
2465 while (!isSPACE(*s)) s++;
2466 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2467 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2468 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2469 Perl_croak(aTHX_ "Not a perl script");
2470 while (*s == ' ' || *s == '\t') s++;
2472 * #! arg must be what we saw above. They can invoke it by
2473 * mentioning suidperl explicitly, but they may not add any strange
2474 * arguments beyond what #! says if they do invoke suidperl that way.
2476 len = strlen(validarg);
2477 if (strEQ(validarg," PHOOEY ") ||
2478 strnNE(s,validarg,len) || !isSPACE(s[len]))
2479 Perl_croak(aTHX_ "Args must match #! line");
2482 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2483 PL_euid == PL_statbuf.st_uid)
2485 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2486 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2487 #endif /* IAMSUID */
2489 if (PL_euid) { /* oops, we're not the setuid root perl */
2490 (void)PerlIO_close(PL_rsfp);
2493 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2495 Perl_croak(aTHX_ "Can't do setuid\n");
2498 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2500 (void)setegid(PL_statbuf.st_gid);
2503 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2505 #ifdef HAS_SETRESGID
2506 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2508 PerlProc_setgid(PL_statbuf.st_gid);
2512 if (PerlProc_getegid() != PL_statbuf.st_gid)
2513 Perl_croak(aTHX_ "Can't do setegid!\n");
2515 if (PL_statbuf.st_mode & S_ISUID) {
2516 if (PL_statbuf.st_uid != PL_euid)
2518 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2521 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2523 #ifdef HAS_SETRESUID
2524 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2526 PerlProc_setuid(PL_statbuf.st_uid);
2530 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2531 Perl_croak(aTHX_ "Can't do seteuid!\n");
2533 else if (PL_uid) { /* oops, mustn't run as root */
2535 (void)seteuid((Uid_t)PL_uid);
2538 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2540 #ifdef HAS_SETRESUID
2541 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2543 PerlProc_setuid((Uid_t)PL_uid);
2547 if (PerlProc_geteuid() != PL_uid)
2548 Perl_croak(aTHX_ "Can't do seteuid!\n");
2551 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2552 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
2555 else if (PL_preprocess)
2556 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2557 else if (fdscript >= 0)
2558 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2560 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2562 /* We absolutely must clear out any saved ids here, so we */
2563 /* exec the real perl, substituting fd script for scriptname. */
2564 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2565 PerlIO_rewind(PL_rsfp);
2566 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2567 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2568 if (!PL_origargv[which])
2569 Perl_croak(aTHX_ "Permission denied");
2570 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2571 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2572 #if defined(HAS_FCNTL) && defined(F_SETFD)
2573 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2575 PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
2576 Perl_croak(aTHX_ "Can't do setuid\n");
2577 #endif /* IAMSUID */
2579 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2580 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2582 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2583 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2585 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2588 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2589 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2590 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2591 /* not set-id, must be wrapped */
2597 S_find_beginning(pTHX)
2599 register char *s, *s2;
2601 /* skip forward in input to the real script? */
2604 while (PL_doextract) {
2605 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2606 Perl_croak(aTHX_ "No Perl script found in input\n");
2607 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2608 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2609 PL_doextract = FALSE;
2610 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2612 while (*s == ' ' || *s == '\t') s++;
2614 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2615 if (strnEQ(s2-4,"perl",4))
2617 while (s = moreswitches(s)) ;
2627 PL_uid = PerlProc_getuid();
2628 PL_euid = PerlProc_geteuid();
2629 PL_gid = PerlProc_getgid();
2630 PL_egid = PerlProc_getegid();
2632 PL_uid |= PL_gid << 16;
2633 PL_euid |= PL_egid << 16;
2635 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2639 S_forbid_setid(pTHX_ char *s)
2641 if (PL_euid != PL_uid)
2642 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2643 if (PL_egid != PL_gid)
2644 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2648 Perl_init_debugger(pTHX)
2651 HV *ostash = PL_curstash;
2653 PL_curstash = PL_debstash;
2654 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2655 AvREAL_off(PL_dbargs);
2656 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2657 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2658 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2659 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
2660 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2661 sv_setiv(PL_DBsingle, 0);
2662 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2663 sv_setiv(PL_DBtrace, 0);
2664 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2665 sv_setiv(PL_DBsignal, 0);
2666 PL_curstash = ostash;
2669 #ifndef STRESS_REALLOC
2670 #define REASONABLE(size) (size)
2672 #define REASONABLE(size) (1) /* unreasonable */
2676 Perl_init_stacks(pTHX)
2678 /* start with 128-item stack and 8K cxstack */
2679 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2680 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2681 PL_curstackinfo->si_type = PERLSI_MAIN;
2682 PL_curstack = PL_curstackinfo->si_stack;
2683 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2685 PL_stack_base = AvARRAY(PL_curstack);
2686 PL_stack_sp = PL_stack_base;
2687 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2689 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2692 PL_tmps_max = REASONABLE(128);
2694 New(54,PL_markstack,REASONABLE(32),I32);
2695 PL_markstack_ptr = PL_markstack;
2696 PL_markstack_max = PL_markstack + REASONABLE(32);
2700 New(54,PL_scopestack,REASONABLE(32),I32);
2701 PL_scopestack_ix = 0;
2702 PL_scopestack_max = REASONABLE(32);
2704 New(54,PL_savestack,REASONABLE(128),ANY);
2705 PL_savestack_ix = 0;
2706 PL_savestack_max = REASONABLE(128);
2708 New(54,PL_retstack,REASONABLE(16),OP*);
2710 PL_retstack_max = REASONABLE(16);
2719 while (PL_curstackinfo->si_next)
2720 PL_curstackinfo = PL_curstackinfo->si_next;
2721 while (PL_curstackinfo) {
2722 PERL_SI *p = PL_curstackinfo->si_prev;
2723 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2724 Safefree(PL_curstackinfo->si_cxstack);
2725 Safefree(PL_curstackinfo);
2726 PL_curstackinfo = p;
2728 Safefree(PL_tmps_stack);
2729 Safefree(PL_markstack);
2730 Safefree(PL_scopestack);
2731 Safefree(PL_savestack);
2732 Safefree(PL_retstack);
2736 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2747 lex_start(PL_linestr);
2749 PL_subname = newSVpvn("main",4);
2753 S_init_predump_symbols(pTHX)
2760 sv_setpvn(get_sv("\"", TRUE), " ", 1);
2761 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2762 GvMULTI_on(PL_stdingv);
2763 io = GvIOp(PL_stdingv);
2764 IoIFP(io) = PerlIO_stdin();
2765 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2767 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2769 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2772 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
2774 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2776 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2778 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2779 GvMULTI_on(PL_stderrgv);
2780 io = GvIOp(PL_stderrgv);
2781 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
2782 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2784 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2786 PL_statname = NEWSV(66,0); /* last filename we did stat on */
2789 PL_osname = savepv(OSNAME);
2793 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
2800 argc--,argv++; /* skip name of script */
2801 if (PL_doswitches) {
2802 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2805 if (argv[0][1] == '-') {
2809 if (s = strchr(argv[0], '=')) {
2811 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2814 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2817 PL_toptarget = NEWSV(0,0);
2818 sv_upgrade(PL_toptarget, SVt_PVFM);
2819 sv_setpvn(PL_toptarget, "", 0);
2820 PL_bodytarget = NEWSV(0,0);
2821 sv_upgrade(PL_bodytarget, SVt_PVFM);
2822 sv_setpvn(PL_bodytarget, "", 0);
2823 PL_formtarget = PL_bodytarget;
2826 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2827 sv_setpv(GvSV(tmpgv),PL_origfilename);
2828 magicname("0", "0", 1);
2830 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2832 sv_setpv(GvSV(tmpgv), os2_execname());
2834 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2836 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2837 GvMULTI_on(PL_argvgv);
2838 (void)gv_AVadd(PL_argvgv);
2839 av_clear(GvAVn(PL_argvgv));
2840 for (; argc > 0; argc--,argv++) {
2841 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2844 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2846 GvMULTI_on(PL_envgv);
2847 hv = GvHVn(PL_envgv);
2848 hv_magic(hv, PL_envgv, 'E');
2849 #if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
2850 /* Note that if the supplied env parameter is actually a copy
2851 of the global environ then it may now point to free'd memory
2852 if the environment has been modified since. To avoid this
2853 problem we treat env==NULL as meaning 'use the default'
2858 environ[0] = Nullch;
2859 for (; *env; env++) {
2860 if (!(s = strchr(*env,'=')))
2866 sv = newSVpv(s--,0);
2867 (void)hv_store(hv, *env, s - *env, sv, 0);
2869 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2870 /* Sins of the RTL. See note in my_setenv(). */
2871 (void)PerlEnv_putenv(savepv(*env));
2875 #ifdef DYNAMIC_ENV_FETCH
2876 HvNAME(hv) = savepv(ENV_HV_NAME);
2880 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2881 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
2885 S_init_perllib(pTHX)
2890 s = PerlEnv_getenv("PERL5LIB");
2894 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2896 /* Treat PERL5?LIB as a possible search list logical name -- the
2897 * "natural" VMS idiom for a Unix path string. We allow each
2898 * element to be a set of |-separated directories for compatibility.
2902 if (my_trnlnm("PERL5LIB",buf,0))
2903 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2905 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2909 /* Use the ~-expanded versions of APPLLIB (undocumented),
2910 ARCHLIB PRIVLIB SITEARCH and SITELIB
2913 incpush(APPLLIB_EXP, TRUE);
2917 incpush(ARCHLIB_EXP, FALSE);
2920 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2923 incpush(PRIVLIB_EXP, TRUE);
2925 incpush(PRIVLIB_EXP, FALSE);
2929 incpush(SITEARCH_EXP, FALSE);
2933 incpush(SITELIB_EXP, TRUE);
2935 incpush(SITELIB_EXP, FALSE);
2938 #if defined(PERL_VENDORLIB_EXP)
2940 incpush(PERL_VENDORLIB_EXP, TRUE);
2942 incpush(PERL_VENDORLIB_EXP, FALSE);
2946 incpush(".", FALSE);
2950 # define PERLLIB_SEP ';'
2953 # define PERLLIB_SEP '|'
2955 # define PERLLIB_SEP ':'
2958 #ifndef PERLLIB_MANGLE
2959 # define PERLLIB_MANGLE(s,n) (s)
2963 S_incpush(pTHX_ char *p, int addsubdirs)
2965 SV *subdir = Nullsv;
2971 subdir = sv_newmortal();
2972 if (!PL_archpat_auto) {
2973 STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
2974 + sizeof("//auto"));
2975 New(55, PL_archpat_auto, len, char);
2976 sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
2978 for (len = sizeof(ARCHNAME) + 2;
2979 PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2980 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
2985 /* Break at all separators */
2987 SV *libdir = NEWSV(55,0);
2990 /* skip any consecutive separators */
2991 while ( *p == PERLLIB_SEP ) {
2992 /* Uncomment the next line for PATH semantics */
2993 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
2997 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2998 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3003 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3004 p = Nullch; /* break out */
3008 * BEFORE pushing libdir onto @INC we may first push version- and
3009 * archname-specific sub-directories.
3012 struct stat tmpstatbuf;
3017 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3019 while (unix[len-1] == '/') len--; /* Cosmetic */
3020 sv_usepvn(libdir,unix,len);
3023 PerlIO_printf(Perl_error_log,
3024 "Failed to unixify @INC element \"%s\"\n",
3027 /* .../archname/version if -d .../archname/version/auto */
3028 sv_setsv(subdir, libdir);
3029 sv_catpv(subdir, PL_archpat_auto);
3030 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3031 S_ISDIR(tmpstatbuf.st_mode))
3032 av_push(GvAVn(PL_incgv),
3033 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
3035 /* .../archname if -d .../archname/auto */
3036 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
3037 strlen(PL_patchlevel) + 1, "", 0);
3038 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3039 S_ISDIR(tmpstatbuf.st_mode))
3040 av_push(GvAVn(PL_incgv),
3041 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
3044 /* finally push this lib directory on the end of @INC */
3045 av_push(GvAVn(PL_incgv), libdir);
3050 STATIC struct perl_thread *
3051 S_init_main_thread(pTHX)
3053 #if !defined(PERL_IMPLICIT_CONTEXT)
3054 struct perl_thread *thr;
3058 Newz(53, thr, 1, struct perl_thread);
3059 PL_curcop = &PL_compiling;
3060 thr->interp = PERL_GET_INTERP;
3061 thr->cvcache = newHV();
3062 thr->threadsv = newAV();
3063 /* thr->threadsvp is set when find_threadsv is called */
3064 thr->specific = newAV();
3065 thr->flags = THRf_R_JOINABLE;
3066 MUTEX_INIT(&thr->mutex);
3067 /* Handcraft thrsv similarly to mess_sv */
3068 New(53, PL_thrsv, 1, SV);
3069 Newz(53, xpv, 1, XPV);
3070 SvFLAGS(PL_thrsv) = SVt_PV;
3071 SvANY(PL_thrsv) = (void*)xpv;
3072 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3073 SvPVX(PL_thrsv) = (char*)thr;
3074 SvCUR_set(PL_thrsv, sizeof(thr));
3075 SvLEN_set(PL_thrsv, sizeof(thr));
3076 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3077 thr->oursv = PL_thrsv;
3078 PL_chopset = " \n-";
3081 MUTEX_LOCK(&PL_threads_mutex);
3086 MUTEX_UNLOCK(&PL_threads_mutex);
3088 #ifdef HAVE_THREAD_INTERN
3089 Perl_init_thread_intern(thr);
3092 #ifdef SET_THREAD_SELF
3093 SET_THREAD_SELF(thr);
3095 thr->self = pthread_self();
3096 #endif /* SET_THREAD_SELF */
3100 * These must come after the SET_THR because sv_setpvn does
3101 * SvTAINT and the taint fields require dTHR.
3103 PL_toptarget = NEWSV(0,0);
3104 sv_upgrade(PL_toptarget, SVt_PVFM);
3105 sv_setpvn(PL_toptarget, "", 0);
3106 PL_bodytarget = NEWSV(0,0);
3107 sv_upgrade(PL_bodytarget, SVt_PVFM);
3108 sv_setpvn(PL_bodytarget, "", 0);
3109 PL_formtarget = PL_bodytarget;
3110 thr->errsv = newSVpvn("", 0);
3111 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
3114 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3115 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3116 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3117 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3118 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3120 PL_reginterp_cnt = 0;
3124 #endif /* USE_THREADS */
3127 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3131 line_t oldline = CopLINE(PL_curcop);
3137 while (AvFILL(paramList) >= 0) {
3138 cv = (CV*)av_shift(paramList);
3140 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
3144 (void)SvPV(atsv, len);
3147 PL_curcop = &PL_compiling;
3148 CopLINE_set(PL_curcop, oldline);
3149 if (paramList == PL_beginav)
3150 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3152 Perl_sv_catpvf(aTHX_ atsv,
3153 "%s failed--call queue aborted",
3154 paramList == PL_stopav ? "STOP"
3155 : paramList == PL_initav ? "INIT"
3157 while (PL_scopestack_ix > oldscope)
3159 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
3166 /* my_exit() was called */
3167 while (PL_scopestack_ix > oldscope)
3170 PL_curstash = PL_defstash;
3171 PL_curcop = &PL_compiling;
3172 CopLINE_set(PL_curcop, oldline);
3173 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3174 if (paramList == PL_beginav)
3175 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3177 Perl_croak(aTHX_ "%s failed--call queue aborted",
3178 paramList == PL_stopav ? "STOP"
3179 : paramList == PL_initav ? "INIT"
3186 PL_curcop = &PL_compiling;
3187 CopLINE_set(PL_curcop, oldline);
3190 PerlIO_printf(Perl_error_log, "panic: restartop\n");
3198 S_call_list_body(pTHX_ va_list args)
3201 CV *cv = va_arg(args, CV*);
3203 PUSHMARK(PL_stack_sp);
3204 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3209 Perl_my_exit(pTHX_ U32 status)
3213 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3214 thr, (unsigned long) status));
3223 STATUS_NATIVE_SET(status);
3230 Perl_my_failure_exit(pTHX)
3233 if (vaxc$errno & 1) {
3234 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3235 STATUS_NATIVE_SET(44);
3238 if (!vaxc$errno && errno) /* unlikely */
3239 STATUS_NATIVE_SET(44);
3241 STATUS_NATIVE_SET(vaxc$errno);
3246 STATUS_POSIX_SET(errno);
3248 exitstatus = STATUS_POSIX >> 8;
3249 if (exitstatus & 255)
3250 STATUS_POSIX_SET(exitstatus);
3252 STATUS_POSIX_SET(255);
3259 S_my_exit_jump(pTHX)
3262 register PERL_CONTEXT *cx;
3267 SvREFCNT_dec(PL_e_script);
3268 PL_e_script = Nullsv;
3271 POPSTACK_TO(PL_mainstack);
3272 if (cxstack_ix >= 0) {
3275 POPBLOCK(cx,PL_curpm);
3287 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3290 p = SvPVX(PL_e_script);
3291 nl = strchr(p, '\n');
3292 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3294 filter_del(read_e_script);
3297 sv_catpvn(buf_sv, p, nl-p);
3298 sv_chop(PL_e_script, nl);