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 */
224 New(51,PL_debname,128,char);
225 New(52,PL_debdelim,128,char);
235 int destruct_level; /* 0=none, 1=full, 2=full with checks */
241 #endif /* USE_THREADS */
245 /* Pass 1 on any remaining threads: detach joinables, join zombies */
247 MUTEX_LOCK(&PL_threads_mutex);
248 DEBUG_S(PerlIO_printf(Perl_debug_log,
249 "perl_destruct: waiting for %d threads...\n",
251 for (t = thr->next; t != thr; t = t->next) {
252 MUTEX_LOCK(&t->mutex);
253 switch (ThrSTATE(t)) {
256 DEBUG_S(PerlIO_printf(Perl_debug_log,
257 "perl_destruct: joining zombie %p\n", t));
258 ThrSETSTATE(t, THRf_DEAD);
259 MUTEX_UNLOCK(&t->mutex);
262 * The SvREFCNT_dec below may take a long time (e.g. av
263 * may contain an object scalar whose destructor gets
264 * called) so we have to unlock threads_mutex and start
267 MUTEX_UNLOCK(&PL_threads_mutex);
269 SvREFCNT_dec((SV*)av);
270 DEBUG_S(PerlIO_printf(Perl_debug_log,
271 "perl_destruct: joined zombie %p OK\n", t));
273 case THRf_R_JOINABLE:
274 DEBUG_S(PerlIO_printf(Perl_debug_log,
275 "perl_destruct: detaching thread %p\n", t));
276 ThrSETSTATE(t, THRf_R_DETACHED);
278 * We unlock threads_mutex and t->mutex in the opposite order
279 * from which we locked them just so that DETACH won't
280 * deadlock if it panics. It's only a breach of good style
281 * not a bug since they are unlocks not locks.
283 MUTEX_UNLOCK(&PL_threads_mutex);
285 MUTEX_UNLOCK(&t->mutex);
288 DEBUG_S(PerlIO_printf(Perl_debug_log,
289 "perl_destruct: ignoring %p (state %u)\n",
291 MUTEX_UNLOCK(&t->mutex);
292 /* fall through and out */
295 /* We leave the above "Pass 1" loop with threads_mutex still locked */
297 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
298 while (PL_nthreads > 1)
300 DEBUG_S(PerlIO_printf(Perl_debug_log,
301 "perl_destruct: final wait for %d threads\n",
303 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
305 /* At this point, we're the last thread */
306 MUTEX_UNLOCK(&PL_threads_mutex);
307 DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
308 MUTEX_DESTROY(&PL_threads_mutex);
309 COND_DESTROY(&PL_nthreads_cond);
310 #endif /* !defined(FAKE_THREADS) */
311 #endif /* USE_THREADS */
313 destruct_level = PL_perl_destruct_level;
317 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
319 if (destruct_level < i)
328 /* We must account for everything. */
330 /* Destroy the main CV and syntax tree */
332 PL_curpad = AvARRAY(PL_comppad);
333 op_free(PL_main_root);
334 PL_main_root = Nullop;
336 PL_curcop = &PL_compiling;
337 PL_main_start = Nullop;
338 SvREFCNT_dec(PL_main_cv);
342 if (PL_sv_objcount) {
344 * Try to destruct global references. We do this first so that the
345 * destructors and destructees still exist. Some sv's might remain.
346 * Non-referenced objects are on their own.
351 /* unhook hooks which will soon be, or use, destroyed data */
352 SvREFCNT_dec(PL_warnhook);
353 PL_warnhook = Nullsv;
354 SvREFCNT_dec(PL_diehook);
357 /* call exit list functions */
358 while (PL_exitlistlen-- > 0)
359 PL_exitlist[PL_exitlistlen].fn(aTHXo_ PL_exitlist[PL_exitlistlen].ptr);
361 Safefree(PL_exitlist);
363 if (destruct_level == 0){
365 DEBUG_P(debprofdump());
367 /* The exit() function will do everything that needs doing. */
371 /* loosen bonds of global variables */
374 (void)PerlIO_close(PL_rsfp);
378 /* Filters for program text */
379 SvREFCNT_dec(PL_rsfp_filters);
380 PL_rsfp_filters = Nullav;
383 PL_preprocess = FALSE;
389 PL_doswitches = FALSE;
390 PL_dowarn = G_WARN_OFF;
391 PL_doextract = FALSE;
392 PL_sawampersand = FALSE; /* must save all match strings */
393 PL_sawstudy = FALSE; /* do fbm_instr on all strings */
397 Safefree(PL_inplace);
401 SvREFCNT_dec(PL_e_script);
402 PL_e_script = Nullsv;
405 /* magical thingies */
407 Safefree(PL_ofs); /* $, */
410 Safefree(PL_ors); /* $\ */
413 SvREFCNT_dec(PL_rs); /* $/ */
416 SvREFCNT_dec(PL_nrs); /* $/ helper */
419 PL_multiline = 0; /* $* */
421 SvREFCNT_dec(PL_statname);
422 PL_statname = Nullsv;
425 /* defgv, aka *_ should be taken care of elsewhere */
427 /* clean up after study() */
428 SvREFCNT_dec(PL_lastscream);
429 PL_lastscream = Nullsv;
430 Safefree(PL_screamfirst);
432 Safefree(PL_screamnext);
436 Safefree(PL_efloatbuf);
437 PL_efloatbuf = Nullch;
440 /* startup and shutdown function lists */
441 SvREFCNT_dec(PL_beginav);
442 SvREFCNT_dec(PL_endav);
443 SvREFCNT_dec(PL_initav);
448 /* shortcuts just get cleared */
455 PL_argvoutgv = Nullgv;
457 PL_stderrgv = Nullgv;
458 PL_last_in_gv = Nullgv;
461 /* reset so print() ends up where we expect */
464 /* Prepare to destruct main symbol table. */
470 /* clear queued errors */
471 SvREFCNT_dec(PL_errors);
475 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
476 if (PL_scopestack_ix != 0)
477 Perl_warner(aTHX_ WARN_INTERNAL,
478 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
479 (long)PL_scopestack_ix);
480 if (PL_savestack_ix != 0)
481 Perl_warner(aTHX_ WARN_INTERNAL,
482 "Unbalanced saves: %ld more saves than restores\n",
483 (long)PL_savestack_ix);
484 if (PL_tmps_floor != -1)
485 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
486 (long)PL_tmps_floor + 1);
487 if (cxstack_ix != -1)
488 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
489 (long)cxstack_ix + 1);
492 /* Now absolutely destruct everything, somehow or other, loops or no. */
494 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
495 while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
496 last_sv_count = PL_sv_count;
499 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
500 SvFLAGS(PL_strtab) |= SVt_PVHV;
502 /* Destruct the global string table. */
504 /* Yell and reset the HeVAL() slots that are still holding refcounts,
505 * so that sv_free() won't fail on them.
513 max = HvMAX(PL_strtab);
514 array = HvARRAY(PL_strtab);
517 if (hent && ckWARN_d(WARN_INTERNAL)) {
518 Perl_warner(aTHX_ WARN_INTERNAL,
519 "Unbalanced string table refcount: (%d) for \"%s\"",
520 HeVAL(hent) - Nullsv, HeKEY(hent));
521 HeVAL(hent) = Nullsv;
531 SvREFCNT_dec(PL_strtab);
533 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
534 Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
538 /* No SVs have survived, need to clean out */
540 PL_pidstatus = Nullhv;
541 Safefree(PL_origfilename);
542 Safefree(PL_archpat_auto);
543 Safefree(PL_reg_start_tmp);
545 Safefree(PL_reg_curpm);
546 Safefree(PL_reg_poscache);
547 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
548 Safefree(PL_op_mask);
550 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
552 DEBUG_P(debprofdump());
554 MUTEX_DESTROY(&PL_strtab_mutex);
555 MUTEX_DESTROY(&PL_sv_mutex);
556 MUTEX_DESTROY(&PL_eval_mutex);
557 MUTEX_DESTROY(&PL_cred_mutex);
558 COND_DESTROY(&PL_eval_cond);
559 #ifdef EMULATE_ATOMIC_REFCOUNTS
560 MUTEX_DESTROY(&PL_svref_mutex);
561 #endif /* EMULATE_ATOMIC_REFCOUNTS */
563 /* As the penultimate thing, free the non-arena SV for thrsv */
564 Safefree(SvPVX(PL_thrsv));
565 Safefree(SvANY(PL_thrsv));
568 #endif /* USE_THREADS */
570 /* As the absolutely last thing, free the non-arena SV for mess() */
573 /* it could have accumulated taint magic */
574 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
577 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
578 moremagic = mg->mg_moremagic;
579 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
580 Safefree(mg->mg_ptr);
584 /* we know that type >= SVt_PV */
585 SvOOK_off(PL_mess_sv);
586 Safefree(SvPVX(PL_mess_sv));
587 Safefree(SvANY(PL_mess_sv));
588 Safefree(PL_mess_sv);
596 #if defined(PERL_OBJECT)
604 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
606 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
607 PL_exitlist[PL_exitlistlen].fn = fn;
608 PL_exitlist[PL_exitlistlen].ptr = ptr;
613 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
623 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
626 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
627 setuid perl scripts securely.\n");
631 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
632 _dyld_lookup_and_bind
633 ("__environ", (unsigned long *) &environ_pointer, NULL);
638 #ifndef VMS /* VMS doesn't have environ array */
639 PL_origenviron = environ;
644 /* Come here if running an undumped a.out. */
646 PL_origfilename = savepv(argv[0]);
647 PL_do_undump = FALSE;
648 cxstack_ix = -1; /* start label stack again */
650 init_postdump_symbols(argc,argv,env);
655 PL_curpad = AvARRAY(PL_comppad);
656 op_free(PL_main_root);
657 PL_main_root = Nullop;
659 PL_main_start = Nullop;
660 SvREFCNT_dec(PL_main_cv);
664 oldscope = PL_scopestack_ix;
665 PL_dowarn = G_WARN_OFF;
667 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_parse_body),
676 /* my_exit() was called */
677 while (PL_scopestack_ix > oldscope)
680 PL_curstash = PL_defstash;
681 if (PL_endav && !PL_minus_c)
682 call_list(oldscope, PL_endav);
683 return STATUS_NATIVE_EXPORT;
685 PerlIO_printf(Perl_error_log, "panic: top_env\n");
692 S_parse_body(pTHX_ va_list args)
695 int argc = PL_origargc;
696 char **argv = PL_origargv;
697 char **env = va_arg(args, char**);
698 char *scriptname = NULL;
700 VOL bool dosearch = FALSE;
706 XSINIT_t xsinit = va_arg(args, XSINIT_t);
708 sv_setpvn(PL_linestr,"",0);
709 sv = newSVpvn("",0); /* first used for -I flags */
713 for (argc--,argv++; argc > 0; argc--,argv++) {
714 if (argv[0][0] != '-' || !argv[0][1])
718 validarg = " PHOOEY ";
725 #ifndef PERL_STRICT_CR
749 if (s = moreswitches(s))
759 if (PL_euid != PL_uid || PL_egid != PL_gid)
760 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
762 PL_e_script = newSVpvn("",0);
763 filter_add(read_e_script, NULL);
766 sv_catpv(PL_e_script, s);
768 sv_catpv(PL_e_script, argv[1]);
772 Perl_croak(aTHX_ "No code specified for -e");
773 sv_catpv(PL_e_script, "\n");
776 case 'I': /* -I handled both here and in moreswitches() */
778 if (!*++s && (s=argv[1]) != Nullch) {
781 while (s && isSPACE(*s))
785 for (e = s; *e && !isSPACE(*e); e++) ;
792 } /* XXX else croak? */
796 PL_preprocess = TRUE;
806 PL_preambleav = newAV();
807 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
809 PL_Sv = newSVpv("print myconfig();",0);
811 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
813 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
815 sv_catpv(PL_Sv,"\" Compile-time options:");
817 sv_catpv(PL_Sv," DEBUGGING");
820 sv_catpv(PL_Sv," MULTIPLICITY");
823 sv_catpv(PL_Sv," USE_THREADS");
826 sv_catpv(PL_Sv," PERL_OBJECT");
828 # ifdef PERL_IMPLICIT_CONTEXT
829 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
831 # ifdef PERL_IMPLICIT_SYS
832 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
834 sv_catpv(PL_Sv,"\\n\",");
836 #if defined(LOCAL_PATCH_COUNT)
837 if (LOCAL_PATCH_COUNT > 0) {
839 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
840 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
841 if (PL_localpatches[i])
842 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
846 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
849 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
851 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
856 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
857 print \" \\%ENV:\\n @env\\n\" if @env; \
858 print \" \\@INC:\\n @INC\\n\";");
861 PL_Sv = newSVpv("config_vars(qw(",0);
862 sv_catpv(PL_Sv, ++s);
863 sv_catpv(PL_Sv, "))");
866 av_push(PL_preambleav, PL_Sv);
867 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
873 PL_cddir = savepv(s);
878 if (!*++s || isSPACE(*s)) {
882 /* catch use of gnu style long options */
883 if (strEQ(s, "version")) {
887 if (strEQ(s, "help")) {
894 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
900 #ifndef SECURE_INTERNAL_GETENV
903 (s = PerlEnv_getenv("PERL5OPT"))) {
906 if (*s == '-' && *(s+1) == 'T')
919 if (!strchr("DIMUdmw", *s))
920 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
927 scriptname = argv[0];
930 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
932 else if (scriptname == Nullch) {
934 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
942 open_script(scriptname,dosearch,sv,&fdscript);
944 validate_suid(validarg, scriptname,fdscript);
946 #if defined(SIGCHLD) || defined(SIGCLD)
949 # define SIGCHLD SIGCLD
951 Sighandler_t sigstate = rsignal_state(SIGCHLD);
952 if (sigstate == SIG_IGN) {
953 if (ckWARN(WARN_SIGNAL))
954 Perl_warner(aTHX_ WARN_SIGNAL,
955 "Can't ignore signal CHLD, forcing to default");
956 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
964 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
965 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
966 CvUNIQUE_on(PL_compcv);
968 PL_comppad = newAV();
969 av_push(PL_comppad, Nullsv);
970 PL_curpad = AvARRAY(PL_comppad);
971 PL_comppad_name = newAV();
972 PL_comppad_name_fill = 0;
973 PL_min_intro_pending = 0;
976 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
977 PL_curpad[0] = (SV*)newAV();
978 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
979 CvOWNER(PL_compcv) = 0;
980 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
981 MUTEX_INIT(CvMUTEXP(PL_compcv));
982 #endif /* USE_THREADS */
984 comppadlist = newAV();
985 AvREAL_off(comppadlist);
986 av_store(comppadlist, 0, (SV*)PL_comppad_name);
987 av_store(comppadlist, 1, (SV*)PL_comppad);
988 CvPADLIST(PL_compcv) = comppadlist;
990 boot_core_UNIVERSAL();
994 (*xsinit)(aTHXo); /* in case linked C routines want magical variables */
995 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
1003 init_predump_symbols();
1004 /* init_postdump_symbols not currently designed to be called */
1005 /* more than once (ENV isn't cleared first, for example) */
1006 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
1008 init_postdump_symbols(argc,argv,env);
1012 /* now parse the script */
1014 SETERRNO(0,SS$_NORMAL);
1016 if (yyparse() || PL_error_count) {
1018 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1020 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1024 PL_curcop->cop_line = 0;
1025 PL_curstash = PL_defstash;
1026 PL_preprocess = FALSE;
1028 SvREFCNT_dec(PL_e_script);
1029 PL_e_script = Nullsv;
1032 /* now that script is parsed, we can modify record separator */
1033 SvREFCNT_dec(PL_rs);
1034 PL_rs = SvREFCNT_inc(PL_nrs);
1035 sv_setsv(get_sv("/", TRUE), PL_rs);
1040 gv_check(PL_defstash);
1046 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1047 dump_mstats("after compilation:");
1066 oldscope = PL_scopestack_ix;
1069 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
1072 cxstack_ix = -1; /* start context stack again */
1074 case 0: /* normal completion */
1075 case 2: /* my_exit() */
1076 while (PL_scopestack_ix > oldscope)
1079 PL_curstash = PL_defstash;
1080 if (PL_endav && !PL_minus_c)
1081 call_list(oldscope, PL_endav);
1083 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1084 dump_mstats("after execution: ");
1086 return STATUS_NATIVE_EXPORT;
1089 POPSTACK_TO(PL_mainstack);
1092 PerlIO_printf(Perl_error_log, "panic: restartop\n");
1102 S_run_body(pTHX_ va_list args)
1105 I32 oldscope = va_arg(args, I32);
1107 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1108 PL_sawampersand ? "Enabling" : "Omitting"));
1110 if (!PL_restartop) {
1111 DEBUG_x(dump_all());
1112 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1113 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1114 (unsigned long) thr));
1117 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1120 if (PERLDB_SINGLE && PL_DBsingle)
1121 sv_setiv(PL_DBsingle, 1);
1123 call_list(oldscope, PL_initav);
1129 PL_op = PL_restartop;
1133 else if (PL_main_start) {
1134 CvDEPTH(PL_main_cv) = 1;
1135 PL_op = PL_main_start;
1145 Perl_get_sv(pTHX_ const char *name, I32 create)
1149 if (name[1] == '\0' && !isALPHA(name[0])) {
1150 PADOFFSET tmp = find_threadsv(name);
1151 if (tmp != NOT_IN_PAD) {
1153 return THREADSV(tmp);
1156 #endif /* USE_THREADS */
1157 gv = gv_fetchpv(name, create, SVt_PV);
1164 Perl_get_av(pTHX_ const char *name, I32 create)
1166 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1175 Perl_get_hv(pTHX_ const char *name, I32 create)
1177 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1186 Perl_get_cv(pTHX_ const char *name, I32 create)
1188 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1189 /* XXX unsafe for threads if eval_owner isn't held */
1190 /* XXX this is probably not what they think they're getting.
1191 * It has the same effect as "sub name;", i.e. just a forward
1193 if (create && !GvCVu(gv))
1194 return newSUB(start_subparse(FALSE, 0),
1195 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1203 /* Be sure to refetch the stack pointer after calling these routines. */
1206 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1208 /* See G_* flags in cop.h */
1209 /* null terminated arg list */
1216 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1221 return call_pv(sub_name, flags);
1225 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1226 /* name of the subroutine */
1227 /* See G_* flags in cop.h */
1229 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1233 Perl_call_method(pTHX_ const char *methname, I32 flags)
1234 /* name of the subroutine */
1235 /* See G_* flags in cop.h */
1241 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1246 return call_sv(*PL_stack_sp--, flags);
1249 /* May be called with any of a CV, a GV, or an SV containing the name. */
1251 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1253 /* See G_* flags in cop.h */
1256 LOGOP myop; /* fake syntax tree node */
1260 bool oldcatch = CATCH_GET;
1265 if (flags & G_DISCARD) {
1270 Zero(&myop, 1, LOGOP);
1271 myop.op_next = Nullop;
1272 if (!(flags & G_NOARGS))
1273 myop.op_flags |= OPf_STACKED;
1274 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1275 (flags & G_ARRAY) ? OPf_WANT_LIST :
1280 EXTEND(PL_stack_sp, 1);
1281 *++PL_stack_sp = sv;
1283 oldscope = PL_scopestack_ix;
1285 if (PERLDB_SUB && PL_curstash != PL_debstash
1286 /* Handle first BEGIN of -d. */
1287 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1288 /* Try harder, since this may have been a sighandler, thus
1289 * curstash may be meaningless. */
1290 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1291 && !(flags & G_NODEBUG))
1292 PL_op->op_private |= OPpENTERSUB_DB;
1294 if (!(flags & G_EVAL)) {
1296 call_xbody((OP*)&myop, FALSE);
1297 retval = PL_stack_sp - (PL_stack_base + oldmark);
1298 CATCH_SET(oldcatch);
1301 cLOGOP->op_other = PL_op;
1303 /* we're trying to emulate pp_entertry() here */
1305 register PERL_CONTEXT *cx;
1306 I32 gimme = GIMME_V;
1311 push_return(PL_op->op_next);
1312 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1314 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1316 PL_in_eval = EVAL_INEVAL;
1317 if (flags & G_KEEPERR)
1318 PL_in_eval |= EVAL_KEEPERR;
1325 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1329 retval = PL_stack_sp - (PL_stack_base + oldmark);
1330 if (!(flags & G_KEEPERR))
1337 /* my_exit() was called */
1338 PL_curstash = PL_defstash;
1341 Perl_croak(aTHX_ "Callback called exit");
1346 PL_op = PL_restartop;
1350 PL_stack_sp = PL_stack_base + oldmark;
1351 if (flags & G_ARRAY)
1355 *++PL_stack_sp = &PL_sv_undef;
1360 if (PL_scopestack_ix > oldscope) {
1364 register PERL_CONTEXT *cx;
1375 if (flags & G_DISCARD) {
1376 PL_stack_sp = PL_stack_base + oldmark;
1386 S_call_body(pTHX_ va_list args)
1388 OP *myop = va_arg(args, OP*);
1389 int is_eval = va_arg(args, int);
1391 call_xbody(myop, is_eval);
1396 S_call_xbody(pTHX_ OP *myop, int is_eval)
1400 if (PL_op == myop) {
1402 PL_op = Perl_pp_entereval(aTHX);
1404 PL_op = Perl_pp_entersub(aTHX);
1410 /* Eval a string. The G_EVAL flag is always assumed. */
1413 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1415 /* See G_* flags in cop.h */
1418 UNOP myop; /* fake syntax tree node */
1419 I32 oldmark = SP - PL_stack_base;
1426 if (flags & G_DISCARD) {
1433 Zero(PL_op, 1, UNOP);
1434 EXTEND(PL_stack_sp, 1);
1435 *++PL_stack_sp = sv;
1436 oldscope = PL_scopestack_ix;
1438 if (!(flags & G_NOARGS))
1439 myop.op_flags = OPf_STACKED;
1440 myop.op_next = Nullop;
1441 myop.op_type = OP_ENTEREVAL;
1442 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1443 (flags & G_ARRAY) ? OPf_WANT_LIST :
1445 if (flags & G_KEEPERR)
1446 myop.op_flags |= OPf_SPECIAL;
1449 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1453 retval = PL_stack_sp - (PL_stack_base + oldmark);
1454 if (!(flags & G_KEEPERR))
1461 /* my_exit() was called */
1462 PL_curstash = PL_defstash;
1465 Perl_croak(aTHX_ "Callback called exit");
1470 PL_op = PL_restartop;
1474 PL_stack_sp = PL_stack_base + oldmark;
1475 if (flags & G_ARRAY)
1479 *++PL_stack_sp = &PL_sv_undef;
1484 if (flags & G_DISCARD) {
1485 PL_stack_sp = PL_stack_base + oldmark;
1495 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1498 SV* sv = newSVpv(p, 0);
1501 eval_sv(sv, G_SCALAR);
1508 if (croak_on_error && SvTRUE(ERRSV)) {
1510 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1516 /* Require a module. */
1519 Perl_require_pv(pTHX_ const char *pv)
1523 PUSHSTACKi(PERLSI_REQUIRE);
1525 sv = sv_newmortal();
1526 sv_setpv(sv, "require '");
1529 eval_sv(sv, G_DISCARD);
1535 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1539 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1540 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1544 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
1546 /* This message really ought to be max 23 lines.
1547 * Removed -h because the user already knows that opton. Others? */
1549 static char *usage_msg[] = {
1550 "-0[octal] specify record separator (\\0, if no argument)",
1551 "-a autosplit mode with -n or -p (splits $_ into @F)",
1552 "-c check syntax only (runs BEGIN and END blocks)",
1553 "-d[:debugger] run program under debugger",
1554 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1555 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1556 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1557 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1558 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1559 "-l[octal] enable line ending processing, specifies line terminator",
1560 "-[mM][-]module execute `use/no module...' before executing program",
1561 "-n assume 'while (<>) { ... }' loop around program",
1562 "-p assume loop like -n but print line also, like sed",
1563 "-P run program through C preprocessor before compilation",
1564 "-s enable rudimentary parsing for switches after programfile",
1565 "-S look for programfile using PATH environment variable",
1566 "-T enable tainting checks",
1567 "-u dump core after parsing program",
1568 "-U allow unsafe operations",
1569 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1570 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1571 "-w enable many useful warnings (RECOMMENDED)",
1572 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1576 char **p = usage_msg;
1578 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1580 printf("\n %s", *p++);
1583 /* This routine handles any switches that can be given during run */
1586 Perl_moreswitches(pTHX_ char *s)
1595 rschar = scan_oct(s, 4, &numlen);
1596 SvREFCNT_dec(PL_nrs);
1597 if (rschar & ~((U8)~0))
1598 PL_nrs = &PL_sv_undef;
1599 else if (!rschar && numlen >= 2)
1600 PL_nrs = newSVpvn("", 0);
1603 PL_nrs = newSVpvn(&ch, 1);
1609 PL_splitstr = savepv(s + 1);
1623 if (*s == ':' || *s == '=') {
1624 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1628 PL_perldb = PERLDB_ALL;
1636 if (isALPHA(s[1])) {
1637 static char debopts[] = "psltocPmfrxuLHXDS";
1640 for (s++; *s && (d = strchr(debopts,*s)); s++)
1641 PL_debug |= 1 << (d - debopts);
1644 PL_debug = atoi(s+1);
1645 for (s++; isDIGIT(*s); s++) ;
1647 PL_debug |= 0x80000000;
1650 if (ckWARN_d(WARN_DEBUGGING))
1651 Perl_warner(aTHX_ WARN_DEBUGGING,
1652 "Recompile perl with -DDEBUGGING to use -D switch\n");
1653 for (s++; isALNUM(*s); s++) ;
1659 usage(PL_origargv[0]);
1663 Safefree(PL_inplace);
1664 PL_inplace = savepv(s+1);
1666 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1669 if (*s == '-') /* Additional switches on #! line. */
1673 case 'I': /* -I handled both here and in parse_perl() */
1676 while (*s && isSPACE(*s))
1680 for (e = s; *e && !isSPACE(*e); e++) ;
1681 p = savepvn(s, e-s);
1687 Perl_croak(aTHX_ "No space allowed after -I");
1695 PL_ors = savepv("\n");
1697 *PL_ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1702 if (RsPARA(PL_nrs)) {
1707 PL_ors = SvPV(PL_nrs, PL_orslen);
1708 PL_ors = savepvn(PL_ors, PL_orslen);
1712 forbid_setid("-M"); /* XXX ? */
1715 forbid_setid("-m"); /* XXX ? */
1720 /* -M-foo == 'no foo' */
1721 if (*s == '-') { use = "no "; ++s; }
1722 sv = newSVpv(use,0);
1724 /* We allow -M'Module qw(Foo Bar)' */
1725 while(isALNUM(*s) || *s==':') ++s;
1727 sv_catpv(sv, start);
1728 if (*(start-1) == 'm') {
1730 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
1731 sv_catpv( sv, " ()");
1734 sv_catpvn(sv, start, s-start);
1735 sv_catpv(sv, " split(/,/,q{");
1740 if (PL_preambleav == NULL)
1741 PL_preambleav = newAV();
1742 av_push(PL_preambleav, sv);
1745 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1757 PL_doswitches = TRUE;
1762 Perl_croak(aTHX_ "Too late for \"-T\" option");
1766 PL_do_undump = TRUE;
1774 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
1775 printf("\nThis is perl, version %d.%03d_%02d built for %s",
1776 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME);
1778 printf("\nThis is perl, version %s built for %s",
1779 PL_patchlevel, ARCHNAME);
1781 #if defined(LOCAL_PATCH_COUNT)
1782 if (LOCAL_PATCH_COUNT > 0)
1783 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1784 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1787 printf("\n\nCopyright 1987-1999, Larry Wall\n");
1789 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1792 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1793 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
1796 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1797 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
1800 printf("atariST series port, ++jrb bammi@cadence.com\n");
1803 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
1806 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1809 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
1812 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
1815 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
1818 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
1821 printf("MiNT port by Guido Flohr, 1997-1999\n");
1823 #ifdef BINARY_BUILD_NOTICE
1824 BINARY_BUILD_NOTICE;
1827 Perl may be copied only under the terms of either the Artistic License or the\n\
1828 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1829 Complete documentation for Perl, including FAQ lists, should be found on\n\
1830 this system using `man perl' or `perldoc perl'. If you have access to the\n\
1831 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1834 if (! (PL_dowarn & G_WARN_ALL_MASK))
1835 PL_dowarn |= G_WARN_ON;
1839 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1840 PL_compiling.cop_warnings = WARN_ALL ;
1844 PL_dowarn = G_WARN_ALL_OFF;
1845 PL_compiling.cop_warnings = WARN_NONE ;
1850 if (s[1] == '-') /* Additional switches on #! line. */
1855 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1861 #ifdef ALTERNATE_SHEBANG
1862 case 'S': /* OS/2 needs -S on "extproc" line. */
1870 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
1875 /* compliments of Tom Christiansen */
1877 /* unexec() can be found in the Gnu emacs distribution */
1878 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1881 Perl_my_unexec(pTHX)
1889 prog = newSVpv(BIN_EXP, 0);
1890 sv_catpv(prog, "/perl");
1891 file = newSVpv(PL_origfilename, 0);
1892 sv_catpv(file, ".perldump");
1894 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1895 /* unexec prints msg to stderr in case of failure */
1896 PerlProc_exit(status);
1899 # include <lib$routines.h>
1900 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1902 ABORT(); /* for use with undump */
1907 /* initialize curinterp */
1912 #ifdef PERL_OBJECT /* XXX kludge */
1915 PL_chopset = " \n-"; \
1916 PL_copline = NOLINE; \
1917 PL_curcop = &PL_compiling;\
1918 PL_curcopdb = NULL; \
1921 PL_dumpindent = 4; \
1922 PL_laststatval = -1; \
1923 PL_laststype = OP_STAT; \
1924 PL_maxscream = -1; \
1925 PL_maxsysfd = MAXSYSFD; \
1926 PL_statname = Nullsv; \
1927 PL_tmps_floor = -1; \
1929 PL_op_mask = NULL; \
1931 PL_laststatval = -1; \
1932 PL_laststype = OP_STAT; \
1933 PL_mess_sv = Nullsv; \
1934 PL_splitstr = " "; \
1935 PL_generation = 100; \
1936 PL_exitlist = NULL; \
1937 PL_exitlistlen = 0; \
1939 PL_in_clean_objs = FALSE; \
1940 PL_in_clean_all = FALSE; \
1941 PL_profiledata = NULL; \
1943 PL_rsfp_filters = Nullav; \
1948 # ifdef MULTIPLICITY
1949 # define PERLVAR(var,type)
1950 # define PERLVARA(var,n,type)
1951 # if defined(PERL_IMPLICIT_CONTEXT)
1952 # if defined(USE_THREADS)
1953 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
1954 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
1955 # else /* !USE_THREADS */
1956 # define PERLVARI(var,type,init) aTHX->var = init;
1957 # define PERLVARIC(var,type,init) aTHX->var = init;
1958 # endif /* USE_THREADS */
1960 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
1961 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
1963 # include "intrpvar.h"
1964 # ifndef USE_THREADS
1965 # include "thrdvar.h"
1972 # define PERLVAR(var,type)
1973 # define PERLVARA(var,n,type)
1974 # define PERLVARI(var,type,init) PL_##var = init;
1975 # define PERLVARIC(var,type,init) PL_##var = init;
1976 # include "intrpvar.h"
1977 # ifndef USE_THREADS
1978 # include "thrdvar.h"
1990 S_init_main_stash(pTHX)
1995 /* Note that strtab is a rather special HV. Assumptions are made
1996 about not iterating on it, and not adding tie magic to it.
1997 It is properly deallocated in perl_destruct() */
1998 PL_strtab = newHV();
2000 MUTEX_INIT(&PL_strtab_mutex);
2002 HvSHAREKEYS_off(PL_strtab); /* mandatory */
2003 hv_ksplit(PL_strtab, 512);
2005 PL_curstash = PL_defstash = newHV();
2006 PL_curstname = newSVpvn("main",4);
2007 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2008 SvREFCNT_dec(GvHV(gv));
2009 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2011 HvNAME(PL_defstash) = savepv("main");
2012 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2013 GvMULTI_on(PL_incgv);
2014 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2015 GvMULTI_on(PL_hintgv);
2016 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2017 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2018 GvMULTI_on(PL_errgv);
2019 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2020 GvMULTI_on(PL_replgv);
2021 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
2022 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2023 sv_setpvn(ERRSV, "", 0);
2024 PL_curstash = PL_defstash;
2025 PL_compiling.cop_stash = PL_defstash;
2026 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2027 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2028 /* We must init $/ before switches are processed. */
2029 sv_setpvn(get_sv("/", TRUE), "\n", 1);
2033 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2041 PL_origfilename = savepv("-e");
2044 /* if find_script() returns, it returns a malloc()-ed value */
2045 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2047 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2048 char *s = scriptname + 8;
2049 *fdscript = atoi(s);
2053 scriptname = savepv(s + 1);
2054 Safefree(PL_origfilename);
2055 PL_origfilename = scriptname;
2060 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
2061 if (strEQ(PL_origfilename,"-"))
2063 if (*fdscript >= 0) {
2064 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2065 #if defined(HAS_FCNTL) && defined(F_SETFD)
2067 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2070 else if (PL_preprocess) {
2071 char *cpp_cfg = CPPSTDIN;
2072 SV *cpp = newSVpvn("",0);
2073 SV *cmd = NEWSV(0,0);
2075 if (strEQ(cpp_cfg, "cppstdin"))
2076 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2077 sv_catpv(cpp, cpp_cfg);
2080 sv_catpv(sv,PRIVLIB_EXP);
2083 Perl_sv_setpvf(aTHX_ cmd, "\
2084 sed %s -e \"/^[^#]/b\" \
2085 -e \"/^#[ ]*include[ ]/b\" \
2086 -e \"/^#[ ]*define[ ]/b\" \
2087 -e \"/^#[ ]*if[ ]/b\" \
2088 -e \"/^#[ ]*ifdef[ ]/b\" \
2089 -e \"/^#[ ]*ifndef[ ]/b\" \
2090 -e \"/^#[ ]*else/b\" \
2091 -e \"/^#[ ]*elif[ ]/b\" \
2092 -e \"/^#[ ]*undef[ ]/b\" \
2093 -e \"/^#[ ]*endif/b\" \
2096 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2099 Perl_sv_setpvf(aTHX_ cmd, "\
2100 %s %s -e '/^[^#]/b' \
2101 -e '/^#[ ]*include[ ]/b' \
2102 -e '/^#[ ]*define[ ]/b' \
2103 -e '/^#[ ]*if[ ]/b' \
2104 -e '/^#[ ]*ifdef[ ]/b' \
2105 -e '/^#[ ]*ifndef[ ]/b' \
2106 -e '/^#[ ]*else/b' \
2107 -e '/^#[ ]*elif[ ]/b' \
2108 -e '/^#[ ]*undef[ ]/b' \
2109 -e '/^#[ ]*endif/b' \
2113 Perl_sv_setpvf(aTHX_ cmd, "\
2114 %s %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' \
2132 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2134 scriptname, cpp, sv, CPPMINUS);
2135 PL_doextract = FALSE;
2136 #ifdef IAMSUID /* actually, this is caught earlier */
2137 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2139 (void)seteuid(PL_uid); /* musn't stay setuid root */
2142 (void)setreuid((Uid_t)-1, PL_uid);
2144 #ifdef HAS_SETRESUID
2145 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2147 PerlProc_setuid(PL_uid);
2151 if (PerlProc_geteuid() != PL_uid)
2152 Perl_croak(aTHX_ "Can't do seteuid!\n");
2154 #endif /* IAMSUID */
2155 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2159 else if (!*scriptname) {
2160 forbid_setid("program input from stdin");
2161 PL_rsfp = PerlIO_stdin();
2164 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2165 #if defined(HAS_FCNTL) && defined(F_SETFD)
2167 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2172 #ifndef IAMSUID /* in case script is not readable before setuid */
2174 PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&PL_statbuf) >= 0 &&
2175 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2178 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2179 Perl_croak(aTHX_ "Can't do setuid\n");
2183 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2184 SvPVX(GvSV(PL_curcop->cop_filegv)), Strerror(errno));
2189 * I_SYSSTATVFS HAS_FSTATVFS
2191 * I_STATFS HAS_FSTATFS
2192 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2193 * here so that metaconfig picks them up. */
2197 S_fd_on_nosuid_fs(pTHX_ int fd)
2202 * Preferred order: fstatvfs(), fstatfs(), getmntent().
2203 * fstatvfs() is UNIX98.
2205 * getmntent() is O(number-of-mounted-filesystems) and can hang.
2208 # ifdef HAS_FSTATVFS
2209 struct statvfs stfs;
2210 check_okay = fstatvfs(fd, &stfs) == 0;
2211 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2213 # if defined(HAS_FSTATFS) && defined(HAS_STRUCT_STATFS_FLAGS)
2215 check_okay = fstatfs(fd, &stfs) == 0;
2216 # undef PERL_MOUNT_NOSUID
2217 # if !defined(PERL_MOUNT_NOSUID) && defined(MNT_NOSUID)
2218 # define PERL_MOUNT_NOSUID MNT_NOSUID
2220 # if !defined(PERL_MOUNT_NOSUID) && defined(MS_NOSUID)
2221 # define PERL_MOUNT_NOSUID MS_NOSUID
2223 # if !defined(PERL_MOUNT_NOSUID) && defined(M_NOSUID)
2224 # define PERL_MOUNT_NOSUID M_NOSUID
2226 # ifdef PERL_MOUNT_NOSUID
2227 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2230 # if defined(HAS_GETMNTENT) && defined(HAS_HASMNTOPT) && defined(MNTOPT_NOSUID)
2231 FILE *mtab = fopen("/etc/mtab", "r");
2232 struct mntent *entry;
2233 struct stat stb, fsb;
2235 if (mtab && (fstat(fd, &stb) == 0)) {
2236 while (entry = getmntent(mtab)) {
2237 if (stat(entry->mnt_dir, &fsb) == 0
2238 && fsb.st_dev == stb.st_dev)
2240 /* found the filesystem */
2242 if (hasmntopt(entry, MNTOPT_NOSUID))
2245 } /* A single fs may well fail its stat(). */
2250 # endif /* mntent */
2251 # endif /* statfs */
2252 # endif /* statvfs */
2254 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\"", PL_origfilename);
2257 #endif /* IAMSUID */
2260 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2264 /* do we need to emulate setuid on scripts? */
2266 /* This code is for those BSD systems that have setuid #! scripts disabled
2267 * in the kernel because of a security problem. Merely defining DOSUID
2268 * in perl will not fix that problem, but if you have disabled setuid
2269 * scripts in the kernel, this will attempt to emulate setuid and setgid
2270 * on scripts that have those now-otherwise-useless bits set. The setuid
2271 * root version must be called suidperl or sperlN.NNN. If regular perl
2272 * discovers that it has opened a setuid script, it calls suidperl with
2273 * the same argv that it had. If suidperl finds that the script it has
2274 * just opened is NOT setuid root, it sets the effective uid back to the
2275 * uid. We don't just make perl setuid root because that loses the
2276 * effective uid we had before invoking perl, if it was different from the
2279 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2280 * be defined in suidperl only. suidperl must be setuid root. The
2281 * Configure script will set this up for you if you want it.
2288 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2289 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2290 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2295 #ifndef HAS_SETREUID
2296 /* On this access check to make sure the directories are readable,
2297 * there is actually a small window that the user could use to make
2298 * filename point to an accessible directory. So there is a faint
2299 * chance that someone could execute a setuid script down in a
2300 * non-accessible directory. I don't know what to do about that.
2301 * But I don't think it's too important. The manual lies when
2302 * it says access() is useful in setuid programs.
2304 if (PerlLIO_access(SvPVX(GvSV(PL_curcop->cop_filegv)),1)) /*double check*/
2305 Perl_croak(aTHX_ "Permission denied");
2307 /* If we can swap euid and uid, then we can determine access rights
2308 * with a simple stat of the file, and then compare device and
2309 * inode to make sure we did stat() on the same file we opened.
2310 * Then we just have to make sure he or she can execute it.
2313 struct stat tmpstatbuf;
2317 setreuid(PL_euid,PL_uid) < 0
2320 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2323 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2324 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2325 if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0)
2326 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2327 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2328 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2329 Perl_croak(aTHX_ "Permission denied");
2331 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2332 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2333 (void)PerlIO_close(PL_rsfp);
2334 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2335 PerlIO_printf(PL_rsfp,
2336 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2337 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2338 (long)PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2339 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2340 SvPVX(GvSV(PL_curcop->cop_filegv)),
2341 (long)PL_statbuf.st_uid, (long)PL_statbuf.st_gid);
2342 (void)PerlProc_pclose(PL_rsfp);
2344 Perl_croak(aTHX_ "Permission denied\n");
2348 setreuid(PL_uid,PL_euid) < 0
2350 # if defined(HAS_SETRESUID)
2351 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2354 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2355 Perl_croak(aTHX_ "Can't reswap uid and euid");
2356 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2357 Perl_croak(aTHX_ "Permission denied\n");
2359 #endif /* HAS_SETREUID */
2360 #endif /* IAMSUID */
2362 if (!S_ISREG(PL_statbuf.st_mode))
2363 Perl_croak(aTHX_ "Permission denied");
2364 if (PL_statbuf.st_mode & S_IWOTH)
2365 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2366 PL_doswitches = FALSE; /* -s is insecure in suid */
2367 PL_curcop->cop_line++;
2368 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2369 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2370 Perl_croak(aTHX_ "No #! line");
2371 s = SvPV(PL_linestr,n_a)+2;
2373 while (!isSPACE(*s)) s++;
2374 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2375 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2376 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2377 Perl_croak(aTHX_ "Not a perl script");
2378 while (*s == ' ' || *s == '\t') s++;
2380 * #! arg must be what we saw above. They can invoke it by
2381 * mentioning suidperl explicitly, but they may not add any strange
2382 * arguments beyond what #! says if they do invoke suidperl that way.
2384 len = strlen(validarg);
2385 if (strEQ(validarg," PHOOEY ") ||
2386 strnNE(s,validarg,len) || !isSPACE(s[len]))
2387 Perl_croak(aTHX_ "Args must match #! line");
2390 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2391 PL_euid == PL_statbuf.st_uid)
2393 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2394 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2395 #endif /* IAMSUID */
2397 if (PL_euid) { /* oops, we're not the setuid root perl */
2398 (void)PerlIO_close(PL_rsfp);
2401 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2403 Perl_croak(aTHX_ "Can't do setuid\n");
2406 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2408 (void)setegid(PL_statbuf.st_gid);
2411 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2413 #ifdef HAS_SETRESGID
2414 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2416 PerlProc_setgid(PL_statbuf.st_gid);
2420 if (PerlProc_getegid() != PL_statbuf.st_gid)
2421 Perl_croak(aTHX_ "Can't do setegid!\n");
2423 if (PL_statbuf.st_mode & S_ISUID) {
2424 if (PL_statbuf.st_uid != PL_euid)
2426 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2429 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2431 #ifdef HAS_SETRESUID
2432 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2434 PerlProc_setuid(PL_statbuf.st_uid);
2438 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2439 Perl_croak(aTHX_ "Can't do seteuid!\n");
2441 else if (PL_uid) { /* oops, mustn't run as root */
2443 (void)seteuid((Uid_t)PL_uid);
2446 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2448 #ifdef HAS_SETRESUID
2449 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2451 PerlProc_setuid((Uid_t)PL_uid);
2455 if (PerlProc_geteuid() != PL_uid)
2456 Perl_croak(aTHX_ "Can't do seteuid!\n");
2459 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2460 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
2463 else if (PL_preprocess)
2464 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2465 else if (fdscript >= 0)
2466 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2468 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2470 /* We absolutely must clear out any saved ids here, so we */
2471 /* exec the real perl, substituting fd script for scriptname. */
2472 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2473 PerlIO_rewind(PL_rsfp);
2474 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2475 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2476 if (!PL_origargv[which])
2477 Perl_croak(aTHX_ "Permission denied");
2478 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2479 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2480 #if defined(HAS_FCNTL) && defined(F_SETFD)
2481 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2483 PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
2484 Perl_croak(aTHX_ "Can't do setuid\n");
2485 #endif /* IAMSUID */
2487 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2488 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2490 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2491 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2493 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2496 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2497 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2498 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2499 /* not set-id, must be wrapped */
2505 S_find_beginning(pTHX)
2507 register char *s, *s2;
2509 /* skip forward in input to the real script? */
2512 while (PL_doextract) {
2513 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2514 Perl_croak(aTHX_ "No Perl script found in input\n");
2515 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2516 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2517 PL_doextract = FALSE;
2518 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2520 while (*s == ' ' || *s == '\t') s++;
2522 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2523 if (strnEQ(s2-4,"perl",4))
2525 while (s = moreswitches(s)) ;
2527 if (PL_cddir && PerlDir_chdir(PL_cddir) < 0)
2528 Perl_croak(aTHX_ "Can't chdir to %s",PL_cddir);
2537 PL_uid = PerlProc_getuid();
2538 PL_euid = PerlProc_geteuid();
2539 PL_gid = PerlProc_getgid();
2540 PL_egid = PerlProc_getegid();
2542 PL_uid |= PL_gid << 16;
2543 PL_euid |= PL_egid << 16;
2545 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2549 S_forbid_setid(pTHX_ char *s)
2551 if (PL_euid != PL_uid)
2552 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2553 if (PL_egid != PL_gid)
2554 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2558 Perl_init_debugger(pTHX)
2561 HV *ostash = PL_curstash;
2563 PL_curstash = PL_debstash;
2564 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2565 AvREAL_off(PL_dbargs);
2566 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2567 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2568 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2569 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
2570 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2571 sv_setiv(PL_DBsingle, 0);
2572 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2573 sv_setiv(PL_DBtrace, 0);
2574 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2575 sv_setiv(PL_DBsignal, 0);
2576 PL_curstash = ostash;
2579 #ifndef STRESS_REALLOC
2580 #define REASONABLE(size) (size)
2582 #define REASONABLE(size) (1) /* unreasonable */
2586 Perl_init_stacks(pTHX)
2588 /* start with 128-item stack and 8K cxstack */
2589 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2590 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2591 PL_curstackinfo->si_type = PERLSI_MAIN;
2592 PL_curstack = PL_curstackinfo->si_stack;
2593 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2595 PL_stack_base = AvARRAY(PL_curstack);
2596 PL_stack_sp = PL_stack_base;
2597 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2599 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2602 PL_tmps_max = REASONABLE(128);
2604 New(54,PL_markstack,REASONABLE(32),I32);
2605 PL_markstack_ptr = PL_markstack;
2606 PL_markstack_max = PL_markstack + REASONABLE(32);
2610 New(54,PL_scopestack,REASONABLE(32),I32);
2611 PL_scopestack_ix = 0;
2612 PL_scopestack_max = REASONABLE(32);
2614 New(54,PL_savestack,REASONABLE(128),ANY);
2615 PL_savestack_ix = 0;
2616 PL_savestack_max = REASONABLE(128);
2618 New(54,PL_retstack,REASONABLE(16),OP*);
2620 PL_retstack_max = REASONABLE(16);
2629 while (PL_curstackinfo->si_next)
2630 PL_curstackinfo = PL_curstackinfo->si_next;
2631 while (PL_curstackinfo) {
2632 PERL_SI *p = PL_curstackinfo->si_prev;
2633 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2634 Safefree(PL_curstackinfo->si_cxstack);
2635 Safefree(PL_curstackinfo);
2636 PL_curstackinfo = p;
2638 Safefree(PL_tmps_stack);
2639 Safefree(PL_markstack);
2640 Safefree(PL_scopestack);
2641 Safefree(PL_savestack);
2642 Safefree(PL_retstack);
2644 Safefree(PL_debname);
2645 Safefree(PL_debdelim);
2650 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2661 lex_start(PL_linestr);
2663 PL_subname = newSVpvn("main",4);
2667 S_init_predump_symbols(pTHX)
2674 sv_setpvn(get_sv("\"", TRUE), " ", 1);
2675 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2676 GvMULTI_on(PL_stdingv);
2677 io = GvIOp(PL_stdingv);
2678 IoIFP(io) = PerlIO_stdin();
2679 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2681 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2683 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2686 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
2688 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2690 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2692 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2693 GvMULTI_on(PL_stderrgv);
2694 io = GvIOp(PL_stderrgv);
2695 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
2696 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2698 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2700 PL_statname = NEWSV(66,0); /* last filename we did stat on */
2703 PL_osname = savepv(OSNAME);
2707 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
2714 argc--,argv++; /* skip name of script */
2715 if (PL_doswitches) {
2716 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2719 if (argv[0][1] == '-') {
2723 if (s = strchr(argv[0], '=')) {
2725 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2728 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2731 PL_toptarget = NEWSV(0,0);
2732 sv_upgrade(PL_toptarget, SVt_PVFM);
2733 sv_setpvn(PL_toptarget, "", 0);
2734 PL_bodytarget = NEWSV(0,0);
2735 sv_upgrade(PL_bodytarget, SVt_PVFM);
2736 sv_setpvn(PL_bodytarget, "", 0);
2737 PL_formtarget = PL_bodytarget;
2740 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2741 sv_setpv(GvSV(tmpgv),PL_origfilename);
2742 magicname("0", "0", 1);
2744 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2746 sv_setpv(GvSV(tmpgv), os2_execname());
2748 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2750 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2751 GvMULTI_on(PL_argvgv);
2752 (void)gv_AVadd(PL_argvgv);
2753 av_clear(GvAVn(PL_argvgv));
2754 for (; argc > 0; argc--,argv++) {
2755 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2758 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2760 GvMULTI_on(PL_envgv);
2761 hv = GvHVn(PL_envgv);
2762 hv_magic(hv, PL_envgv, 'E');
2763 #if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
2764 /* Note that if the supplied env parameter is actually a copy
2765 of the global environ then it may now point to free'd memory
2766 if the environment has been modified since. To avoid this
2767 problem we treat env==NULL as meaning 'use the default'
2772 environ[0] = Nullch;
2773 for (; *env; env++) {
2774 if (!(s = strchr(*env,'=')))
2780 sv = newSVpv(s--,0);
2781 (void)hv_store(hv, *env, s - *env, sv, 0);
2783 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2784 /* Sins of the RTL. See note in my_setenv(). */
2785 (void)PerlEnv_putenv(savepv(*env));
2789 #ifdef DYNAMIC_ENV_FETCH
2790 HvNAME(hv) = savepv(ENV_HV_NAME);
2794 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2795 sv_setiv(GvSV(tmpgv), (IV)getpid());
2799 S_init_perllib(pTHX)
2804 s = PerlEnv_getenv("PERL5LIB");
2808 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2810 /* Treat PERL5?LIB as a possible search list logical name -- the
2811 * "natural" VMS idiom for a Unix path string. We allow each
2812 * element to be a set of |-separated directories for compatibility.
2816 if (my_trnlnm("PERL5LIB",buf,0))
2817 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2819 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2823 /* Use the ~-expanded versions of APPLLIB (undocumented),
2824 ARCHLIB PRIVLIB SITEARCH and SITELIB
2827 incpush(APPLLIB_EXP, TRUE);
2831 incpush(ARCHLIB_EXP, FALSE);
2834 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2837 incpush(PRIVLIB_EXP, TRUE);
2839 incpush(PRIVLIB_EXP, FALSE);
2843 incpush(SITEARCH_EXP, FALSE);
2847 incpush(SITELIB_EXP, TRUE);
2849 incpush(SITELIB_EXP, FALSE);
2852 #if defined(PERL_VENDORLIB_EXP)
2854 incpush(PERL_VENDORLIB_EXP, TRUE);
2856 incpush(PERL_VENDORLIB_EXP, FALSE);
2860 incpush(".", FALSE);
2864 # define PERLLIB_SEP ';'
2867 # define PERLLIB_SEP '|'
2869 # define PERLLIB_SEP ':'
2872 #ifndef PERLLIB_MANGLE
2873 # define PERLLIB_MANGLE(s,n) (s)
2877 S_incpush(pTHX_ char *p, int addsubdirs)
2879 SV *subdir = Nullsv;
2885 subdir = sv_newmortal();
2886 if (!PL_archpat_auto) {
2887 STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
2888 + sizeof("//auto"));
2889 New(55, PL_archpat_auto, len, char);
2890 sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
2892 for (len = sizeof(ARCHNAME) + 2;
2893 PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2894 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
2899 /* Break at all separators */
2901 SV *libdir = NEWSV(55,0);
2904 /* skip any consecutive separators */
2905 while ( *p == PERLLIB_SEP ) {
2906 /* Uncomment the next line for PATH semantics */
2907 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
2911 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2912 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2917 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2918 p = Nullch; /* break out */
2922 * BEFORE pushing libdir onto @INC we may first push version- and
2923 * archname-specific sub-directories.
2926 struct stat tmpstatbuf;
2931 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
2933 while (unix[len-1] == '/') len--; /* Cosmetic */
2934 sv_usepvn(libdir,unix,len);
2937 PerlIO_printf(Perl_error_log,
2938 "Failed to unixify @INC element \"%s\"\n",
2941 /* .../archname/version if -d .../archname/version/auto */
2942 sv_setsv(subdir, libdir);
2943 sv_catpv(subdir, PL_archpat_auto);
2944 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2945 S_ISDIR(tmpstatbuf.st_mode))
2946 av_push(GvAVn(PL_incgv),
2947 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2949 /* .../archname if -d .../archname/auto */
2950 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2951 strlen(PL_patchlevel) + 1, "", 0);
2952 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2953 S_ISDIR(tmpstatbuf.st_mode))
2954 av_push(GvAVn(PL_incgv),
2955 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2958 /* finally push this lib directory on the end of @INC */
2959 av_push(GvAVn(PL_incgv), libdir);
2964 STATIC struct perl_thread *
2965 S_init_main_thread(pTHX)
2967 #if !defined(PERL_IMPLICIT_CONTEXT)
2968 struct perl_thread *thr;
2972 Newz(53, thr, 1, struct perl_thread);
2973 PL_curcop = &PL_compiling;
2974 thr->interp = PERL_GET_INTERP;
2975 thr->cvcache = newHV();
2976 thr->threadsv = newAV();
2977 /* thr->threadsvp is set when find_threadsv is called */
2978 thr->specific = newAV();
2979 thr->flags = THRf_R_JOINABLE;
2980 MUTEX_INIT(&thr->mutex);
2981 /* Handcraft thrsv similarly to mess_sv */
2982 New(53, PL_thrsv, 1, SV);
2983 Newz(53, xpv, 1, XPV);
2984 SvFLAGS(PL_thrsv) = SVt_PV;
2985 SvANY(PL_thrsv) = (void*)xpv;
2986 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
2987 SvPVX(PL_thrsv) = (char*)thr;
2988 SvCUR_set(PL_thrsv, sizeof(thr));
2989 SvLEN_set(PL_thrsv, sizeof(thr));
2990 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
2991 thr->oursv = PL_thrsv;
2992 PL_chopset = " \n-";
2995 MUTEX_LOCK(&PL_threads_mutex);
3000 MUTEX_UNLOCK(&PL_threads_mutex);
3002 #ifdef HAVE_THREAD_INTERN
3003 Perl_init_thread_intern(thr);
3006 #ifdef SET_THREAD_SELF
3007 SET_THREAD_SELF(thr);
3009 thr->self = pthread_self();
3010 #endif /* SET_THREAD_SELF */
3014 * These must come after the SET_THR because sv_setpvn does
3015 * SvTAINT and the taint fields require dTHR.
3017 PL_toptarget = NEWSV(0,0);
3018 sv_upgrade(PL_toptarget, SVt_PVFM);
3019 sv_setpvn(PL_toptarget, "", 0);
3020 PL_bodytarget = NEWSV(0,0);
3021 sv_upgrade(PL_bodytarget, SVt_PVFM);
3022 sv_setpvn(PL_bodytarget, "", 0);
3023 PL_formtarget = PL_bodytarget;
3024 thr->errsv = newSVpvn("", 0);
3025 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
3028 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3029 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3030 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3031 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3032 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3034 PL_reginterp_cnt = 0;
3038 #endif /* USE_THREADS */
3041 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3045 line_t oldline = PL_curcop->cop_line;
3051 while (AvFILL(paramList) >= 0) {
3052 cv = (CV*)av_shift(paramList);
3054 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
3057 (void)SvPV(atsv, len);
3059 PL_curcop = &PL_compiling;
3060 PL_curcop->cop_line = oldline;
3061 if (paramList == PL_beginav)
3062 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3064 sv_catpv(atsv, "END failed--cleanup aborted");
3065 while (PL_scopestack_ix > oldscope)
3067 Perl_croak(aTHX_ "%s", SvPVX(atsv));
3074 /* my_exit() was called */
3075 while (PL_scopestack_ix > oldscope)
3078 PL_curstash = PL_defstash;
3079 if (PL_endav && !PL_minus_c)
3080 call_list(oldscope, PL_endav);
3081 PL_curcop = &PL_compiling;
3082 PL_curcop->cop_line = oldline;
3083 if (PL_statusvalue) {
3084 if (paramList == PL_beginav)
3085 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3087 Perl_croak(aTHX_ "END failed--cleanup aborted");
3093 PL_curcop = &PL_compiling;
3094 PL_curcop->cop_line = oldline;
3097 PerlIO_printf(Perl_error_log, "panic: restartop\n");
3105 S_call_list_body(pTHX_ va_list args)
3108 CV *cv = va_arg(args, CV*);
3110 PUSHMARK(PL_stack_sp);
3111 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3116 Perl_my_exit(pTHX_ U32 status)
3120 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3121 thr, (unsigned long) status));
3130 STATUS_NATIVE_SET(status);
3137 Perl_my_failure_exit(pTHX)
3140 if (vaxc$errno & 1) {
3141 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3142 STATUS_NATIVE_SET(44);
3145 if (!vaxc$errno && errno) /* unlikely */
3146 STATUS_NATIVE_SET(44);
3148 STATUS_NATIVE_SET(vaxc$errno);
3153 STATUS_POSIX_SET(errno);
3155 exitstatus = STATUS_POSIX >> 8;
3156 if (exitstatus & 255)
3157 STATUS_POSIX_SET(exitstatus);
3159 STATUS_POSIX_SET(255);
3166 S_my_exit_jump(pTHX)
3169 register PERL_CONTEXT *cx;
3174 SvREFCNT_dec(PL_e_script);
3175 PL_e_script = Nullsv;
3178 POPSTACK_TO(PL_mainstack);
3179 if (cxstack_ix >= 0) {
3182 POPBLOCK(cx,PL_curpm);
3195 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3198 p = SvPVX(PL_e_script);
3199 nl = strchr(p, '\n');
3200 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3202 filter_del(read_e_script);
3205 sv_catpvn(buf_sv, p, nl-p);
3206 sv_chop(PL_e_script, nl);