3 * Copyright (c) 1987-1999 Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
15 #define PERL_IN_PERL_C
17 #include "patchlevel.h" /* for local_patches */
19 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
24 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
25 char *getenv (char *); /* Usually in <stdlib.h> */
28 static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen);
43 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
51 perl_alloc(struct IPerlMem* ipM, struct IPerlEnv* ipE,
52 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
53 struct IPerlDir* ipD, struct IPerlSock* ipS,
54 struct IPerlProc* ipP)
56 CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP);
64 #ifdef PERL_IMPLICIT_SYS
66 perl_alloc_using(struct IPerlMem* ipM, struct IPerlEnv* ipE,
67 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
68 struct IPerlDir* ipD, struct IPerlSock* ipS,
69 struct IPerlProc* ipP)
71 PerlInterpreter *my_perl;
73 /* New() needs interpreter, so call malloc() instead */
74 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
75 PERL_SET_INTERP(my_perl);
76 Zero(my_perl, 1, PerlInterpreter);
90 PerlInterpreter *my_perl;
92 /* New() needs interpreter, so call malloc() instead */
93 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
94 PERL_SET_INTERP(my_perl);
97 #endif /* PERL_IMPLICIT_SYS */
98 #endif /* PERL_OBJECT */
101 perl_construct(pTHXx)
106 struct perl_thread *thr = NULL;
107 #endif /* FAKE_THREADS */
108 #endif /* USE_THREADS */
112 PL_perl_destruct_level = 1;
114 if (PL_perl_destruct_level > 0)
118 /* Init the real globals (and main thread)? */
123 #ifdef ALLOC_THREAD_KEY
126 if (pthread_key_create(&PL_thr_key, 0))
127 Perl_croak(aTHX_ "panic: pthread_key_create");
129 MUTEX_INIT(&PL_sv_mutex);
131 * Safe to use basic SV functions from now on (though
132 * not things like mortals or tainting yet).
134 MUTEX_INIT(&PL_eval_mutex);
135 COND_INIT(&PL_eval_cond);
136 MUTEX_INIT(&PL_threads_mutex);
137 COND_INIT(&PL_nthreads_cond);
138 #ifdef EMULATE_ATOMIC_REFCOUNTS
139 MUTEX_INIT(&PL_svref_mutex);
140 #endif /* EMULATE_ATOMIC_REFCOUNTS */
142 MUTEX_INIT(&PL_cred_mutex);
144 thr = init_main_thread();
145 #endif /* USE_THREADS */
147 PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
149 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
151 PL_linestr = NEWSV(65,79);
152 sv_upgrade(PL_linestr,SVt_PVIV);
154 if (!SvREADONLY(&PL_sv_undef)) {
155 /* set read-only and try to insure than we wont see REFCNT==0
158 SvREADONLY_on(&PL_sv_undef);
159 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
161 sv_setpv(&PL_sv_no,PL_No);
163 SvREADONLY_on(&PL_sv_no);
164 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
166 sv_setpv(&PL_sv_yes,PL_Yes);
168 SvREADONLY_on(&PL_sv_yes);
169 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
174 /* PL_sighandlerp = sighandler; */
176 PL_sighandlerp = Perl_sighandler;
178 PL_pidstatus = newHV();
182 * There is no way we can refer to them from Perl so close them to save
183 * space. The other alternative would be to provide STDAUX and STDPRN
186 (void)fclose(stdaux);
187 (void)fclose(stdprn);
191 PL_nrs = newSVpvn("\n", 1);
192 PL_rs = SvREFCNT_inc(PL_nrs);
197 PL_lex_state = LEX_NOTPARSING;
203 SET_NUMERIC_STANDARD();
205 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
206 sprintf(PL_patchlevel, "%7.5f", (double) PERL_REVISION
207 + ((double) PERL_VERSION / (double) 1000)
208 + ((double) PERL_SUBVERSION / (double) 100000));
210 sprintf(PL_patchlevel, "%5.3f", (double) PERL_REVISION +
211 ((double) PERL_VERSION / (double) 1000));
214 #if defined(LOCAL_PATCH_COUNT)
215 PL_localpatches = local_patches; /* For possible -v */
218 PerlIO_init(); /* Hook to IO system */
220 PL_fdpid = newAV(); /* for remembering popen pids by fd */
221 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
230 int destruct_level; /* 0=none, 1=full, 2=full with checks */
236 #endif /* USE_THREADS */
240 /* Pass 1 on any remaining threads: detach joinables, join zombies */
242 MUTEX_LOCK(&PL_threads_mutex);
243 DEBUG_S(PerlIO_printf(Perl_debug_log,
244 "perl_destruct: waiting for %d threads...\n",
246 for (t = thr->next; t != thr; t = t->next) {
247 MUTEX_LOCK(&t->mutex);
248 switch (ThrSTATE(t)) {
251 DEBUG_S(PerlIO_printf(Perl_debug_log,
252 "perl_destruct: joining zombie %p\n", t));
253 ThrSETSTATE(t, THRf_DEAD);
254 MUTEX_UNLOCK(&t->mutex);
257 * The SvREFCNT_dec below may take a long time (e.g. av
258 * may contain an object scalar whose destructor gets
259 * called) so we have to unlock threads_mutex and start
262 MUTEX_UNLOCK(&PL_threads_mutex);
264 SvREFCNT_dec((SV*)av);
265 DEBUG_S(PerlIO_printf(Perl_debug_log,
266 "perl_destruct: joined zombie %p OK\n", t));
268 case THRf_R_JOINABLE:
269 DEBUG_S(PerlIO_printf(Perl_debug_log,
270 "perl_destruct: detaching thread %p\n", t));
271 ThrSETSTATE(t, THRf_R_DETACHED);
273 * We unlock threads_mutex and t->mutex in the opposite order
274 * from which we locked them just so that DETACH won't
275 * deadlock if it panics. It's only a breach of good style
276 * not a bug since they are unlocks not locks.
278 MUTEX_UNLOCK(&PL_threads_mutex);
280 MUTEX_UNLOCK(&t->mutex);
283 DEBUG_S(PerlIO_printf(Perl_debug_log,
284 "perl_destruct: ignoring %p (state %u)\n",
286 MUTEX_UNLOCK(&t->mutex);
287 /* fall through and out */
290 /* We leave the above "Pass 1" loop with threads_mutex still locked */
292 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
293 while (PL_nthreads > 1)
295 DEBUG_S(PerlIO_printf(Perl_debug_log,
296 "perl_destruct: final wait for %d threads\n",
298 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
300 /* At this point, we're the last thread */
301 MUTEX_UNLOCK(&PL_threads_mutex);
302 DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
303 MUTEX_DESTROY(&PL_threads_mutex);
304 COND_DESTROY(&PL_nthreads_cond);
305 #endif /* !defined(FAKE_THREADS) */
306 #endif /* USE_THREADS */
308 destruct_level = PL_perl_destruct_level;
312 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
314 if (destruct_level < i)
323 /* We must account for everything. */
325 /* Destroy the main CV and syntax tree */
327 PL_curpad = AvARRAY(PL_comppad);
328 op_free(PL_main_root);
329 PL_main_root = Nullop;
331 PL_curcop = &PL_compiling;
332 PL_main_start = Nullop;
333 SvREFCNT_dec(PL_main_cv);
337 if (PL_sv_objcount) {
339 * Try to destruct global references. We do this first so that the
340 * destructors and destructees still exist. Some sv's might remain.
341 * Non-referenced objects are on their own.
346 /* unhook hooks which will soon be, or use, destroyed data */
347 SvREFCNT_dec(PL_warnhook);
348 PL_warnhook = Nullsv;
349 SvREFCNT_dec(PL_diehook);
352 /* call exit list functions */
353 while (PL_exitlistlen-- > 0)
354 PL_exitlist[PL_exitlistlen].fn(aTHXo_ PL_exitlist[PL_exitlistlen].ptr);
356 Safefree(PL_exitlist);
358 if (destruct_level == 0){
360 DEBUG_P(debprofdump());
362 /* The exit() function will do everything that needs doing. */
366 /* loosen bonds of global variables */
369 (void)PerlIO_close(PL_rsfp);
373 /* Filters for program text */
374 SvREFCNT_dec(PL_rsfp_filters);
375 PL_rsfp_filters = Nullav;
378 PL_preprocess = FALSE;
384 PL_doswitches = FALSE;
385 PL_dowarn = G_WARN_OFF;
386 PL_doextract = FALSE;
387 PL_sawampersand = FALSE; /* must save all match strings */
390 Safefree(PL_inplace);
394 SvREFCNT_dec(PL_e_script);
395 PL_e_script = Nullsv;
398 /* magical thingies */
400 Safefree(PL_ofs); /* $, */
403 Safefree(PL_ors); /* $\ */
406 SvREFCNT_dec(PL_rs); /* $/ */
409 SvREFCNT_dec(PL_nrs); /* $/ helper */
412 PL_multiline = 0; /* $* */
414 SvREFCNT_dec(PL_statname);
415 PL_statname = Nullsv;
418 /* defgv, aka *_ should be taken care of elsewhere */
420 /* clean up after study() */
421 SvREFCNT_dec(PL_lastscream);
422 PL_lastscream = Nullsv;
423 Safefree(PL_screamfirst);
425 Safefree(PL_screamnext);
429 Safefree(PL_efloatbuf);
430 PL_efloatbuf = Nullch;
433 /* startup and shutdown function lists */
434 SvREFCNT_dec(PL_beginav);
435 SvREFCNT_dec(PL_endav);
436 SvREFCNT_dec(PL_stopav);
437 SvREFCNT_dec(PL_initav);
443 /* shortcuts just get cleared */
449 PL_argvoutgv = Nullgv;
451 PL_stderrgv = Nullgv;
452 PL_last_in_gv = Nullgv;
455 /* reset so print() ends up where we expect */
458 /* Prepare to destruct main symbol table. */
464 /* clear queued errors */
465 SvREFCNT_dec(PL_errors);
469 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
470 if (PL_scopestack_ix != 0)
471 Perl_warner(aTHX_ WARN_INTERNAL,
472 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
473 (long)PL_scopestack_ix);
474 if (PL_savestack_ix != 0)
475 Perl_warner(aTHX_ WARN_INTERNAL,
476 "Unbalanced saves: %ld more saves than restores\n",
477 (long)PL_savestack_ix);
478 if (PL_tmps_floor != -1)
479 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
480 (long)PL_tmps_floor + 1);
481 if (cxstack_ix != -1)
482 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
483 (long)cxstack_ix + 1);
486 /* Now absolutely destruct everything, somehow or other, loops or no. */
488 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
489 while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
490 last_sv_count = PL_sv_count;
493 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
494 SvFLAGS(PL_strtab) |= SVt_PVHV;
496 /* Destruct the global string table. */
498 /* Yell and reset the HeVAL() slots that are still holding refcounts,
499 * so that sv_free() won't fail on them.
507 max = HvMAX(PL_strtab);
508 array = HvARRAY(PL_strtab);
511 if (hent && ckWARN_d(WARN_INTERNAL)) {
512 Perl_warner(aTHX_ WARN_INTERNAL,
513 "Unbalanced string table refcount: (%d) for \"%s\"",
514 HeVAL(hent) - Nullsv, HeKEY(hent));
515 HeVAL(hent) = Nullsv;
525 SvREFCNT_dec(PL_strtab);
527 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
528 Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
532 /* No SVs have survived, need to clean out */
534 PL_pidstatus = Nullhv;
535 Safefree(PL_origfilename);
536 Safefree(PL_archpat_auto);
537 Safefree(PL_reg_start_tmp);
539 Safefree(PL_reg_curpm);
540 Safefree(PL_reg_poscache);
541 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
542 Safefree(PL_op_mask);
544 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
546 DEBUG_P(debprofdump());
548 MUTEX_DESTROY(&PL_strtab_mutex);
549 MUTEX_DESTROY(&PL_sv_mutex);
550 MUTEX_DESTROY(&PL_eval_mutex);
551 MUTEX_DESTROY(&PL_cred_mutex);
552 COND_DESTROY(&PL_eval_cond);
553 #ifdef EMULATE_ATOMIC_REFCOUNTS
554 MUTEX_DESTROY(&PL_svref_mutex);
555 #endif /* EMULATE_ATOMIC_REFCOUNTS */
557 /* As the penultimate thing, free the non-arena SV for thrsv */
558 Safefree(SvPVX(PL_thrsv));
559 Safefree(SvANY(PL_thrsv));
562 #endif /* USE_THREADS */
564 /* As the absolutely last thing, free the non-arena SV for mess() */
567 /* it could have accumulated taint magic */
568 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
571 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
572 moremagic = mg->mg_moremagic;
573 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
574 Safefree(mg->mg_ptr);
578 /* we know that type >= SVt_PV */
579 SvOOK_off(PL_mess_sv);
580 Safefree(SvPVX(PL_mess_sv));
581 Safefree(SvANY(PL_mess_sv));
582 Safefree(PL_mess_sv);
590 #if defined(PERL_OBJECT)
598 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
600 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
601 PL_exitlist[PL_exitlistlen].fn = fn;
602 PL_exitlist[PL_exitlistlen].ptr = ptr;
607 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
617 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
620 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
621 setuid perl scripts securely.\n");
625 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
626 _dyld_lookup_and_bind
627 ("__environ", (unsigned long *) &environ_pointer, NULL);
632 #ifndef VMS /* VMS doesn't have environ array */
633 PL_origenviron = environ;
638 /* Come here if running an undumped a.out. */
640 PL_origfilename = savepv(argv[0]);
641 PL_do_undump = FALSE;
642 cxstack_ix = -1; /* start label stack again */
644 init_postdump_symbols(argc,argv,env);
649 PL_curpad = AvARRAY(PL_comppad);
650 op_free(PL_main_root);
651 PL_main_root = Nullop;
653 PL_main_start = Nullop;
654 SvREFCNT_dec(PL_main_cv);
658 oldscope = PL_scopestack_ix;
659 PL_dowarn = G_WARN_OFF;
661 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_parse_body),
666 call_list(oldscope, PL_stopav);
672 /* my_exit() was called */
673 while (PL_scopestack_ix > oldscope)
676 PL_curstash = PL_defstash;
678 call_list(oldscope, PL_stopav);
679 return STATUS_NATIVE_EXPORT;
681 PerlIO_printf(Perl_error_log, "panic: top_env\n");
688 S_parse_body(pTHX_ va_list args)
691 int argc = PL_origargc;
692 char **argv = PL_origargv;
693 char **env = va_arg(args, char**);
694 char *scriptname = NULL;
696 VOL bool dosearch = FALSE;
701 char *cddir = Nullch;
703 XSINIT_t xsinit = va_arg(args, XSINIT_t);
705 sv_setpvn(PL_linestr,"",0);
706 sv = newSVpvn("",0); /* first used for -I flags */
710 for (argc--,argv++; argc > 0; argc--,argv++) {
711 if (argv[0][0] != '-' || !argv[0][1])
715 validarg = " PHOOEY ";
722 #ifndef PERL_STRICT_CR
746 if (s = moreswitches(s))
756 if (PL_euid != PL_uid || PL_egid != PL_gid)
757 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
759 PL_e_script = newSVpvn("",0);
760 filter_add(read_e_script, NULL);
763 sv_catpv(PL_e_script, s);
765 sv_catpv(PL_e_script, argv[1]);
769 Perl_croak(aTHX_ "No code specified for -e");
770 sv_catpv(PL_e_script, "\n");
773 case 'I': /* -I handled both here and in moreswitches() */
775 if (!*++s && (s=argv[1]) != Nullch) {
778 while (s && isSPACE(*s))
782 for (e = s; *e && !isSPACE(*e); e++) ;
789 } /* XXX else croak? */
793 PL_preprocess = TRUE;
803 PL_preambleav = newAV();
804 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
806 PL_Sv = newSVpv("print myconfig();",0);
808 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
810 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
812 sv_catpv(PL_Sv,"\" Compile-time options:");
814 sv_catpv(PL_Sv," DEBUGGING");
817 sv_catpv(PL_Sv," MULTIPLICITY");
820 sv_catpv(PL_Sv," USE_THREADS");
823 sv_catpv(PL_Sv," PERL_OBJECT");
825 # ifdef PERL_IMPLICIT_CONTEXT
826 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
828 # ifdef PERL_IMPLICIT_SYS
829 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
831 sv_catpv(PL_Sv,"\\n\",");
833 #if defined(LOCAL_PATCH_COUNT)
834 if (LOCAL_PATCH_COUNT > 0) {
836 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
837 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
838 if (PL_localpatches[i])
839 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
843 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
846 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
848 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
853 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
854 print \" \\%ENV:\\n @env\\n\" if @env; \
855 print \" \\@INC:\\n @INC\\n\";");
858 PL_Sv = newSVpv("config_vars(qw(",0);
859 sv_catpv(PL_Sv, ++s);
860 sv_catpv(PL_Sv, "))");
863 av_push(PL_preambleav, PL_Sv);
864 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
875 if (!*++s || isSPACE(*s)) {
879 /* catch use of gnu style long options */
880 if (strEQ(s, "version")) {
884 if (strEQ(s, "help")) {
891 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
897 #ifndef SECURE_INTERNAL_GETENV
900 (s = PerlEnv_getenv("PERL5OPT"))) {
903 if (*s == '-' && *(s+1) == 'T')
916 if (!strchr("DIMUdmw", *s))
917 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
924 scriptname = argv[0];
927 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
929 else if (scriptname == Nullch) {
931 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
939 open_script(scriptname,dosearch,sv,&fdscript);
941 validate_suid(validarg, scriptname,fdscript);
943 #if defined(SIGCHLD) || defined(SIGCLD)
946 # define SIGCHLD SIGCLD
948 Sighandler_t sigstate = rsignal_state(SIGCHLD);
949 if (sigstate == SIG_IGN) {
950 if (ckWARN(WARN_SIGNAL))
951 Perl_warner(aTHX_ WARN_SIGNAL,
952 "Can't ignore signal CHLD, forcing to default");
953 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
960 if (cddir && PerlDir_chdir(cddir) < 0)
961 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
965 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
966 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
967 CvUNIQUE_on(PL_compcv);
969 PL_comppad = newAV();
970 av_push(PL_comppad, Nullsv);
971 PL_curpad = AvARRAY(PL_comppad);
972 PL_comppad_name = newAV();
973 PL_comppad_name_fill = 0;
974 PL_min_intro_pending = 0;
977 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
978 PL_curpad[0] = (SV*)newAV();
979 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
980 CvOWNER(PL_compcv) = 0;
981 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
982 MUTEX_INIT(CvMUTEXP(PL_compcv));
983 #endif /* USE_THREADS */
985 comppadlist = newAV();
986 AvREAL_off(comppadlist);
987 av_store(comppadlist, 0, (SV*)PL_comppad_name);
988 av_store(comppadlist, 1, (SV*)PL_comppad);
989 CvPADLIST(PL_compcv) = comppadlist;
991 boot_core_UNIVERSAL();
995 (*xsinit)(aTHXo); /* in case linked C routines want magical variables */
996 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
1004 init_predump_symbols();
1005 /* init_postdump_symbols not currently designed to be called */
1006 /* more than once (ENV isn't cleared first, for example) */
1007 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
1009 init_postdump_symbols(argc,argv,env);
1013 /* now parse the script */
1015 SETERRNO(0,SS$_NORMAL);
1017 if (yyparse() || PL_error_count) {
1019 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1021 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1025 PL_curcop->cop_line = 0;
1026 PL_curstash = PL_defstash;
1027 PL_preprocess = FALSE;
1029 SvREFCNT_dec(PL_e_script);
1030 PL_e_script = Nullsv;
1033 /* now that script is parsed, we can modify record separator */
1034 SvREFCNT_dec(PL_rs);
1035 PL_rs = SvREFCNT_inc(PL_nrs);
1036 sv_setsv(get_sv("/", TRUE), PL_rs);
1041 gv_check(PL_defstash);
1047 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1048 dump_mstats("after compilation:");
1067 oldscope = PL_scopestack_ix;
1070 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
1073 cxstack_ix = -1; /* start context stack again */
1075 case 0: /* normal completion */
1076 case 2: /* my_exit() */
1077 while (PL_scopestack_ix > oldscope)
1080 PL_curstash = PL_defstash;
1081 if (PL_endav && !PL_minus_c)
1082 call_list(oldscope, PL_endav);
1084 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1085 dump_mstats("after execution: ");
1087 return STATUS_NATIVE_EXPORT;
1090 POPSTACK_TO(PL_mainstack);
1093 PerlIO_printf(Perl_error_log, "panic: restartop\n");
1103 S_run_body(pTHX_ va_list args)
1106 I32 oldscope = va_arg(args, I32);
1108 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1109 PL_sawampersand ? "Enabling" : "Omitting"));
1111 if (!PL_restartop) {
1112 DEBUG_x(dump_all());
1113 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1114 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1118 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1121 if (PERLDB_SINGLE && PL_DBsingle)
1122 sv_setiv(PL_DBsingle, 1);
1124 call_list(oldscope, PL_initav);
1130 PL_op = PL_restartop;
1134 else if (PL_main_start) {
1135 CvDEPTH(PL_main_cv) = 1;
1136 PL_op = PL_main_start;
1146 Perl_get_sv(pTHX_ const char *name, I32 create)
1150 if (name[1] == '\0' && !isALPHA(name[0])) {
1151 PADOFFSET tmp = find_threadsv(name);
1152 if (tmp != NOT_IN_PAD) {
1154 return THREADSV(tmp);
1157 #endif /* USE_THREADS */
1158 gv = gv_fetchpv(name, create, SVt_PV);
1165 Perl_get_av(pTHX_ const char *name, I32 create)
1167 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1176 Perl_get_hv(pTHX_ const char *name, I32 create)
1178 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1187 Perl_get_cv(pTHX_ const char *name, I32 create)
1189 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1190 /* XXX unsafe for threads if eval_owner isn't held */
1191 /* XXX this is probably not what they think they're getting.
1192 * It has the same effect as "sub name;", i.e. just a forward
1194 if (create && !GvCVu(gv))
1195 return newSUB(start_subparse(FALSE, 0),
1196 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1204 /* Be sure to refetch the stack pointer after calling these routines. */
1207 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1209 /* See G_* flags in cop.h */
1210 /* null terminated arg list */
1217 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1222 return call_pv(sub_name, flags);
1226 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1227 /* name of the subroutine */
1228 /* See G_* flags in cop.h */
1230 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1234 Perl_call_method(pTHX_ const char *methname, I32 flags)
1235 /* name of the subroutine */
1236 /* See G_* flags in cop.h */
1242 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1247 return call_sv(*PL_stack_sp--, flags);
1250 /* May be called with any of a CV, a GV, or an SV containing the name. */
1252 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1254 /* See G_* flags in cop.h */
1257 LOGOP myop; /* fake syntax tree node */
1261 bool oldcatch = CATCH_GET;
1266 if (flags & G_DISCARD) {
1271 Zero(&myop, 1, LOGOP);
1272 myop.op_next = Nullop;
1273 if (!(flags & G_NOARGS))
1274 myop.op_flags |= OPf_STACKED;
1275 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1276 (flags & G_ARRAY) ? OPf_WANT_LIST :
1281 EXTEND(PL_stack_sp, 1);
1282 *++PL_stack_sp = sv;
1284 oldscope = PL_scopestack_ix;
1286 if (PERLDB_SUB && PL_curstash != PL_debstash
1287 /* Handle first BEGIN of -d. */
1288 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1289 /* Try harder, since this may have been a sighandler, thus
1290 * curstash may be meaningless. */
1291 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1292 && !(flags & G_NODEBUG))
1293 PL_op->op_private |= OPpENTERSUB_DB;
1295 if (!(flags & G_EVAL)) {
1297 call_xbody((OP*)&myop, FALSE);
1298 retval = PL_stack_sp - (PL_stack_base + oldmark);
1299 CATCH_SET(oldcatch);
1302 cLOGOP->op_other = PL_op;
1304 /* we're trying to emulate pp_entertry() here */
1306 register PERL_CONTEXT *cx;
1307 I32 gimme = GIMME_V;
1312 push_return(PL_op->op_next);
1313 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1315 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1317 PL_in_eval = EVAL_INEVAL;
1318 if (flags & G_KEEPERR)
1319 PL_in_eval |= EVAL_KEEPERR;
1326 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1330 retval = PL_stack_sp - (PL_stack_base + oldmark);
1331 if (!(flags & G_KEEPERR))
1338 /* my_exit() was called */
1339 PL_curstash = PL_defstash;
1342 Perl_croak(aTHX_ "Callback called exit");
1347 PL_op = PL_restartop;
1351 PL_stack_sp = PL_stack_base + oldmark;
1352 if (flags & G_ARRAY)
1356 *++PL_stack_sp = &PL_sv_undef;
1361 if (PL_scopestack_ix > oldscope) {
1365 register PERL_CONTEXT *cx;
1376 if (flags & G_DISCARD) {
1377 PL_stack_sp = PL_stack_base + oldmark;
1387 S_call_body(pTHX_ va_list args)
1389 OP *myop = va_arg(args, OP*);
1390 int is_eval = va_arg(args, int);
1392 call_xbody(myop, is_eval);
1397 S_call_xbody(pTHX_ OP *myop, int is_eval)
1401 if (PL_op == myop) {
1403 PL_op = Perl_pp_entereval(aTHX);
1405 PL_op = Perl_pp_entersub(aTHX);
1411 /* Eval a string. The G_EVAL flag is always assumed. */
1414 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1416 /* See G_* flags in cop.h */
1419 UNOP myop; /* fake syntax tree node */
1420 I32 oldmark = SP - PL_stack_base;
1427 if (flags & G_DISCARD) {
1434 Zero(PL_op, 1, UNOP);
1435 EXTEND(PL_stack_sp, 1);
1436 *++PL_stack_sp = sv;
1437 oldscope = PL_scopestack_ix;
1439 if (!(flags & G_NOARGS))
1440 myop.op_flags = OPf_STACKED;
1441 myop.op_next = Nullop;
1442 myop.op_type = OP_ENTEREVAL;
1443 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1444 (flags & G_ARRAY) ? OPf_WANT_LIST :
1446 if (flags & G_KEEPERR)
1447 myop.op_flags |= OPf_SPECIAL;
1450 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1454 retval = PL_stack_sp - (PL_stack_base + oldmark);
1455 if (!(flags & G_KEEPERR))
1462 /* my_exit() was called */
1463 PL_curstash = PL_defstash;
1466 Perl_croak(aTHX_ "Callback called exit");
1471 PL_op = PL_restartop;
1475 PL_stack_sp = PL_stack_base + oldmark;
1476 if (flags & G_ARRAY)
1480 *++PL_stack_sp = &PL_sv_undef;
1485 if (flags & G_DISCARD) {
1486 PL_stack_sp = PL_stack_base + oldmark;
1496 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1499 SV* sv = newSVpv(p, 0);
1502 eval_sv(sv, G_SCALAR);
1509 if (croak_on_error && SvTRUE(ERRSV)) {
1511 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1517 /* Require a module. */
1520 Perl_require_pv(pTHX_ const char *pv)
1524 PUSHSTACKi(PERLSI_REQUIRE);
1526 sv = sv_newmortal();
1527 sv_setpv(sv, "require '");
1530 eval_sv(sv, G_DISCARD);
1536 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1540 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1541 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1545 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
1547 /* This message really ought to be max 23 lines.
1548 * Removed -h because the user already knows that opton. Others? */
1550 static char *usage_msg[] = {
1551 "-0[octal] specify record separator (\\0, if no argument)",
1552 "-a autosplit mode with -n or -p (splits $_ into @F)",
1553 "-c check syntax only (runs BEGIN and END blocks)",
1554 "-d[:debugger] run program under debugger",
1555 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1556 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1557 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1558 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1559 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1560 "-l[octal] enable line ending processing, specifies line terminator",
1561 "-[mM][-]module execute `use/no module...' before executing program",
1562 "-n assume 'while (<>) { ... }' loop around program",
1563 "-p assume loop like -n but print line also, like sed",
1564 "-P run program through C preprocessor before compilation",
1565 "-s enable rudimentary parsing for switches after programfile",
1566 "-S look for programfile using PATH environment variable",
1567 "-T enable tainting checks",
1568 "-u dump core after parsing program",
1569 "-U allow unsafe operations",
1570 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1571 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1572 "-w enable many useful warnings (RECOMMENDED)",
1573 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1577 char **p = usage_msg;
1579 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1581 printf("\n %s", *p++);
1584 /* This routine handles any switches that can be given during run */
1587 Perl_moreswitches(pTHX_ char *s)
1596 rschar = (U32)scan_oct(s, 4, &numlen);
1597 SvREFCNT_dec(PL_nrs);
1598 if (rschar & ~((U8)~0))
1599 PL_nrs = &PL_sv_undef;
1600 else if (!rschar && numlen >= 2)
1601 PL_nrs = newSVpvn("", 0);
1604 PL_nrs = newSVpvn(&ch, 1);
1610 PL_splitstr = savepv(s + 1);
1624 if (*s == ':' || *s == '=') {
1625 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1629 PL_perldb = PERLDB_ALL;
1637 if (isALPHA(s[1])) {
1638 static char debopts[] = "psltocPmfrxuLHXDS";
1641 for (s++; *s && (d = strchr(debopts,*s)); s++)
1642 PL_debug |= 1 << (d - debopts);
1645 PL_debug = atoi(s+1);
1646 for (s++; isDIGIT(*s); s++) ;
1648 PL_debug |= 0x80000000;
1651 if (ckWARN_d(WARN_DEBUGGING))
1652 Perl_warner(aTHX_ WARN_DEBUGGING,
1653 "Recompile perl with -DDEBUGGING to use -D switch\n");
1654 for (s++; isALNUM(*s); s++) ;
1660 usage(PL_origargv[0]);
1664 Safefree(PL_inplace);
1665 PL_inplace = savepv(s+1);
1667 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1670 if (*s == '-') /* Additional switches on #! line. */
1674 case 'I': /* -I handled both here and in parse_perl() */
1677 while (*s && isSPACE(*s))
1681 for (e = s; *e && !isSPACE(*e); e++) ;
1682 p = savepvn(s, e-s);
1688 Perl_croak(aTHX_ "No space allowed after -I");
1696 PL_ors = savepv("\n");
1698 *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
1703 if (RsPARA(PL_nrs)) {
1708 PL_ors = SvPV(PL_nrs, PL_orslen);
1709 PL_ors = savepvn(PL_ors, PL_orslen);
1713 forbid_setid("-M"); /* XXX ? */
1716 forbid_setid("-m"); /* XXX ? */
1721 /* -M-foo == 'no foo' */
1722 if (*s == '-') { use = "no "; ++s; }
1723 sv = newSVpv(use,0);
1725 /* We allow -M'Module qw(Foo Bar)' */
1726 while(isALNUM(*s) || *s==':') ++s;
1728 sv_catpv(sv, start);
1729 if (*(start-1) == 'm') {
1731 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
1732 sv_catpv( sv, " ()");
1735 sv_catpvn(sv, start, s-start);
1736 sv_catpv(sv, " split(/,/,q{");
1741 if (PL_preambleav == NULL)
1742 PL_preambleav = newAV();
1743 av_push(PL_preambleav, sv);
1746 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1758 PL_doswitches = TRUE;
1763 Perl_croak(aTHX_ "Too late for \"-T\" option");
1767 PL_do_undump = TRUE;
1775 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
1776 printf("\nThis is perl, version %d.%03d_%02d built for %s",
1777 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME);
1779 printf("\nThis is perl, version %s built for %s",
1780 PL_patchlevel, ARCHNAME);
1782 #if defined(LOCAL_PATCH_COUNT)
1783 if (LOCAL_PATCH_COUNT > 0)
1784 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1785 (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1788 printf("\n\nCopyright 1987-1999, Larry Wall\n");
1790 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1793 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1794 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
1797 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1798 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
1801 printf("atariST series port, ++jrb bammi@cadence.com\n");
1804 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
1807 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1810 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
1813 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
1816 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
1819 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
1822 printf("MiNT port by Guido Flohr, 1997-1999\n");
1824 #ifdef BINARY_BUILD_NOTICE
1825 BINARY_BUILD_NOTICE;
1828 Perl may be copied only under the terms of either the Artistic License or the\n\
1829 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1830 Complete documentation for Perl, including FAQ lists, should be found on\n\
1831 this system using `man perl' or `perldoc perl'. If you have access to the\n\
1832 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1835 if (! (PL_dowarn & G_WARN_ALL_MASK))
1836 PL_dowarn |= G_WARN_ON;
1840 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1841 PL_compiling.cop_warnings = WARN_ALL ;
1845 PL_dowarn = G_WARN_ALL_OFF;
1846 PL_compiling.cop_warnings = WARN_NONE ;
1851 if (s[1] == '-') /* Additional switches on #! line. */
1856 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1862 #ifdef ALTERNATE_SHEBANG
1863 case 'S': /* OS/2 needs -S on "extproc" line. */
1871 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
1876 /* compliments of Tom Christiansen */
1878 /* unexec() can be found in the Gnu emacs distribution */
1879 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1882 Perl_my_unexec(pTHX)
1890 prog = newSVpv(BIN_EXP, 0);
1891 sv_catpv(prog, "/perl");
1892 file = newSVpv(PL_origfilename, 0);
1893 sv_catpv(file, ".perldump");
1895 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1896 /* unexec prints msg to stderr in case of failure */
1897 PerlProc_exit(status);
1900 # include <lib$routines.h>
1901 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1903 ABORT(); /* for use with undump */
1908 /* initialize curinterp */
1913 #ifdef PERL_OBJECT /* XXX kludge */
1916 PL_chopset = " \n-"; \
1917 PL_copline = NOLINE; \
1918 PL_curcop = &PL_compiling;\
1919 PL_curcopdb = NULL; \
1921 PL_dumpindent = 4; \
1922 PL_laststatval = -1; \
1923 PL_laststype = OP_STAT; \
1924 PL_maxscream = -1; \
1925 PL_maxsysfd = MAXSYSFD; \
1926 PL_statname = Nullsv; \
1927 PL_tmps_floor = -1; \
1929 PL_op_mask = NULL; \
1930 PL_laststatval = -1; \
1931 PL_laststype = OP_STAT; \
1932 PL_mess_sv = Nullsv; \
1933 PL_splitstr = " "; \
1934 PL_generation = 100; \
1935 PL_exitlist = NULL; \
1936 PL_exitlistlen = 0; \
1938 PL_in_clean_objs = FALSE; \
1939 PL_in_clean_all = FALSE; \
1940 PL_profiledata = NULL; \
1942 PL_rsfp_filters = Nullav; \
1947 # ifdef MULTIPLICITY
1948 # define PERLVAR(var,type)
1949 # define PERLVARA(var,n,type)
1950 # if defined(PERL_IMPLICIT_CONTEXT)
1951 # if defined(USE_THREADS)
1952 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
1953 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
1954 # else /* !USE_THREADS */
1955 # define PERLVARI(var,type,init) aTHX->var = init;
1956 # define PERLVARIC(var,type,init) aTHX->var = init;
1957 # endif /* USE_THREADS */
1959 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
1960 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
1962 # include "intrpvar.h"
1963 # ifndef USE_THREADS
1964 # include "thrdvar.h"
1971 # define PERLVAR(var,type)
1972 # define PERLVARA(var,n,type)
1973 # define PERLVARI(var,type,init) PL_##var = init;
1974 # define PERLVARIC(var,type,init) PL_##var = init;
1975 # include "intrpvar.h"
1976 # ifndef USE_THREADS
1977 # include "thrdvar.h"
1989 S_init_main_stash(pTHX)
1994 /* Note that strtab is a rather special HV. Assumptions are made
1995 about not iterating on it, and not adding tie magic to it.
1996 It is properly deallocated in perl_destruct() */
1997 PL_strtab = newHV();
1999 MUTEX_INIT(&PL_strtab_mutex);
2001 HvSHAREKEYS_off(PL_strtab); /* mandatory */
2002 hv_ksplit(PL_strtab, 512);
2004 PL_curstash = PL_defstash = newHV();
2005 PL_curstname = newSVpvn("main",4);
2006 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2007 SvREFCNT_dec(GvHV(gv));
2008 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2010 HvNAME(PL_defstash) = savepv("main");
2011 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2012 GvMULTI_on(PL_incgv);
2013 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2014 GvMULTI_on(PL_hintgv);
2015 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2016 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2017 GvMULTI_on(PL_errgv);
2018 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2019 GvMULTI_on(PL_replgv);
2020 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
2021 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2022 sv_setpvn(ERRSV, "", 0);
2023 PL_curstash = PL_defstash;
2024 PL_compiling.cop_stash = PL_defstash;
2025 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2026 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2027 /* We must init $/ before switches are processed. */
2028 sv_setpvn(get_sv("/", TRUE), "\n", 1);
2032 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2040 PL_origfilename = savepv("-e");
2043 /* if find_script() returns, it returns a malloc()-ed value */
2044 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2046 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2047 char *s = scriptname + 8;
2048 *fdscript = atoi(s);
2052 scriptname = savepv(s + 1);
2053 Safefree(PL_origfilename);
2054 PL_origfilename = scriptname;
2059 CopFILEGV_set(PL_curcop, gv_fetchfile(PL_origfilename));
2060 if (strEQ(PL_origfilename,"-"))
2062 if (*fdscript >= 0) {
2063 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2064 #if defined(HAS_FCNTL) && defined(F_SETFD)
2066 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2069 else if (PL_preprocess) {
2070 char *cpp_cfg = CPPSTDIN;
2071 SV *cpp = newSVpvn("",0);
2072 SV *cmd = NEWSV(0,0);
2074 if (strEQ(cpp_cfg, "cppstdin"))
2075 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2076 sv_catpv(cpp, cpp_cfg);
2079 sv_catpv(sv,PRIVLIB_EXP);
2082 Perl_sv_setpvf(aTHX_ cmd, "\
2083 sed %s -e \"/^[^#]/b\" \
2084 -e \"/^#[ ]*include[ ]/b\" \
2085 -e \"/^#[ ]*define[ ]/b\" \
2086 -e \"/^#[ ]*if[ ]/b\" \
2087 -e \"/^#[ ]*ifdef[ ]/b\" \
2088 -e \"/^#[ ]*ifndef[ ]/b\" \
2089 -e \"/^#[ ]*else/b\" \
2090 -e \"/^#[ ]*elif[ ]/b\" \
2091 -e \"/^#[ ]*undef[ ]/b\" \
2092 -e \"/^#[ ]*endif/b\" \
2095 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2098 Perl_sv_setpvf(aTHX_ cmd, "\
2099 %s %s -e '/^[^#]/b' \
2100 -e '/^#[ ]*include[ ]/b' \
2101 -e '/^#[ ]*define[ ]/b' \
2102 -e '/^#[ ]*if[ ]/b' \
2103 -e '/^#[ ]*ifdef[ ]/b' \
2104 -e '/^#[ ]*ifndef[ ]/b' \
2105 -e '/^#[ ]*else/b' \
2106 -e '/^#[ ]*elif[ ]/b' \
2107 -e '/^#[ ]*undef[ ]/b' \
2108 -e '/^#[ ]*endif/b' \
2112 Perl_sv_setpvf(aTHX_ cmd, "\
2113 %s %s -e '/^[^#]/b' \
2114 -e '/^#[ ]*include[ ]/b' \
2115 -e '/^#[ ]*define[ ]/b' \
2116 -e '/^#[ ]*if[ ]/b' \
2117 -e '/^#[ ]*ifdef[ ]/b' \
2118 -e '/^#[ ]*ifndef[ ]/b' \
2119 -e '/^#[ ]*else/b' \
2120 -e '/^#[ ]*elif[ ]/b' \
2121 -e '/^#[ ]*undef[ ]/b' \
2122 -e '/^#[ ]*endif/b' \
2131 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2133 scriptname, cpp, sv, CPPMINUS);
2134 PL_doextract = FALSE;
2135 #ifdef IAMSUID /* actually, this is caught earlier */
2136 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2138 (void)seteuid(PL_uid); /* musn't stay setuid root */
2141 (void)setreuid((Uid_t)-1, PL_uid);
2143 #ifdef HAS_SETRESUID
2144 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2146 PerlProc_setuid(PL_uid);
2150 if (PerlProc_geteuid() != PL_uid)
2151 Perl_croak(aTHX_ "Can't do seteuid!\n");
2153 #endif /* IAMSUID */
2154 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2158 else if (!*scriptname) {
2159 forbid_setid("program input from stdin");
2160 PL_rsfp = PerlIO_stdin();
2163 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2164 #if defined(HAS_FCNTL) && defined(F_SETFD)
2166 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2171 #ifndef IAMSUID /* in case script is not readable before setuid */
2173 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2174 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2177 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2178 Perl_croak(aTHX_ "Can't do setuid\n");
2182 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2183 CopFILE(PL_curcop), Strerror(errno));
2188 * I_SYSSTATVFS HAS_FSTATVFS
2190 * I_STATFS HAS_FSTATFS
2191 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2192 * here so that metaconfig picks them up. */
2196 S_fd_on_nosuid_fs(pTHX_ int fd)
2198 int check_okay = 0; /* able to do all the required sys/libcalls */
2199 int on_nosuid = 0; /* the fd is on a nosuid fs */
2201 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2202 * fstatvfs() is UNIX98.
2203 * fstatfs() is 4.3 BSD.
2204 * ustat()+getmnt() is pre-4.3 BSD.
2205 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2206 * an irrelevant filesystem while trying to reach the right one.
2209 # ifdef HAS_FSTATVFS
2210 struct statvfs stfs;
2211 check_okay = fstatvfs(fd, &stfs) == 0;
2212 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2214 # ifdef PERL_MOUNT_NOSUID
2215 # if defined(HAS_FSTATFS) && \
2216 defined(HAS_STRUCT_STATFS) && \
2217 defined(HAS_STRUCT_STATFS_F_FLAGS)
2219 check_okay = fstatfs(fd, &stfs) == 0;
2220 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2222 # if defined(HAS_FSTAT) && \
2223 defined(HAS_USTAT) && \
2224 defined(HAS_GETMNT) && \
2225 defined(HAS_STRUCT_FS_DATA) &&
2228 if (fstat(fd, &fdst) == 0) {
2230 if (ustat(fdst.st_dev, &us) == 0) {
2232 /* NOSTAT_ONE here because we're not examining fields which
2233 * vary between that case and STAT_ONE. */
2234 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2235 size_t cmplen = sizeof(us.f_fname);
2236 if (sizeof(fsd.fd_req.path) < cmplen)
2237 cmplen = sizeof(fsd.fd_req.path);
2238 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2239 fdst.st_dev == fsd.fd_req.dev) {
2241 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2247 # endif /* fstat+ustat+getmnt */
2248 # endif /* fstatfs */
2250 # if defined(HAS_GETMNTENT) && \
2251 defined(HAS_HASMNTOPT) && \
2252 defined(MNTOPT_NOSUID)
2253 FILE *mtab = fopen("/etc/mtab", "r");
2254 struct mntent *entry;
2255 struct stat stb, fsb;
2257 if (mtab && (fstat(fd, &stb) == 0)) {
2258 while (entry = getmntent(mtab)) {
2259 if (stat(entry->mnt_dir, &fsb) == 0
2260 && fsb.st_dev == stb.st_dev)
2262 /* found the filesystem */
2264 if (hasmntopt(entry, MNTOPT_NOSUID))
2267 } /* A single fs may well fail its stat(). */
2272 # endif /* getmntent+hasmntopt */
2273 # endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */
2274 # endif /* statvfs */
2277 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
2280 #endif /* IAMSUID */
2283 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2287 /* do we need to emulate setuid on scripts? */
2289 /* This code is for those BSD systems that have setuid #! scripts disabled
2290 * in the kernel because of a security problem. Merely defining DOSUID
2291 * in perl will not fix that problem, but if you have disabled setuid
2292 * scripts in the kernel, this will attempt to emulate setuid and setgid
2293 * on scripts that have those now-otherwise-useless bits set. The setuid
2294 * root version must be called suidperl or sperlN.NNN. If regular perl
2295 * discovers that it has opened a setuid script, it calls suidperl with
2296 * the same argv that it had. If suidperl finds that the script it has
2297 * just opened is NOT setuid root, it sets the effective uid back to the
2298 * uid. We don't just make perl setuid root because that loses the
2299 * effective uid we had before invoking perl, if it was different from the
2302 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2303 * be defined in suidperl only. suidperl must be setuid root. The
2304 * Configure script will set this up for you if you want it.
2311 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2312 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2313 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2318 #ifndef HAS_SETREUID
2319 /* On this access check to make sure the directories are readable,
2320 * there is actually a small window that the user could use to make
2321 * filename point to an accessible directory. So there is a faint
2322 * chance that someone could execute a setuid script down in a
2323 * non-accessible directory. I don't know what to do about that.
2324 * But I don't think it's too important. The manual lies when
2325 * it says access() is useful in setuid programs.
2327 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
2328 Perl_croak(aTHX_ "Permission denied");
2330 /* If we can swap euid and uid, then we can determine access rights
2331 * with a simple stat of the file, and then compare device and
2332 * inode to make sure we did stat() on the same file we opened.
2333 * Then we just have to make sure he or she can execute it.
2336 struct stat tmpstatbuf;
2340 setreuid(PL_euid,PL_uid) < 0
2343 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2346 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2347 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2348 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
2349 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2350 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2351 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2352 Perl_croak(aTHX_ "Permission denied");
2354 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2355 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2356 (void)PerlIO_close(PL_rsfp);
2357 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2358 PerlIO_printf(PL_rsfp,
2359 "User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2360 (Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n",
2361 PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2362 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2364 PL_statbuf.st_uid, PL_statbuf.st_gid);
2365 (void)PerlProc_pclose(PL_rsfp);
2367 Perl_croak(aTHX_ "Permission denied\n");
2371 setreuid(PL_uid,PL_euid) < 0
2373 # if defined(HAS_SETRESUID)
2374 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2377 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2378 Perl_croak(aTHX_ "Can't reswap uid and euid");
2379 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2380 Perl_croak(aTHX_ "Permission denied\n");
2382 #endif /* HAS_SETREUID */
2383 #endif /* IAMSUID */
2385 if (!S_ISREG(PL_statbuf.st_mode))
2386 Perl_croak(aTHX_ "Permission denied");
2387 if (PL_statbuf.st_mode & S_IWOTH)
2388 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2389 PL_doswitches = FALSE; /* -s is insecure in suid */
2390 PL_curcop->cop_line++;
2391 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2392 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2393 Perl_croak(aTHX_ "No #! line");
2394 s = SvPV(PL_linestr,n_a)+2;
2396 while (!isSPACE(*s)) s++;
2397 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2398 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2399 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2400 Perl_croak(aTHX_ "Not a perl script");
2401 while (*s == ' ' || *s == '\t') s++;
2403 * #! arg must be what we saw above. They can invoke it by
2404 * mentioning suidperl explicitly, but they may not add any strange
2405 * arguments beyond what #! says if they do invoke suidperl that way.
2407 len = strlen(validarg);
2408 if (strEQ(validarg," PHOOEY ") ||
2409 strnNE(s,validarg,len) || !isSPACE(s[len]))
2410 Perl_croak(aTHX_ "Args must match #! line");
2413 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2414 PL_euid == PL_statbuf.st_uid)
2416 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2417 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2418 #endif /* IAMSUID */
2420 if (PL_euid) { /* oops, we're not the setuid root perl */
2421 (void)PerlIO_close(PL_rsfp);
2424 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2426 Perl_croak(aTHX_ "Can't do setuid\n");
2429 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2431 (void)setegid(PL_statbuf.st_gid);
2434 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2436 #ifdef HAS_SETRESGID
2437 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2439 PerlProc_setgid(PL_statbuf.st_gid);
2443 if (PerlProc_getegid() != PL_statbuf.st_gid)
2444 Perl_croak(aTHX_ "Can't do setegid!\n");
2446 if (PL_statbuf.st_mode & S_ISUID) {
2447 if (PL_statbuf.st_uid != PL_euid)
2449 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2452 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2454 #ifdef HAS_SETRESUID
2455 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2457 PerlProc_setuid(PL_statbuf.st_uid);
2461 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2462 Perl_croak(aTHX_ "Can't do seteuid!\n");
2464 else if (PL_uid) { /* oops, mustn't run as root */
2466 (void)seteuid((Uid_t)PL_uid);
2469 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2471 #ifdef HAS_SETRESUID
2472 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2474 PerlProc_setuid((Uid_t)PL_uid);
2478 if (PerlProc_geteuid() != PL_uid)
2479 Perl_croak(aTHX_ "Can't do seteuid!\n");
2482 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2483 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
2486 else if (PL_preprocess)
2487 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2488 else if (fdscript >= 0)
2489 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2491 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2493 /* We absolutely must clear out any saved ids here, so we */
2494 /* exec the real perl, substituting fd script for scriptname. */
2495 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2496 PerlIO_rewind(PL_rsfp);
2497 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2498 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2499 if (!PL_origargv[which])
2500 Perl_croak(aTHX_ "Permission denied");
2501 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2502 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2503 #if defined(HAS_FCNTL) && defined(F_SETFD)
2504 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2506 PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
2507 Perl_croak(aTHX_ "Can't do setuid\n");
2508 #endif /* IAMSUID */
2510 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2511 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2513 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2514 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2516 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2519 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2520 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2521 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2522 /* not set-id, must be wrapped */
2528 S_find_beginning(pTHX)
2530 register char *s, *s2;
2532 /* skip forward in input to the real script? */
2535 while (PL_doextract) {
2536 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2537 Perl_croak(aTHX_ "No Perl script found in input\n");
2538 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2539 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2540 PL_doextract = FALSE;
2541 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2543 while (*s == ' ' || *s == '\t') s++;
2545 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2546 if (strnEQ(s2-4,"perl",4))
2548 while (s = moreswitches(s)) ;
2558 PL_uid = PerlProc_getuid();
2559 PL_euid = PerlProc_geteuid();
2560 PL_gid = PerlProc_getgid();
2561 PL_egid = PerlProc_getegid();
2563 PL_uid |= PL_gid << 16;
2564 PL_euid |= PL_egid << 16;
2566 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2570 S_forbid_setid(pTHX_ char *s)
2572 if (PL_euid != PL_uid)
2573 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2574 if (PL_egid != PL_gid)
2575 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2579 Perl_init_debugger(pTHX)
2582 HV *ostash = PL_curstash;
2584 PL_curstash = PL_debstash;
2585 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2586 AvREAL_off(PL_dbargs);
2587 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2588 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2589 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2590 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
2591 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2592 sv_setiv(PL_DBsingle, 0);
2593 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2594 sv_setiv(PL_DBtrace, 0);
2595 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2596 sv_setiv(PL_DBsignal, 0);
2597 PL_curstash = ostash;
2600 #ifndef STRESS_REALLOC
2601 #define REASONABLE(size) (size)
2603 #define REASONABLE(size) (1) /* unreasonable */
2607 Perl_init_stacks(pTHX)
2609 /* start with 128-item stack and 8K cxstack */
2610 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2611 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2612 PL_curstackinfo->si_type = PERLSI_MAIN;
2613 PL_curstack = PL_curstackinfo->si_stack;
2614 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2616 PL_stack_base = AvARRAY(PL_curstack);
2617 PL_stack_sp = PL_stack_base;
2618 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2620 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2623 PL_tmps_max = REASONABLE(128);
2625 New(54,PL_markstack,REASONABLE(32),I32);
2626 PL_markstack_ptr = PL_markstack;
2627 PL_markstack_max = PL_markstack + REASONABLE(32);
2631 New(54,PL_scopestack,REASONABLE(32),I32);
2632 PL_scopestack_ix = 0;
2633 PL_scopestack_max = REASONABLE(32);
2635 New(54,PL_savestack,REASONABLE(128),ANY);
2636 PL_savestack_ix = 0;
2637 PL_savestack_max = REASONABLE(128);
2639 New(54,PL_retstack,REASONABLE(16),OP*);
2641 PL_retstack_max = REASONABLE(16);
2650 while (PL_curstackinfo->si_next)
2651 PL_curstackinfo = PL_curstackinfo->si_next;
2652 while (PL_curstackinfo) {
2653 PERL_SI *p = PL_curstackinfo->si_prev;
2654 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2655 Safefree(PL_curstackinfo->si_cxstack);
2656 Safefree(PL_curstackinfo);
2657 PL_curstackinfo = p;
2659 Safefree(PL_tmps_stack);
2660 Safefree(PL_markstack);
2661 Safefree(PL_scopestack);
2662 Safefree(PL_savestack);
2663 Safefree(PL_retstack);
2667 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2678 lex_start(PL_linestr);
2680 PL_subname = newSVpvn("main",4);
2684 S_init_predump_symbols(pTHX)
2691 sv_setpvn(get_sv("\"", TRUE), " ", 1);
2692 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2693 GvMULTI_on(PL_stdingv);
2694 io = GvIOp(PL_stdingv);
2695 IoIFP(io) = PerlIO_stdin();
2696 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2698 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2700 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2703 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
2705 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2707 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2709 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2710 GvMULTI_on(PL_stderrgv);
2711 io = GvIOp(PL_stderrgv);
2712 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
2713 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2715 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2717 PL_statname = NEWSV(66,0); /* last filename we did stat on */
2720 PL_osname = savepv(OSNAME);
2724 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
2731 argc--,argv++; /* skip name of script */
2732 if (PL_doswitches) {
2733 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2736 if (argv[0][1] == '-') {
2740 if (s = strchr(argv[0], '=')) {
2742 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2745 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2748 PL_toptarget = NEWSV(0,0);
2749 sv_upgrade(PL_toptarget, SVt_PVFM);
2750 sv_setpvn(PL_toptarget, "", 0);
2751 PL_bodytarget = NEWSV(0,0);
2752 sv_upgrade(PL_bodytarget, SVt_PVFM);
2753 sv_setpvn(PL_bodytarget, "", 0);
2754 PL_formtarget = PL_bodytarget;
2757 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2758 sv_setpv(GvSV(tmpgv),PL_origfilename);
2759 magicname("0", "0", 1);
2761 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2763 sv_setpv(GvSV(tmpgv), os2_execname());
2765 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2767 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2768 GvMULTI_on(PL_argvgv);
2769 (void)gv_AVadd(PL_argvgv);
2770 av_clear(GvAVn(PL_argvgv));
2771 for (; argc > 0; argc--,argv++) {
2772 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2774 PL_argvout_stack = newAV();
2776 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2778 GvMULTI_on(PL_envgv);
2779 hv = GvHVn(PL_envgv);
2780 hv_magic(hv, PL_envgv, 'E');
2781 #if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
2782 /* Note that if the supplied env parameter is actually a copy
2783 of the global environ then it may now point to free'd memory
2784 if the environment has been modified since. To avoid this
2785 problem we treat env==NULL as meaning 'use the default'
2790 environ[0] = Nullch;
2791 for (; *env; env++) {
2792 if (!(s = strchr(*env,'=')))
2798 sv = newSVpv(s--,0);
2799 (void)hv_store(hv, *env, s - *env, sv, 0);
2801 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2802 /* Sins of the RTL. See note in my_setenv(). */
2803 (void)PerlEnv_putenv(savepv(*env));
2807 #ifdef DYNAMIC_ENV_FETCH
2808 HvNAME(hv) = savepv(ENV_HV_NAME);
2812 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2813 sv_setiv(GvSV(tmpgv), (IV)getpid());
2817 S_init_perllib(pTHX)
2822 s = PerlEnv_getenv("PERL5LIB");
2826 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2828 /* Treat PERL5?LIB as a possible search list logical name -- the
2829 * "natural" VMS idiom for a Unix path string. We allow each
2830 * element to be a set of |-separated directories for compatibility.
2834 if (my_trnlnm("PERL5LIB",buf,0))
2835 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2837 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2841 /* Use the ~-expanded versions of APPLLIB (undocumented),
2842 ARCHLIB PRIVLIB SITEARCH and SITELIB
2845 incpush(APPLLIB_EXP, TRUE);
2849 incpush(ARCHLIB_EXP, FALSE);
2852 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2855 incpush(PRIVLIB_EXP, TRUE);
2857 incpush(PRIVLIB_EXP, FALSE);
2861 incpush(SITEARCH_EXP, FALSE);
2865 incpush(SITELIB_EXP, TRUE);
2867 incpush(SITELIB_EXP, FALSE);
2870 #if defined(PERL_VENDORLIB_EXP)
2872 incpush(PERL_VENDORLIB_EXP, TRUE);
2874 incpush(PERL_VENDORLIB_EXP, FALSE);
2878 incpush(".", FALSE);
2882 # define PERLLIB_SEP ';'
2885 # define PERLLIB_SEP '|'
2887 # define PERLLIB_SEP ':'
2890 #ifndef PERLLIB_MANGLE
2891 # define PERLLIB_MANGLE(s,n) (s)
2895 S_incpush(pTHX_ char *p, int addsubdirs)
2897 SV *subdir = Nullsv;
2903 subdir = sv_newmortal();
2904 if (!PL_archpat_auto) {
2905 STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
2906 + sizeof("//auto"));
2907 New(55, PL_archpat_auto, len, char);
2908 sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
2910 for (len = sizeof(ARCHNAME) + 2;
2911 PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2912 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
2917 /* Break at all separators */
2919 SV *libdir = NEWSV(55,0);
2922 /* skip any consecutive separators */
2923 while ( *p == PERLLIB_SEP ) {
2924 /* Uncomment the next line for PATH semantics */
2925 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
2929 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2930 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2935 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2936 p = Nullch; /* break out */
2940 * BEFORE pushing libdir onto @INC we may first push version- and
2941 * archname-specific sub-directories.
2944 struct stat tmpstatbuf;
2949 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
2951 while (unix[len-1] == '/') len--; /* Cosmetic */
2952 sv_usepvn(libdir,unix,len);
2955 PerlIO_printf(Perl_error_log,
2956 "Failed to unixify @INC element \"%s\"\n",
2959 /* .../archname/version if -d .../archname/version/auto */
2960 sv_setsv(subdir, libdir);
2961 sv_catpv(subdir, PL_archpat_auto);
2962 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2963 S_ISDIR(tmpstatbuf.st_mode))
2964 av_push(GvAVn(PL_incgv),
2965 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2967 /* .../archname if -d .../archname/auto */
2968 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2969 strlen(PL_patchlevel) + 1, "", 0);
2970 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2971 S_ISDIR(tmpstatbuf.st_mode))
2972 av_push(GvAVn(PL_incgv),
2973 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2976 /* finally push this lib directory on the end of @INC */
2977 av_push(GvAVn(PL_incgv), libdir);
2982 STATIC struct perl_thread *
2983 S_init_main_thread(pTHX)
2985 #if !defined(PERL_IMPLICIT_CONTEXT)
2986 struct perl_thread *thr;
2990 Newz(53, thr, 1, struct perl_thread);
2991 PL_curcop = &PL_compiling;
2992 thr->interp = PERL_GET_INTERP;
2993 thr->cvcache = newHV();
2994 thr->threadsv = newAV();
2995 /* thr->threadsvp is set when find_threadsv is called */
2996 thr->specific = newAV();
2997 thr->flags = THRf_R_JOINABLE;
2998 MUTEX_INIT(&thr->mutex);
2999 /* Handcraft thrsv similarly to mess_sv */
3000 New(53, PL_thrsv, 1, SV);
3001 Newz(53, xpv, 1, XPV);
3002 SvFLAGS(PL_thrsv) = SVt_PV;
3003 SvANY(PL_thrsv) = (void*)xpv;
3004 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3005 SvPVX(PL_thrsv) = (char*)thr;
3006 SvCUR_set(PL_thrsv, sizeof(thr));
3007 SvLEN_set(PL_thrsv, sizeof(thr));
3008 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3009 thr->oursv = PL_thrsv;
3010 PL_chopset = " \n-";
3013 MUTEX_LOCK(&PL_threads_mutex);
3018 MUTEX_UNLOCK(&PL_threads_mutex);
3020 #ifdef HAVE_THREAD_INTERN
3021 Perl_init_thread_intern(thr);
3024 #ifdef SET_THREAD_SELF
3025 SET_THREAD_SELF(thr);
3027 thr->self = pthread_self();
3028 #endif /* SET_THREAD_SELF */
3032 * These must come after the SET_THR because sv_setpvn does
3033 * SvTAINT and the taint fields require dTHR.
3035 PL_toptarget = NEWSV(0,0);
3036 sv_upgrade(PL_toptarget, SVt_PVFM);
3037 sv_setpvn(PL_toptarget, "", 0);
3038 PL_bodytarget = NEWSV(0,0);
3039 sv_upgrade(PL_bodytarget, SVt_PVFM);
3040 sv_setpvn(PL_bodytarget, "", 0);
3041 PL_formtarget = PL_bodytarget;
3042 thr->errsv = newSVpvn("", 0);
3043 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
3046 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3047 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3048 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3049 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3050 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3052 PL_reginterp_cnt = 0;
3056 #endif /* USE_THREADS */
3059 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3063 line_t oldline = PL_curcop->cop_line;
3069 while (AvFILL(paramList) >= 0) {
3070 cv = (CV*)av_shift(paramList);
3072 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
3075 (void)SvPV(atsv, len);
3077 PL_curcop = &PL_compiling;
3078 PL_curcop->cop_line = oldline;
3079 if (paramList == PL_beginav)
3080 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3082 Perl_sv_catpvf(aTHX_ atsv,
3083 "%s failed--call queue aborted",
3084 paramList == PL_stopav ? "STOP"
3085 : paramList == PL_initav ? "INIT"
3087 while (PL_scopestack_ix > oldscope)
3089 Perl_croak(aTHX_ "%s", SvPVX(atsv));
3096 /* my_exit() was called */
3097 while (PL_scopestack_ix > oldscope)
3100 PL_curstash = PL_defstash;
3101 PL_curcop = &PL_compiling;
3102 PL_curcop->cop_line = oldline;
3103 if (PL_statusvalue) {
3104 if (paramList == PL_beginav)
3105 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3107 Perl_croak(aTHX_ "%s failed--call queue aborted",
3108 paramList == PL_stopav ? "STOP"
3109 : paramList == PL_initav ? "INIT"
3116 PL_curcop = &PL_compiling;
3117 PL_curcop->cop_line = oldline;
3120 PerlIO_printf(Perl_error_log, "panic: restartop\n");
3128 S_call_list_body(pTHX_ va_list args)
3131 CV *cv = va_arg(args, CV*);
3133 PUSHMARK(PL_stack_sp);
3134 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3139 Perl_my_exit(pTHX_ U32 status)
3143 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3144 thr, (unsigned long) status));
3153 STATUS_NATIVE_SET(status);
3160 Perl_my_failure_exit(pTHX)
3163 if (vaxc$errno & 1) {
3164 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3165 STATUS_NATIVE_SET(44);
3168 if (!vaxc$errno && errno) /* unlikely */
3169 STATUS_NATIVE_SET(44);
3171 STATUS_NATIVE_SET(vaxc$errno);
3176 STATUS_POSIX_SET(errno);
3178 exitstatus = STATUS_POSIX >> 8;
3179 if (exitstatus & 255)
3180 STATUS_POSIX_SET(exitstatus);
3182 STATUS_POSIX_SET(255);
3189 S_my_exit_jump(pTHX)
3192 register PERL_CONTEXT *cx;
3197 SvREFCNT_dec(PL_e_script);
3198 PL_e_script = Nullsv;
3201 POPSTACK_TO(PL_mainstack);
3202 if (cxstack_ix >= 0) {
3205 POPBLOCK(cx,PL_curpm);
3217 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3220 p = SvPVX(PL_e_script);
3221 nl = strchr(p, '\n');
3222 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3224 filter_del(read_e_script);
3227 sv_catpvn(buf_sv, p, nl-p);
3228 sv_chop(PL_e_script, nl);