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);
99 #endif /* PERL_IMPLICIT_SYS */
102 perl_construct(pTHXx)
107 struct perl_thread *thr = NULL;
108 #endif /* FAKE_THREADS */
109 #endif /* USE_THREADS */
113 PL_perl_destruct_level = 1;
115 if (PL_perl_destruct_level > 0)
119 /* Init the real globals (and main thread)? */
124 #ifdef ALLOC_THREAD_KEY
127 if (pthread_key_create(&PL_thr_key, 0))
128 Perl_croak(aTHX_ "panic: pthread_key_create");
130 MUTEX_INIT(&PL_sv_mutex);
132 * Safe to use basic SV functions from now on (though
133 * not things like mortals or tainting yet).
135 MUTEX_INIT(&PL_eval_mutex);
136 COND_INIT(&PL_eval_cond);
137 MUTEX_INIT(&PL_threads_mutex);
138 COND_INIT(&PL_nthreads_cond);
139 #ifdef EMULATE_ATOMIC_REFCOUNTS
140 MUTEX_INIT(&PL_svref_mutex);
141 #endif /* EMULATE_ATOMIC_REFCOUNTS */
143 MUTEX_INIT(&PL_cred_mutex);
145 thr = init_main_thread();
146 #endif /* USE_THREADS */
148 PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
150 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
152 PL_linestr = NEWSV(65,79);
153 sv_upgrade(PL_linestr,SVt_PVIV);
155 if (!SvREADONLY(&PL_sv_undef)) {
156 /* set read-only and try to insure than we wont see REFCNT==0
159 SvREADONLY_on(&PL_sv_undef);
160 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
162 sv_setpv(&PL_sv_no,PL_No);
164 SvREADONLY_on(&PL_sv_no);
165 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
167 sv_setpv(&PL_sv_yes,PL_Yes);
169 SvREADONLY_on(&PL_sv_yes);
170 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
175 /* PL_sighandlerp = sighandler; */
177 PL_sighandlerp = Perl_sighandler;
179 PL_pidstatus = newHV();
183 * There is no way we can refer to them from Perl so close them to save
184 * space. The other alternative would be to provide STDAUX and STDPRN
187 (void)fclose(stdaux);
188 (void)fclose(stdprn);
192 PL_nrs = newSVpvn("\n", 1);
193 PL_rs = SvREFCNT_inc(PL_nrs);
198 PL_lex_state = LEX_NOTPARSING;
204 SET_NUMERIC_STANDARD();
206 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
207 sprintf(PL_patchlevel, "%7.5f", (double) PERL_REVISION
208 + ((double) PERL_VERSION / (double) 1000)
209 + ((double) PERL_SUBVERSION / (double) 100000));
211 sprintf(PL_patchlevel, "%5.3f", (double) PERL_REVISION +
212 ((double) PERL_VERSION / (double) 1000));
215 #if defined(LOCAL_PATCH_COUNT)
216 PL_localpatches = local_patches; /* For possible -v */
219 PerlIO_init(); /* Hook to IO system */
221 PL_fdpid = newAV(); /* for remembering popen pids by fd */
222 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
231 int destruct_level; /* 0=none, 1=full, 2=full with checks */
237 #endif /* USE_THREADS */
239 /* wait for all pseudo-forked children to finish */
240 PERL_WAIT_FOR_CHILDREN;
244 /* Pass 1 on any remaining threads: detach joinables, join zombies */
246 MUTEX_LOCK(&PL_threads_mutex);
247 DEBUG_S(PerlIO_printf(Perl_debug_log,
248 "perl_destruct: waiting for %d threads...\n",
250 for (t = thr->next; t != thr; t = t->next) {
251 MUTEX_LOCK(&t->mutex);
252 switch (ThrSTATE(t)) {
255 DEBUG_S(PerlIO_printf(Perl_debug_log,
256 "perl_destruct: joining zombie %p\n", t));
257 ThrSETSTATE(t, THRf_DEAD);
258 MUTEX_UNLOCK(&t->mutex);
261 * The SvREFCNT_dec below may take a long time (e.g. av
262 * may contain an object scalar whose destructor gets
263 * called) so we have to unlock threads_mutex and start
266 MUTEX_UNLOCK(&PL_threads_mutex);
268 SvREFCNT_dec((SV*)av);
269 DEBUG_S(PerlIO_printf(Perl_debug_log,
270 "perl_destruct: joined zombie %p OK\n", t));
272 case THRf_R_JOINABLE:
273 DEBUG_S(PerlIO_printf(Perl_debug_log,
274 "perl_destruct: detaching thread %p\n", t));
275 ThrSETSTATE(t, THRf_R_DETACHED);
277 * We unlock threads_mutex and t->mutex in the opposite order
278 * from which we locked them just so that DETACH won't
279 * deadlock if it panics. It's only a breach of good style
280 * not a bug since they are unlocks not locks.
282 MUTEX_UNLOCK(&PL_threads_mutex);
284 MUTEX_UNLOCK(&t->mutex);
287 DEBUG_S(PerlIO_printf(Perl_debug_log,
288 "perl_destruct: ignoring %p (state %u)\n",
290 MUTEX_UNLOCK(&t->mutex);
291 /* fall through and out */
294 /* We leave the above "Pass 1" loop with threads_mutex still locked */
296 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
297 while (PL_nthreads > 1)
299 DEBUG_S(PerlIO_printf(Perl_debug_log,
300 "perl_destruct: final wait for %d threads\n",
302 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
304 /* At this point, we're the last thread */
305 MUTEX_UNLOCK(&PL_threads_mutex);
306 DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
307 MUTEX_DESTROY(&PL_threads_mutex);
308 COND_DESTROY(&PL_nthreads_cond);
309 #endif /* !defined(FAKE_THREADS) */
310 #endif /* USE_THREADS */
312 destruct_level = PL_perl_destruct_level;
316 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
318 if (destruct_level < i)
327 /* We must account for everything. */
329 /* Destroy the main CV and syntax tree */
331 PL_curpad = AvARRAY(PL_comppad);
332 op_free(PL_main_root);
333 PL_main_root = Nullop;
335 PL_curcop = &PL_compiling;
336 PL_main_start = Nullop;
337 SvREFCNT_dec(PL_main_cv);
341 if (PL_sv_objcount) {
343 * Try to destruct global references. We do this first so that the
344 * destructors and destructees still exist. Some sv's might remain.
345 * Non-referenced objects are on their own.
350 /* unhook hooks which will soon be, or use, destroyed data */
351 SvREFCNT_dec(PL_warnhook);
352 PL_warnhook = Nullsv;
353 SvREFCNT_dec(PL_diehook);
356 /* call exit list functions */
357 while (PL_exitlistlen-- > 0)
358 PL_exitlist[PL_exitlistlen].fn(aTHXo_ PL_exitlist[PL_exitlistlen].ptr);
360 Safefree(PL_exitlist);
362 if (destruct_level == 0){
364 DEBUG_P(debprofdump());
366 /* The exit() function will do everything that needs doing. */
370 /* loosen bonds of global variables */
373 (void)PerlIO_close(PL_rsfp);
377 /* Filters for program text */
378 SvREFCNT_dec(PL_rsfp_filters);
379 PL_rsfp_filters = Nullav;
382 PL_preprocess = FALSE;
388 PL_doswitches = FALSE;
389 PL_dowarn = G_WARN_OFF;
390 PL_doextract = FALSE;
391 PL_sawampersand = FALSE; /* must save all match strings */
394 Safefree(PL_inplace);
398 SvREFCNT_dec(PL_e_script);
399 PL_e_script = Nullsv;
402 /* magical thingies */
404 Safefree(PL_ofs); /* $, */
407 Safefree(PL_ors); /* $\ */
410 SvREFCNT_dec(PL_rs); /* $/ */
413 SvREFCNT_dec(PL_nrs); /* $/ helper */
416 PL_multiline = 0; /* $* */
418 SvREFCNT_dec(PL_statname);
419 PL_statname = Nullsv;
422 /* defgv, aka *_ should be taken care of elsewhere */
424 /* clean up after study() */
425 SvREFCNT_dec(PL_lastscream);
426 PL_lastscream = Nullsv;
427 Safefree(PL_screamfirst);
429 Safefree(PL_screamnext);
433 Safefree(PL_efloatbuf);
434 PL_efloatbuf = Nullch;
437 /* startup and shutdown function lists */
438 SvREFCNT_dec(PL_beginav);
439 SvREFCNT_dec(PL_endav);
440 SvREFCNT_dec(PL_stopav);
441 SvREFCNT_dec(PL_initav);
447 /* shortcuts just get cleared */
453 PL_argvoutgv = Nullgv;
455 PL_stderrgv = Nullgv;
456 PL_last_in_gv = Nullgv;
458 PL_debstash = Nullhv;
460 /* reset so print() ends up where we expect */
463 SvREFCNT_dec(PL_argvout_stack);
464 PL_argvout_stack = Nullav;
466 SvREFCNT_dec(PL_fdpid);
468 SvREFCNT_dec(PL_modglobal);
469 PL_modglobal = Nullhv;
470 SvREFCNT_dec(PL_preambleav);
471 PL_preambleav = Nullav;
472 SvREFCNT_dec(PL_subname);
474 SvREFCNT_dec(PL_linestr);
476 SvREFCNT_dec(PL_pidstatus);
477 PL_pidstatus = Nullhv;
478 SvREFCNT_dec(PL_toptarget);
479 PL_toptarget = Nullsv;
480 SvREFCNT_dec(PL_bodytarget);
481 PL_bodytarget = Nullsv;
482 PL_formtarget = Nullsv;
484 /* clear utf8 character classes */
485 SvREFCNT_dec(PL_utf8_alnum);
486 SvREFCNT_dec(PL_utf8_alnumc);
487 SvREFCNT_dec(PL_utf8_ascii);
488 SvREFCNT_dec(PL_utf8_alpha);
489 SvREFCNT_dec(PL_utf8_space);
490 SvREFCNT_dec(PL_utf8_cntrl);
491 SvREFCNT_dec(PL_utf8_graph);
492 SvREFCNT_dec(PL_utf8_digit);
493 SvREFCNT_dec(PL_utf8_upper);
494 SvREFCNT_dec(PL_utf8_lower);
495 SvREFCNT_dec(PL_utf8_print);
496 SvREFCNT_dec(PL_utf8_punct);
497 SvREFCNT_dec(PL_utf8_xdigit);
498 SvREFCNT_dec(PL_utf8_mark);
499 SvREFCNT_dec(PL_utf8_toupper);
500 SvREFCNT_dec(PL_utf8_tolower);
501 PL_utf8_alnum = Nullsv;
502 PL_utf8_alnumc = Nullsv;
503 PL_utf8_ascii = Nullsv;
504 PL_utf8_alpha = Nullsv;
505 PL_utf8_space = Nullsv;
506 PL_utf8_cntrl = Nullsv;
507 PL_utf8_graph = Nullsv;
508 PL_utf8_digit = Nullsv;
509 PL_utf8_upper = Nullsv;
510 PL_utf8_lower = Nullsv;
511 PL_utf8_print = Nullsv;
512 PL_utf8_punct = Nullsv;
513 PL_utf8_xdigit = Nullsv;
514 PL_utf8_mark = Nullsv;
515 PL_utf8_toupper = Nullsv;
516 PL_utf8_totitle = Nullsv;
517 PL_utf8_tolower = Nullsv;
519 if (!specialWARN(PL_compiling.cop_warnings))
520 SvREFCNT_dec(PL_compiling.cop_warnings);
521 PL_compiling.cop_warnings = Nullsv;
523 /* Prepare to destruct main symbol table. */
528 SvREFCNT_dec(PL_curstname);
529 PL_curstname = Nullsv;
531 /* clear queued errors */
532 SvREFCNT_dec(PL_errors);
536 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
537 if (PL_scopestack_ix != 0)
538 Perl_warner(aTHX_ WARN_INTERNAL,
539 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
540 (long)PL_scopestack_ix);
541 if (PL_savestack_ix != 0)
542 Perl_warner(aTHX_ WARN_INTERNAL,
543 "Unbalanced saves: %ld more saves than restores\n",
544 (long)PL_savestack_ix);
545 if (PL_tmps_floor != -1)
546 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
547 (long)PL_tmps_floor + 1);
548 if (cxstack_ix != -1)
549 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
550 (long)cxstack_ix + 1);
553 /* Now absolutely destruct everything, somehow or other, loops or no. */
555 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
556 while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
557 last_sv_count = PL_sv_count;
560 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
561 SvFLAGS(PL_strtab) |= SVt_PVHV;
563 /* Destruct the global string table. */
565 /* Yell and reset the HeVAL() slots that are still holding refcounts,
566 * so that sv_free() won't fail on them.
574 max = HvMAX(PL_strtab);
575 array = HvARRAY(PL_strtab);
578 if (hent && ckWARN_d(WARN_INTERNAL)) {
579 Perl_warner(aTHX_ WARN_INTERNAL,
580 "Unbalanced string table refcount: (%d) for \"%s\"",
581 HeVAL(hent) - Nullsv, HeKEY(hent));
582 HeVAL(hent) = Nullsv;
592 SvREFCNT_dec(PL_strtab);
594 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
595 Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
599 /* No SVs have survived, need to clean out */
600 Safefree(PL_origfilename);
601 Safefree(PL_archpat_auto);
602 Safefree(PL_reg_start_tmp);
604 Safefree(PL_reg_curpm);
605 Safefree(PL_reg_poscache);
606 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
607 Safefree(PL_op_mask);
609 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
611 DEBUG_P(debprofdump());
613 MUTEX_DESTROY(&PL_strtab_mutex);
614 MUTEX_DESTROY(&PL_sv_mutex);
615 MUTEX_DESTROY(&PL_eval_mutex);
616 MUTEX_DESTROY(&PL_cred_mutex);
617 COND_DESTROY(&PL_eval_cond);
618 #ifdef EMULATE_ATOMIC_REFCOUNTS
619 MUTEX_DESTROY(&PL_svref_mutex);
620 #endif /* EMULATE_ATOMIC_REFCOUNTS */
622 /* As the penultimate thing, free the non-arena SV for thrsv */
623 Safefree(SvPVX(PL_thrsv));
624 Safefree(SvANY(PL_thrsv));
627 #endif /* USE_THREADS */
629 /* As the absolutely last thing, free the non-arena SV for mess() */
632 /* it could have accumulated taint magic */
633 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
636 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
637 moremagic = mg->mg_moremagic;
638 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
639 Safefree(mg->mg_ptr);
643 /* we know that type >= SVt_PV */
644 SvOOK_off(PL_mess_sv);
645 Safefree(SvPVX(PL_mess_sv));
646 Safefree(SvANY(PL_mess_sv));
647 Safefree(PL_mess_sv);
655 #if defined(PERL_OBJECT)
663 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
665 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
666 PL_exitlist[PL_exitlistlen].fn = fn;
667 PL_exitlist[PL_exitlistlen].ptr = ptr;
672 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
682 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
685 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
686 setuid perl scripts securely.\n");
690 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
691 _dyld_lookup_and_bind
692 ("__environ", (unsigned long *) &environ_pointer, NULL);
697 #ifndef VMS /* VMS doesn't have environ array */
698 PL_origenviron = environ;
703 /* Come here if running an undumped a.out. */
705 PL_origfilename = savepv(argv[0]);
706 PL_do_undump = FALSE;
707 cxstack_ix = -1; /* start label stack again */
709 init_postdump_symbols(argc,argv,env);
714 PL_curpad = AvARRAY(PL_comppad);
715 op_free(PL_main_root);
716 PL_main_root = Nullop;
718 PL_main_start = Nullop;
719 SvREFCNT_dec(PL_main_cv);
723 oldscope = PL_scopestack_ix;
724 PL_dowarn = G_WARN_OFF;
726 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_parse_body),
731 call_list(oldscope, PL_stopav);
737 /* my_exit() was called */
738 while (PL_scopestack_ix > oldscope)
741 PL_curstash = PL_defstash;
743 call_list(oldscope, PL_stopav);
744 return STATUS_NATIVE_EXPORT;
746 PerlIO_printf(Perl_error_log, "panic: top_env\n");
753 S_parse_body(pTHX_ va_list args)
756 int argc = PL_origargc;
757 char **argv = PL_origargv;
758 char **env = va_arg(args, char**);
759 char *scriptname = NULL;
761 VOL bool dosearch = FALSE;
766 char *cddir = Nullch;
768 XSINIT_t xsinit = va_arg(args, XSINIT_t);
770 sv_setpvn(PL_linestr,"",0);
771 sv = newSVpvn("",0); /* first used for -I flags */
775 for (argc--,argv++; argc > 0; argc--,argv++) {
776 if (argv[0][0] != '-' || !argv[0][1])
780 validarg = " PHOOEY ";
787 #ifndef PERL_STRICT_CR
811 if (s = moreswitches(s))
821 if (PL_euid != PL_uid || PL_egid != PL_gid)
822 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
824 PL_e_script = newSVpvn("",0);
825 filter_add(read_e_script, NULL);
828 sv_catpv(PL_e_script, s);
830 sv_catpv(PL_e_script, argv[1]);
834 Perl_croak(aTHX_ "No code specified for -e");
835 sv_catpv(PL_e_script, "\n");
838 case 'I': /* -I handled both here and in moreswitches() */
840 if (!*++s && (s=argv[1]) != Nullch) {
843 while (s && isSPACE(*s))
847 for (e = s; *e && !isSPACE(*e); e++) ;
854 } /* XXX else croak? */
858 PL_preprocess = TRUE;
868 PL_preambleav = newAV();
869 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
871 PL_Sv = newSVpv("print myconfig();",0);
873 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
875 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
877 sv_catpv(PL_Sv,"\" Compile-time options:");
879 sv_catpv(PL_Sv," DEBUGGING");
882 sv_catpv(PL_Sv," MULTIPLICITY");
885 sv_catpv(PL_Sv," USE_THREADS");
888 sv_catpv(PL_Sv," PERL_OBJECT");
890 # ifdef PERL_IMPLICIT_CONTEXT
891 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
893 # ifdef PERL_IMPLICIT_SYS
894 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
896 sv_catpv(PL_Sv,"\\n\",");
898 #if defined(LOCAL_PATCH_COUNT)
899 if (LOCAL_PATCH_COUNT > 0) {
901 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
902 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
903 if (PL_localpatches[i])
904 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
908 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
911 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
913 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
918 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
919 print \" \\%ENV:\\n @env\\n\" if @env; \
920 print \" \\@INC:\\n @INC\\n\";");
923 PL_Sv = newSVpv("config_vars(qw(",0);
924 sv_catpv(PL_Sv, ++s);
925 sv_catpv(PL_Sv, "))");
928 av_push(PL_preambleav, PL_Sv);
929 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
940 if (!*++s || isSPACE(*s)) {
944 /* catch use of gnu style long options */
945 if (strEQ(s, "version")) {
949 if (strEQ(s, "help")) {
956 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
962 #ifndef SECURE_INTERNAL_GETENV
965 (s = PerlEnv_getenv("PERL5OPT"))) {
968 if (*s == '-' && *(s+1) == 'T')
981 if (!strchr("DIMUdmw", *s))
982 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
989 scriptname = argv[0];
992 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
994 else if (scriptname == Nullch) {
996 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1004 open_script(scriptname,dosearch,sv,&fdscript);
1006 validate_suid(validarg, scriptname,fdscript);
1008 #if defined(SIGCHLD) || defined(SIGCLD)
1011 # define SIGCHLD SIGCLD
1013 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1014 if (sigstate == SIG_IGN) {
1015 if (ckWARN(WARN_SIGNAL))
1016 Perl_warner(aTHX_ WARN_SIGNAL,
1017 "Can't ignore signal CHLD, forcing to default");
1018 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1025 if (cddir && PerlDir_chdir(cddir) < 0)
1026 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1030 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1031 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1032 CvUNIQUE_on(PL_compcv);
1034 PL_comppad = newAV();
1035 av_push(PL_comppad, Nullsv);
1036 PL_curpad = AvARRAY(PL_comppad);
1037 PL_comppad_name = newAV();
1038 PL_comppad_name_fill = 0;
1039 PL_min_intro_pending = 0;
1042 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
1043 PL_curpad[0] = (SV*)newAV();
1044 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
1045 CvOWNER(PL_compcv) = 0;
1046 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1047 MUTEX_INIT(CvMUTEXP(PL_compcv));
1048 #endif /* USE_THREADS */
1050 comppadlist = newAV();
1051 AvREAL_off(comppadlist);
1052 av_store(comppadlist, 0, (SV*)PL_comppad_name);
1053 av_store(comppadlist, 1, (SV*)PL_comppad);
1054 CvPADLIST(PL_compcv) = comppadlist;
1056 boot_core_UNIVERSAL();
1057 boot_core_xsutils();
1060 (*xsinit)(aTHXo); /* in case linked C routines want magical variables */
1061 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
1069 init_predump_symbols();
1070 /* init_postdump_symbols not currently designed to be called */
1071 /* more than once (ENV isn't cleared first, for example) */
1072 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
1074 init_postdump_symbols(argc,argv,env);
1078 /* now parse the script */
1080 SETERRNO(0,SS$_NORMAL);
1082 if (yyparse() || PL_error_count) {
1084 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1086 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1090 CopLINE_set(PL_curcop, 0);
1091 PL_curstash = PL_defstash;
1092 PL_preprocess = FALSE;
1094 SvREFCNT_dec(PL_e_script);
1095 PL_e_script = Nullsv;
1098 /* now that script is parsed, we can modify record separator */
1099 SvREFCNT_dec(PL_rs);
1100 PL_rs = SvREFCNT_inc(PL_nrs);
1101 sv_setsv(get_sv("/", TRUE), PL_rs);
1106 SAVECOPFILE(PL_curcop);
1107 SAVECOPLINE(PL_curcop);
1108 gv_check(PL_defstash);
1115 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1116 dump_mstats("after compilation:");
1135 oldscope = PL_scopestack_ix;
1138 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
1141 cxstack_ix = -1; /* start context stack again */
1143 case 0: /* normal completion */
1144 case 2: /* my_exit() */
1145 while (PL_scopestack_ix > oldscope)
1148 PL_curstash = PL_defstash;
1149 if (PL_endav && !PL_minus_c)
1150 call_list(oldscope, PL_endav);
1152 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1153 dump_mstats("after execution: ");
1155 return STATUS_NATIVE_EXPORT;
1158 POPSTACK_TO(PL_mainstack);
1161 PerlIO_printf(Perl_error_log, "panic: restartop\n");
1171 S_run_body(pTHX_ va_list args)
1174 I32 oldscope = va_arg(args, I32);
1176 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1177 PL_sawampersand ? "Enabling" : "Omitting"));
1179 if (!PL_restartop) {
1180 DEBUG_x(dump_all());
1181 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1182 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1186 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1189 if (PERLDB_SINGLE && PL_DBsingle)
1190 sv_setiv(PL_DBsingle, 1);
1192 call_list(oldscope, PL_initav);
1198 PL_op = PL_restartop;
1202 else if (PL_main_start) {
1203 CvDEPTH(PL_main_cv) = 1;
1204 PL_op = PL_main_start;
1214 Perl_get_sv(pTHX_ const char *name, I32 create)
1218 if (name[1] == '\0' && !isALPHA(name[0])) {
1219 PADOFFSET tmp = find_threadsv(name);
1220 if (tmp != NOT_IN_PAD) {
1222 return THREADSV(tmp);
1225 #endif /* USE_THREADS */
1226 gv = gv_fetchpv(name, create, SVt_PV);
1233 Perl_get_av(pTHX_ const char *name, I32 create)
1235 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1244 Perl_get_hv(pTHX_ const char *name, I32 create)
1246 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1255 Perl_get_cv(pTHX_ const char *name, I32 create)
1257 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1258 /* XXX unsafe for threads if eval_owner isn't held */
1259 /* XXX this is probably not what they think they're getting.
1260 * It has the same effect as "sub name;", i.e. just a forward
1262 if (create && !GvCVu(gv))
1263 return newSUB(start_subparse(FALSE, 0),
1264 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1272 /* Be sure to refetch the stack pointer after calling these routines. */
1275 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1277 /* See G_* flags in cop.h */
1278 /* null terminated arg list */
1285 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1290 return call_pv(sub_name, flags);
1294 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1295 /* name of the subroutine */
1296 /* See G_* flags in cop.h */
1298 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1302 Perl_call_method(pTHX_ const char *methname, I32 flags)
1303 /* name of the subroutine */
1304 /* See G_* flags in cop.h */
1310 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1315 return call_sv(*PL_stack_sp--, flags);
1318 /* May be called with any of a CV, a GV, or an SV containing the name. */
1320 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1322 /* See G_* flags in cop.h */
1325 LOGOP myop; /* fake syntax tree node */
1329 bool oldcatch = CATCH_GET;
1334 if (flags & G_DISCARD) {
1339 Zero(&myop, 1, LOGOP);
1340 myop.op_next = Nullop;
1341 if (!(flags & G_NOARGS))
1342 myop.op_flags |= OPf_STACKED;
1343 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1344 (flags & G_ARRAY) ? OPf_WANT_LIST :
1349 EXTEND(PL_stack_sp, 1);
1350 *++PL_stack_sp = sv;
1352 oldscope = PL_scopestack_ix;
1354 if (PERLDB_SUB && PL_curstash != PL_debstash
1355 /* Handle first BEGIN of -d. */
1356 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1357 /* Try harder, since this may have been a sighandler, thus
1358 * curstash may be meaningless. */
1359 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1360 && !(flags & G_NODEBUG))
1361 PL_op->op_private |= OPpENTERSUB_DB;
1363 if (!(flags & G_EVAL)) {
1365 call_xbody((OP*)&myop, FALSE);
1366 retval = PL_stack_sp - (PL_stack_base + oldmark);
1367 CATCH_SET(oldcatch);
1370 cLOGOP->op_other = PL_op;
1372 /* we're trying to emulate pp_entertry() here */
1374 register PERL_CONTEXT *cx;
1375 I32 gimme = GIMME_V;
1380 push_return(PL_op->op_next);
1381 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1383 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1385 PL_in_eval = EVAL_INEVAL;
1386 if (flags & G_KEEPERR)
1387 PL_in_eval |= EVAL_KEEPERR;
1394 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1398 retval = PL_stack_sp - (PL_stack_base + oldmark);
1399 if (!(flags & G_KEEPERR))
1406 /* my_exit() was called */
1407 PL_curstash = PL_defstash;
1409 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1410 Perl_croak(aTHX_ "Callback called exit");
1415 PL_op = PL_restartop;
1419 PL_stack_sp = PL_stack_base + oldmark;
1420 if (flags & G_ARRAY)
1424 *++PL_stack_sp = &PL_sv_undef;
1429 if (PL_scopestack_ix > oldscope) {
1433 register PERL_CONTEXT *cx;
1444 if (flags & G_DISCARD) {
1445 PL_stack_sp = PL_stack_base + oldmark;
1455 S_call_body(pTHX_ va_list args)
1457 OP *myop = va_arg(args, OP*);
1458 int is_eval = va_arg(args, int);
1460 call_xbody(myop, is_eval);
1465 S_call_xbody(pTHX_ OP *myop, int is_eval)
1469 if (PL_op == myop) {
1471 PL_op = Perl_pp_entereval(aTHX);
1473 PL_op = Perl_pp_entersub(aTHX);
1479 /* Eval a string. The G_EVAL flag is always assumed. */
1482 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1484 /* See G_* flags in cop.h */
1487 UNOP myop; /* fake syntax tree node */
1488 I32 oldmark = SP - PL_stack_base;
1495 if (flags & G_DISCARD) {
1502 Zero(PL_op, 1, UNOP);
1503 EXTEND(PL_stack_sp, 1);
1504 *++PL_stack_sp = sv;
1505 oldscope = PL_scopestack_ix;
1507 if (!(flags & G_NOARGS))
1508 myop.op_flags = OPf_STACKED;
1509 myop.op_next = Nullop;
1510 myop.op_type = OP_ENTEREVAL;
1511 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1512 (flags & G_ARRAY) ? OPf_WANT_LIST :
1514 if (flags & G_KEEPERR)
1515 myop.op_flags |= OPf_SPECIAL;
1518 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1522 retval = PL_stack_sp - (PL_stack_base + oldmark);
1523 if (!(flags & G_KEEPERR))
1530 /* my_exit() was called */
1531 PL_curstash = PL_defstash;
1533 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1534 Perl_croak(aTHX_ "Callback called exit");
1539 PL_op = PL_restartop;
1543 PL_stack_sp = PL_stack_base + oldmark;
1544 if (flags & G_ARRAY)
1548 *++PL_stack_sp = &PL_sv_undef;
1553 if (flags & G_DISCARD) {
1554 PL_stack_sp = PL_stack_base + oldmark;
1564 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1567 SV* sv = newSVpv(p, 0);
1570 eval_sv(sv, G_SCALAR);
1577 if (croak_on_error && SvTRUE(ERRSV)) {
1579 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1585 /* Require a module. */
1588 Perl_require_pv(pTHX_ const char *pv)
1592 PUSHSTACKi(PERLSI_REQUIRE);
1594 sv = sv_newmortal();
1595 sv_setpv(sv, "require '");
1598 eval_sv(sv, G_DISCARD);
1604 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1608 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1609 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1613 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
1615 /* This message really ought to be max 23 lines.
1616 * Removed -h because the user already knows that opton. Others? */
1618 static char *usage_msg[] = {
1619 "-0[octal] specify record separator (\\0, if no argument)",
1620 "-a autosplit mode with -n or -p (splits $_ into @F)",
1621 "-c check syntax only (runs BEGIN and END blocks)",
1622 "-d[:debugger] run program under debugger",
1623 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1624 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1625 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1626 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1627 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1628 "-l[octal] enable line ending processing, specifies line terminator",
1629 "-[mM][-]module execute `use/no module...' before executing program",
1630 "-n assume 'while (<>) { ... }' loop around program",
1631 "-p assume loop like -n but print line also, like sed",
1632 "-P run program through C preprocessor before compilation",
1633 "-s enable rudimentary parsing for switches after programfile",
1634 "-S look for programfile using PATH environment variable",
1635 "-T enable tainting checks",
1636 "-u dump core after parsing program",
1637 "-U allow unsafe operations",
1638 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1639 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1640 "-w enable many useful warnings (RECOMMENDED)",
1641 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1645 char **p = usage_msg;
1647 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1649 printf("\n %s", *p++);
1652 /* This routine handles any switches that can be given during run */
1655 Perl_moreswitches(pTHX_ char *s)
1664 rschar = (U32)scan_oct(s, 4, &numlen);
1665 SvREFCNT_dec(PL_nrs);
1666 if (rschar & ~((U8)~0))
1667 PL_nrs = &PL_sv_undef;
1668 else if (!rschar && numlen >= 2)
1669 PL_nrs = newSVpvn("", 0);
1672 PL_nrs = newSVpvn(&ch, 1);
1678 PL_splitstr = savepv(s + 1);
1692 if (*s == ':' || *s == '=') {
1693 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1697 PL_perldb = PERLDB_ALL;
1705 if (isALPHA(s[1])) {
1706 static char debopts[] = "psltocPmfrxuLHXDS";
1709 for (s++; *s && (d = strchr(debopts,*s)); s++)
1710 PL_debug |= 1 << (d - debopts);
1713 PL_debug = atoi(s+1);
1714 for (s++; isDIGIT(*s); s++) ;
1716 PL_debug |= 0x80000000;
1719 if (ckWARN_d(WARN_DEBUGGING))
1720 Perl_warner(aTHX_ WARN_DEBUGGING,
1721 "Recompile perl with -DDEBUGGING to use -D switch\n");
1722 for (s++; isALNUM(*s); s++) ;
1728 usage(PL_origargv[0]);
1732 Safefree(PL_inplace);
1733 PL_inplace = savepv(s+1);
1735 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1738 if (*s == '-') /* Additional switches on #! line. */
1742 case 'I': /* -I handled both here and in parse_perl() */
1745 while (*s && isSPACE(*s))
1749 for (e = s; *e && !isSPACE(*e); e++) ;
1750 p = savepvn(s, e-s);
1756 Perl_croak(aTHX_ "No space allowed after -I");
1764 PL_ors = savepv("\n");
1766 *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
1771 if (RsPARA(PL_nrs)) {
1776 PL_ors = SvPV(PL_nrs, PL_orslen);
1777 PL_ors = savepvn(PL_ors, PL_orslen);
1781 forbid_setid("-M"); /* XXX ? */
1784 forbid_setid("-m"); /* XXX ? */
1789 /* -M-foo == 'no foo' */
1790 if (*s == '-') { use = "no "; ++s; }
1791 sv = newSVpv(use,0);
1793 /* We allow -M'Module qw(Foo Bar)' */
1794 while(isALNUM(*s) || *s==':') ++s;
1796 sv_catpv(sv, start);
1797 if (*(start-1) == 'm') {
1799 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
1800 sv_catpv( sv, " ()");
1803 sv_catpvn(sv, start, s-start);
1804 sv_catpv(sv, " split(/,/,q{");
1810 PL_preambleav = newAV();
1811 av_push(PL_preambleav, sv);
1814 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1826 PL_doswitches = TRUE;
1831 Perl_croak(aTHX_ "Too late for \"-T\" option");
1835 PL_do_undump = TRUE;
1843 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
1844 printf("\nThis is perl, version %d.%03d_%02d built for %s",
1845 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME);
1847 printf("\nThis is perl, version %s built for %s",
1848 PL_patchlevel, ARCHNAME);
1850 #if defined(LOCAL_PATCH_COUNT)
1851 if (LOCAL_PATCH_COUNT > 0)
1852 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1853 (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1856 printf("\n\nCopyright 1987-1999, Larry Wall\n");
1858 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1861 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1862 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
1865 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1866 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
1869 printf("atariST series port, ++jrb bammi@cadence.com\n");
1872 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
1875 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1878 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
1881 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
1884 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
1887 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
1890 printf("MiNT port by Guido Flohr, 1997-1999\n");
1892 #ifdef BINARY_BUILD_NOTICE
1893 BINARY_BUILD_NOTICE;
1896 Perl may be copied only under the terms of either the Artistic License or the\n\
1897 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1898 Complete documentation for Perl, including FAQ lists, should be found on\n\
1899 this system using `man perl' or `perldoc perl'. If you have access to the\n\
1900 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1903 if (! (PL_dowarn & G_WARN_ALL_MASK))
1904 PL_dowarn |= G_WARN_ON;
1908 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1909 PL_compiling.cop_warnings = WARN_ALL ;
1913 PL_dowarn = G_WARN_ALL_OFF;
1914 PL_compiling.cop_warnings = WARN_NONE ;
1919 if (s[1] == '-') /* Additional switches on #! line. */
1924 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1930 #ifdef ALTERNATE_SHEBANG
1931 case 'S': /* OS/2 needs -S on "extproc" line. */
1939 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
1944 /* compliments of Tom Christiansen */
1946 /* unexec() can be found in the Gnu emacs distribution */
1947 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1950 Perl_my_unexec(pTHX)
1958 prog = newSVpv(BIN_EXP, 0);
1959 sv_catpv(prog, "/perl");
1960 file = newSVpv(PL_origfilename, 0);
1961 sv_catpv(file, ".perldump");
1963 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1964 /* unexec prints msg to stderr in case of failure */
1965 PerlProc_exit(status);
1968 # include <lib$routines.h>
1969 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1971 ABORT(); /* for use with undump */
1976 /* initialize curinterp */
1981 #ifdef PERL_OBJECT /* XXX kludge */
1984 PL_chopset = " \n-"; \
1985 PL_copline = NOLINE; \
1986 PL_curcop = &PL_compiling;\
1987 PL_curcopdb = NULL; \
1989 PL_dumpindent = 4; \
1990 PL_laststatval = -1; \
1991 PL_laststype = OP_STAT; \
1992 PL_maxscream = -1; \
1993 PL_maxsysfd = MAXSYSFD; \
1994 PL_statname = Nullsv; \
1995 PL_tmps_floor = -1; \
1997 PL_op_mask = NULL; \
1998 PL_laststatval = -1; \
1999 PL_laststype = OP_STAT; \
2000 PL_mess_sv = Nullsv; \
2001 PL_splitstr = " "; \
2002 PL_generation = 100; \
2003 PL_exitlist = NULL; \
2004 PL_exitlistlen = 0; \
2006 PL_in_clean_objs = FALSE; \
2007 PL_in_clean_all = FALSE; \
2008 PL_profiledata = NULL; \
2010 PL_rsfp_filters = Nullav; \
2015 # ifdef MULTIPLICITY
2016 # define PERLVAR(var,type)
2017 # define PERLVARA(var,n,type)
2018 # if defined(PERL_IMPLICIT_CONTEXT)
2019 # if defined(USE_THREADS)
2020 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2021 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2022 # else /* !USE_THREADS */
2023 # define PERLVARI(var,type,init) aTHX->var = init;
2024 # define PERLVARIC(var,type,init) aTHX->var = init;
2025 # endif /* USE_THREADS */
2027 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2028 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2030 # include "intrpvar.h"
2031 # ifndef USE_THREADS
2032 # include "thrdvar.h"
2039 # define PERLVAR(var,type)
2040 # define PERLVARA(var,n,type)
2041 # define PERLVARI(var,type,init) PL_##var = init;
2042 # define PERLVARIC(var,type,init) PL_##var = init;
2043 # include "intrpvar.h"
2044 # ifndef USE_THREADS
2045 # include "thrdvar.h"
2057 S_init_main_stash(pTHX)
2062 /* Note that strtab is a rather special HV. Assumptions are made
2063 about not iterating on it, and not adding tie magic to it.
2064 It is properly deallocated in perl_destruct() */
2065 PL_strtab = newHV();
2067 MUTEX_INIT(&PL_strtab_mutex);
2069 HvSHAREKEYS_off(PL_strtab); /* mandatory */
2070 hv_ksplit(PL_strtab, 512);
2072 PL_curstash = PL_defstash = newHV();
2073 PL_curstname = newSVpvn("main",4);
2074 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2075 SvREFCNT_dec(GvHV(gv));
2076 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2078 HvNAME(PL_defstash) = savepv("main");
2079 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2080 GvMULTI_on(PL_incgv);
2081 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2082 GvMULTI_on(PL_hintgv);
2083 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2084 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2085 GvMULTI_on(PL_errgv);
2086 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2087 GvMULTI_on(PL_replgv);
2088 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
2089 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2090 sv_setpvn(ERRSV, "", 0);
2091 PL_curstash = PL_defstash;
2092 CopSTASH_set(&PL_compiling, PL_defstash);
2093 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2094 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2095 /* We must init $/ before switches are processed. */
2096 sv_setpvn(get_sv("/", TRUE), "\n", 1);
2100 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2108 PL_origfilename = savepv("-e");
2111 /* if find_script() returns, it returns a malloc()-ed value */
2112 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2114 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2115 char *s = scriptname + 8;
2116 *fdscript = atoi(s);
2120 scriptname = savepv(s + 1);
2121 Safefree(PL_origfilename);
2122 PL_origfilename = scriptname;
2127 CopFILE_set(PL_curcop, PL_origfilename);
2128 if (strEQ(PL_origfilename,"-"))
2130 if (*fdscript >= 0) {
2131 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2132 #if defined(HAS_FCNTL) && defined(F_SETFD)
2134 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2137 else if (PL_preprocess) {
2138 char *cpp_cfg = CPPSTDIN;
2139 SV *cpp = newSVpvn("",0);
2140 SV *cmd = NEWSV(0,0);
2142 if (strEQ(cpp_cfg, "cppstdin"))
2143 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2144 sv_catpv(cpp, cpp_cfg);
2147 sv_catpv(sv,PRIVLIB_EXP);
2150 Perl_sv_setpvf(aTHX_ cmd, "\
2151 sed %s -e \"/^[^#]/b\" \
2152 -e \"/^#[ ]*include[ ]/b\" \
2153 -e \"/^#[ ]*define[ ]/b\" \
2154 -e \"/^#[ ]*if[ ]/b\" \
2155 -e \"/^#[ ]*ifdef[ ]/b\" \
2156 -e \"/^#[ ]*ifndef[ ]/b\" \
2157 -e \"/^#[ ]*else/b\" \
2158 -e \"/^#[ ]*elif[ ]/b\" \
2159 -e \"/^#[ ]*undef[ ]/b\" \
2160 -e \"/^#[ ]*endif/b\" \
2163 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2166 Perl_sv_setpvf(aTHX_ cmd, "\
2167 %s %s -e '/^[^#]/b' \
2168 -e '/^#[ ]*include[ ]/b' \
2169 -e '/^#[ ]*define[ ]/b' \
2170 -e '/^#[ ]*if[ ]/b' \
2171 -e '/^#[ ]*ifdef[ ]/b' \
2172 -e '/^#[ ]*ifndef[ ]/b' \
2173 -e '/^#[ ]*else/b' \
2174 -e '/^#[ ]*elif[ ]/b' \
2175 -e '/^#[ ]*undef[ ]/b' \
2176 -e '/^#[ ]*endif/b' \
2180 Perl_sv_setpvf(aTHX_ cmd, "\
2181 %s %s -e '/^[^#]/b' \
2182 -e '/^#[ ]*include[ ]/b' \
2183 -e '/^#[ ]*define[ ]/b' \
2184 -e '/^#[ ]*if[ ]/b' \
2185 -e '/^#[ ]*ifdef[ ]/b' \
2186 -e '/^#[ ]*ifndef[ ]/b' \
2187 -e '/^#[ ]*else/b' \
2188 -e '/^#[ ]*elif[ ]/b' \
2189 -e '/^#[ ]*undef[ ]/b' \
2190 -e '/^#[ ]*endif/b' \
2199 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2201 scriptname, cpp, sv, CPPMINUS);
2202 PL_doextract = FALSE;
2203 #ifdef IAMSUID /* actually, this is caught earlier */
2204 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2206 (void)seteuid(PL_uid); /* musn't stay setuid root */
2209 (void)setreuid((Uid_t)-1, PL_uid);
2211 #ifdef HAS_SETRESUID
2212 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2214 PerlProc_setuid(PL_uid);
2218 if (PerlProc_geteuid() != PL_uid)
2219 Perl_croak(aTHX_ "Can't do seteuid!\n");
2221 #endif /* IAMSUID */
2222 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2226 else if (!*scriptname) {
2227 forbid_setid("program input from stdin");
2228 PL_rsfp = PerlIO_stdin();
2231 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2232 #if defined(HAS_FCNTL) && defined(F_SETFD)
2234 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2239 #ifndef IAMSUID /* in case script is not readable before setuid */
2241 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2242 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2245 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2246 Perl_croak(aTHX_ "Can't do setuid\n");
2250 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2251 CopFILE(PL_curcop), Strerror(errno));
2256 * I_SYSSTATVFS HAS_FSTATVFS
2258 * I_STATFS HAS_FSTATFS
2259 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2260 * here so that metaconfig picks them up. */
2264 S_fd_on_nosuid_fs(pTHX_ int fd)
2266 int check_okay = 0; /* able to do all the required sys/libcalls */
2267 int on_nosuid = 0; /* the fd is on a nosuid fs */
2269 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2270 * fstatvfs() is UNIX98.
2271 * fstatfs() is 4.3 BSD.
2272 * ustat()+getmnt() is pre-4.3 BSD.
2273 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2274 * an irrelevant filesystem while trying to reach the right one.
2277 # ifdef HAS_FSTATVFS
2278 struct statvfs stfs;
2279 check_okay = fstatvfs(fd, &stfs) == 0;
2280 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2282 # ifdef PERL_MOUNT_NOSUID
2283 # if defined(HAS_FSTATFS) && \
2284 defined(HAS_STRUCT_STATFS) && \
2285 defined(HAS_STRUCT_STATFS_F_FLAGS)
2287 check_okay = fstatfs(fd, &stfs) == 0;
2288 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2290 # if defined(HAS_FSTAT) && \
2291 defined(HAS_USTAT) && \
2292 defined(HAS_GETMNT) && \
2293 defined(HAS_STRUCT_FS_DATA) &&
2296 if (fstat(fd, &fdst) == 0) {
2298 if (ustat(fdst.st_dev, &us) == 0) {
2300 /* NOSTAT_ONE here because we're not examining fields which
2301 * vary between that case and STAT_ONE. */
2302 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2303 size_t cmplen = sizeof(us.f_fname);
2304 if (sizeof(fsd.fd_req.path) < cmplen)
2305 cmplen = sizeof(fsd.fd_req.path);
2306 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2307 fdst.st_dev == fsd.fd_req.dev) {
2309 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2315 # endif /* fstat+ustat+getmnt */
2316 # endif /* fstatfs */
2318 # if defined(HAS_GETMNTENT) && \
2319 defined(HAS_HASMNTOPT) && \
2320 defined(MNTOPT_NOSUID)
2321 FILE *mtab = fopen("/etc/mtab", "r");
2322 struct mntent *entry;
2323 struct stat stb, fsb;
2325 if (mtab && (fstat(fd, &stb) == 0)) {
2326 while (entry = getmntent(mtab)) {
2327 if (stat(entry->mnt_dir, &fsb) == 0
2328 && fsb.st_dev == stb.st_dev)
2330 /* found the filesystem */
2332 if (hasmntopt(entry, MNTOPT_NOSUID))
2335 } /* A single fs may well fail its stat(). */
2340 # endif /* getmntent+hasmntopt */
2341 # endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */
2342 # endif /* statvfs */
2345 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
2348 #endif /* IAMSUID */
2351 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2355 /* do we need to emulate setuid on scripts? */
2357 /* This code is for those BSD systems that have setuid #! scripts disabled
2358 * in the kernel because of a security problem. Merely defining DOSUID
2359 * in perl will not fix that problem, but if you have disabled setuid
2360 * scripts in the kernel, this will attempt to emulate setuid and setgid
2361 * on scripts that have those now-otherwise-useless bits set. The setuid
2362 * root version must be called suidperl or sperlN.NNN. If regular perl
2363 * discovers that it has opened a setuid script, it calls suidperl with
2364 * the same argv that it had. If suidperl finds that the script it has
2365 * just opened is NOT setuid root, it sets the effective uid back to the
2366 * uid. We don't just make perl setuid root because that loses the
2367 * effective uid we had before invoking perl, if it was different from the
2370 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2371 * be defined in suidperl only. suidperl must be setuid root. The
2372 * Configure script will set this up for you if you want it.
2379 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2380 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2381 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2386 #ifndef HAS_SETREUID
2387 /* On this access check to make sure the directories are readable,
2388 * there is actually a small window that the user could use to make
2389 * filename point to an accessible directory. So there is a faint
2390 * chance that someone could execute a setuid script down in a
2391 * non-accessible directory. I don't know what to do about that.
2392 * But I don't think it's too important. The manual lies when
2393 * it says access() is useful in setuid programs.
2395 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
2396 Perl_croak(aTHX_ "Permission denied");
2398 /* If we can swap euid and uid, then we can determine access rights
2399 * with a simple stat of the file, and then compare device and
2400 * inode to make sure we did stat() on the same file we opened.
2401 * Then we just have to make sure he or she can execute it.
2404 struct stat tmpstatbuf;
2408 setreuid(PL_euid,PL_uid) < 0
2411 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2414 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2415 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2416 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
2417 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2418 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2419 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2420 Perl_croak(aTHX_ "Permission denied");
2422 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2423 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2424 (void)PerlIO_close(PL_rsfp);
2425 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2426 PerlIO_printf(PL_rsfp,
2427 "User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2428 (Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n",
2429 PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2430 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2432 PL_statbuf.st_uid, PL_statbuf.st_gid);
2433 (void)PerlProc_pclose(PL_rsfp);
2435 Perl_croak(aTHX_ "Permission denied\n");
2439 setreuid(PL_uid,PL_euid) < 0
2441 # if defined(HAS_SETRESUID)
2442 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2445 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2446 Perl_croak(aTHX_ "Can't reswap uid and euid");
2447 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2448 Perl_croak(aTHX_ "Permission denied\n");
2450 #endif /* HAS_SETREUID */
2451 #endif /* IAMSUID */
2453 if (!S_ISREG(PL_statbuf.st_mode))
2454 Perl_croak(aTHX_ "Permission denied");
2455 if (PL_statbuf.st_mode & S_IWOTH)
2456 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2457 PL_doswitches = FALSE; /* -s is insecure in suid */
2458 CopLINE_inc(PL_curcop);
2459 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2460 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2461 Perl_croak(aTHX_ "No #! line");
2462 s = SvPV(PL_linestr,n_a)+2;
2464 while (!isSPACE(*s)) s++;
2465 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2466 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2467 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2468 Perl_croak(aTHX_ "Not a perl script");
2469 while (*s == ' ' || *s == '\t') s++;
2471 * #! arg must be what we saw above. They can invoke it by
2472 * mentioning suidperl explicitly, but they may not add any strange
2473 * arguments beyond what #! says if they do invoke suidperl that way.
2475 len = strlen(validarg);
2476 if (strEQ(validarg," PHOOEY ") ||
2477 strnNE(s,validarg,len) || !isSPACE(s[len]))
2478 Perl_croak(aTHX_ "Args must match #! line");
2481 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2482 PL_euid == PL_statbuf.st_uid)
2484 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2485 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2486 #endif /* IAMSUID */
2488 if (PL_euid) { /* oops, we're not the setuid root perl */
2489 (void)PerlIO_close(PL_rsfp);
2492 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2494 Perl_croak(aTHX_ "Can't do setuid\n");
2497 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2499 (void)setegid(PL_statbuf.st_gid);
2502 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2504 #ifdef HAS_SETRESGID
2505 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2507 PerlProc_setgid(PL_statbuf.st_gid);
2511 if (PerlProc_getegid() != PL_statbuf.st_gid)
2512 Perl_croak(aTHX_ "Can't do setegid!\n");
2514 if (PL_statbuf.st_mode & S_ISUID) {
2515 if (PL_statbuf.st_uid != PL_euid)
2517 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2520 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2522 #ifdef HAS_SETRESUID
2523 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2525 PerlProc_setuid(PL_statbuf.st_uid);
2529 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2530 Perl_croak(aTHX_ "Can't do seteuid!\n");
2532 else if (PL_uid) { /* oops, mustn't run as root */
2534 (void)seteuid((Uid_t)PL_uid);
2537 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2539 #ifdef HAS_SETRESUID
2540 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2542 PerlProc_setuid((Uid_t)PL_uid);
2546 if (PerlProc_geteuid() != PL_uid)
2547 Perl_croak(aTHX_ "Can't do seteuid!\n");
2550 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2551 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
2554 else if (PL_preprocess)
2555 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2556 else if (fdscript >= 0)
2557 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2559 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2561 /* We absolutely must clear out any saved ids here, so we */
2562 /* exec the real perl, substituting fd script for scriptname. */
2563 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2564 PerlIO_rewind(PL_rsfp);
2565 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2566 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2567 if (!PL_origargv[which])
2568 Perl_croak(aTHX_ "Permission denied");
2569 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2570 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2571 #if defined(HAS_FCNTL) && defined(F_SETFD)
2572 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2574 PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
2575 Perl_croak(aTHX_ "Can't do setuid\n");
2576 #endif /* IAMSUID */
2578 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2579 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2581 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2582 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2584 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2587 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2588 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2589 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2590 /* not set-id, must be wrapped */
2596 S_find_beginning(pTHX)
2598 register char *s, *s2;
2600 /* skip forward in input to the real script? */
2603 while (PL_doextract) {
2604 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2605 Perl_croak(aTHX_ "No Perl script found in input\n");
2606 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2607 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2608 PL_doextract = FALSE;
2609 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2611 while (*s == ' ' || *s == '\t') s++;
2613 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2614 if (strnEQ(s2-4,"perl",4))
2616 while (s = moreswitches(s)) ;
2626 PL_uid = PerlProc_getuid();
2627 PL_euid = PerlProc_geteuid();
2628 PL_gid = PerlProc_getgid();
2629 PL_egid = PerlProc_getegid();
2631 PL_uid |= PL_gid << 16;
2632 PL_euid |= PL_egid << 16;
2634 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2638 S_forbid_setid(pTHX_ char *s)
2640 if (PL_euid != PL_uid)
2641 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2642 if (PL_egid != PL_gid)
2643 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2647 Perl_init_debugger(pTHX)
2650 HV *ostash = PL_curstash;
2652 PL_curstash = PL_debstash;
2653 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2654 AvREAL_off(PL_dbargs);
2655 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2656 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2657 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2658 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
2659 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2660 sv_setiv(PL_DBsingle, 0);
2661 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2662 sv_setiv(PL_DBtrace, 0);
2663 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2664 sv_setiv(PL_DBsignal, 0);
2665 PL_curstash = ostash;
2668 #ifndef STRESS_REALLOC
2669 #define REASONABLE(size) (size)
2671 #define REASONABLE(size) (1) /* unreasonable */
2675 Perl_init_stacks(pTHX)
2677 /* start with 128-item stack and 8K cxstack */
2678 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2679 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2680 PL_curstackinfo->si_type = PERLSI_MAIN;
2681 PL_curstack = PL_curstackinfo->si_stack;
2682 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2684 PL_stack_base = AvARRAY(PL_curstack);
2685 PL_stack_sp = PL_stack_base;
2686 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2688 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2691 PL_tmps_max = REASONABLE(128);
2693 New(54,PL_markstack,REASONABLE(32),I32);
2694 PL_markstack_ptr = PL_markstack;
2695 PL_markstack_max = PL_markstack + REASONABLE(32);
2699 New(54,PL_scopestack,REASONABLE(32),I32);
2700 PL_scopestack_ix = 0;
2701 PL_scopestack_max = REASONABLE(32);
2703 New(54,PL_savestack,REASONABLE(128),ANY);
2704 PL_savestack_ix = 0;
2705 PL_savestack_max = REASONABLE(128);
2707 New(54,PL_retstack,REASONABLE(16),OP*);
2709 PL_retstack_max = REASONABLE(16);
2718 while (PL_curstackinfo->si_next)
2719 PL_curstackinfo = PL_curstackinfo->si_next;
2720 while (PL_curstackinfo) {
2721 PERL_SI *p = PL_curstackinfo->si_prev;
2722 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2723 Safefree(PL_curstackinfo->si_cxstack);
2724 Safefree(PL_curstackinfo);
2725 PL_curstackinfo = p;
2727 Safefree(PL_tmps_stack);
2728 Safefree(PL_markstack);
2729 Safefree(PL_scopestack);
2730 Safefree(PL_savestack);
2731 Safefree(PL_retstack);
2735 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2746 lex_start(PL_linestr);
2748 PL_subname = newSVpvn("main",4);
2752 S_init_predump_symbols(pTHX)
2759 sv_setpvn(get_sv("\"", TRUE), " ", 1);
2760 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2761 GvMULTI_on(PL_stdingv);
2762 io = GvIOp(PL_stdingv);
2763 IoIFP(io) = PerlIO_stdin();
2764 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2766 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2768 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2771 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
2773 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2775 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2777 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2778 GvMULTI_on(PL_stderrgv);
2779 io = GvIOp(PL_stderrgv);
2780 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
2781 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2783 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2785 PL_statname = NEWSV(66,0); /* last filename we did stat on */
2788 PL_osname = savepv(OSNAME);
2792 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
2799 argc--,argv++; /* skip name of script */
2800 if (PL_doswitches) {
2801 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2804 if (argv[0][1] == '-') {
2808 if (s = strchr(argv[0], '=')) {
2810 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2813 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2816 PL_toptarget = NEWSV(0,0);
2817 sv_upgrade(PL_toptarget, SVt_PVFM);
2818 sv_setpvn(PL_toptarget, "", 0);
2819 PL_bodytarget = NEWSV(0,0);
2820 sv_upgrade(PL_bodytarget, SVt_PVFM);
2821 sv_setpvn(PL_bodytarget, "", 0);
2822 PL_formtarget = PL_bodytarget;
2825 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2826 sv_setpv(GvSV(tmpgv),PL_origfilename);
2827 magicname("0", "0", 1);
2829 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2831 sv_setpv(GvSV(tmpgv), os2_execname());
2833 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2835 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2836 GvMULTI_on(PL_argvgv);
2837 (void)gv_AVadd(PL_argvgv);
2838 av_clear(GvAVn(PL_argvgv));
2839 for (; argc > 0; argc--,argv++) {
2840 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2843 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2845 GvMULTI_on(PL_envgv);
2846 hv = GvHVn(PL_envgv);
2847 hv_magic(hv, PL_envgv, 'E');
2848 #if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
2849 /* Note that if the supplied env parameter is actually a copy
2850 of the global environ then it may now point to free'd memory
2851 if the environment has been modified since. To avoid this
2852 problem we treat env==NULL as meaning 'use the default'
2857 environ[0] = Nullch;
2858 for (; *env; env++) {
2859 if (!(s = strchr(*env,'=')))
2865 sv = newSVpv(s--,0);
2866 (void)hv_store(hv, *env, s - *env, sv, 0);
2868 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2869 /* Sins of the RTL. See note in my_setenv(). */
2870 (void)PerlEnv_putenv(savepv(*env));
2874 #ifdef DYNAMIC_ENV_FETCH
2875 HvNAME(hv) = savepv(ENV_HV_NAME);
2879 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2880 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
2884 S_init_perllib(pTHX)
2889 s = PerlEnv_getenv("PERL5LIB");
2893 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2895 /* Treat PERL5?LIB as a possible search list logical name -- the
2896 * "natural" VMS idiom for a Unix path string. We allow each
2897 * element to be a set of |-separated directories for compatibility.
2901 if (my_trnlnm("PERL5LIB",buf,0))
2902 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2904 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2908 /* Use the ~-expanded versions of APPLLIB (undocumented),
2909 ARCHLIB PRIVLIB SITEARCH and SITELIB
2912 incpush(APPLLIB_EXP, TRUE);
2916 incpush(ARCHLIB_EXP, FALSE);
2919 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2922 incpush(PRIVLIB_EXP, TRUE);
2924 incpush(PRIVLIB_EXP, FALSE);
2928 incpush(SITEARCH_EXP, FALSE);
2932 incpush(SITELIB_EXP, TRUE);
2934 incpush(SITELIB_EXP, FALSE);
2937 #if defined(PERL_VENDORLIB_EXP)
2939 incpush(PERL_VENDORLIB_EXP, TRUE);
2941 incpush(PERL_VENDORLIB_EXP, FALSE);
2945 incpush(".", FALSE);
2949 # define PERLLIB_SEP ';'
2952 # define PERLLIB_SEP '|'
2954 # define PERLLIB_SEP ':'
2957 #ifndef PERLLIB_MANGLE
2958 # define PERLLIB_MANGLE(s,n) (s)
2962 S_incpush(pTHX_ char *p, int addsubdirs)
2964 SV *subdir = Nullsv;
2970 subdir = sv_newmortal();
2971 if (!PL_archpat_auto) {
2972 STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
2973 + sizeof("//auto"));
2974 New(55, PL_archpat_auto, len, char);
2975 sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
2977 for (len = sizeof(ARCHNAME) + 2;
2978 PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2979 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
2984 /* Break at all separators */
2986 SV *libdir = NEWSV(55,0);
2989 /* skip any consecutive separators */
2990 while ( *p == PERLLIB_SEP ) {
2991 /* Uncomment the next line for PATH semantics */
2992 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
2996 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2997 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3002 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3003 p = Nullch; /* break out */
3007 * BEFORE pushing libdir onto @INC we may first push version- and
3008 * archname-specific sub-directories.
3011 struct stat tmpstatbuf;
3016 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3018 while (unix[len-1] == '/') len--; /* Cosmetic */
3019 sv_usepvn(libdir,unix,len);
3022 PerlIO_printf(Perl_error_log,
3023 "Failed to unixify @INC element \"%s\"\n",
3026 /* .../archname/version if -d .../archname/version/auto */
3027 sv_setsv(subdir, libdir);
3028 sv_catpv(subdir, PL_archpat_auto);
3029 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3030 S_ISDIR(tmpstatbuf.st_mode))
3031 av_push(GvAVn(PL_incgv),
3032 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
3034 /* .../archname if -d .../archname/auto */
3035 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
3036 strlen(PL_patchlevel) + 1, "", 0);
3037 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3038 S_ISDIR(tmpstatbuf.st_mode))
3039 av_push(GvAVn(PL_incgv),
3040 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
3043 /* finally push this lib directory on the end of @INC */
3044 av_push(GvAVn(PL_incgv), libdir);
3049 STATIC struct perl_thread *
3050 S_init_main_thread(pTHX)
3052 #if !defined(PERL_IMPLICIT_CONTEXT)
3053 struct perl_thread *thr;
3057 Newz(53, thr, 1, struct perl_thread);
3058 PL_curcop = &PL_compiling;
3059 thr->interp = PERL_GET_INTERP;
3060 thr->cvcache = newHV();
3061 thr->threadsv = newAV();
3062 /* thr->threadsvp is set when find_threadsv is called */
3063 thr->specific = newAV();
3064 thr->flags = THRf_R_JOINABLE;
3065 MUTEX_INIT(&thr->mutex);
3066 /* Handcraft thrsv similarly to mess_sv */
3067 New(53, PL_thrsv, 1, SV);
3068 Newz(53, xpv, 1, XPV);
3069 SvFLAGS(PL_thrsv) = SVt_PV;
3070 SvANY(PL_thrsv) = (void*)xpv;
3071 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3072 SvPVX(PL_thrsv) = (char*)thr;
3073 SvCUR_set(PL_thrsv, sizeof(thr));
3074 SvLEN_set(PL_thrsv, sizeof(thr));
3075 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3076 thr->oursv = PL_thrsv;
3077 PL_chopset = " \n-";
3080 MUTEX_LOCK(&PL_threads_mutex);
3085 MUTEX_UNLOCK(&PL_threads_mutex);
3087 #ifdef HAVE_THREAD_INTERN
3088 Perl_init_thread_intern(thr);
3091 #ifdef SET_THREAD_SELF
3092 SET_THREAD_SELF(thr);
3094 thr->self = pthread_self();
3095 #endif /* SET_THREAD_SELF */
3099 * These must come after the SET_THR because sv_setpvn does
3100 * SvTAINT and the taint fields require dTHR.
3102 PL_toptarget = NEWSV(0,0);
3103 sv_upgrade(PL_toptarget, SVt_PVFM);
3104 sv_setpvn(PL_toptarget, "", 0);
3105 PL_bodytarget = NEWSV(0,0);
3106 sv_upgrade(PL_bodytarget, SVt_PVFM);
3107 sv_setpvn(PL_bodytarget, "", 0);
3108 PL_formtarget = PL_bodytarget;
3109 thr->errsv = newSVpvn("", 0);
3110 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
3113 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3114 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3115 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3116 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3117 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3119 PL_reginterp_cnt = 0;
3123 #endif /* USE_THREADS */
3126 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3130 line_t oldline = CopLINE(PL_curcop);
3136 while (AvFILL(paramList) >= 0) {
3137 cv = (CV*)av_shift(paramList);
3139 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
3143 (void)SvPV(atsv, len);
3146 PL_curcop = &PL_compiling;
3147 CopLINE_set(PL_curcop, oldline);
3148 if (paramList == PL_beginav)
3149 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3151 Perl_sv_catpvf(aTHX_ atsv,
3152 "%s failed--call queue aborted",
3153 paramList == PL_stopav ? "STOP"
3154 : paramList == PL_initav ? "INIT"
3156 while (PL_scopestack_ix > oldscope)
3158 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
3165 /* my_exit() was called */
3166 while (PL_scopestack_ix > oldscope)
3169 PL_curstash = PL_defstash;
3170 PL_curcop = &PL_compiling;
3171 CopLINE_set(PL_curcop, oldline);
3172 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3173 if (paramList == PL_beginav)
3174 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3176 Perl_croak(aTHX_ "%s failed--call queue aborted",
3177 paramList == PL_stopav ? "STOP"
3178 : paramList == PL_initav ? "INIT"
3185 PL_curcop = &PL_compiling;
3186 CopLINE_set(PL_curcop, oldline);
3189 PerlIO_printf(Perl_error_log, "panic: restartop\n");
3197 S_call_list_body(pTHX_ va_list args)
3200 CV *cv = va_arg(args, CV*);
3202 PUSHMARK(PL_stack_sp);
3203 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3208 Perl_my_exit(pTHX_ U32 status)
3212 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3213 thr, (unsigned long) status));
3222 STATUS_NATIVE_SET(status);
3229 Perl_my_failure_exit(pTHX)
3232 if (vaxc$errno & 1) {
3233 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3234 STATUS_NATIVE_SET(44);
3237 if (!vaxc$errno && errno) /* unlikely */
3238 STATUS_NATIVE_SET(44);
3240 STATUS_NATIVE_SET(vaxc$errno);
3245 STATUS_POSIX_SET(errno);
3247 exitstatus = STATUS_POSIX >> 8;
3248 if (exitstatus & 255)
3249 STATUS_POSIX_SET(exitstatus);
3251 STATUS_POSIX_SET(255);
3258 S_my_exit_jump(pTHX)
3261 register PERL_CONTEXT *cx;
3266 SvREFCNT_dec(PL_e_script);
3267 PL_e_script = Nullsv;
3270 POPSTACK_TO(PL_mainstack);
3271 if (cxstack_ix >= 0) {
3274 POPBLOCK(cx,PL_curpm);
3286 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3289 p = SvPVX(PL_e_script);
3290 nl = strchr(p, '\n');
3291 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3293 filter_del(read_e_script);
3296 sv_catpvn(buf_sv, p, nl-p);
3297 sv_chop(PL_e_script, nl);