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 */
223 #ifdef MACOS_TRADITIONAL
224 /* In MacOS time() already returns values in excess of 2**31-1,
225 * therefore we patch the integerness away. */
226 PL_opargs[OP_TIME] &= ~OA_RETINTEGER;
236 int destruct_level; /* 0=none, 1=full, 2=full with checks */
242 #endif /* USE_THREADS */
246 /* Pass 1 on any remaining threads: detach joinables, join zombies */
248 MUTEX_LOCK(&PL_threads_mutex);
249 DEBUG_S(PerlIO_printf(Perl_debug_log,
250 "perl_destruct: waiting for %d threads...\n",
252 for (t = thr->next; t != thr; t = t->next) {
253 MUTEX_LOCK(&t->mutex);
254 switch (ThrSTATE(t)) {
257 DEBUG_S(PerlIO_printf(Perl_debug_log,
258 "perl_destruct: joining zombie %p\n", t));
259 ThrSETSTATE(t, THRf_DEAD);
260 MUTEX_UNLOCK(&t->mutex);
263 * The SvREFCNT_dec below may take a long time (e.g. av
264 * may contain an object scalar whose destructor gets
265 * called) so we have to unlock threads_mutex and start
268 MUTEX_UNLOCK(&PL_threads_mutex);
270 SvREFCNT_dec((SV*)av);
271 DEBUG_S(PerlIO_printf(Perl_debug_log,
272 "perl_destruct: joined zombie %p OK\n", t));
274 case THRf_R_JOINABLE:
275 DEBUG_S(PerlIO_printf(Perl_debug_log,
276 "perl_destruct: detaching thread %p\n", t));
277 ThrSETSTATE(t, THRf_R_DETACHED);
279 * We unlock threads_mutex and t->mutex in the opposite order
280 * from which we locked them just so that DETACH won't
281 * deadlock if it panics. It's only a breach of good style
282 * not a bug since they are unlocks not locks.
284 MUTEX_UNLOCK(&PL_threads_mutex);
286 MUTEX_UNLOCK(&t->mutex);
289 DEBUG_S(PerlIO_printf(Perl_debug_log,
290 "perl_destruct: ignoring %p (state %u)\n",
292 MUTEX_UNLOCK(&t->mutex);
293 /* fall through and out */
296 /* We leave the above "Pass 1" loop with threads_mutex still locked */
298 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
299 while (PL_nthreads > 1)
301 DEBUG_S(PerlIO_printf(Perl_debug_log,
302 "perl_destruct: final wait for %d threads\n",
304 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
306 /* At this point, we're the last thread */
307 MUTEX_UNLOCK(&PL_threads_mutex);
308 DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
309 MUTEX_DESTROY(&PL_threads_mutex);
310 COND_DESTROY(&PL_nthreads_cond);
311 #endif /* !defined(FAKE_THREADS) */
312 #endif /* USE_THREADS */
314 destruct_level = PL_perl_destruct_level;
318 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
320 if (destruct_level < i)
329 /* We must account for everything. */
331 /* Destroy the main CV and syntax tree */
333 PL_curpad = AvARRAY(PL_comppad);
334 op_free(PL_main_root);
335 PL_main_root = Nullop;
337 PL_curcop = &PL_compiling;
338 PL_main_start = Nullop;
339 SvREFCNT_dec(PL_main_cv);
343 if (PL_sv_objcount) {
345 * Try to destruct global references. We do this first so that the
346 * destructors and destructees still exist. Some sv's might remain.
347 * Non-referenced objects are on their own.
352 /* unhook hooks which will soon be, or use, destroyed data */
353 SvREFCNT_dec(PL_warnhook);
354 PL_warnhook = Nullsv;
355 SvREFCNT_dec(PL_diehook);
358 /* call exit list functions */
359 while (PL_exitlistlen-- > 0)
360 PL_exitlist[PL_exitlistlen].fn(aTHXo_ PL_exitlist[PL_exitlistlen].ptr);
362 Safefree(PL_exitlist);
364 if (destruct_level == 0){
366 DEBUG_P(debprofdump());
368 /* The exit() function will do everything that needs doing. */
372 /* loosen bonds of global variables */
375 (void)PerlIO_close(PL_rsfp);
379 /* Filters for program text */
380 SvREFCNT_dec(PL_rsfp_filters);
381 PL_rsfp_filters = Nullav;
384 PL_preprocess = FALSE;
390 PL_doswitches = FALSE;
391 PL_dowarn = G_WARN_OFF;
392 PL_doextract = FALSE;
393 PL_sawampersand = FALSE; /* must save all match strings */
396 Safefree(PL_inplace);
400 SvREFCNT_dec(PL_e_script);
401 PL_e_script = Nullsv;
404 /* magical thingies */
406 Safefree(PL_ofs); /* $, */
409 Safefree(PL_ors); /* $\ */
412 SvREFCNT_dec(PL_rs); /* $/ */
415 SvREFCNT_dec(PL_nrs); /* $/ helper */
418 PL_multiline = 0; /* $* */
420 SvREFCNT_dec(PL_statname);
421 PL_statname = Nullsv;
424 /* defgv, aka *_ should be taken care of elsewhere */
426 /* clean up after study() */
427 SvREFCNT_dec(PL_lastscream);
428 PL_lastscream = Nullsv;
429 Safefree(PL_screamfirst);
431 Safefree(PL_screamnext);
435 Safefree(PL_efloatbuf);
436 PL_efloatbuf = Nullch;
439 /* startup and shutdown function lists */
440 SvREFCNT_dec(PL_beginav);
441 SvREFCNT_dec(PL_endav);
442 SvREFCNT_dec(PL_initav);
447 /* shortcuts just get cleared */
453 PL_argvoutgv = Nullgv;
455 PL_stderrgv = Nullgv;
456 PL_last_in_gv = Nullgv;
459 /* reset so print() ends up where we expect */
462 /* Prepare to destruct main symbol table. */
468 /* clear queued errors */
469 SvREFCNT_dec(PL_errors);
473 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
474 if (PL_scopestack_ix != 0)
475 Perl_warner(aTHX_ WARN_INTERNAL,
476 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
477 (long)PL_scopestack_ix);
478 if (PL_savestack_ix != 0)
479 Perl_warner(aTHX_ WARN_INTERNAL,
480 "Unbalanced saves: %ld more saves than restores\n",
481 (long)PL_savestack_ix);
482 if (PL_tmps_floor != -1)
483 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
484 (long)PL_tmps_floor + 1);
485 if (cxstack_ix != -1)
486 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
487 (long)cxstack_ix + 1);
490 /* Now absolutely destruct everything, somehow or other, loops or no. */
492 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
493 while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
494 last_sv_count = PL_sv_count;
497 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
498 SvFLAGS(PL_strtab) |= SVt_PVHV;
500 /* Destruct the global string table. */
502 /* Yell and reset the HeVAL() slots that are still holding refcounts,
503 * so that sv_free() won't fail on them.
511 max = HvMAX(PL_strtab);
512 array = HvARRAY(PL_strtab);
515 if (hent && ckWARN_d(WARN_INTERNAL)) {
516 Perl_warner(aTHX_ WARN_INTERNAL,
517 "Unbalanced string table refcount: (%d) for \"%s\"",
518 HeVAL(hent) - Nullsv, HeKEY(hent));
519 HeVAL(hent) = Nullsv;
529 SvREFCNT_dec(PL_strtab);
531 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
532 Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
536 /* No SVs have survived, need to clean out */
538 PL_pidstatus = Nullhv;
539 Safefree(PL_origfilename);
540 Safefree(PL_archpat_auto);
541 Safefree(PL_reg_start_tmp);
543 Safefree(PL_reg_curpm);
544 Safefree(PL_reg_poscache);
545 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
546 Safefree(PL_op_mask);
548 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
550 DEBUG_P(debprofdump());
552 MUTEX_DESTROY(&PL_strtab_mutex);
553 MUTEX_DESTROY(&PL_sv_mutex);
554 MUTEX_DESTROY(&PL_eval_mutex);
555 MUTEX_DESTROY(&PL_cred_mutex);
556 COND_DESTROY(&PL_eval_cond);
557 #ifdef EMULATE_ATOMIC_REFCOUNTS
558 MUTEX_DESTROY(&PL_svref_mutex);
559 #endif /* EMULATE_ATOMIC_REFCOUNTS */
561 /* As the penultimate thing, free the non-arena SV for thrsv */
562 Safefree(SvPVX(PL_thrsv));
563 Safefree(SvANY(PL_thrsv));
566 #endif /* USE_THREADS */
568 /* As the absolutely last thing, free the non-arena SV for mess() */
571 /* it could have accumulated taint magic */
572 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
575 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
576 moremagic = mg->mg_moremagic;
577 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
578 Safefree(mg->mg_ptr);
582 /* we know that type >= SVt_PV */
583 SvOOK_off(PL_mess_sv);
584 Safefree(SvPVX(PL_mess_sv));
585 Safefree(SvANY(PL_mess_sv));
586 Safefree(PL_mess_sv);
594 #if defined(PERL_OBJECT)
602 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
604 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
605 PL_exitlist[PL_exitlistlen].fn = fn;
606 PL_exitlist[PL_exitlistlen].ptr = ptr;
611 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
621 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
624 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
625 setuid perl scripts securely.\n");
629 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
630 _dyld_lookup_and_bind
631 ("__environ", (unsigned long *) &environ_pointer, NULL);
636 #ifndef VMS /* VMS doesn't have environ array */
637 PL_origenviron = environ;
642 /* Come here if running an undumped a.out. */
644 PL_origfilename = savepv(argv[0]);
645 PL_do_undump = FALSE;
646 cxstack_ix = -1; /* start label stack again */
648 init_postdump_symbols(argc,argv,env);
653 PL_curpad = AvARRAY(PL_comppad);
654 op_free(PL_main_root);
655 PL_main_root = Nullop;
657 PL_main_start = Nullop;
658 SvREFCNT_dec(PL_main_cv);
662 oldscope = PL_scopestack_ix;
663 PL_dowarn = G_WARN_OFF;
665 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_parse_body),
674 /* my_exit() was called */
675 while (PL_scopestack_ix > oldscope)
678 PL_curstash = PL_defstash;
679 if (PL_endav && !PL_minus_c)
680 call_list(oldscope, PL_endav);
681 return STATUS_NATIVE_EXPORT;
683 PerlIO_printf(Perl_error_log, "panic: top_env\n");
690 S_parse_body(pTHX_ va_list args)
693 int argc = PL_origargc;
694 char **argv = PL_origargv;
695 char **env = va_arg(args, char**);
696 char *scriptname = NULL;
698 VOL bool dosearch = FALSE;
703 char *cddir = Nullch;
705 XSINIT_t xsinit = va_arg(args, XSINIT_t);
707 sv_setpvn(PL_linestr,"",0);
708 sv = newSVpvn("",0); /* first used for -I flags */
712 for (argc--,argv++; argc > 0; argc--,argv++) {
713 if (argv[0][0] != '-' || !argv[0][1])
717 validarg = " PHOOEY ";
724 #ifndef PERL_STRICT_CR
748 if (s = moreswitches(s))
758 #ifdef MACOS_TRADITIONAL
759 /* ignore -e for Dev:Pseudo argument */
760 if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
763 if (PL_euid != PL_uid || PL_egid != PL_gid)
764 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
766 PL_e_script = newSVpvn("",0);
767 filter_add(read_e_script, NULL);
770 sv_catpv(PL_e_script, s);
772 sv_catpv(PL_e_script, argv[1]);
776 Perl_croak(aTHX_ "No code specified for -e");
777 sv_catpv(PL_e_script, "\n");
780 case 'I': /* -I handled both here and in moreswitches() */
782 if (!*++s && (s=argv[1]) != Nullch) {
785 while (s && isSPACE(*s))
789 for (e = s; *e && !isSPACE(*e); e++) ;
796 } /* XXX else croak? */
800 PL_preprocess = TRUE;
810 PL_preambleav = newAV();
811 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
813 PL_Sv = newSVpv("print myconfig();",0);
815 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
817 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
819 sv_catpv(PL_Sv,"\" Compile-time options:");
821 sv_catpv(PL_Sv," DEBUGGING");
824 sv_catpv(PL_Sv," MULTIPLICITY");
827 sv_catpv(PL_Sv," USE_THREADS");
830 sv_catpv(PL_Sv," PERL_OBJECT");
832 # ifdef PERL_IMPLICIT_CONTEXT
833 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
835 # ifdef PERL_IMPLICIT_SYS
836 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
838 sv_catpv(PL_Sv,"\\n\",");
840 #if defined(LOCAL_PATCH_COUNT)
841 if (LOCAL_PATCH_COUNT > 0) {
843 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
844 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
845 if (PL_localpatches[i])
846 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
850 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
853 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
855 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
860 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
861 print \" \\%ENV:\\n @env\\n\" if @env; \
862 print \" \\@INC:\\n @INC\\n\";");
865 PL_Sv = newSVpv("config_vars(qw(",0);
866 sv_catpv(PL_Sv, ++s);
867 sv_catpv(PL_Sv, "))");
870 av_push(PL_preambleav, PL_Sv);
871 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
882 if (!*++s || isSPACE(*s)) {
886 /* catch use of gnu style long options */
887 if (strEQ(s, "version")) {
891 if (strEQ(s, "help")) {
898 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
904 #ifndef SECURE_INTERNAL_GETENV
907 (s = PerlEnv_getenv("PERL5OPT"))) {
910 if (*s == '-' && *(s+1) == 'T')
923 if (!strchr("DIMUdmw", *s))
924 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
931 scriptname = argv[0];
934 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
936 else if (scriptname == Nullch) {
938 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
946 open_script(scriptname,dosearch,sv,&fdscript);
948 validate_suid(validarg, scriptname,fdscript);
950 #if defined(SIGCHLD) || defined(SIGCLD)
953 # define SIGCHLD SIGCLD
955 Sighandler_t sigstate = rsignal_state(SIGCHLD);
956 if (sigstate == SIG_IGN) {
957 if (ckWARN(WARN_SIGNAL))
958 Perl_warner(aTHX_ WARN_SIGNAL,
959 "Can't ignore signal CHLD, forcing to default");
960 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
965 #ifdef MACOS_TRADITIONAL
966 if (PL_doextract || gAlwaysExtract)
971 if (cddir && PerlDir_chdir(cddir) < 0)
972 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
975 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
976 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
977 CvUNIQUE_on(PL_compcv);
979 PL_comppad = newAV();
980 av_push(PL_comppad, Nullsv);
981 PL_curpad = AvARRAY(PL_comppad);
982 PL_comppad_name = newAV();
983 PL_comppad_name_fill = 0;
984 PL_min_intro_pending = 0;
987 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
988 PL_curpad[0] = (SV*)newAV();
989 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
990 CvOWNER(PL_compcv) = 0;
991 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
992 MUTEX_INIT(CvMUTEXP(PL_compcv));
993 #endif /* USE_THREADS */
995 comppadlist = newAV();
996 AvREAL_off(comppadlist);
997 av_store(comppadlist, 0, (SV*)PL_comppad_name);
998 av_store(comppadlist, 1, (SV*)PL_comppad);
999 CvPADLIST(PL_compcv) = comppadlist;
1001 boot_core_UNIVERSAL();
1002 boot_core_xsutils();
1005 (*xsinit)(aTHXo); /* in case linked C routines want magical variables */
1006 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
1014 init_predump_symbols();
1015 /* init_postdump_symbols not currently designed to be called */
1016 /* more than once (ENV isn't cleared first, for example) */
1017 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
1019 init_postdump_symbols(argc,argv,env);
1023 /* now parse the script */
1025 SETERRNO(0,SS$_NORMAL);
1027 #ifdef MACOS_TRADITIONAL
1028 if (gSyntaxError = (yyparse() || PL_error_count)) {
1030 Perl_croak(aTHX_ "%s had compilation errors.\n", MPWFileName(PL_origfilename));
1032 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1033 MPWFileName(PL_origfilename));
1037 if (yyparse() || PL_error_count) {
1039 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1041 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1046 PL_curcop->cop_line = 0;
1047 PL_curstash = PL_defstash;
1048 PL_preprocess = FALSE;
1050 SvREFCNT_dec(PL_e_script);
1051 PL_e_script = Nullsv;
1054 /* now that script is parsed, we can modify record separator */
1055 SvREFCNT_dec(PL_rs);
1056 PL_rs = SvREFCNT_inc(PL_nrs);
1057 sv_setsv(get_sv("/", TRUE), PL_rs);
1062 gv_check(PL_defstash);
1068 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1069 dump_mstats("after compilation:");
1088 oldscope = PL_scopestack_ix;
1091 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
1094 cxstack_ix = -1; /* start context stack again */
1096 case 0: /* normal completion */
1097 case 2: /* my_exit() */
1098 while (PL_scopestack_ix > oldscope)
1101 PL_curstash = PL_defstash;
1102 if (PL_endav && !PL_minus_c)
1103 call_list(oldscope, PL_endav);
1105 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1106 dump_mstats("after execution: ");
1108 return STATUS_NATIVE_EXPORT;
1111 POPSTACK_TO(PL_mainstack);
1114 PerlIO_printf(Perl_error_log, "panic: restartop\n");
1124 S_run_body(pTHX_ va_list args)
1127 I32 oldscope = va_arg(args, I32);
1129 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1130 PL_sawampersand ? "Enabling" : "Omitting"));
1132 if (!PL_restartop) {
1133 DEBUG_x(dump_all());
1134 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1135 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1139 #ifdef MACOS_TRADITIONAL
1140 PerlIO_printf(PerlIO_stderr(), "# %s syntax OK\n", MPWFileName(PL_origfilename));
1142 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1146 if (PERLDB_SINGLE && PL_DBsingle)
1147 sv_setiv(PL_DBsingle, 1);
1149 call_list(oldscope, PL_initav);
1155 PL_op = PL_restartop;
1159 else if (PL_main_start) {
1160 CvDEPTH(PL_main_cv) = 1;
1161 PL_op = PL_main_start;
1171 Perl_get_sv(pTHX_ const char *name, I32 create)
1175 if (name[1] == '\0' && !isALPHA(name[0])) {
1176 PADOFFSET tmp = find_threadsv(name);
1177 if (tmp != NOT_IN_PAD) {
1179 return THREADSV(tmp);
1182 #endif /* USE_THREADS */
1183 gv = gv_fetchpv(name, create, SVt_PV);
1190 Perl_get_av(pTHX_ const char *name, I32 create)
1192 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1201 Perl_get_hv(pTHX_ const char *name, I32 create)
1203 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1212 Perl_get_cv(pTHX_ const char *name, I32 create)
1214 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1215 /* XXX unsafe for threads if eval_owner isn't held */
1216 /* XXX this is probably not what they think they're getting.
1217 * It has the same effect as "sub name;", i.e. just a forward
1219 if (create && !GvCVu(gv))
1220 return newSUB(start_subparse(FALSE, 0),
1221 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1229 /* Be sure to refetch the stack pointer after calling these routines. */
1232 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1234 /* See G_* flags in cop.h */
1235 /* null terminated arg list */
1242 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1247 return call_pv(sub_name, flags);
1251 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1252 /* name of the subroutine */
1253 /* See G_* flags in cop.h */
1255 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1259 Perl_call_method(pTHX_ const char *methname, I32 flags)
1260 /* name of the subroutine */
1261 /* See G_* flags in cop.h */
1267 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1272 return call_sv(*PL_stack_sp--, flags);
1275 /* May be called with any of a CV, a GV, or an SV containing the name. */
1277 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1279 /* See G_* flags in cop.h */
1282 LOGOP myop; /* fake syntax tree node */
1286 bool oldcatch = CATCH_GET;
1291 if (flags & G_DISCARD) {
1296 Zero(&myop, 1, LOGOP);
1297 myop.op_next = Nullop;
1298 if (!(flags & G_NOARGS))
1299 myop.op_flags |= OPf_STACKED;
1300 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1301 (flags & G_ARRAY) ? OPf_WANT_LIST :
1306 EXTEND(PL_stack_sp, 1);
1307 *++PL_stack_sp = sv;
1309 oldscope = PL_scopestack_ix;
1311 if (PERLDB_SUB && PL_curstash != PL_debstash
1312 /* Handle first BEGIN of -d. */
1313 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1314 /* Try harder, since this may have been a sighandler, thus
1315 * curstash may be meaningless. */
1316 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1317 && !(flags & G_NODEBUG))
1318 PL_op->op_private |= OPpENTERSUB_DB;
1320 if (!(flags & G_EVAL)) {
1322 call_xbody((OP*)&myop, FALSE);
1323 retval = PL_stack_sp - (PL_stack_base + oldmark);
1324 CATCH_SET(oldcatch);
1327 cLOGOP->op_other = PL_op;
1329 /* we're trying to emulate pp_entertry() here */
1331 register PERL_CONTEXT *cx;
1332 I32 gimme = GIMME_V;
1337 push_return(PL_op->op_next);
1338 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1340 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1342 PL_in_eval = EVAL_INEVAL;
1343 if (flags & G_KEEPERR)
1344 PL_in_eval |= EVAL_KEEPERR;
1351 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1355 retval = PL_stack_sp - (PL_stack_base + oldmark);
1356 if (!(flags & G_KEEPERR))
1363 /* my_exit() was called */
1364 PL_curstash = PL_defstash;
1367 Perl_croak(aTHX_ "Callback called exit");
1372 PL_op = PL_restartop;
1376 PL_stack_sp = PL_stack_base + oldmark;
1377 if (flags & G_ARRAY)
1381 *++PL_stack_sp = &PL_sv_undef;
1386 if (PL_scopestack_ix > oldscope) {
1390 register PERL_CONTEXT *cx;
1401 if (flags & G_DISCARD) {
1402 PL_stack_sp = PL_stack_base + oldmark;
1412 S_call_body(pTHX_ va_list args)
1414 OP *myop = va_arg(args, OP*);
1415 int is_eval = va_arg(args, int);
1417 call_xbody(myop, is_eval);
1422 S_call_xbody(pTHX_ OP *myop, int is_eval)
1426 if (PL_op == myop) {
1428 PL_op = Perl_pp_entereval(aTHX);
1430 PL_op = Perl_pp_entersub(aTHX);
1436 /* Eval a string. The G_EVAL flag is always assumed. */
1439 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1441 /* See G_* flags in cop.h */
1444 UNOP myop; /* fake syntax tree node */
1445 I32 oldmark = SP - PL_stack_base;
1452 if (flags & G_DISCARD) {
1459 Zero(PL_op, 1, UNOP);
1460 EXTEND(PL_stack_sp, 1);
1461 *++PL_stack_sp = sv;
1462 oldscope = PL_scopestack_ix;
1464 if (!(flags & G_NOARGS))
1465 myop.op_flags = OPf_STACKED;
1466 myop.op_next = Nullop;
1467 myop.op_type = OP_ENTEREVAL;
1468 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1469 (flags & G_ARRAY) ? OPf_WANT_LIST :
1471 if (flags & G_KEEPERR)
1472 myop.op_flags |= OPf_SPECIAL;
1475 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1479 retval = PL_stack_sp - (PL_stack_base + oldmark);
1480 if (!(flags & G_KEEPERR))
1487 /* my_exit() was called */
1488 PL_curstash = PL_defstash;
1491 Perl_croak(aTHX_ "Callback called exit");
1496 PL_op = PL_restartop;
1500 PL_stack_sp = PL_stack_base + oldmark;
1501 if (flags & G_ARRAY)
1505 *++PL_stack_sp = &PL_sv_undef;
1510 if (flags & G_DISCARD) {
1511 PL_stack_sp = PL_stack_base + oldmark;
1521 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1524 SV* sv = newSVpv(p, 0);
1527 eval_sv(sv, G_SCALAR);
1534 if (croak_on_error && SvTRUE(ERRSV)) {
1536 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1542 /* Require a module. */
1545 Perl_require_pv(pTHX_ const char *pv)
1549 PUSHSTACKi(PERLSI_REQUIRE);
1551 sv = sv_newmortal();
1552 sv_setpv(sv, "require '");
1555 eval_sv(sv, G_DISCARD);
1561 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1565 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1566 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1570 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
1572 /* This message really ought to be max 23 lines.
1573 * Removed -h because the user already knows that opton. Others? */
1575 static char *usage_msg[] = {
1576 "-0[octal] specify record separator (\\0, if no argument)",
1577 "-a autosplit mode with -n or -p (splits $_ into @F)",
1578 "-c check syntax only (runs BEGIN and END blocks)",
1579 "-d[:debugger] run program under debugger",
1580 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1581 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1582 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1583 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1584 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1585 "-l[octal] enable line ending processing, specifies line terminator",
1586 "-[mM][-]module execute `use/no module...' before executing program",
1587 "-n assume 'while (<>) { ... }' loop around program",
1588 "-p assume loop like -n but print line also, like sed",
1589 "-P run program through C preprocessor before compilation",
1590 "-s enable rudimentary parsing for switches after programfile",
1591 "-S look for programfile using PATH environment variable",
1592 "-T enable tainting checks",
1593 "-u dump core after parsing program",
1594 "-U allow unsafe operations",
1595 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1596 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1597 "-w enable many useful warnings (RECOMMENDED)",
1598 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1602 char **p = usage_msg;
1604 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1606 printf("\n %s", *p++);
1609 /* This routine handles any switches that can be given during run */
1612 Perl_moreswitches(pTHX_ char *s)
1621 rschar = (U32)scan_oct(s, 4, &numlen);
1622 SvREFCNT_dec(PL_nrs);
1623 if (rschar & ~((U8)~0))
1624 PL_nrs = &PL_sv_undef;
1625 else if (!rschar && numlen >= 2)
1626 PL_nrs = newSVpvn("", 0);
1629 PL_nrs = newSVpvn(&ch, 1);
1635 PL_splitstr = savepv(s + 1);
1649 if (*s == ':' || *s == '=') {
1650 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1654 PL_perldb = PERLDB_ALL;
1662 if (isALPHA(s[1])) {
1663 static char debopts[] = "psltocPmfrxuLHXDS";
1666 for (s++; *s && (d = strchr(debopts,*s)); s++)
1667 PL_debug |= 1 << (d - debopts);
1670 PL_debug = atoi(s+1);
1671 for (s++; isDIGIT(*s); s++) ;
1673 PL_debug |= 0x80000000;
1676 if (ckWARN_d(WARN_DEBUGGING))
1677 Perl_warner(aTHX_ WARN_DEBUGGING,
1678 "Recompile perl with -DDEBUGGING to use -D switch\n");
1679 for (s++; isALNUM(*s); s++) ;
1685 usage(PL_origargv[0]);
1689 Safefree(PL_inplace);
1690 PL_inplace = savepv(s+1);
1692 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1695 if (*s == '-') /* Additional switches on #! line. */
1699 case 'I': /* -I handled both here and in parse_perl() */
1702 while (*s && isSPACE(*s))
1706 for (e = s; *e && !isSPACE(*e); e++) ;
1707 p = savepvn(s, e-s);
1713 Perl_croak(aTHX_ "No space allowed after -I");
1721 PL_ors = savepv("\n");
1723 *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
1728 if (RsPARA(PL_nrs)) {
1733 PL_ors = SvPV(PL_nrs, PL_orslen);
1734 PL_ors = savepvn(PL_ors, PL_orslen);
1738 forbid_setid("-M"); /* XXX ? */
1741 forbid_setid("-m"); /* XXX ? */
1746 /* -M-foo == 'no foo' */
1747 if (*s == '-') { use = "no "; ++s; }
1748 sv = newSVpv(use,0);
1750 /* We allow -M'Module qw(Foo Bar)' */
1751 while(isALNUM(*s) || *s==':') ++s;
1753 sv_catpv(sv, start);
1754 if (*(start-1) == 'm') {
1756 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
1757 sv_catpv( sv, " ()");
1760 sv_catpvn(sv, start, s-start);
1761 sv_catpv(sv, " split(/,/,q{");
1766 if (PL_preambleav == NULL)
1767 PL_preambleav = newAV();
1768 av_push(PL_preambleav, sv);
1771 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1783 PL_doswitches = TRUE;
1788 Perl_croak(aTHX_ "Too late for \"-T\" option");
1792 #ifdef MACOS_TRADITIONAL
1793 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
1795 PL_do_undump = TRUE;
1803 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
1804 printf("\nThis is perl, version %d.%03d_%02d built for %s",
1805 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME);
1807 printf("\nThis is perl, version %s built for %s",
1808 PL_patchlevel, ARCHNAME);
1810 #if defined(LOCAL_PATCH_COUNT)
1811 if (LOCAL_PATCH_COUNT > 0)
1812 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1813 (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1816 printf("\n\nCopyright 1987-1999, Larry Wall\n");
1817 #ifdef MACOS_TRADITIONAL
1818 fputs("Macintosh port Copyright 1991-1999, Matthias Neeracher\n", stdout);
1821 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1824 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1825 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
1828 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1829 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
1832 printf("atariST series port, ++jrb bammi@cadence.com\n");
1835 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
1838 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1841 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
1844 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
1847 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
1850 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
1853 printf("MiNT port by Guido Flohr, 1997-1999\n");
1855 #ifdef BINARY_BUILD_NOTICE
1856 BINARY_BUILD_NOTICE;
1859 Perl may be copied only under the terms of either the Artistic License or the\n\
1860 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1861 Complete documentation for Perl, including FAQ lists, should be found on\n\
1862 this system using `man perl' or `perldoc perl'. If you have access to the\n\
1863 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1866 if (! (PL_dowarn & G_WARN_ALL_MASK))
1867 PL_dowarn |= G_WARN_ON;
1871 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1872 PL_compiling.cop_warnings = WARN_ALL ;
1876 PL_dowarn = G_WARN_ALL_OFF;
1877 PL_compiling.cop_warnings = WARN_NONE ;
1882 if (s[1] == '-') /* Additional switches on #! line. */
1887 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1893 #ifdef ALTERNATE_SHEBANG
1894 case 'S': /* OS/2 needs -S on "extproc" line. */
1902 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
1907 /* compliments of Tom Christiansen */
1909 /* unexec() can be found in the Gnu emacs distribution */
1910 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1913 Perl_my_unexec(pTHX)
1921 prog = newSVpv(BIN_EXP, 0);
1922 sv_catpv(prog, "/perl");
1923 file = newSVpv(PL_origfilename, 0);
1924 sv_catpv(file, ".perldump");
1926 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1927 /* unexec prints msg to stderr in case of failure */
1928 PerlProc_exit(status);
1931 # include <lib$routines.h>
1932 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1934 ABORT(); /* for use with undump */
1939 /* initialize curinterp */
1944 #ifdef PERL_OBJECT /* XXX kludge */
1947 PL_chopset = " \n-"; \
1948 PL_copline = NOLINE; \
1949 PL_curcop = &PL_compiling;\
1950 PL_curcopdb = NULL; \
1952 PL_dumpindent = 4; \
1953 PL_laststatval = -1; \
1954 PL_laststype = OP_STAT; \
1955 PL_maxscream = -1; \
1956 PL_maxsysfd = MAXSYSFD; \
1957 PL_statname = Nullsv; \
1958 PL_tmps_floor = -1; \
1960 PL_op_mask = NULL; \
1961 PL_laststatval = -1; \
1962 PL_laststype = OP_STAT; \
1963 PL_mess_sv = Nullsv; \
1964 PL_splitstr = " "; \
1965 PL_generation = 100; \
1966 PL_exitlist = NULL; \
1967 PL_exitlistlen = 0; \
1969 PL_in_clean_objs = FALSE; \
1970 PL_in_clean_all = FALSE; \
1971 PL_profiledata = NULL; \
1973 PL_rsfp_filters = Nullav; \
1978 # ifdef MULTIPLICITY
1979 # define PERLVAR(var,type)
1980 # define PERLVARA(var,n,type)
1981 # if defined(PERL_IMPLICIT_CONTEXT)
1982 # if defined(USE_THREADS)
1983 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
1984 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
1985 # else /* !USE_THREADS */
1986 # define PERLVARI(var,type,init) aTHX->var = init;
1987 # define PERLVARIC(var,type,init) aTHX->var = init;
1988 # endif /* USE_THREADS */
1990 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
1991 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
1993 # include "intrpvar.h"
1994 # ifndef USE_THREADS
1995 # include "thrdvar.h"
2002 # define PERLVAR(var,type)
2003 # define PERLVARA(var,n,type)
2004 # define PERLVARI(var,type,init) PL_##var = init;
2005 # define PERLVARIC(var,type,init) PL_##var = init;
2006 # include "intrpvar.h"
2007 # ifndef USE_THREADS
2008 # include "thrdvar.h"
2020 S_init_main_stash(pTHX)
2025 /* Note that strtab is a rather special HV. Assumptions are made
2026 about not iterating on it, and not adding tie magic to it.
2027 It is properly deallocated in perl_destruct() */
2028 PL_strtab = newHV();
2030 MUTEX_INIT(&PL_strtab_mutex);
2032 HvSHAREKEYS_off(PL_strtab); /* mandatory */
2033 hv_ksplit(PL_strtab, 512);
2035 PL_curstash = PL_defstash = newHV();
2036 PL_curstname = newSVpvn("main",4);
2037 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2038 SvREFCNT_dec(GvHV(gv));
2039 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2041 HvNAME(PL_defstash) = savepv("main");
2042 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2043 GvMULTI_on(PL_incgv);
2044 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2045 GvMULTI_on(PL_hintgv);
2046 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2047 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2048 GvMULTI_on(PL_errgv);
2049 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2050 GvMULTI_on(PL_replgv);
2051 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
2052 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2053 sv_setpvn(ERRSV, "", 0);
2054 PL_curstash = PL_defstash;
2055 PL_compiling.cop_stash = PL_defstash;
2056 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2057 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2058 /* We must init $/ before switches are processed. */
2059 sv_setpvn(get_sv("/", TRUE), "\n", 1);
2063 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2071 PL_origfilename = savepv("-e");
2074 /* if find_script() returns, it returns a malloc()-ed value */
2075 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2077 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2078 char *s = scriptname + 8;
2079 *fdscript = atoi(s);
2083 scriptname = savepv(s + 1);
2084 Safefree(PL_origfilename);
2085 PL_origfilename = scriptname;
2090 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
2091 if (strEQ(PL_origfilename,"-"))
2093 if (*fdscript >= 0) {
2094 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2095 #if defined(HAS_FCNTL) && defined(F_SETFD)
2097 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2100 else if (PL_preprocess) {
2101 char *cpp_cfg = CPPSTDIN;
2102 SV *cpp = newSVpvn("",0);
2103 SV *cmd = NEWSV(0,0);
2105 if (strEQ(cpp_cfg, "cppstdin"))
2106 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2107 sv_catpv(cpp, cpp_cfg);
2110 sv_catpv(sv,PRIVLIB_EXP);
2113 Perl_sv_setpvf(aTHX_ cmd, "\
2114 sed %s -e \"/^[^#]/b\" \
2115 -e \"/^#[ ]*include[ ]/b\" \
2116 -e \"/^#[ ]*define[ ]/b\" \
2117 -e \"/^#[ ]*if[ ]/b\" \
2118 -e \"/^#[ ]*ifdef[ ]/b\" \
2119 -e \"/^#[ ]*ifndef[ ]/b\" \
2120 -e \"/^#[ ]*else/b\" \
2121 -e \"/^#[ ]*elif[ ]/b\" \
2122 -e \"/^#[ ]*undef[ ]/b\" \
2123 -e \"/^#[ ]*endif/b\" \
2126 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2129 Perl_sv_setpvf(aTHX_ cmd, "\
2130 %s %s -e '/^[^#]/b' \
2131 -e '/^#[ ]*include[ ]/b' \
2132 -e '/^#[ ]*define[ ]/b' \
2133 -e '/^#[ ]*if[ ]/b' \
2134 -e '/^#[ ]*ifdef[ ]/b' \
2135 -e '/^#[ ]*ifndef[ ]/b' \
2136 -e '/^#[ ]*else/b' \
2137 -e '/^#[ ]*elif[ ]/b' \
2138 -e '/^#[ ]*undef[ ]/b' \
2139 -e '/^#[ ]*endif/b' \
2143 Perl_sv_setpvf(aTHX_ cmd, "\
2144 %s %s -e '/^[^#]/b' \
2145 -e '/^#[ ]*include[ ]/b' \
2146 -e '/^#[ ]*define[ ]/b' \
2147 -e '/^#[ ]*if[ ]/b' \
2148 -e '/^#[ ]*ifdef[ ]/b' \
2149 -e '/^#[ ]*ifndef[ ]/b' \
2150 -e '/^#[ ]*else/b' \
2151 -e '/^#[ ]*elif[ ]/b' \
2152 -e '/^#[ ]*undef[ ]/b' \
2153 -e '/^#[ ]*endif/b' \
2162 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2164 scriptname, cpp, sv, CPPMINUS);
2165 PL_doextract = FALSE;
2166 #ifdef IAMSUID /* actually, this is caught earlier */
2167 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2169 (void)seteuid(PL_uid); /* musn't stay setuid root */
2172 (void)setreuid((Uid_t)-1, PL_uid);
2174 #ifdef HAS_SETRESUID
2175 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2177 PerlProc_setuid(PL_uid);
2181 if (PerlProc_geteuid() != PL_uid)
2182 Perl_croak(aTHX_ "Can't do seteuid!\n");
2184 #endif /* IAMSUID */
2185 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2189 else if (!*scriptname) {
2190 forbid_setid("program input from stdin");
2191 PL_rsfp = PerlIO_stdin();
2194 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2195 #if defined(HAS_FCNTL) && defined(F_SETFD)
2197 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2202 #ifndef IAMSUID /* in case script is not readable before setuid */
2204 PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&PL_statbuf) >= 0 &&
2205 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2208 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2209 Perl_croak(aTHX_ "Can't do setuid\n");
2213 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2214 SvPVX(GvSV(PL_curcop->cop_filegv)), Strerror(errno));
2219 * I_SYSSTATVFS HAS_FSTATVFS
2221 * I_STATFS HAS_FSTATFS
2222 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2223 * here so that metaconfig picks them up. */
2227 S_fd_on_nosuid_fs(pTHX_ int fd)
2229 int check_okay = 0; /* able to do all the required sys/libcalls */
2230 int on_nosuid = 0; /* the fd is on a nosuid fs */
2232 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2233 * fstatvfs() is UNIX98.
2234 * fstatfs() is 4.3 BSD.
2235 * ustat()+getmnt() is pre-4.3 BSD.
2236 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2237 * an irrelevant filesystem while trying to reach the right one.
2240 # ifdef HAS_FSTATVFS
2241 struct statvfs stfs;
2242 check_okay = fstatvfs(fd, &stfs) == 0;
2243 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2245 # ifdef PERL_MOUNT_NOSUID
2246 # if defined(HAS_FSTATFS) && \
2247 defined(HAS_STRUCT_STATFS) && \
2248 defined(HAS_STRUCT_STATFS_F_FLAGS)
2250 check_okay = fstatfs(fd, &stfs) == 0;
2251 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2253 # if defined(HAS_FSTAT) && \
2254 defined(HAS_USTAT) && \
2255 defined(HAS_GETMNT) && \
2256 defined(HAS_STRUCT_FS_DATA) &&
2259 if (fstat(fd, &fdst) == 0) {
2261 if (ustat(fdst.st_dev, &us) == 0) {
2263 /* NOSTAT_ONE here because we're not examining fields which
2264 * vary between that case and STAT_ONE. */
2265 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2266 size_t cmplen = sizeof(us.f_fname);
2267 if (sizeof(fsd.fd_req.path) < cmplen)
2268 cmplen = sizeof(fsd.fd_req.path);
2269 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2270 fdst.st_dev == fsd.fd_req.dev) {
2272 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2278 # endif /* fstat+ustat+getmnt */
2279 # endif /* fstatfs */
2281 # if defined(HAS_GETMNTENT) && \
2282 defined(HAS_HASMNTOPT) && \
2283 defined(MNTOPT_NOSUID)
2284 FILE *mtab = fopen("/etc/mtab", "r");
2285 struct mntent *entry;
2286 struct stat stb, fsb;
2288 if (mtab && (fstat(fd, &stb) == 0)) {
2289 while (entry = getmntent(mtab)) {
2290 if (stat(entry->mnt_dir, &fsb) == 0
2291 && fsb.st_dev == stb.st_dev)
2293 /* found the filesystem */
2295 if (hasmntopt(entry, MNTOPT_NOSUID))
2298 } /* A single fs may well fail its stat(). */
2303 # endif /* getmntent+hasmntopt */
2304 # endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */
2305 # endif /* statvfs */
2308 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
2311 #endif /* IAMSUID */
2314 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2318 /* do we need to emulate setuid on scripts? */
2320 /* This code is for those BSD systems that have setuid #! scripts disabled
2321 * in the kernel because of a security problem. Merely defining DOSUID
2322 * in perl will not fix that problem, but if you have disabled setuid
2323 * scripts in the kernel, this will attempt to emulate setuid and setgid
2324 * on scripts that have those now-otherwise-useless bits set. The setuid
2325 * root version must be called suidperl or sperlN.NNN. If regular perl
2326 * discovers that it has opened a setuid script, it calls suidperl with
2327 * the same argv that it had. If suidperl finds that the script it has
2328 * just opened is NOT setuid root, it sets the effective uid back to the
2329 * uid. We don't just make perl setuid root because that loses the
2330 * effective uid we had before invoking perl, if it was different from the
2333 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2334 * be defined in suidperl only. suidperl must be setuid root. The
2335 * Configure script will set this up for you if you want it.
2342 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2343 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2344 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2349 #ifndef HAS_SETREUID
2350 /* On this access check to make sure the directories are readable,
2351 * there is actually a small window that the user could use to make
2352 * filename point to an accessible directory. So there is a faint
2353 * chance that someone could execute a setuid script down in a
2354 * non-accessible directory. I don't know what to do about that.
2355 * But I don't think it's too important. The manual lies when
2356 * it says access() is useful in setuid programs.
2358 if (PerlLIO_access(SvPVX(GvSV(PL_curcop->cop_filegv)),1)) /*double check*/
2359 Perl_croak(aTHX_ "Permission denied");
2361 /* If we can swap euid and uid, then we can determine access rights
2362 * with a simple stat of the file, and then compare device and
2363 * inode to make sure we did stat() on the same file we opened.
2364 * Then we just have to make sure he or she can execute it.
2367 struct stat tmpstatbuf;
2371 setreuid(PL_euid,PL_uid) < 0
2374 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2377 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2378 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2379 if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0)
2380 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2381 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2382 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2383 Perl_croak(aTHX_ "Permission denied");
2385 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2386 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2387 (void)PerlIO_close(PL_rsfp);
2388 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2389 PerlIO_printf(PL_rsfp,
2390 "User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2391 (Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n",
2392 PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2393 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2394 SvPVX(GvSV(PL_curcop->cop_filegv)),
2395 PL_statbuf.st_uid, PL_statbuf.st_gid);
2396 (void)PerlProc_pclose(PL_rsfp);
2398 Perl_croak(aTHX_ "Permission denied\n");
2402 setreuid(PL_uid,PL_euid) < 0
2404 # if defined(HAS_SETRESUID)
2405 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2408 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2409 Perl_croak(aTHX_ "Can't reswap uid and euid");
2410 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2411 Perl_croak(aTHX_ "Permission denied\n");
2413 #endif /* HAS_SETREUID */
2414 #endif /* IAMSUID */
2416 if (!S_ISREG(PL_statbuf.st_mode))
2417 Perl_croak(aTHX_ "Permission denied");
2418 if (PL_statbuf.st_mode & S_IWOTH)
2419 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2420 PL_doswitches = FALSE; /* -s is insecure in suid */
2421 PL_curcop->cop_line++;
2422 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2423 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2424 Perl_croak(aTHX_ "No #! line");
2425 s = SvPV(PL_linestr,n_a)+2;
2427 while (!isSPACE(*s)) s++;
2428 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2429 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2430 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2431 Perl_croak(aTHX_ "Not a perl script");
2432 while (*s == ' ' || *s == '\t') s++;
2434 * #! arg must be what we saw above. They can invoke it by
2435 * mentioning suidperl explicitly, but they may not add any strange
2436 * arguments beyond what #! says if they do invoke suidperl that way.
2438 len = strlen(validarg);
2439 if (strEQ(validarg," PHOOEY ") ||
2440 strnNE(s,validarg,len) || !isSPACE(s[len]))
2441 Perl_croak(aTHX_ "Args must match #! line");
2444 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2445 PL_euid == PL_statbuf.st_uid)
2447 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2448 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2449 #endif /* IAMSUID */
2451 if (PL_euid) { /* oops, we're not the setuid root perl */
2452 (void)PerlIO_close(PL_rsfp);
2455 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2457 Perl_croak(aTHX_ "Can't do setuid\n");
2460 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2462 (void)setegid(PL_statbuf.st_gid);
2465 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2467 #ifdef HAS_SETRESGID
2468 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2470 PerlProc_setgid(PL_statbuf.st_gid);
2474 if (PerlProc_getegid() != PL_statbuf.st_gid)
2475 Perl_croak(aTHX_ "Can't do setegid!\n");
2477 if (PL_statbuf.st_mode & S_ISUID) {
2478 if (PL_statbuf.st_uid != PL_euid)
2480 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2483 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2485 #ifdef HAS_SETRESUID
2486 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2488 PerlProc_setuid(PL_statbuf.st_uid);
2492 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2493 Perl_croak(aTHX_ "Can't do seteuid!\n");
2495 else if (PL_uid) { /* oops, mustn't run as root */
2497 (void)seteuid((Uid_t)PL_uid);
2500 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2502 #ifdef HAS_SETRESUID
2503 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2505 PerlProc_setuid((Uid_t)PL_uid);
2509 if (PerlProc_geteuid() != PL_uid)
2510 Perl_croak(aTHX_ "Can't do seteuid!\n");
2513 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2514 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
2517 else if (PL_preprocess)
2518 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2519 else if (fdscript >= 0)
2520 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2522 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2524 /* We absolutely must clear out any saved ids here, so we */
2525 /* exec the real perl, substituting fd script for scriptname. */
2526 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2527 PerlIO_rewind(PL_rsfp);
2528 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2529 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2530 if (!PL_origargv[which])
2531 Perl_croak(aTHX_ "Permission denied");
2532 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2533 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2534 #if defined(HAS_FCNTL) && defined(F_SETFD)
2535 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2537 PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
2538 Perl_croak(aTHX_ "Can't do setuid\n");
2539 #endif /* IAMSUID */
2541 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2542 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2544 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2545 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2547 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2550 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2551 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2552 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2553 /* not set-id, must be wrapped */
2559 S_find_beginning(pTHX)
2561 register char *s, *s2;
2563 /* skip forward in input to the real script? */
2566 #ifdef MACOS_TRADITIONAL
2567 /* Since the Mac OS does not honor !# arguments for us,
2568 * we do it ourselves. */
2569 while (PL_doextract || gAlwaysExtract) {
2570 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2571 if (!gAlwaysExtract)
2572 Perl_croak(aTHX_ "No Perl script found in input\n");
2574 if (PL_doextract) /* require explicit override ? */
2575 if (!OverrideExtract(PL_origfilename))
2576 Perl_croak(aTHX_ "User aborted script\n");
2578 PL_doextract = FALSE;
2580 /* Pater peccavi, file does not have #! */
2581 PerlIO_rewind(PL_rsfp);
2586 while (PL_doextract) {
2587 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2588 Perl_croak(aTHX_ "No Perl script found in input\n");
2590 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2591 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2592 PL_doextract = FALSE;
2593 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2595 while (*s == ' ' || *s == '\t') s++;
2597 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2598 if (strnEQ(s2-4,"perl",4))
2600 while (s = moreswitches(s)) ;
2610 PL_uid = PerlProc_getuid();
2611 PL_euid = PerlProc_geteuid();
2612 PL_gid = PerlProc_getgid();
2613 PL_egid = PerlProc_getegid();
2615 PL_uid |= PL_gid << 16;
2616 PL_euid |= PL_egid << 16;
2618 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2622 S_forbid_setid(pTHX_ char *s)
2624 if (PL_euid != PL_uid)
2625 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2626 if (PL_egid != PL_gid)
2627 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2631 Perl_init_debugger(pTHX)
2634 HV *ostash = PL_curstash;
2636 PL_curstash = PL_debstash;
2637 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2638 AvREAL_off(PL_dbargs);
2639 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2640 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2641 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2642 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
2643 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2644 sv_setiv(PL_DBsingle, 0);
2645 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2646 sv_setiv(PL_DBtrace, 0);
2647 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2648 sv_setiv(PL_DBsignal, 0);
2649 PL_curstash = ostash;
2652 #ifndef STRESS_REALLOC
2653 #define REASONABLE(size) (size)
2655 #define REASONABLE(size) (1) /* unreasonable */
2659 Perl_init_stacks(pTHX)
2661 /* start with 128-item stack and 8K cxstack */
2662 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2663 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2664 PL_curstackinfo->si_type = PERLSI_MAIN;
2665 PL_curstack = PL_curstackinfo->si_stack;
2666 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2668 PL_stack_base = AvARRAY(PL_curstack);
2669 PL_stack_sp = PL_stack_base;
2670 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2672 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2675 PL_tmps_max = REASONABLE(128);
2677 New(54,PL_markstack,REASONABLE(32),I32);
2678 PL_markstack_ptr = PL_markstack;
2679 PL_markstack_max = PL_markstack + REASONABLE(32);
2683 New(54,PL_scopestack,REASONABLE(32),I32);
2684 PL_scopestack_ix = 0;
2685 PL_scopestack_max = REASONABLE(32);
2687 New(54,PL_savestack,REASONABLE(128),ANY);
2688 PL_savestack_ix = 0;
2689 PL_savestack_max = REASONABLE(128);
2691 New(54,PL_retstack,REASONABLE(16),OP*);
2693 PL_retstack_max = REASONABLE(16);
2702 while (PL_curstackinfo->si_next)
2703 PL_curstackinfo = PL_curstackinfo->si_next;
2704 while (PL_curstackinfo) {
2705 PERL_SI *p = PL_curstackinfo->si_prev;
2706 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2707 Safefree(PL_curstackinfo->si_cxstack);
2708 Safefree(PL_curstackinfo);
2709 PL_curstackinfo = p;
2711 Safefree(PL_tmps_stack);
2712 Safefree(PL_markstack);
2713 Safefree(PL_scopestack);
2714 Safefree(PL_savestack);
2715 Safefree(PL_retstack);
2719 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2730 lex_start(PL_linestr);
2732 PL_subname = newSVpvn("main",4);
2736 S_init_predump_symbols(pTHX)
2743 sv_setpvn(get_sv("\"", TRUE), " ", 1);
2744 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2745 GvMULTI_on(PL_stdingv);
2746 io = GvIOp(PL_stdingv);
2747 IoIFP(io) = PerlIO_stdin();
2748 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2750 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2752 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2755 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
2757 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2759 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2761 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2762 GvMULTI_on(PL_stderrgv);
2763 io = GvIOp(PL_stderrgv);
2764 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
2765 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2767 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2769 PL_statname = NEWSV(66,0); /* last filename we did stat on */
2772 Safefree(PL_osname);
2773 PL_osname = savepv(OSNAME);
2777 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
2784 argc--,argv++; /* skip name of script */
2785 if (PL_doswitches) {
2786 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2789 if (argv[0][1] == '-') {
2793 if (s = strchr(argv[0], '=')) {
2795 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2798 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2801 PL_toptarget = NEWSV(0,0);
2802 sv_upgrade(PL_toptarget, SVt_PVFM);
2803 sv_setpvn(PL_toptarget, "", 0);
2804 PL_bodytarget = NEWSV(0,0);
2805 sv_upgrade(PL_bodytarget, SVt_PVFM);
2806 sv_setpvn(PL_bodytarget, "", 0);
2807 PL_formtarget = PL_bodytarget;
2810 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2811 #ifdef MACOS_TRADITIONAL
2812 sv_setpv(GvSV(tmpgv),MPWFileName(PL_origfilename));
2813 /* $0 is not majick on a Mac */
2815 sv_setpv(GvSV(tmpgv),PL_origfilename);
2816 magicname("0", "0", 1);
2819 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2821 sv_setpv(GvSV(tmpgv), os2_execname());
2823 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2825 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2826 GvMULTI_on(PL_argvgv);
2827 (void)gv_AVadd(PL_argvgv);
2828 av_clear(GvAVn(PL_argvgv));
2829 for (; argc > 0; argc--,argv++) {
2830 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2833 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2835 GvMULTI_on(PL_envgv);
2836 hv = GvHVn(PL_envgv);
2837 hv_magic(hv, PL_envgv, 'E');
2838 #if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
2839 /* Note that if the supplied env parameter is actually a copy
2840 of the global environ then it may now point to free'd memory
2841 if the environment has been modified since. To avoid this
2842 problem we treat env==NULL as meaning 'use the default'
2847 environ[0] = Nullch;
2848 for (; *env; env++) {
2849 if (!(s = strchr(*env,'=')))
2855 sv = newSVpv(s--,0);
2856 (void)hv_store(hv, *env, s - *env, sv, 0);
2858 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2859 /* Sins of the RTL. See note in my_setenv(). */
2860 (void)PerlEnv_putenv(savepv(*env));
2864 #ifdef DYNAMIC_ENV_FETCH
2865 HvNAME(hv) = savepv(ENV_HV_NAME);
2869 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2870 sv_setiv(GvSV(tmpgv), (IV)getpid());
2874 S_init_perllib(pTHX)
2879 s = PerlEnv_getenv("PERL5LIB");
2883 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2885 /* Treat PERL5?LIB as a possible search list logical name -- the
2886 * "natural" VMS idiom for a Unix path string. We allow each
2887 * element to be a set of |-separated directories for compatibility.
2891 if (my_trnlnm("PERL5LIB",buf,0))
2892 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2894 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2898 /* Use the ~-expanded versions of APPLLIB (undocumented),
2899 ARCHLIB PRIVLIB SITEARCH and SITELIB
2902 incpush(APPLLIB_EXP, TRUE);
2906 incpush(ARCHLIB_EXP, FALSE);
2908 #ifdef MACOS_TRADITIONAL
2910 struct stat tmpstatbuf;
2911 SV * privdir = NEWSV(55, 0);
2912 char * macperl = getenv("MACPERL") || "";
2914 Perl_sv_setpvf(privdir, "%slib:", macperl);
2915 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
2916 incpush(SvPVX(privdir), TRUE);
2917 Perl_sv_setpvf(privdir, "%ssite_perl:", macperl);
2918 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
2919 incpush(SvPVX(privdir), TRUE);
2921 SvREFCNT_dec(privdir);
2924 incpush(":", FALSE);
2927 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2930 incpush(PRIVLIB_EXP, TRUE);
2932 incpush(PRIVLIB_EXP, FALSE);
2936 incpush(SITEARCH_EXP, FALSE);
2940 incpush(SITELIB_EXP, TRUE);
2942 incpush(SITELIB_EXP, FALSE);
2945 #if defined(PERL_VENDORLIB_EXP)
2947 incpush(PERL_VENDORLIB_EXP, TRUE);
2949 incpush(PERL_VENDORLIB_EXP, FALSE);
2953 incpush(".", FALSE);
2954 #endif /* MACOS_TRADITIONAL */
2957 #if defined(MACOS_TRADITIONAL)
2958 # define PERLLIB_SEP ','
2960 # if defined(DOSISH)
2961 # define PERLLIB_SEP ';'
2964 # define PERLLIB_SEP '|'
2966 # define PERLLIB_SEP ':'
2970 #ifndef PERLLIB_MANGLE
2971 # define PERLLIB_MANGLE(s,n) (s)
2975 S_incpush(pTHX_ char *p, int addsubdirs)
2977 SV *subdir = Nullsv;
2983 subdir = sv_newmortal();
2984 if (!PL_archpat_auto) {
2985 STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
2986 + sizeof("//auto"));
2987 New(55, PL_archpat_auto, len, char);
2988 #ifdef MACOS_TRADITIONAL
2989 sprintf(PL_archpat_auto, "%s:%s:auto:", ARCHNAME, PL_patchlevel);
2991 sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
2994 for (len = sizeof(ARCHNAME) + 2;
2995 PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2996 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
3001 /* Break at all separators */
3003 SV *libdir = NEWSV(55,0);
3006 /* skip any consecutive separators */
3007 while ( *p == PERLLIB_SEP ) {
3008 /* Uncomment the next line for PATH semantics */
3009 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3013 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3014 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3019 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3020 p = Nullch; /* break out */
3022 #ifdef MACOS_TRADITIONAL
3023 if (!strchr(SvPVX(libdir), ':'))
3024 sv_insert(libdir, 0, 0, ":", 1);
3025 if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
3026 sv_catpv(libdir, ":");
3030 * BEFORE pushing libdir onto @INC we may first push version- and
3031 * archname-specific sub-directories.
3034 struct stat tmpstatbuf;
3039 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3041 while (unix[len-1] == '/') len--; /* Cosmetic */
3042 sv_usepvn(libdir,unix,len);
3045 PerlIO_printf(Perl_error_log,
3046 "Failed to unixify @INC element \"%s\"\n",
3049 /* .../archname/version if -d .../archname/version/auto */
3050 sv_setsv(subdir, libdir);
3051 sv_catpv(subdir, PL_archpat_auto);
3052 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3053 S_ISDIR(tmpstatbuf.st_mode))
3054 av_push(GvAVn(PL_incgv),
3055 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
3057 /* .../archname if -d .../archname/auto */
3058 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
3059 strlen(PL_patchlevel) + 1, "", 0);
3060 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3061 S_ISDIR(tmpstatbuf.st_mode))
3062 av_push(GvAVn(PL_incgv),
3063 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
3066 /* finally push this lib directory on the end of @INC */
3067 av_push(GvAVn(PL_incgv), libdir);
3072 STATIC struct perl_thread *
3073 S_init_main_thread(pTHX)
3075 #if !defined(PERL_IMPLICIT_CONTEXT)
3076 struct perl_thread *thr;
3080 Newz(53, thr, 1, struct perl_thread);
3081 PL_curcop = &PL_compiling;
3082 thr->interp = PERL_GET_INTERP;
3083 thr->cvcache = newHV();
3084 thr->threadsv = newAV();
3085 /* thr->threadsvp is set when find_threadsv is called */
3086 thr->specific = newAV();
3087 thr->flags = THRf_R_JOINABLE;
3088 MUTEX_INIT(&thr->mutex);
3089 /* Handcraft thrsv similarly to mess_sv */
3090 New(53, PL_thrsv, 1, SV);
3091 Newz(53, xpv, 1, XPV);
3092 SvFLAGS(PL_thrsv) = SVt_PV;
3093 SvANY(PL_thrsv) = (void*)xpv;
3094 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3095 SvPVX(PL_thrsv) = (char*)thr;
3096 SvCUR_set(PL_thrsv, sizeof(thr));
3097 SvLEN_set(PL_thrsv, sizeof(thr));
3098 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3099 thr->oursv = PL_thrsv;
3100 PL_chopset = " \n-";
3103 MUTEX_LOCK(&PL_threads_mutex);
3108 MUTEX_UNLOCK(&PL_threads_mutex);
3110 #ifdef HAVE_THREAD_INTERN
3111 Perl_init_thread_intern(thr);
3114 #ifdef SET_THREAD_SELF
3115 SET_THREAD_SELF(thr);
3117 thr->self = pthread_self();
3118 #endif /* SET_THREAD_SELF */
3122 * These must come after the SET_THR because sv_setpvn does
3123 * SvTAINT and the taint fields require dTHR.
3125 PL_toptarget = NEWSV(0,0);
3126 sv_upgrade(PL_toptarget, SVt_PVFM);
3127 sv_setpvn(PL_toptarget, "", 0);
3128 PL_bodytarget = NEWSV(0,0);
3129 sv_upgrade(PL_bodytarget, SVt_PVFM);
3130 sv_setpvn(PL_bodytarget, "", 0);
3131 PL_formtarget = PL_bodytarget;
3132 thr->errsv = newSVpvn("", 0);
3133 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
3136 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3137 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3138 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3139 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3140 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3142 PL_reginterp_cnt = 0;
3146 #endif /* USE_THREADS */
3149 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3153 line_t oldline = PL_curcop->cop_line;
3159 while (AvFILL(paramList) >= 0) {
3160 cv = (CV*)av_shift(paramList);
3162 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
3165 (void)SvPV(atsv, len);
3167 PL_curcop = &PL_compiling;
3168 PL_curcop->cop_line = oldline;
3169 if (paramList == PL_beginav)
3170 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3172 sv_catpv(atsv, "END failed--cleanup aborted");
3173 while (PL_scopestack_ix > oldscope)
3175 Perl_croak(aTHX_ "%s", SvPVX(atsv));
3182 /* my_exit() was called */
3183 while (PL_scopestack_ix > oldscope)
3186 PL_curstash = PL_defstash;
3187 if (PL_endav && !PL_minus_c)
3188 call_list(oldscope, PL_endav);
3189 PL_curcop = &PL_compiling;
3190 PL_curcop->cop_line = oldline;
3191 if (PL_statusvalue) {
3192 if (paramList == PL_beginav)
3193 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3195 Perl_croak(aTHX_ "END failed--cleanup aborted");
3201 PL_curcop = &PL_compiling;
3202 PL_curcop->cop_line = oldline;
3205 PerlIO_printf(Perl_error_log, "panic: restartop\n");
3213 S_call_list_body(pTHX_ va_list args)
3216 CV *cv = va_arg(args, CV*);
3218 PUSHMARK(PL_stack_sp);
3219 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3224 Perl_my_exit(pTHX_ U32 status)
3228 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3229 thr, (unsigned long) status));
3238 STATUS_NATIVE_SET(status);
3245 Perl_my_failure_exit(pTHX)
3248 if (vaxc$errno & 1) {
3249 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3250 STATUS_NATIVE_SET(44);
3253 if (!vaxc$errno && errno) /* unlikely */
3254 STATUS_NATIVE_SET(44);
3256 STATUS_NATIVE_SET(vaxc$errno);
3261 STATUS_POSIX_SET(errno);
3263 exitstatus = STATUS_POSIX >> 8;
3264 if (exitstatus & 255)
3265 STATUS_POSIX_SET(exitstatus);
3267 STATUS_POSIX_SET(255);
3274 S_my_exit_jump(pTHX)
3277 register PERL_CONTEXT *cx;
3282 SvREFCNT_dec(PL_e_script);
3283 PL_e_script = Nullsv;
3286 POPSTACK_TO(PL_mainstack);
3287 if (cxstack_ix >= 0) {
3290 POPBLOCK(cx,PL_curpm);
3303 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3306 p = SvPVX(PL_e_script);
3307 nl = strchr(p, '\n');
3308 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3310 filter_del(read_e_script);
3313 sv_catpvn(buf_sv, p, nl-p);
3314 sv_chop(PL_e_script, nl);