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 %"UVuf")\n",
285 t, (UV)ThrSTATE(t)));
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 #ifdef MACOS_TRADITIONAL
757 /* ignore -e for Dev:Pseudo argument */
758 if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
761 if (PL_euid != PL_uid || PL_egid != PL_gid)
762 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
764 PL_e_script = newSVpvn("",0);
765 filter_add(read_e_script, NULL);
768 sv_catpv(PL_e_script, s);
770 sv_catpv(PL_e_script, argv[1]);
774 Perl_croak(aTHX_ "No code specified for -e");
775 sv_catpv(PL_e_script, "\n");
778 case 'I': /* -I handled both here and in moreswitches() */
780 if (!*++s && (s=argv[1]) != Nullch) {
783 while (s && isSPACE(*s))
787 for (e = s; *e && !isSPACE(*e); e++) ;
794 } /* XXX else croak? */
798 PL_preprocess = TRUE;
808 PL_preambleav = newAV();
809 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
811 PL_Sv = newSVpv("print myconfig();",0);
813 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
815 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
817 sv_catpv(PL_Sv,"\" Compile-time options:");
819 sv_catpv(PL_Sv," DEBUGGING");
822 sv_catpv(PL_Sv," MULTIPLICITY");
825 sv_catpv(PL_Sv," USE_THREADS");
828 sv_catpv(PL_Sv," PERL_OBJECT");
830 # ifdef PERL_IMPLICIT_CONTEXT
831 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
833 # ifdef PERL_IMPLICIT_SYS
834 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
836 sv_catpv(PL_Sv,"\\n\",");
838 #if defined(LOCAL_PATCH_COUNT)
839 if (LOCAL_PATCH_COUNT > 0) {
841 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
842 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
843 if (PL_localpatches[i])
844 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
848 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
851 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
853 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
858 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
859 print \" \\%ENV:\\n @env\\n\" if @env; \
860 print \" \\@INC:\\n @INC\\n\";");
863 PL_Sv = newSVpv("config_vars(qw(",0);
864 sv_catpv(PL_Sv, ++s);
865 sv_catpv(PL_Sv, "))");
868 av_push(PL_preambleav, PL_Sv);
869 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
880 if (!*++s || isSPACE(*s)) {
884 /* catch use of gnu style long options */
885 if (strEQ(s, "version")) {
889 if (strEQ(s, "help")) {
896 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
902 #ifndef SECURE_INTERNAL_GETENV
905 (s = PerlEnv_getenv("PERL5OPT"))) {
908 if (*s == '-' && *(s+1) == 'T')
921 if (!strchr("DIMUdmw", *s))
922 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
929 scriptname = argv[0];
932 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
934 else if (scriptname == Nullch) {
936 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
944 open_script(scriptname,dosearch,sv,&fdscript);
946 validate_suid(validarg, scriptname,fdscript);
948 #if defined(SIGCHLD) || defined(SIGCLD)
951 # define SIGCHLD SIGCLD
953 Sighandler_t sigstate = rsignal_state(SIGCHLD);
954 if (sigstate == SIG_IGN) {
955 if (ckWARN(WARN_SIGNAL))
956 Perl_warner(aTHX_ WARN_SIGNAL,
957 "Can't ignore signal CHLD, forcing to default");
958 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
963 #ifdef MACOS_TRADITIONAL
964 if (PL_doextract || gAlwaysExtract)
969 if (cddir && PerlDir_chdir(cddir) < 0)
970 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
973 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
974 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
975 CvUNIQUE_on(PL_compcv);
977 PL_comppad = newAV();
978 av_push(PL_comppad, Nullsv);
979 PL_curpad = AvARRAY(PL_comppad);
980 PL_comppad_name = newAV();
981 PL_comppad_name_fill = 0;
982 PL_min_intro_pending = 0;
985 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
986 PL_curpad[0] = (SV*)newAV();
987 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
988 CvOWNER(PL_compcv) = 0;
989 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
990 MUTEX_INIT(CvMUTEXP(PL_compcv));
991 #endif /* USE_THREADS */
993 comppadlist = newAV();
994 AvREAL_off(comppadlist);
995 av_store(comppadlist, 0, (SV*)PL_comppad_name);
996 av_store(comppadlist, 1, (SV*)PL_comppad);
997 CvPADLIST(PL_compcv) = comppadlist;
999 boot_core_UNIVERSAL();
1000 boot_core_xsutils();
1003 (*xsinit)(aTHXo); /* in case linked C routines want magical variables */
1004 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
1012 init_predump_symbols();
1013 /* init_postdump_symbols not currently designed to be called */
1014 /* more than once (ENV isn't cleared first, for example) */
1015 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
1017 init_postdump_symbols(argc,argv,env);
1021 /* now parse the script */
1023 SETERRNO(0,SS$_NORMAL);
1025 #ifdef MACOS_TRADITIONAL
1026 if (gSyntaxError = (yyparse() || PL_error_count)) {
1028 Perl_croak(aTHX_ "%s had compilation errors.\n", MPWFileName(PL_origfilename));
1030 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1031 MPWFileName(PL_origfilename));
1035 if (yyparse() || PL_error_count) {
1037 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1039 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1044 PL_curcop->cop_line = 0;
1045 PL_curstash = PL_defstash;
1046 PL_preprocess = FALSE;
1048 SvREFCNT_dec(PL_e_script);
1049 PL_e_script = Nullsv;
1052 /* now that script is parsed, we can modify record separator */
1053 SvREFCNT_dec(PL_rs);
1054 PL_rs = SvREFCNT_inc(PL_nrs);
1055 sv_setsv(get_sv("/", TRUE), PL_rs);
1060 gv_check(PL_defstash);
1066 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1067 dump_mstats("after compilation:");
1086 oldscope = PL_scopestack_ix;
1089 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
1092 cxstack_ix = -1; /* start context stack again */
1094 case 0: /* normal completion */
1095 case 2: /* my_exit() */
1096 while (PL_scopestack_ix > oldscope)
1099 PL_curstash = PL_defstash;
1100 if (PL_endav && !PL_minus_c)
1101 call_list(oldscope, PL_endav);
1103 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1104 dump_mstats("after execution: ");
1106 return STATUS_NATIVE_EXPORT;
1109 POPSTACK_TO(PL_mainstack);
1112 PerlIO_printf(Perl_error_log, "panic: restartop\n");
1122 S_run_body(pTHX_ va_list args)
1125 I32 oldscope = va_arg(args, I32);
1127 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1128 PL_sawampersand ? "Enabling" : "Omitting"));
1130 if (!PL_restartop) {
1131 DEBUG_x(dump_all());
1132 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1133 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1137 #ifdef MACOS_TRADITIONAL
1138 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", MPWFileName(PL_origfilename));
1140 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1144 if (PERLDB_SINGLE && PL_DBsingle)
1145 sv_setiv(PL_DBsingle, 1);
1147 call_list(oldscope, PL_initav);
1153 PL_op = PL_restartop;
1157 else if (PL_main_start) {
1158 CvDEPTH(PL_main_cv) = 1;
1159 PL_op = PL_main_start;
1169 Perl_get_sv(pTHX_ const char *name, I32 create)
1173 if (name[1] == '\0' && !isALPHA(name[0])) {
1174 PADOFFSET tmp = find_threadsv(name);
1175 if (tmp != NOT_IN_PAD) {
1177 return THREADSV(tmp);
1180 #endif /* USE_THREADS */
1181 gv = gv_fetchpv(name, create, SVt_PV);
1188 Perl_get_av(pTHX_ const char *name, I32 create)
1190 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1199 Perl_get_hv(pTHX_ const char *name, I32 create)
1201 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1210 Perl_get_cv(pTHX_ const char *name, I32 create)
1212 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1213 /* XXX unsafe for threads if eval_owner isn't held */
1214 /* XXX this is probably not what they think they're getting.
1215 * It has the same effect as "sub name;", i.e. just a forward
1217 if (create && !GvCVu(gv))
1218 return newSUB(start_subparse(FALSE, 0),
1219 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1227 /* Be sure to refetch the stack pointer after calling these routines. */
1230 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1232 /* See G_* flags in cop.h */
1233 /* null terminated arg list */
1240 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1245 return call_pv(sub_name, flags);
1249 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1250 /* name of the subroutine */
1251 /* See G_* flags in cop.h */
1253 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1257 Perl_call_method(pTHX_ const char *methname, I32 flags)
1258 /* name of the subroutine */
1259 /* See G_* flags in cop.h */
1265 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1270 return call_sv(*PL_stack_sp--, flags);
1273 /* May be called with any of a CV, a GV, or an SV containing the name. */
1275 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1277 /* See G_* flags in cop.h */
1280 LOGOP myop; /* fake syntax tree node */
1284 bool oldcatch = CATCH_GET;
1289 if (flags & G_DISCARD) {
1294 Zero(&myop, 1, LOGOP);
1295 myop.op_next = Nullop;
1296 if (!(flags & G_NOARGS))
1297 myop.op_flags |= OPf_STACKED;
1298 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1299 (flags & G_ARRAY) ? OPf_WANT_LIST :
1304 EXTEND(PL_stack_sp, 1);
1305 *++PL_stack_sp = sv;
1307 oldscope = PL_scopestack_ix;
1309 if (PERLDB_SUB && PL_curstash != PL_debstash
1310 /* Handle first BEGIN of -d. */
1311 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1312 /* Try harder, since this may have been a sighandler, thus
1313 * curstash may be meaningless. */
1314 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1315 && !(flags & G_NODEBUG))
1316 PL_op->op_private |= OPpENTERSUB_DB;
1318 if (!(flags & G_EVAL)) {
1320 call_xbody((OP*)&myop, FALSE);
1321 retval = PL_stack_sp - (PL_stack_base + oldmark);
1322 CATCH_SET(oldcatch);
1325 cLOGOP->op_other = PL_op;
1327 /* we're trying to emulate pp_entertry() here */
1329 register PERL_CONTEXT *cx;
1330 I32 gimme = GIMME_V;
1335 push_return(PL_op->op_next);
1336 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1338 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1340 PL_in_eval = EVAL_INEVAL;
1341 if (flags & G_KEEPERR)
1342 PL_in_eval |= EVAL_KEEPERR;
1349 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1353 retval = PL_stack_sp - (PL_stack_base + oldmark);
1354 if (!(flags & G_KEEPERR))
1361 /* my_exit() was called */
1362 PL_curstash = PL_defstash;
1365 Perl_croak(aTHX_ "Callback called exit");
1370 PL_op = PL_restartop;
1374 PL_stack_sp = PL_stack_base + oldmark;
1375 if (flags & G_ARRAY)
1379 *++PL_stack_sp = &PL_sv_undef;
1384 if (PL_scopestack_ix > oldscope) {
1388 register PERL_CONTEXT *cx;
1399 if (flags & G_DISCARD) {
1400 PL_stack_sp = PL_stack_base + oldmark;
1410 S_call_body(pTHX_ va_list args)
1412 OP *myop = va_arg(args, OP*);
1413 int is_eval = va_arg(args, int);
1415 call_xbody(myop, is_eval);
1420 S_call_xbody(pTHX_ OP *myop, int is_eval)
1424 if (PL_op == myop) {
1426 PL_op = Perl_pp_entereval(aTHX);
1428 PL_op = Perl_pp_entersub(aTHX);
1434 /* Eval a string. The G_EVAL flag is always assumed. */
1437 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1439 /* See G_* flags in cop.h */
1442 UNOP myop; /* fake syntax tree node */
1443 I32 oldmark = SP - PL_stack_base;
1450 if (flags & G_DISCARD) {
1457 Zero(PL_op, 1, UNOP);
1458 EXTEND(PL_stack_sp, 1);
1459 *++PL_stack_sp = sv;
1460 oldscope = PL_scopestack_ix;
1462 if (!(flags & G_NOARGS))
1463 myop.op_flags = OPf_STACKED;
1464 myop.op_next = Nullop;
1465 myop.op_type = OP_ENTEREVAL;
1466 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1467 (flags & G_ARRAY) ? OPf_WANT_LIST :
1469 if (flags & G_KEEPERR)
1470 myop.op_flags |= OPf_SPECIAL;
1473 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1477 retval = PL_stack_sp - (PL_stack_base + oldmark);
1478 if (!(flags & G_KEEPERR))
1485 /* my_exit() was called */
1486 PL_curstash = PL_defstash;
1489 Perl_croak(aTHX_ "Callback called exit");
1494 PL_op = PL_restartop;
1498 PL_stack_sp = PL_stack_base + oldmark;
1499 if (flags & G_ARRAY)
1503 *++PL_stack_sp = &PL_sv_undef;
1508 if (flags & G_DISCARD) {
1509 PL_stack_sp = PL_stack_base + oldmark;
1519 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1522 SV* sv = newSVpv(p, 0);
1525 eval_sv(sv, G_SCALAR);
1532 if (croak_on_error && SvTRUE(ERRSV)) {
1534 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1540 /* Require a module. */
1543 Perl_require_pv(pTHX_ const char *pv)
1547 PUSHSTACKi(PERLSI_REQUIRE);
1549 sv = sv_newmortal();
1550 sv_setpv(sv, "require '");
1553 eval_sv(sv, G_DISCARD);
1559 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1563 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1564 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1568 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
1570 /* This message really ought to be max 23 lines.
1571 * Removed -h because the user already knows that opton. Others? */
1573 static char *usage_msg[] = {
1574 "-0[octal] specify record separator (\\0, if no argument)",
1575 "-a autosplit mode with -n or -p (splits $_ into @F)",
1576 "-c check syntax only (runs BEGIN and END blocks)",
1577 "-d[:debugger] run program under debugger",
1578 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1579 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1580 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1581 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1582 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1583 "-l[octal] enable line ending processing, specifies line terminator",
1584 "-[mM][-]module execute `use/no module...' before executing program",
1585 "-n assume 'while (<>) { ... }' loop around program",
1586 "-p assume loop like -n but print line also, like sed",
1587 "-P run program through C preprocessor before compilation",
1588 "-s enable rudimentary parsing for switches after programfile",
1589 "-S look for programfile using PATH environment variable",
1590 "-T enable tainting checks",
1591 "-u dump core after parsing program",
1592 "-U allow unsafe operations",
1593 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1594 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1595 "-w enable many useful warnings (RECOMMENDED)",
1596 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1600 char **p = usage_msg;
1602 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1604 printf("\n %s", *p++);
1607 /* This routine handles any switches that can be given during run */
1610 Perl_moreswitches(pTHX_ char *s)
1619 rschar = (U32)scan_oct(s, 4, &numlen);
1620 SvREFCNT_dec(PL_nrs);
1621 if (rschar & ~((U8)~0))
1622 PL_nrs = &PL_sv_undef;
1623 else if (!rschar && numlen >= 2)
1624 PL_nrs = newSVpvn("", 0);
1627 PL_nrs = newSVpvn(&ch, 1);
1633 PL_splitstr = savepv(s + 1);
1647 if (*s == ':' || *s == '=') {
1648 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1652 PL_perldb = PERLDB_ALL;
1660 if (isALPHA(s[1])) {
1661 static char debopts[] = "psltocPmfrxuLHXDS";
1664 for (s++; *s && (d = strchr(debopts,*s)); s++)
1665 PL_debug |= 1 << (d - debopts);
1668 PL_debug = atoi(s+1);
1669 for (s++; isDIGIT(*s); s++) ;
1671 PL_debug |= 0x80000000;
1674 if (ckWARN_d(WARN_DEBUGGING))
1675 Perl_warner(aTHX_ WARN_DEBUGGING,
1676 "Recompile perl with -DDEBUGGING to use -D switch\n");
1677 for (s++; isALNUM(*s); s++) ;
1683 usage(PL_origargv[0]);
1687 Safefree(PL_inplace);
1688 PL_inplace = savepv(s+1);
1690 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1693 if (*s == '-') /* Additional switches on #! line. */
1697 case 'I': /* -I handled both here and in parse_perl() */
1700 while (*s && isSPACE(*s))
1704 for (e = s; *e && !isSPACE(*e); e++) ;
1705 p = savepvn(s, e-s);
1711 Perl_croak(aTHX_ "No space allowed after -I");
1719 PL_ors = savepv("\n");
1721 *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
1726 if (RsPARA(PL_nrs)) {
1731 PL_ors = SvPV(PL_nrs, PL_orslen);
1732 PL_ors = savepvn(PL_ors, PL_orslen);
1736 forbid_setid("-M"); /* XXX ? */
1739 forbid_setid("-m"); /* XXX ? */
1744 /* -M-foo == 'no foo' */
1745 if (*s == '-') { use = "no "; ++s; }
1746 sv = newSVpv(use,0);
1748 /* We allow -M'Module qw(Foo Bar)' */
1749 while(isALNUM(*s) || *s==':') ++s;
1751 sv_catpv(sv, start);
1752 if (*(start-1) == 'm') {
1754 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
1755 sv_catpv( sv, " ()");
1758 sv_catpvn(sv, start, s-start);
1759 sv_catpv(sv, " split(/,/,q{");
1764 if (PL_preambleav == NULL)
1765 PL_preambleav = newAV();
1766 av_push(PL_preambleav, sv);
1769 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1781 PL_doswitches = TRUE;
1786 Perl_croak(aTHX_ "Too late for \"-T\" option");
1790 #ifdef MACOS_TRADITIONAL
1791 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
1793 PL_do_undump = TRUE;
1801 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
1802 printf("\nThis is perl, version %d.%03d_%02d built for %s",
1803 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME);
1805 printf("\nThis is perl, version %s built for %s",
1806 PL_patchlevel, ARCHNAME);
1808 #if defined(LOCAL_PATCH_COUNT)
1809 if (LOCAL_PATCH_COUNT > 0)
1810 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1811 (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1814 printf("\n\nCopyright 1987-1999, Larry Wall\n");
1815 #ifdef MACOS_TRADITIONAL
1816 fputs("Macintosh port Copyright 1991-1999, Matthias Neeracher\n", stdout);
1819 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1822 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1823 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
1826 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1827 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
1830 printf("atariST series port, ++jrb bammi@cadence.com\n");
1833 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
1836 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1839 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
1842 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
1845 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
1848 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
1851 printf("MiNT port by Guido Flohr, 1997-1999\n");
1853 #ifdef BINARY_BUILD_NOTICE
1854 BINARY_BUILD_NOTICE;
1857 Perl may be copied only under the terms of either the Artistic License or the\n\
1858 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1859 Complete documentation for Perl, including FAQ lists, should be found on\n\
1860 this system using `man perl' or `perldoc perl'. If you have access to the\n\
1861 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1864 if (! (PL_dowarn & G_WARN_ALL_MASK))
1865 PL_dowarn |= G_WARN_ON;
1869 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1870 PL_compiling.cop_warnings = WARN_ALL ;
1874 PL_dowarn = G_WARN_ALL_OFF;
1875 PL_compiling.cop_warnings = WARN_NONE ;
1880 if (s[1] == '-') /* Additional switches on #! line. */
1885 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1891 #ifdef ALTERNATE_SHEBANG
1892 case 'S': /* OS/2 needs -S on "extproc" line. */
1900 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
1905 /* compliments of Tom Christiansen */
1907 /* unexec() can be found in the Gnu emacs distribution */
1908 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1911 Perl_my_unexec(pTHX)
1919 prog = newSVpv(BIN_EXP, 0);
1920 sv_catpv(prog, "/perl");
1921 file = newSVpv(PL_origfilename, 0);
1922 sv_catpv(file, ".perldump");
1924 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1925 /* unexec prints msg to stderr in case of failure */
1926 PerlProc_exit(status);
1929 # include <lib$routines.h>
1930 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1932 ABORT(); /* for use with undump */
1937 /* initialize curinterp */
1942 #ifdef PERL_OBJECT /* XXX kludge */
1945 PL_chopset = " \n-"; \
1946 PL_copline = NOLINE; \
1947 PL_curcop = &PL_compiling;\
1948 PL_curcopdb = NULL; \
1950 PL_dumpindent = 4; \
1951 PL_laststatval = -1; \
1952 PL_laststype = OP_STAT; \
1953 PL_maxscream = -1; \
1954 PL_maxsysfd = MAXSYSFD; \
1955 PL_statname = Nullsv; \
1956 PL_tmps_floor = -1; \
1958 PL_op_mask = NULL; \
1959 PL_laststatval = -1; \
1960 PL_laststype = OP_STAT; \
1961 PL_mess_sv = Nullsv; \
1962 PL_splitstr = " "; \
1963 PL_generation = 100; \
1964 PL_exitlist = NULL; \
1965 PL_exitlistlen = 0; \
1967 PL_in_clean_objs = FALSE; \
1968 PL_in_clean_all = FALSE; \
1969 PL_profiledata = NULL; \
1971 PL_rsfp_filters = Nullav; \
1976 # ifdef MULTIPLICITY
1977 # define PERLVAR(var,type)
1978 # define PERLVARA(var,n,type)
1979 # if defined(PERL_IMPLICIT_CONTEXT)
1980 # if defined(USE_THREADS)
1981 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
1982 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
1983 # else /* !USE_THREADS */
1984 # define PERLVARI(var,type,init) aTHX->var = init;
1985 # define PERLVARIC(var,type,init) aTHX->var = init;
1986 # endif /* USE_THREADS */
1988 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
1989 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
1991 # include "intrpvar.h"
1992 # ifndef USE_THREADS
1993 # include "thrdvar.h"
2000 # define PERLVAR(var,type)
2001 # define PERLVARA(var,n,type)
2002 # define PERLVARI(var,type,init) PL_##var = init;
2003 # define PERLVARIC(var,type,init) PL_##var = init;
2004 # include "intrpvar.h"
2005 # ifndef USE_THREADS
2006 # include "thrdvar.h"
2015 #ifdef MACOS_TRADITIONAL
2016 /* In MacOS time() already returns values in excess of 2**31-1,
2017 * therefore we patch the integerness away. */
2018 PL_opargs[OP_TIME] &= ~OA_RETINTEGER;
2024 S_init_main_stash(pTHX)
2029 /* Note that strtab is a rather special HV. Assumptions are made
2030 about not iterating on it, and not adding tie magic to it.
2031 It is properly deallocated in perl_destruct() */
2032 PL_strtab = newHV();
2034 MUTEX_INIT(&PL_strtab_mutex);
2036 HvSHAREKEYS_off(PL_strtab); /* mandatory */
2037 hv_ksplit(PL_strtab, 512);
2039 PL_curstash = PL_defstash = newHV();
2040 PL_curstname = newSVpvn("main",4);
2041 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2042 SvREFCNT_dec(GvHV(gv));
2043 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2045 HvNAME(PL_defstash) = savepv("main");
2046 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2047 GvMULTI_on(PL_incgv);
2048 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2049 GvMULTI_on(PL_hintgv);
2050 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2051 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2052 GvMULTI_on(PL_errgv);
2053 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2054 GvMULTI_on(PL_replgv);
2055 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
2056 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2057 sv_setpvn(ERRSV, "", 0);
2058 PL_curstash = PL_defstash;
2059 PL_compiling.cop_stash = PL_defstash;
2060 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2061 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2062 /* We must init $/ before switches are processed. */
2063 sv_setpvn(get_sv("/", TRUE), "\n", 1);
2067 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2075 PL_origfilename = savepv("-e");
2078 /* if find_script() returns, it returns a malloc()-ed value */
2079 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2081 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2082 char *s = scriptname + 8;
2083 *fdscript = atoi(s);
2087 scriptname = savepv(s + 1);
2088 Safefree(PL_origfilename);
2089 PL_origfilename = scriptname;
2094 CopFILEGV_set(PL_curcop, gv_fetchfile(PL_origfilename));
2095 if (strEQ(PL_origfilename,"-"))
2097 if (*fdscript >= 0) {
2098 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2099 #if defined(HAS_FCNTL) && defined(F_SETFD)
2101 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2104 else if (PL_preprocess) {
2105 char *cpp_cfg = CPPSTDIN;
2106 SV *cpp = newSVpvn("",0);
2107 SV *cmd = NEWSV(0,0);
2109 if (strEQ(cpp_cfg, "cppstdin"))
2110 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2111 sv_catpv(cpp, cpp_cfg);
2114 sv_catpv(sv,PRIVLIB_EXP);
2117 Perl_sv_setpvf(aTHX_ cmd, "\
2118 sed %s -e \"/^[^#]/b\" \
2119 -e \"/^#[ ]*include[ ]/b\" \
2120 -e \"/^#[ ]*define[ ]/b\" \
2121 -e \"/^#[ ]*if[ ]/b\" \
2122 -e \"/^#[ ]*ifdef[ ]/b\" \
2123 -e \"/^#[ ]*ifndef[ ]/b\" \
2124 -e \"/^#[ ]*else/b\" \
2125 -e \"/^#[ ]*elif[ ]/b\" \
2126 -e \"/^#[ ]*undef[ ]/b\" \
2127 -e \"/^#[ ]*endif/b\" \
2130 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2133 Perl_sv_setpvf(aTHX_ cmd, "\
2134 %s %s -e '/^[^#]/b' \
2135 -e '/^#[ ]*include[ ]/b' \
2136 -e '/^#[ ]*define[ ]/b' \
2137 -e '/^#[ ]*if[ ]/b' \
2138 -e '/^#[ ]*ifdef[ ]/b' \
2139 -e '/^#[ ]*ifndef[ ]/b' \
2140 -e '/^#[ ]*else/b' \
2141 -e '/^#[ ]*elif[ ]/b' \
2142 -e '/^#[ ]*undef[ ]/b' \
2143 -e '/^#[ ]*endif/b' \
2147 Perl_sv_setpvf(aTHX_ cmd, "\
2148 %s %s -e '/^[^#]/b' \
2149 -e '/^#[ ]*include[ ]/b' \
2150 -e '/^#[ ]*define[ ]/b' \
2151 -e '/^#[ ]*if[ ]/b' \
2152 -e '/^#[ ]*ifdef[ ]/b' \
2153 -e '/^#[ ]*ifndef[ ]/b' \
2154 -e '/^#[ ]*else/b' \
2155 -e '/^#[ ]*elif[ ]/b' \
2156 -e '/^#[ ]*undef[ ]/b' \
2157 -e '/^#[ ]*endif/b' \
2166 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2168 scriptname, cpp, sv, CPPMINUS);
2169 PL_doextract = FALSE;
2170 #ifdef IAMSUID /* actually, this is caught earlier */
2171 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2173 (void)seteuid(PL_uid); /* musn't stay setuid root */
2176 (void)setreuid((Uid_t)-1, PL_uid);
2178 #ifdef HAS_SETRESUID
2179 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2181 PerlProc_setuid(PL_uid);
2185 if (PerlProc_geteuid() != PL_uid)
2186 Perl_croak(aTHX_ "Can't do seteuid!\n");
2188 #endif /* IAMSUID */
2189 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2193 else if (!*scriptname) {
2194 forbid_setid("program input from stdin");
2195 PL_rsfp = PerlIO_stdin();
2198 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2199 #if defined(HAS_FCNTL) && defined(F_SETFD)
2201 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2206 #ifndef IAMSUID /* in case script is not readable before setuid */
2208 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2209 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2212 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2213 Perl_croak(aTHX_ "Can't do setuid\n");
2217 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2218 CopFILE(PL_curcop), Strerror(errno));
2223 * I_SYSSTATVFS HAS_FSTATVFS
2225 * I_STATFS HAS_FSTATFS
2226 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2227 * here so that metaconfig picks them up. */
2231 S_fd_on_nosuid_fs(pTHX_ int fd)
2233 int check_okay = 0; /* able to do all the required sys/libcalls */
2234 int on_nosuid = 0; /* the fd is on a nosuid fs */
2236 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2237 * fstatvfs() is UNIX98.
2238 * fstatfs() is 4.3 BSD.
2239 * ustat()+getmnt() is pre-4.3 BSD.
2240 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2241 * an irrelevant filesystem while trying to reach the right one.
2244 # ifdef HAS_FSTATVFS
2245 struct statvfs stfs;
2246 check_okay = fstatvfs(fd, &stfs) == 0;
2247 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2249 # ifdef PERL_MOUNT_NOSUID
2250 # if defined(HAS_FSTATFS) && \
2251 defined(HAS_STRUCT_STATFS) && \
2252 defined(HAS_STRUCT_STATFS_F_FLAGS)
2254 check_okay = fstatfs(fd, &stfs) == 0;
2255 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2257 # if defined(HAS_FSTAT) && \
2258 defined(HAS_USTAT) && \
2259 defined(HAS_GETMNT) && \
2260 defined(HAS_STRUCT_FS_DATA) &&
2263 if (fstat(fd, &fdst) == 0) {
2265 if (ustat(fdst.st_dev, &us) == 0) {
2267 /* NOSTAT_ONE here because we're not examining fields which
2268 * vary between that case and STAT_ONE. */
2269 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2270 size_t cmplen = sizeof(us.f_fname);
2271 if (sizeof(fsd.fd_req.path) < cmplen)
2272 cmplen = sizeof(fsd.fd_req.path);
2273 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2274 fdst.st_dev == fsd.fd_req.dev) {
2276 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2282 # endif /* fstat+ustat+getmnt */
2283 # endif /* fstatfs */
2285 # if defined(HAS_GETMNTENT) && \
2286 defined(HAS_HASMNTOPT) && \
2287 defined(MNTOPT_NOSUID)
2288 FILE *mtab = fopen("/etc/mtab", "r");
2289 struct mntent *entry;
2290 struct stat stb, fsb;
2292 if (mtab && (fstat(fd, &stb) == 0)) {
2293 while (entry = getmntent(mtab)) {
2294 if (stat(entry->mnt_dir, &fsb) == 0
2295 && fsb.st_dev == stb.st_dev)
2297 /* found the filesystem */
2299 if (hasmntopt(entry, MNTOPT_NOSUID))
2302 } /* A single fs may well fail its stat(). */
2307 # endif /* getmntent+hasmntopt */
2308 # endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */
2309 # endif /* statvfs */
2312 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
2315 #endif /* IAMSUID */
2318 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2322 /* do we need to emulate setuid on scripts? */
2324 /* This code is for those BSD systems that have setuid #! scripts disabled
2325 * in the kernel because of a security problem. Merely defining DOSUID
2326 * in perl will not fix that problem, but if you have disabled setuid
2327 * scripts in the kernel, this will attempt to emulate setuid and setgid
2328 * on scripts that have those now-otherwise-useless bits set. The setuid
2329 * root version must be called suidperl or sperlN.NNN. If regular perl
2330 * discovers that it has opened a setuid script, it calls suidperl with
2331 * the same argv that it had. If suidperl finds that the script it has
2332 * just opened is NOT setuid root, it sets the effective uid back to the
2333 * uid. We don't just make perl setuid root because that loses the
2334 * effective uid we had before invoking perl, if it was different from the
2337 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2338 * be defined in suidperl only. suidperl must be setuid root. The
2339 * Configure script will set this up for you if you want it.
2346 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2347 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2348 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2353 #ifndef HAS_SETREUID
2354 /* On this access check to make sure the directories are readable,
2355 * there is actually a small window that the user could use to make
2356 * filename point to an accessible directory. So there is a faint
2357 * chance that someone could execute a setuid script down in a
2358 * non-accessible directory. I don't know what to do about that.
2359 * But I don't think it's too important. The manual lies when
2360 * it says access() is useful in setuid programs.
2362 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
2363 Perl_croak(aTHX_ "Permission denied");
2365 /* If we can swap euid and uid, then we can determine access rights
2366 * with a simple stat of the file, and then compare device and
2367 * inode to make sure we did stat() on the same file we opened.
2368 * Then we just have to make sure he or she can execute it.
2371 struct stat tmpstatbuf;
2375 setreuid(PL_euid,PL_uid) < 0
2378 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2381 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2382 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2383 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
2384 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2385 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2386 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2387 Perl_croak(aTHX_ "Permission denied");
2389 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2390 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2391 (void)PerlIO_close(PL_rsfp);
2392 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2393 PerlIO_printf(PL_rsfp,
2394 "User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2395 (Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n",
2396 PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2397 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2399 PL_statbuf.st_uid, PL_statbuf.st_gid);
2400 (void)PerlProc_pclose(PL_rsfp);
2402 Perl_croak(aTHX_ "Permission denied\n");
2406 setreuid(PL_uid,PL_euid) < 0
2408 # if defined(HAS_SETRESUID)
2409 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2412 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2413 Perl_croak(aTHX_ "Can't reswap uid and euid");
2414 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2415 Perl_croak(aTHX_ "Permission denied\n");
2417 #endif /* HAS_SETREUID */
2418 #endif /* IAMSUID */
2420 if (!S_ISREG(PL_statbuf.st_mode))
2421 Perl_croak(aTHX_ "Permission denied");
2422 if (PL_statbuf.st_mode & S_IWOTH)
2423 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2424 PL_doswitches = FALSE; /* -s is insecure in suid */
2425 PL_curcop->cop_line++;
2426 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2427 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2428 Perl_croak(aTHX_ "No #! line");
2429 s = SvPV(PL_linestr,n_a)+2;
2431 while (!isSPACE(*s)) s++;
2432 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2433 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2434 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2435 Perl_croak(aTHX_ "Not a perl script");
2436 while (*s == ' ' || *s == '\t') s++;
2438 * #! arg must be what we saw above. They can invoke it by
2439 * mentioning suidperl explicitly, but they may not add any strange
2440 * arguments beyond what #! says if they do invoke suidperl that way.
2442 len = strlen(validarg);
2443 if (strEQ(validarg," PHOOEY ") ||
2444 strnNE(s,validarg,len) || !isSPACE(s[len]))
2445 Perl_croak(aTHX_ "Args must match #! line");
2448 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2449 PL_euid == PL_statbuf.st_uid)
2451 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2452 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2453 #endif /* IAMSUID */
2455 if (PL_euid) { /* oops, we're not the setuid root perl */
2456 (void)PerlIO_close(PL_rsfp);
2459 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2461 Perl_croak(aTHX_ "Can't do setuid\n");
2464 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2466 (void)setegid(PL_statbuf.st_gid);
2469 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2471 #ifdef HAS_SETRESGID
2472 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2474 PerlProc_setgid(PL_statbuf.st_gid);
2478 if (PerlProc_getegid() != PL_statbuf.st_gid)
2479 Perl_croak(aTHX_ "Can't do setegid!\n");
2481 if (PL_statbuf.st_mode & S_ISUID) {
2482 if (PL_statbuf.st_uid != PL_euid)
2484 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2487 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2489 #ifdef HAS_SETRESUID
2490 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2492 PerlProc_setuid(PL_statbuf.st_uid);
2496 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2497 Perl_croak(aTHX_ "Can't do seteuid!\n");
2499 else if (PL_uid) { /* oops, mustn't run as root */
2501 (void)seteuid((Uid_t)PL_uid);
2504 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2506 #ifdef HAS_SETRESUID
2507 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2509 PerlProc_setuid((Uid_t)PL_uid);
2513 if (PerlProc_geteuid() != PL_uid)
2514 Perl_croak(aTHX_ "Can't do seteuid!\n");
2517 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2518 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
2521 else if (PL_preprocess)
2522 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2523 else if (fdscript >= 0)
2524 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2526 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2528 /* We absolutely must clear out any saved ids here, so we */
2529 /* exec the real perl, substituting fd script for scriptname. */
2530 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2531 PerlIO_rewind(PL_rsfp);
2532 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2533 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2534 if (!PL_origargv[which])
2535 Perl_croak(aTHX_ "Permission denied");
2536 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2537 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2538 #if defined(HAS_FCNTL) && defined(F_SETFD)
2539 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2541 PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
2542 Perl_croak(aTHX_ "Can't do setuid\n");
2543 #endif /* IAMSUID */
2545 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2546 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2548 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2549 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2551 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2554 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2555 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2556 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2557 /* not set-id, must be wrapped */
2563 S_find_beginning(pTHX)
2565 register char *s, *s2;
2567 /* skip forward in input to the real script? */
2570 #ifdef MACOS_TRADITIONAL
2571 /* Since the Mac OS does not honor !# arguments for us,
2572 * we do it ourselves. */
2573 while (PL_doextract || gAlwaysExtract) {
2574 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2575 if (!gAlwaysExtract)
2576 Perl_croak(aTHX_ "No Perl script found in input\n");
2578 if (PL_doextract) /* require explicit override ? */
2579 if (!OverrideExtract(PL_origfilename))
2580 Perl_croak(aTHX_ "User aborted script\n");
2582 PL_doextract = FALSE;
2584 /* Pater peccavi, file does not have #! */
2585 PerlIO_rewind(PL_rsfp);
2590 while (PL_doextract) {
2591 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2592 Perl_croak(aTHX_ "No Perl script found in input\n");
2594 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2595 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2596 PL_doextract = FALSE;
2597 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2599 while (*s == ' ' || *s == '\t') s++;
2601 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2602 if (strnEQ(s2-4,"perl",4))
2604 while (s = moreswitches(s)) ;
2614 PL_uid = PerlProc_getuid();
2615 PL_euid = PerlProc_geteuid();
2616 PL_gid = PerlProc_getgid();
2617 PL_egid = PerlProc_getegid();
2619 PL_uid |= PL_gid << 16;
2620 PL_euid |= PL_egid << 16;
2622 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2626 S_forbid_setid(pTHX_ char *s)
2628 if (PL_euid != PL_uid)
2629 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2630 if (PL_egid != PL_gid)
2631 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2635 Perl_init_debugger(pTHX)
2638 HV *ostash = PL_curstash;
2640 PL_curstash = PL_debstash;
2641 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2642 AvREAL_off(PL_dbargs);
2643 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2644 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2645 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2646 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
2647 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2648 sv_setiv(PL_DBsingle, 0);
2649 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2650 sv_setiv(PL_DBtrace, 0);
2651 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2652 sv_setiv(PL_DBsignal, 0);
2653 PL_curstash = ostash;
2656 #ifndef STRESS_REALLOC
2657 #define REASONABLE(size) (size)
2659 #define REASONABLE(size) (1) /* unreasonable */
2663 Perl_init_stacks(pTHX)
2665 /* start with 128-item stack and 8K cxstack */
2666 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2667 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2668 PL_curstackinfo->si_type = PERLSI_MAIN;
2669 PL_curstack = PL_curstackinfo->si_stack;
2670 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2672 PL_stack_base = AvARRAY(PL_curstack);
2673 PL_stack_sp = PL_stack_base;
2674 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2676 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2679 PL_tmps_max = REASONABLE(128);
2681 New(54,PL_markstack,REASONABLE(32),I32);
2682 PL_markstack_ptr = PL_markstack;
2683 PL_markstack_max = PL_markstack + REASONABLE(32);
2687 New(54,PL_scopestack,REASONABLE(32),I32);
2688 PL_scopestack_ix = 0;
2689 PL_scopestack_max = REASONABLE(32);
2691 New(54,PL_savestack,REASONABLE(128),ANY);
2692 PL_savestack_ix = 0;
2693 PL_savestack_max = REASONABLE(128);
2695 New(54,PL_retstack,REASONABLE(16),OP*);
2697 PL_retstack_max = REASONABLE(16);
2706 while (PL_curstackinfo->si_next)
2707 PL_curstackinfo = PL_curstackinfo->si_next;
2708 while (PL_curstackinfo) {
2709 PERL_SI *p = PL_curstackinfo->si_prev;
2710 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2711 Safefree(PL_curstackinfo->si_cxstack);
2712 Safefree(PL_curstackinfo);
2713 PL_curstackinfo = p;
2715 Safefree(PL_tmps_stack);
2716 Safefree(PL_markstack);
2717 Safefree(PL_scopestack);
2718 Safefree(PL_savestack);
2719 Safefree(PL_retstack);
2723 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2734 lex_start(PL_linestr);
2736 PL_subname = newSVpvn("main",4);
2740 S_init_predump_symbols(pTHX)
2747 sv_setpvn(get_sv("\"", TRUE), " ", 1);
2748 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2749 GvMULTI_on(PL_stdingv);
2750 io = GvIOp(PL_stdingv);
2751 IoIFP(io) = PerlIO_stdin();
2752 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2754 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2756 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2759 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
2761 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2763 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2765 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2766 GvMULTI_on(PL_stderrgv);
2767 io = GvIOp(PL_stderrgv);
2768 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
2769 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2771 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2773 PL_statname = NEWSV(66,0); /* last filename we did stat on */
2776 Safefree(PL_osname);
2777 PL_osname = savepv(OSNAME);
2781 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
2788 argc--,argv++; /* skip name of script */
2789 if (PL_doswitches) {
2790 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2793 if (argv[0][1] == '-') {
2797 if (s = strchr(argv[0], '=')) {
2799 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2802 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2805 PL_toptarget = NEWSV(0,0);
2806 sv_upgrade(PL_toptarget, SVt_PVFM);
2807 sv_setpvn(PL_toptarget, "", 0);
2808 PL_bodytarget = NEWSV(0,0);
2809 sv_upgrade(PL_bodytarget, SVt_PVFM);
2810 sv_setpvn(PL_bodytarget, "", 0);
2811 PL_formtarget = PL_bodytarget;
2814 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2815 #ifdef MACOS_TRADITIONAL
2816 sv_setpv(GvSV(tmpgv),MPWFileName(PL_origfilename));
2817 /* $0 is not majick on a Mac */
2819 sv_setpv(GvSV(tmpgv),PL_origfilename);
2820 magicname("0", "0", 1);
2823 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2825 sv_setpv(GvSV(tmpgv), os2_execname());
2827 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2829 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2830 GvMULTI_on(PL_argvgv);
2831 (void)gv_AVadd(PL_argvgv);
2832 av_clear(GvAVn(PL_argvgv));
2833 for (; argc > 0; argc--,argv++) {
2834 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2836 PL_argvout_stack = newAV();
2838 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2840 GvMULTI_on(PL_envgv);
2841 hv = GvHVn(PL_envgv);
2842 hv_magic(hv, PL_envgv, 'E');
2843 #if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
2844 /* Note that if the supplied env parameter is actually a copy
2845 of the global environ then it may now point to free'd memory
2846 if the environment has been modified since. To avoid this
2847 problem we treat env==NULL as meaning 'use the default'
2852 environ[0] = Nullch;
2853 for (; *env; env++) {
2854 if (!(s = strchr(*env,'=')))
2860 sv = newSVpv(s--,0);
2861 (void)hv_store(hv, *env, s - *env, sv, 0);
2863 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2864 /* Sins of the RTL. See note in my_setenv(). */
2865 (void)PerlEnv_putenv(savepv(*env));
2869 #ifdef DYNAMIC_ENV_FETCH
2870 HvNAME(hv) = savepv(ENV_HV_NAME);
2874 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2875 sv_setiv(GvSV(tmpgv), (IV)getpid());
2879 S_init_perllib(pTHX)
2884 s = PerlEnv_getenv("PERL5LIB");
2888 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2890 /* Treat PERL5?LIB as a possible search list logical name -- the
2891 * "natural" VMS idiom for a Unix path string. We allow each
2892 * element to be a set of |-separated directories for compatibility.
2896 if (my_trnlnm("PERL5LIB",buf,0))
2897 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2899 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2903 /* Use the ~-expanded versions of APPLLIB (undocumented),
2904 ARCHLIB PRIVLIB SITEARCH and SITELIB
2907 incpush(APPLLIB_EXP, TRUE);
2911 incpush(ARCHLIB_EXP, FALSE);
2913 #ifdef MACOS_TRADITIONAL
2915 struct stat tmpstatbuf;
2916 SV * privdir = NEWSV(55, 0);
2917 char * macperl = getenv("MACPERL") || "";
2919 Perl_sv_setpvf(privdir, "%slib:", macperl);
2920 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
2921 incpush(SvPVX(privdir), TRUE);
2922 Perl_sv_setpvf(privdir, "%ssite_perl:", macperl);
2923 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
2924 incpush(SvPVX(privdir), TRUE);
2926 SvREFCNT_dec(privdir);
2929 incpush(":", FALSE);
2932 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2935 incpush(PRIVLIB_EXP, TRUE);
2937 incpush(PRIVLIB_EXP, FALSE);
2941 incpush(SITEARCH_EXP, FALSE);
2945 incpush(SITELIB_EXP, TRUE);
2947 incpush(SITELIB_EXP, FALSE);
2950 #if defined(PERL_VENDORLIB_EXP)
2952 incpush(PERL_VENDORLIB_EXP, TRUE);
2954 incpush(PERL_VENDORLIB_EXP, FALSE);
2958 incpush(".", FALSE);
2959 #endif /* MACOS_TRADITIONAL */
2962 #if defined(MACOS_TRADITIONAL)
2963 # define PERLLIB_SEP ','
2965 # if defined(DOSISH)
2966 # define PERLLIB_SEP ';'
2969 # define PERLLIB_SEP '|'
2971 # define PERLLIB_SEP ':'
2975 #ifndef PERLLIB_MANGLE
2976 # define PERLLIB_MANGLE(s,n) (s)
2980 S_incpush(pTHX_ char *p, int addsubdirs)
2982 SV *subdir = Nullsv;
2988 subdir = sv_newmortal();
2989 if (!PL_archpat_auto) {
2990 STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
2991 + sizeof("//auto"));
2992 New(55, PL_archpat_auto, len, char);
2993 #ifdef MACOS_TRADITIONAL
2994 sprintf(PL_archpat_auto, "%s:%s:auto:", ARCHNAME, PL_patchlevel);
2996 sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
2999 for (len = sizeof(ARCHNAME) + 2;
3000 PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
3001 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
3006 /* Break at all separators */
3008 SV *libdir = NEWSV(55,0);
3011 /* skip any consecutive separators */
3012 while ( *p == PERLLIB_SEP ) {
3013 /* Uncomment the next line for PATH semantics */
3014 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3018 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3019 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3024 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3025 p = Nullch; /* break out */
3027 #ifdef MACOS_TRADITIONAL
3028 if (!strchr(SvPVX(libdir), ':'))
3029 sv_insert(libdir, 0, 0, ":", 1);
3030 if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
3031 sv_catpv(libdir, ":");
3035 * BEFORE pushing libdir onto @INC we may first push version- and
3036 * archname-specific sub-directories.
3039 struct stat tmpstatbuf;
3044 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3046 while (unix[len-1] == '/') len--; /* Cosmetic */
3047 sv_usepvn(libdir,unix,len);
3050 PerlIO_printf(Perl_error_log,
3051 "Failed to unixify @INC element \"%s\"\n",
3054 /* .../archname/version if -d .../archname/version/auto */
3055 sv_setsv(subdir, libdir);
3056 sv_catpv(subdir, PL_archpat_auto);
3057 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3058 S_ISDIR(tmpstatbuf.st_mode))
3059 av_push(GvAVn(PL_incgv),
3060 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
3062 /* .../archname if -d .../archname/auto */
3063 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
3064 strlen(PL_patchlevel) + 1, "", 0);
3065 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3066 S_ISDIR(tmpstatbuf.st_mode))
3067 av_push(GvAVn(PL_incgv),
3068 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
3071 /* finally push this lib directory on the end of @INC */
3072 av_push(GvAVn(PL_incgv), libdir);
3077 STATIC struct perl_thread *
3078 S_init_main_thread(pTHX)
3080 #if !defined(PERL_IMPLICIT_CONTEXT)
3081 struct perl_thread *thr;
3085 Newz(53, thr, 1, struct perl_thread);
3086 PL_curcop = &PL_compiling;
3087 thr->interp = PERL_GET_INTERP;
3088 thr->cvcache = newHV();
3089 thr->threadsv = newAV();
3090 /* thr->threadsvp is set when find_threadsv is called */
3091 thr->specific = newAV();
3092 thr->flags = THRf_R_JOINABLE;
3093 MUTEX_INIT(&thr->mutex);
3094 /* Handcraft thrsv similarly to mess_sv */
3095 New(53, PL_thrsv, 1, SV);
3096 Newz(53, xpv, 1, XPV);
3097 SvFLAGS(PL_thrsv) = SVt_PV;
3098 SvANY(PL_thrsv) = (void*)xpv;
3099 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3100 SvPVX(PL_thrsv) = (char*)thr;
3101 SvCUR_set(PL_thrsv, sizeof(thr));
3102 SvLEN_set(PL_thrsv, sizeof(thr));
3103 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3104 thr->oursv = PL_thrsv;
3105 PL_chopset = " \n-";
3108 MUTEX_LOCK(&PL_threads_mutex);
3113 MUTEX_UNLOCK(&PL_threads_mutex);
3115 #ifdef HAVE_THREAD_INTERN
3116 Perl_init_thread_intern(thr);
3119 #ifdef SET_THREAD_SELF
3120 SET_THREAD_SELF(thr);
3122 thr->self = pthread_self();
3123 #endif /* SET_THREAD_SELF */
3127 * These must come after the SET_THR because sv_setpvn does
3128 * SvTAINT and the taint fields require dTHR.
3130 PL_toptarget = NEWSV(0,0);
3131 sv_upgrade(PL_toptarget, SVt_PVFM);
3132 sv_setpvn(PL_toptarget, "", 0);
3133 PL_bodytarget = NEWSV(0,0);
3134 sv_upgrade(PL_bodytarget, SVt_PVFM);
3135 sv_setpvn(PL_bodytarget, "", 0);
3136 PL_formtarget = PL_bodytarget;
3137 thr->errsv = newSVpvn("", 0);
3138 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
3141 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3142 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3143 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3144 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3145 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3147 PL_reginterp_cnt = 0;
3151 #endif /* USE_THREADS */
3154 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3158 line_t oldline = PL_curcop->cop_line;
3164 while (AvFILL(paramList) >= 0) {
3165 cv = (CV*)av_shift(paramList);
3167 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
3170 (void)SvPV(atsv, len);
3172 PL_curcop = &PL_compiling;
3173 PL_curcop->cop_line = oldline;
3174 if (paramList == PL_beginav)
3175 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3177 Perl_sv_catpvf(aTHX_ atsv,
3178 "%s failed--call queue aborted",
3179 paramList == PL_stopav ? "STOP"
3180 : paramList == PL_initav ? "INIT"
3182 while (PL_scopestack_ix > oldscope)
3184 Perl_croak(aTHX_ "%s", SvPVX(atsv));
3191 /* my_exit() was called */
3192 while (PL_scopestack_ix > oldscope)
3195 PL_curstash = PL_defstash;
3196 PL_curcop = &PL_compiling;
3197 PL_curcop->cop_line = oldline;
3198 if (PL_statusvalue) {
3199 if (paramList == PL_beginav)
3200 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3202 Perl_croak(aTHX_ "%s failed--call queue aborted",
3203 paramList == PL_stopav ? "STOP"
3204 : paramList == PL_initav ? "INIT"
3211 PL_curcop = &PL_compiling;
3212 PL_curcop->cop_line = oldline;
3215 PerlIO_printf(Perl_error_log, "panic: restartop\n");
3223 S_call_list_body(pTHX_ va_list args)
3226 CV *cv = va_arg(args, CV*);
3228 PUSHMARK(PL_stack_sp);
3229 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3234 Perl_my_exit(pTHX_ U32 status)
3238 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3239 thr, (unsigned long) status));
3248 STATUS_NATIVE_SET(status);
3255 Perl_my_failure_exit(pTHX)
3258 if (vaxc$errno & 1) {
3259 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3260 STATUS_NATIVE_SET(44);
3263 if (!vaxc$errno && errno) /* unlikely */
3264 STATUS_NATIVE_SET(44);
3266 STATUS_NATIVE_SET(vaxc$errno);
3271 STATUS_POSIX_SET(errno);
3273 exitstatus = STATUS_POSIX >> 8;
3274 if (exitstatus & 255)
3275 STATUS_POSIX_SET(exitstatus);
3277 STATUS_POSIX_SET(255);
3284 S_my_exit_jump(pTHX)
3287 register PERL_CONTEXT *cx;
3292 SvREFCNT_dec(PL_e_script);
3293 PL_e_script = Nullsv;
3296 POPSTACK_TO(PL_mainstack);
3297 if (cxstack_ix >= 0) {
3300 POPBLOCK(cx,PL_curpm);
3312 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3315 p = SvPVX(PL_e_script);
3316 nl = strchr(p, '\n');
3317 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3319 filter_del(read_e_script);
3322 sv_catpvn(buf_sv, p, nl-p);
3323 sv_chop(PL_e_script, nl);